diff --git a/CHANGELOG.rst b/CHANGELOG.rst index 3e9cedfdcf..137a4c0063 100644 --- a/CHANGELOG.rst +++ b/CHANGELOG.rst @@ -22,6 +22,22 @@ individual files. The changes are now listed with the most recent at the top. +**January 9 2024 :: Derecho CLM-DART. Tag v10.10.1** + +- CLM-DART scripting updated for Derecho. +- CLM-DART SourceMods packaged with DART. +- Reinstituted both 'complete' and 'single_year' datm streamlist files in shell scripts + due to delays when initializing the CAM reanalysis files through campaign/collections directory. + +bug-fixes: + +- Fixed format statement in assert_mod to conform to Fortran standards. +- Fixed debugging output for failed forward operators. + +doc-fixes: + +- Remove broken link for register for dart. + **December 13 2023 :: Developer tests and bug fixes. Tag v10.10.0** - new developer tests to run all builds for all compilers on NSF NCAR machine diff --git a/conf.py b/conf.py index d006de6a22..dcee0201d1 100644 --- a/conf.py +++ b/conf.py @@ -21,7 +21,7 @@ author = 'Data Assimilation Research Section' # The full version, including alpha/beta/rc tags -release = '10.10.0' +release = '10.10.1' root_doc = 'index' # -- General configuration --------------------------------------------------- diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/README b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/README new file mode 100644 index 0000000000..8ad5b837a9 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/README @@ -0,0 +1,12 @@ +These are everyones sourcemods for cesm1_1_1 ... + +Each file has the parent filename near the top of the modified file so you can check +the differences. + +The cesm1_1_1 POP build namelist mechanism had a bug in it. +Use the one for cesm1_2_beta04 instead. This can be accomplished (amazingly) by +putting the build-namlist in our SourceMods/src.pop2 section. + + xxdiff /glade/p/cesm/cseg/collections/cesm1_1_1/models/ocn/pop2/bld/build-namelist \ + /glade/p/cesm/cseg/collections/cesm1_2_beta04/models/ocn/pop2/bld/build-namelist + diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/README b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/README new file mode 100644 index 0000000000..bb00e7639f --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/README @@ -0,0 +1,9 @@ +This atm_comp_mod.F90 forces CAM to use the CAM initial conditions file while +all other model components are using restart files. This allows us to use +CONTINUE_RUN = TRUE, but this also means we have to write out CAM restart +files because we need to use the information CAM sends to the coupler to +avoid lagging the ocean by a day. At present, this atm_comp_mod.F90 has +some debug statements in it, and will not work properly (I suspect) if we +do not stop at midnight only. This is an interim product. +-- TJH Mon Apr 8 16:22:58 MDT 2013 + diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/atm_comp_mct.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/atm_comp_mct.F90 new file mode 100644 index 0000000000..0c5c151008 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/atm_comp_mct.F90 @@ -0,0 +1,1318 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1/models/atm/cam/src/cpl_mct/atm_comp_mct.F90 + +module atm_comp_mct + + use pio , only: file_desc_t, io_desc_t, var_desc_t, pio_double, pio_def_dim, & + pio_put_att, pio_enddef, pio_initdecomp, pio_read_darray, pio_freedecomp, & + pio_closefile, pio_write_darray, pio_def_var, pio_inq_varid, & + pio_noerr, pio_bcast_error, pio_internal_error, pio_seterrorhandling + use mct_mod + use esmf + use seq_flds_mod + use seq_cdata_mod + use seq_infodata_mod + use seq_timemgr_mod + + use shr_kind_mod , only: r8 => shr_kind_r8, cl=>shr_kind_cl + use shr_file_mod , only: shr_file_getunit, shr_file_freeunit, & + shr_file_setLogUnit, shr_file_setLogLevel, & + shr_file_getLogUnit, shr_file_getLogLevel, & + shr_file_setIO + use shr_sys_mod , only: shr_sys_flush, shr_sys_abort + + use cam_cpl_indices + use cam_comp + use cam_instance , only: cam_instance_init, inst_suffix + use cam_control_mod , only: nsrest, adiabatic, ideal_phys, aqua_planet, eccen, obliqr, lambm0, mvelpp + use radiation , only: radiation_get, radiation_do, radiation_nextsw_cday + use phys_grid , only: get_ncols_p, get_gcol_all_p, & + ngcols, get_gcol_p, get_rlat_all_p, & + get_rlon_all_p, get_area_all_p + use ppgrid , only: pcols, begchunk, endchunk + use dyn_grid , only: get_horiz_grid_dim_d + use camsrfexch , only: cam_out_t, cam_in_t + use cam_restart , only: get_restcase, get_restartdir + use cam_history , only: outfld, ctitle + use abortutils , only: endrun + use filenames , only: interpret_filename_spec, caseid, brnch_retain_casename +#ifdef SPMD + use spmd_utils , only: spmdinit, masterproc, iam + use mpishorthand , only: mpicom +#else + use spmd_utils , only: spmdinit, masterproc, mpicom, iam +#endif + use time_manager , only: get_curr_calday, advance_timestep, get_curr_date, get_nstep, & + is_first_step, get_step_size, timemgr_init, timemgr_check_restart + use ioFileMod + use perf_mod + use cam_logfile , only: iulog + use co2_cycle , only: c_i, co2_readFlux_ocn, co2_readFlux_fuel, co2_transport, & + co2_time_interp_ocn, co2_time_interp_fuel, data_flux_ocn, data_flux_fuel + use physconst , only: mwco2 + use runtime_opts , only: read_namelist + use phys_control , only: cam_chempkg_is + use scamMod , only: single_column,scmlat,scmlon +! +! !PUBLIC TYPES: + implicit none + save + private ! except + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: atm_init_mct + public :: atm_run_mct + public :: atm_final_mct + +!-------------------------------------------------------------------------- +! Private interfaces +!-------------------------------------------------------------------------- + + private :: atm_SetgsMap_mct + private :: atm_import_mct + private :: atm_export_mct + private :: atm_domain_mct + private :: atm_read_srfrest_mct + private :: atm_write_srfrest_mct + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + + type(cam_in_t) , pointer :: cam_in(:) + type(cam_out_t), pointer :: cam_out(:) + + type(mct_aVect) :: a2x_a_SNAP + type(mct_aVect) :: a2x_a_SUM + + integer, parameter :: nlen = 256 ! Length of character strings + character(len=nlen) :: fname_srf_cam ! surface restart filename + character(len=nlen) :: pname_srf_cam ! surface restart full pathname + + ! Filename specifier for restart surface file + character(len=cl) :: rsfilename_spec_cam +! +! Time averaged counter for flux fields +! + integer :: avg_count +! +! Time averaged flux fields +! + character(*), parameter :: a2x_avg_flds = "Faxa_rainc:Faxa_rainl:Faxa_snowc:Faxa_snowl" +! +! Are all surface types present +! + logical :: lnd_present ! if true => land is present + logical :: ocn_present ! if true => ocean is present + + logical :: dart_mode = .true. +! +!================================================================================ +CONTAINS +!================================================================================ + + subroutine atm_init_mct( EClock, cdata_a, x2a_a, a2x_a, NLFilename ) + + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(ESMF_Clock),intent(in) :: EClock + type(seq_cdata), intent(inout) :: cdata_a + type(mct_aVect), intent(inout) :: x2a_a + type(mct_aVect), intent(inout) :: a2x_a + character(len=*), optional, intent(IN) :: NLFilename ! Namelist filename + ! + ! Locals + ! + type(mct_gsMap), pointer :: gsMap_atm + type(mct_gGrid), pointer :: dom_a + type(seq_infodata_type),pointer :: infodata + integer :: ATMID + integer :: mpicom_atm + integer :: lsize + integer :: iradsw + logical :: exists ! true if file exists + real(r8):: nextsw_cday ! calendar of next atm shortwave + integer :: stepno ! time step + integer :: dtime_sync ! integer timestep size + integer :: currentymd ! current year-month-day + integer :: currenttod ! current time of day + integer :: dtime ! time step increment (sec) + integer :: atm_cpl_dt ! driver atm coupling time step + integer :: nstep ! CAM nstep + real(r8):: caldayp1 ! CAM calendar day for for next cam time step + integer :: dtime_cam ! Time-step increment (sec) + integer :: ymd ! CAM current date (YYYYMMDD) + integer :: yr ! CAM current year + integer :: mon ! CAM current month + integer :: day ! CAM current day + integer :: tod ! CAM current time of day (sec) + integer :: start_ymd ! Start date (YYYYMMDD) + integer :: start_tod ! Start time of day (sec) + integer :: ref_ymd ! Reference date (YYYYMMDD) + integer :: ref_tod ! Reference time of day (sec) + integer :: stop_ymd ! Stop date (YYYYMMDD) + integer :: stop_tod ! Stop time of day (sec) + logical :: perpetual_run ! If in perpetual mode or not + integer :: perpetual_ymd ! Perpetual date (YYYYMMDD) + integer :: shrlogunit,shrloglev ! old values + logical :: first_time = .true. + character(len=SHR_KIND_CS) :: calendar ! Calendar type + character(len=SHR_KIND_CS) :: starttype ! infodata start type + integer :: lbnum + integer :: hdim1_d, hdim2_d ! dimensions of rectangular horizontal grid + ! data structure, If 1D data structure, then + ! hdim2_d == 1. + character(len=64) :: filein ! Input namelist filename + !----------------------------------------------------------------------- + ! + ! Determine cdata points + ! +#if (defined _MEMTRACE) + if(masterproc) then + lbnum=1 + call memmon_dump_fort('memmon.out','atm_init_mct:start::',lbnum) + endif +#endif + call seq_cdata_setptrs(cdata_a, ID=ATMID, mpicom=mpicom_atm, & + gsMap=gsMap_atm, dom=dom_a, infodata=infodata) + + if (masterproc) write(iulog,*)'TJH atm_init_mct: first_time is ',first_time + + if (first_time) then + + call cam_instance_init(ATMID) + + ! Set filename specifier for restart surface file + ! (%c=caseid, $y=year, $m=month, $d=day, $s=seconds in day) + rsfilename_spec_cam = '%c.cam' // trim(inst_suffix) // '.rs.%y-%m-%d-%s.nc' + + ! Determine attribute vector indices + + call cam_cpl_indices_set() + + ! Redirect share output to cam log + + call spmdinit(mpicom_atm) + + if (masterproc) then + inquire(file='atm_modelio.nml'//trim(inst_suffix), exist=exists) + if (exists) then + iulog = shr_file_getUnit() + call shr_file_setIO('atm_modelio.nml'//trim(inst_suffix), iulog) + endif + write(iulog,*) "CAM atmosphere model initialization" + endif + + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (iulog) + ! + ! Consistency check + ! + if (co2_readFlux_ocn .and. index_x2a_Faoo_fco2_ocn /= 0) then + write(iulog,*)'error co2_readFlux_ocn and index_x2a_Faoo_fco2_ocn cannot both be active' + call shr_sys_abort() + end if + ! + ! Get data from infodata object + ! + call seq_infodata_GetData( infodata, & + case_name=caseid, case_desc=ctitle, & + start_type=starttype, & + atm_adiabatic=adiabatic, & + atm_ideal_phys=ideal_phys, & + aqua_planet=aqua_planet, & + brnch_retain_casename=brnch_retain_casename, & + single_column=single_column, scmlat=scmlat, scmlon=scmlon, & + orb_eccen=eccen, orb_mvelpp=mvelpp, orb_lambm0=lambm0, orb_obliqr=obliqr, & + lnd_present=lnd_present, ocn_present=ocn_present, & + perpetual=perpetual_run, perpetual_ymd=perpetual_ymd) + ! + ! Get nsrest from startup type methods + ! + + if (dart_mode) then + ! TJH : force the atm into an initial run while everyone else is a restart + ! TJH : This allows us to (potentially) use POP in the restart mode + ! TJH : huge step towards coupled assimilation with coupled models. + starttype = trim(seq_infodata_start_type_start) + end if + + if ( trim(starttype) == trim(seq_infodata_start_type_start)) then + nsrest = 0 + else if (trim(starttype) == trim(seq_infodata_start_type_cont) ) then + nsrest = 1 + else if (trim(starttype) == trim(seq_infodata_start_type_brnch)) then + nsrest = 3 + else + write(iulog,*) 'atm_comp_mct: ERROR: unknown starttype' + call shr_sys_abort() + end if + ! + ! Initialize time manager. + ! + call seq_timemgr_EClockGetData(EClock, & + start_ymd=start_ymd, start_tod=start_tod, & + ref_ymd=ref_ymd, ref_tod=ref_tod, & + stop_ymd=stop_ymd, stop_tod=stop_tod, & + curr_ymd=CurrentYMD, curr_tod=CurrentTOD, & + calendar=calendar ) + + ! In DART mode we allow the coupler to be running in a restart mode, + ! but force CAM into an initial mode. To do this CAM's start time must + ! be set to the current time from the driver's clock. + if (dart_mode) then + if (masterproc) write(iulog,*)'TJH timemgr ref ',ref_ymd, ref_tod + if (masterproc) write(iulog,*)'TJH timemgr start ',start_ymd, start_tod + start_ymd = CurrentYMD + start_tod = CurrentTOD + if (masterproc) write(iulog,*)'TJH reset to ',start_ymd, start_tod + end if + + ! + ! Read namelist + ! + filein = "atm_in" // trim(inst_suffix) + call read_namelist(single_column_in=single_column, scmlat_in=scmlat, & + scmlon_in=scmlon, nlfilename_in=filein) + ! + ! Initialize cam time manager + ! + if ( nsrest == 0 )then + call timemgr_init( calendar_in=calendar, start_ymd=start_ymd, & + start_tod=start_tod, ref_ymd=ref_ymd, & + ref_tod=ref_tod, stop_ymd=stop_ymd, & + stop_tod=stop_tod, & + perpetual_run=perpetual_run, & + perpetual_ymd=perpetual_ymd ) + end if + ! + ! First phase of cam initialization + ! Initialize mpicom_atm, allocate cam_in and cam_out and determine + ! atm decomposition (needed to initialize gsmap) + ! for an initial run, cam_in and cam_out are allocated in cam_initial + ! for a restart/branch run, cam_in and cam_out are allocated in restart + ! Set defaults then override with user-specified input and initialize time manager + ! Note that the following arguments are needed to cam_init for timemgr_restart only + ! + call cam_init( cam_out, cam_in, mpicom_atm, & + start_ymd, start_tod, ref_ymd, ref_tod, stop_ymd, stop_tod, & + perpetual_run, perpetual_ymd, calendar) + ! + ! Check consistency of restart time information with input clock + ! + if (nsrest /= 0) then + dtime_cam = get_step_size() + call timemgr_check_restart( calendar, start_ymd, start_tod, ref_ymd, & + ref_tod, dtime_cam, perpetual_run, perpetual_ymd) + end if + ! + ! Initialize MCT gsMap, domain and attribute vectors + ! + call atm_SetgsMap_mct( mpicom_atm, ATMID, gsMap_atm ) + lsize = mct_gsMap_lsize(gsMap_atm, mpicom_atm) + ! + ! Initialize MCT domain + ! + call atm_domain_mct( lsize, gsMap_atm, dom_a ) + ! + ! Initialize MCT attribute vectors + ! + call mct_aVect_init(a2x_a, rList=seq_flds_a2x_fields, lsize=lsize) + call mct_aVect_zero(a2x_a) + + call mct_aVect_init(x2a_a, rList=seq_flds_x2a_fields, lsize=lsize) + call mct_aVect_zero(x2a_a) + + call mct_aVect_init(a2x_a_SNAP, rList=a2x_avg_flds, lsize=lsize) + call mct_aVect_zero(a2x_a_SNAP) + + call mct_aVect_init(a2x_a_SUM , rList=a2x_avg_flds, lsize=lsize) + call mct_aVect_zero(a2x_a_SUM ) + ! + ! Initialize averaging counter + ! + avg_count = 0 + ! + ! Create initial atm export state + ! + call atm_export_mct( cam_out, a2x_a ) + ! + ! Set flag to specify that an extra albedo calculation is to be done (i.e. specify active) + ! + call seq_infodata_PutData(infodata, atm_prognostic=.true.) + call get_horiz_grid_dim_d(hdim1_d, hdim2_d) + call seq_infodata_PutData(infodata, atm_nx=hdim1_d, atm_ny=hdim2_d) + + ! Set flag to indicate that CAM will provide carbon and dust deposition fluxes. + ! This is now hardcoded to .true. since the ability of CICE to read these + ! fluxes from a file has been removed. + call seq_infodata_PutData(infodata, atm_aero=.true.) + + ! + ! Set time step of radiation computation as the current calday + ! This will only be used on the first timestep of an initial run + ! + if (nsrest == 0) then + nextsw_cday = get_curr_calday() + call seq_infodata_PutData( infodata, nextsw_cday=nextsw_cday ) + end if + + ! End redirection of share output to cam log + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + + first_time = .false. + + else + + ! For initial run, run cam radiation/clouds and return + ! For restart run, read restart x2a_a + ! Note - a2x_a is computed upon the completion of the previous run - cam_run1 is called + ! only for the purposes of finishing the flux averaged calculation to compute a2x_a + ! Note - cam_run1 is called on restart only to have cam internal state consistent with the + ! a2x_a state sent to the coupler + + ! Redirect share output to cam log + + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (iulog) + + call seq_timemgr_EClockGetData(EClock,curr_ymd=CurrentYMD, StepNo=StepNo, dtime=DTime_Sync ) + + if (masterproc) write(iulog,*)'TJH StepNo check. StepNo is ',StepNo + + if (StepNo == 0) then + call atm_import_mct( x2a_a, cam_in ) + call cam_run1 ( cam_in, cam_out ) + call atm_export_mct( cam_out, a2x_a ) + else + call atm_read_srfrest_mct( EClock, cdata_a, x2a_a, a2x_a ) + call atm_import_mct( x2a_a, cam_in ) + call cam_run1 ( cam_in, cam_out ) + end if + + ! Compute time of next radiation computation, like in run method for exact restart + +! tcx was +! nextsw_cday = radiation_nextsw_cday() + + call seq_timemgr_EClockGetData(Eclock,dtime=atm_cpl_dt) + dtime = get_step_size() + nstep = get_nstep() + if (nstep < 1 .or. dtime < atm_cpl_dt) then + nextsw_cday = radiation_nextsw_cday() + else if (dtime == atm_cpl_dt) then + caldayp1 = get_curr_calday(offset=int(dtime)) + nextsw_cday = radiation_nextsw_cday() + if (caldayp1 /= nextsw_cday) nextsw_cday = -1._r8 + else + call shr_sys_abort('dtime must be less than or equal to atm_cpl_dt') + end if + call seq_infodata_PutData( infodata, nextsw_cday=nextsw_cday ) + + ! End redirection of share output to cam log + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + + end if + +#if (defined _MEMTRACE ) + if(masterproc) then + lbnum=1 + call memmon_dump_fort('memmon.out','atm_init_mct:end::',lbnum) + call memmon_reset_addr() + endif +#endif + + call shr_sys_flush(iulog) + + end subroutine atm_init_mct + +!================================================================================ + + subroutine atm_run_mct( EClock, cdata_a, x2a_a, a2x_a) + + !----------------------------------------------------------------------- + ! + ! Uses + ! + use time_manager, only: advance_timestep, get_curr_date, get_curr_calday, & + get_nstep, get_step_size +! use iop, only: scam_use_iop_srf + use pmgrid, only: plev, plevp + use constituents, only: pcnst + use shr_sys_mod, only: shr_sys_flush + use chemistry, only: chem_reset_fluxes + + ! + ! Arguments + ! + type(ESMF_Clock) ,intent(in) :: EClock + type(seq_cdata) ,intent(inout) :: cdata_a + type(mct_aVect) ,intent(inout) :: x2a_a + type(mct_aVect) ,intent(inout) :: a2x_a + ! + ! Local variables + ! + type(seq_infodata_type),pointer :: infodata + integer :: lsize ! size of attribute vector + integer :: StepNo ! time step + integer :: DTime_Sync ! integer timestep size + integer :: CurrentYMD ! current year-month-day + integer :: iradsw ! shortwave radation frequency (time steps) + logical :: dosend ! true => send data back to driver + integer :: dtime ! time step increment (sec) + integer :: atm_cpl_dt ! driver atm coupling time step + integer :: ymd_sync ! Sync date (YYYYMMDD) + integer :: yr_sync ! Sync current year + integer :: mon_sync ! Sync current month + integer :: day_sync ! Sync current day + integer :: tod_sync ! Sync current time of day (sec) + integer :: ymd ! CAM current date (YYYYMMDD) + integer :: yr ! CAM current year + integer :: mon ! CAM current month + integer :: day ! CAM current day + integer :: tod ! CAM current time of day (sec) + integer :: nstep ! CAM nstep + integer :: shrlogunit,shrloglev ! old values + real(r8):: caldayp1 ! CAM calendar day for for next cam time step + real(r8):: nextsw_cday ! calendar of next atm shortwave + logical :: rstwr ! .true. ==> write restart file before returning + logical :: nlend ! Flag signaling last time-step + logical :: rstwr_sync ! .true. ==> write restart file before returning + logical :: nlend_sync ! Flag signaling last time-step + logical :: first_time = .true. + character(len=*), parameter :: subname="atm_run_mct" + !----------------------------------------------------------------------- + integer :: lbnum + +#if (defined _MEMTRACE) + if(masterproc) then + lbnum=1 + call memmon_dump_fort('memmon.out',SubName //':start::',lbnum) + endif +#endif + + ! Redirect share output to cam log + + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (iulog) + + ! Note that sync clock time should match cam time at end of time step/loop not beginning + + call seq_cdata_setptrs(cdata_a, infodata=infodata) + call seq_timemgr_EClockGetData(EClock,curr_ymd=ymd_sync,curr_tod=tod_sync, & + curr_yr=yr_sync,curr_mon=mon_sync,curr_day=day_sync) + + !load orbital parameters + call seq_infodata_GetData( infodata, & + orb_eccen=eccen, orb_mvelpp=mvelpp, orb_lambm0=lambm0, orb_obliqr=obliqr) + + nlend_sync = seq_timemgr_StopAlarmIsOn(EClock) + rstwr_sync = seq_timemgr_RestartAlarmIsOn(EClock) + + ! Map input from mct to cam data structure + + call t_startf ('CAM_import') + call atm_import_mct( x2a_a, cam_in ) + call t_stopf ('CAM_import') + + ! Cycle over all time steps in the atm coupling interval + + dosend = .false. + do while (.not. dosend) + + ! (re)set surface fluxes of chem tracers here to MEGAN fluxes (from CLM) + ! or to zero so that fluxes read from file can be added to MEGAN + call chem_reset_fluxes( x2a_a%rAttr, cam_in ) + + ! Determine if dosend + ! When time is not updated at the beginning of the loop - then return only if + ! are in sync with clock before time is updated + + call get_curr_date( yr, mon, day, tod ) + ymd = yr*10000 + mon*100 + day + tod = tod + dosend = (seq_timemgr_EClockDateInSync( EClock, ymd, tod)) + + ! Determine if time to write cam restart and stop + + rstwr = .false. + if (rstwr_sync .and. dosend) rstwr = .true. + nlend = .false. + if (nlend_sync .and. dosend) nlend = .true. + + ! Single column specific input + + if (single_column) then + call scam_use_iop_srf( cam_in ) + endif + + ! Run CAM (run2, run3, run4) + + call t_startf ('CAM_run2') + call cam_run2( cam_out, cam_in ) + call t_stopf ('CAM_run2') + + call t_startf ('CAM_run3') + call cam_run3( cam_out ) + call t_stopf ('CAM_run3') + + call t_startf ('CAM_run4') + call cam_run4( cam_out, cam_in, rstwr, nlend, & + yr_spec=yr_sync, mon_spec=mon_sync, day_spec=day_sync, sec_spec=tod_sync) + call t_stopf ('CAM_run4') + + ! Advance cam time step + + call t_startf ('CAM_adv_timestep') + call advance_timestep() + call t_stopf ('CAM_adv_timestep') + + ! Run cam radiation/clouds (run1) + + call t_startf ('CAM_run1') + call cam_run1 ( cam_in, cam_out ) + call t_stopf ('CAM_run1') + + ! Map output from cam to mct data structures + + call t_startf ('CAM_export') + call atm_export_mct( cam_out, a2x_a ) + call t_stopf ('CAM_export') + + ! Compute snapshot attribute vector for accumulation + +! don't accumulate on first coupling freq ts1 and ts2 +! for consistency with ccsm3 when flxave is off + nstep = get_nstep() + if (nstep <= 2) then + call mct_aVect_copy( a2x_a, a2x_a_SUM ) + avg_count = 1 + else + call mct_aVect_copy( a2x_a, a2x_a_SNAP ) + call mct_aVect_accum( aVin=a2x_a_SNAP, aVout=a2x_a_SUM ) + avg_count = avg_count + 1 + endif + + end do + + ! Finish accumulation of attribute vector and average and copy accumulation + ! field into output attribute vector + + call mct_aVect_avg ( a2x_a_SUM, avg_count) + call mct_aVect_copy( a2x_a_SUM, a2x_a ) + call mct_aVect_zero( a2x_a_SUM) + avg_count = 0 + + ! Get time of next radiation calculation - albedos will need to be + ! calculated by each surface model at this time + + call seq_timemgr_EClockGetData(Eclock,dtime=atm_cpl_dt) + dtime = get_step_size() + if (dtime < atm_cpl_dt) then + nextsw_cday = radiation_nextsw_cday() + else if (dtime == atm_cpl_dt) then + caldayp1 = get_curr_calday(offset=int(dtime)) + nextsw_cday = radiation_nextsw_cday() + if (caldayp1 /= nextsw_cday) nextsw_cday = -1._r8 + else + call shr_sys_abort('dtime must be less than or equal to atm_cpl_dt') + end if + call seq_infodata_PutData( infodata, nextsw_cday=nextsw_cday ) + + ! Write merged surface data restart file if appropriate + + if (rstwr_sync) then + call atm_write_srfrest_mct( cdata_a, x2a_a, a2x_a, & + yr_spec=yr_sync, mon_spec=mon_sync, day_spec=day_sync, sec_spec=tod_sync) + end if + + ! Check for consistency of internal cam clock with master sync clock + + dtime = get_step_size() + call get_curr_date( yr, mon, day, tod, offset=-dtime ) + ymd = yr*10000 + mon*100 + day + tod = tod + if ( .not. seq_timemgr_EClockDateInSync( EClock, ymd, tod ) )then + call seq_timemgr_EClockGetData(EClock, curr_ymd=ymd_sync, curr_tod=tod_sync ) + write(iulog,*)' cam ymd=',ymd ,' cam tod= ',tod + write(iulog,*)'sync ymd=',ymd_sync,' sync tod= ',tod_sync + call shr_sys_abort( subname//': CAM clock is not in sync with master Sync Clock' ) + end if + + ! End redirection of share output to cam log + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + +#if (defined _MEMTRACE) + if(masterproc) then + lbnum=1 + call memmon_dump_fort('memmon.out',SubName //':end::',lbnum) + call memmon_reset_addr() + endif +#endif + + end subroutine atm_run_mct + +!================================================================================ + + subroutine atm_final_mct( EClock, cdata_a, x2a_a, a2x_a) + type(ESMF_Clock) ,intent(in) :: EClock + type(seq_cdata) ,intent(inout) :: cdata_a + type(mct_aVect) ,intent(inout) :: x2a_a + type(mct_aVect) ,intent(inout) :: a2x_a + + call cam_final( cam_out, cam_in ) + + end subroutine atm_final_mct + +!================================================================================ + + subroutine atm_SetgsMap_mct( mpicom_atm, ATMID, GSMap_atm ) + use phys_grid, only : get_nlcols_p + !------------------------------------------------------------------- + ! + ! Arguments + ! + integer , intent(in) :: mpicom_atm + integer , intent(in) :: ATMID + type(mct_gsMap), intent(out) :: GSMap_atm + ! + ! Local variables + ! + integer, allocatable :: gindex(:) + integer :: i, n, c, ncols, sizebuf, nlcols + integer :: ier ! error status + !------------------------------------------------------------------- + + ! Build the atmosphere grid numbering for MCT + ! NOTE: Numbering scheme is: West to East and South to North + ! starting at south pole. Should be the same as what's used in SCRIP + + ! Determine global seg map + + sizebuf=0 + do c = begchunk, endchunk + ncols = get_ncols_p(c) + do i = 1,ncols + sizebuf = sizebuf+1 + end do + end do + + allocate(gindex(sizebuf)) + + n=0 + do c = begchunk, endchunk + ncols = get_ncols_p(c) + do i = 1,ncols + n=n+1 + gindex(n) = get_gcol_p(c,i) + end do + end do + + nlcols = get_nlcols_p() + call mct_gsMap_init( gsMap_atm, gindex, mpicom_atm, ATMID, nlcols, ngcols) + + deallocate(gindex) + + end subroutine atm_SetgsMap_mct + +!=============================================================================== + + subroutine atm_import_mct( x2a_a, cam_in ) + + !----------------------------------------------------------------------- + ! + ! Uses + ! + use dust_intr, only: dust_idx1 +#if (defined MODAL_AERO) + use mo_chem_utls, only: get_spc_ndx +#endif + use shr_const_mod, only: shr_const_stebol + use seq_drydep_mod,only: n_drydep + ! + ! Arguments + ! + type(mct_aVect), intent(inout) :: x2a_a + type(cam_in_t), intent(inout) :: cam_in(begchunk:endchunk) + ! + ! Local variables + ! + integer :: i,lat,n,c,ig ! indices + integer :: ncols ! number of columns + integer :: dust_ndx + logical, save :: first_time = .true. + +#if (defined MODAL_AERO) + integer, parameter:: ndst =2 + integer, target :: spc_ndx(ndst) +#if (defined MODAL_AERO_7MODE) + integer, pointer :: dst_a5_ndx, dst_a7_ndx +#elif (defined MODAL_AERO_3MODE) + integer, pointer :: dst_a1_ndx, dst_a3_ndx +#endif +#endif + !----------------------------------------------------------------------- + ! +#if (defined MODAL_AERO) +#if (defined MODAL_AERO_7MODE) + dst_a5_ndx => spc_ndx(1) + dst_a7_ndx => spc_ndx(2) + dst_a5_ndx = get_spc_ndx( 'dst_a5' ) + dst_a7_ndx = get_spc_ndx( 'dst_a7' ) +#elif (defined MODAL_AERO_3MODE) + dst_a1_ndx => spc_ndx(1) + dst_a3_ndx => spc_ndx(2) + dst_a1_ndx = get_spc_ndx( 'dst_a1' ) + dst_a3_ndx = get_spc_ndx( 'dst_a3' ) +#endif +#endif + + ! ccsm sign convention is that fluxes are positive downward + + ig=1 + do c=begchunk,endchunk + ncols = get_ncols_p(c) + + ! initialize constituent surface fluxes to zero + cam_in(c)%cflx(:,:) = 0._r8 + + do i =1,ncols + cam_in(c)%wsx(i) = -x2a_a%rAttr(index_x2a_Faxx_taux,ig) + cam_in(c)%wsy(i) = -x2a_a%rAttr(index_x2a_Faxx_tauy,ig) + cam_in(c)%lhf(i) = -x2a_a%rAttr(index_x2a_Faxx_lat, ig) + cam_in(c)%shf(i) = -x2a_a%rAttr(index_x2a_Faxx_sen, ig) + cam_in(c)%lwup(i) = -x2a_a%rAttr(index_x2a_Faxx_lwup,ig) + cam_in(c)%cflx(i,1) = -x2a_a%rAttr(index_x2a_Faxx_evap,ig) + cam_in(c)%asdir(i) = x2a_a%rAttr(index_x2a_Sx_avsdr, ig) + cam_in(c)%aldir(i) = x2a_a%rAttr(index_x2a_Sx_anidr, ig) + cam_in(c)%asdif(i) = x2a_a%rAttr(index_x2a_Sx_avsdf, ig) + cam_in(c)%aldif(i) = x2a_a%rAttr(index_x2a_Sx_anidf, ig) + cam_in(c)%ts(i) = x2a_a%rAttr(index_x2a_Sx_t, ig) + cam_in(c)%sst(i) = x2a_a%rAttr(index_x2a_So_t, ig) + cam_in(c)%snowhland(i) = x2a_a%rAttr(index_x2a_Sl_snowh, ig) + cam_in(c)%snowhice(i) = x2a_a%rAttr(index_x2a_Si_snowh, ig) + cam_in(c)%tref(i) = x2a_a%rAttr(index_x2a_Sx_tref, ig) + cam_in(c)%qref(i) = x2a_a%rAttr(index_x2a_Sx_qref, ig) + cam_in(c)%u10(i) = x2a_a%rAttr(index_x2a_Sx_u10, ig) + cam_in(c)%icefrac(i) = x2a_a%rAttr(index_x2a_Sf_ifrac, ig) + cam_in(c)%ocnfrac(i) = x2a_a%rAttr(index_x2a_Sf_ofrac, ig) + cam_in(c)%landfrac(i) = x2a_a%rAttr(index_x2a_Sf_lfrac, ig) + if ( associated(cam_in(c)%ram1) ) & + cam_in(c)%ram1(i) = x2a_a%rAttr(index_x2a_Sl_ram1 , ig) + if ( associated(cam_in(c)%fv) ) & + cam_in(c)%fv(i) = x2a_a%rAttr(index_x2a_Sl_fv , ig) + if ( associated(cam_in(c)%soilw) ) & + cam_in(c)%soilw(i) = x2a_a%rAttr(index_x2a_Sl_soilw, ig) + dust_ndx = dust_idx1() + ! check that dust constituents are actually in the simulation + if (dust_ndx>0) then +#if (defined MODAL_AERO) +#if (defined MODAL_AERO_7MODE) + cam_in(c)%cflx(i,dust_ndx ) = 0.13_r8 & ! 1st mode, based on Zender et al (2003) Table 1 +#elif (defined MODAL_AERO_3MODE) + cam_in(c)%cflx(i,dust_ndx ) = 0.032_r8 & ! 1st mode, based on Zender et al (2003) Table 1 +#endif + * (-x2a_a%rAttr(index_x2a_Fall_flxdst1, ig) & + -x2a_a%rAttr(index_x2a_Fall_flxdst2, ig) & + -x2a_a%rAttr(index_x2a_Fall_flxdst3, ig) & + -x2a_a%rAttr(index_x2a_Fall_flxdst4, ig)) +#if (defined MODAL_AERO_7MODE) + cam_in(c)%cflx(i,dust_ndx-spc_ndx(1)+spc_ndx(2)) = 0.87_r8 & ! 2nd mode +#elif (defined MODAL_AERO_3MODE) + cam_in(c)%cflx(i,dust_ndx-spc_ndx(1)+spc_ndx(2)) = 0.968_r8 & ! 2nd mode +#endif + * (-x2a_a%rAttr(index_x2a_Fall_flxdst1, ig) & + -x2a_a%rAttr(index_x2a_Fall_flxdst2, ig) & + -x2a_a%rAttr(index_x2a_Fall_flxdst3, ig) & + -x2a_a%rAttr(index_x2a_Fall_flxdst4, ig)) +#else + cam_in(c)%cflx(i,dust_ndx ) = -x2a_a%rAttr(index_x2a_Fall_flxdst1, ig) + cam_in(c)%cflx(i,dust_ndx +1) = -x2a_a%rAttr(index_x2a_Fall_flxdst2, ig) + cam_in(c)%cflx(i,dust_ndx +2) = -x2a_a%rAttr(index_x2a_Fall_flxdst3, ig) + cam_in(c)%cflx(i,dust_ndx +3) = -x2a_a%rAttr(index_x2a_Fall_flxdst4, ig) +#endif + endif + + ! dry dep velocities + if ( index_x2a_Sl_ddvel/=0 .and. n_drydep>0 ) then + cam_in(c)%depvel(i,:n_drydep) = & + x2a_a%rAttr(index_x2a_Sl_ddvel:index_x2a_Sl_ddvel+n_drydep-1, ig) + endif + ! + ! fields needed to calculate water isotopes to ocean evaporation processes + ! + cam_in(c)%ustar(i) = x2a_a%rAttr(index_x2a_So_ustar,ig) + cam_in(c)%re(i) = x2a_a%rAttr(index_x2a_So_re ,ig) + cam_in(c)%ssq(i) = x2a_a%rAttr(index_x2a_So_ssq ,ig) + ! + ! bgc scenarios + ! + if (index_x2a_Fall_fco2_lnd /= 0) then + cam_in(c)%fco2_lnd(i) = -x2a_a%rAttr(index_x2a_Fall_fco2_lnd,ig) + end if + if (index_x2a_Faoo_fco2_ocn /= 0) then + cam_in(c)%fco2_ocn(i) = -x2a_a%rAttr(index_x2a_Faoo_fco2_ocn,ig) + end if + if (index_x2a_Faoo_fdms_ocn /= 0) then + cam_in(c)%fdms(i) = -x2a_a%rAttr(index_x2a_Faoo_fdms_ocn,ig) + end if + + ig=ig+1 + + end do + end do + + ! Get total co2 flux from components, + ! Note - co2_transport determines if cam_in(c)%cflx(i,c_i(1:4)) is allocated + + if (co2_transport()) then + + ! Interpolate in time for flux data read in + if (co2_readFlux_ocn) then + call co2_time_interp_ocn + end if + if (co2_readFlux_fuel) then + call co2_time_interp_fuel + end if + + ! from ocn : data read in or from coupler or zero + ! from fuel: data read in or zero + ! from lnd : through coupler or zero + do c=begchunk,endchunk + ncols = get_ncols_p(c) + do i=1,ncols + + ! all co2 fluxes in unit kgCO2/m2/s ! co2 flux from ocn + if (index_x2a_Faoo_fco2_ocn /= 0) then + cam_in(c)%cflx(i,c_i(1)) = cam_in(c)%fco2_ocn(i) + else if (co2_readFlux_ocn) then + ! convert from molesCO2/m2/s to kgCO2/m2/s + cam_in(c)%cflx(i,c_i(1)) = & + -data_flux_ocn%co2flx(i,c)*(1._r8- cam_in(c)%landfrac(i)) & + *mwco2*1.0e-3_r8 + else + cam_in(c)%cflx(i,c_i(1)) = 0._r8 + end if + + ! co2 flux from fossil fuel + if (co2_readFlux_fuel) then + cam_in(c)%cflx(i,c_i(2)) = data_flux_fuel%co2flx(i,c) + else + cam_in(c)%cflx(i,c_i(2)) = 0._r8 + end if + + ! co2 flux from land (cpl already multiplies flux by land fraction) + if (index_x2a_Fall_fco2_lnd /= 0) then + cam_in(c)%cflx(i,c_i(3)) = cam_in(c)%fco2_lnd(i) + else + cam_in(c)%cflx(i,c_i(3)) = 0._r8 + end if + + ! merged co2 flux + cam_in(c)%cflx(i,c_i(4)) = cam_in(c)%cflx(i,c_i(1)) + & + cam_in(c)%cflx(i,c_i(2)) + & + cam_in(c)%cflx(i,c_i(3)) + end do + end do + end if + ! + ! if first step, determine longwave up flux from the surface temperature + ! + if (first_time) then + if (is_first_step()) then + do c=begchunk, endchunk + ncols = get_ncols_p(c) + do i=1,ncols + cam_in(c)%lwup(i) = shr_const_stebol*(cam_in(c)%ts(i)**4) + end do + end do + end if + first_time = .false. + end if + + end subroutine atm_import_mct + +!=============================================================================== + + subroutine atm_export_mct( cam_out, a2x_a ) + + !------------------------------------------------------------------- + ! + ! Arguments + ! + type(cam_out_t), intent(in) :: cam_out(begchunk:endchunk) + type(mct_aVect), intent(out) :: a2x_a + ! + ! Local variables + ! + integer :: avsize, avnat + integer :: i,m,c,n,ig ! indices + integer :: ncols ! Number of columns + !----------------------------------------------------------------------- + + ! Copy from component arrays into chunk array data structure + ! Rearrange data from chunk structure into lat-lon buffer and subsequently + ! create attribute vector + + ig=1 + do c=begchunk, endchunk + ncols = get_ncols_p(c) + do i=1,ncols + a2x_a%rAttr(index_a2x_Sa_pslv ,ig) = cam_out(c)%psl(i) + a2x_a%rAttr(index_a2x_Sa_z ,ig) = cam_out(c)%zbot(i) + a2x_a%rAttr(index_a2x_Sa_u ,ig) = cam_out(c)%ubot(i) + a2x_a%rAttr(index_a2x_Sa_v ,ig) = cam_out(c)%vbot(i) + a2x_a%rAttr(index_a2x_Sa_tbot ,ig) = cam_out(c)%tbot(i) + a2x_a%rAttr(index_a2x_Sa_ptem ,ig) = cam_out(c)%thbot(i) + a2x_a%rAttr(index_a2x_Sa_pbot ,ig) = cam_out(c)%pbot(i) + a2x_a%rAttr(index_a2x_Sa_shum ,ig) = cam_out(c)%qbot(i,1) + a2x_a%rAttr(index_a2x_Sa_dens ,ig) = cam_out(c)%rho(i) + a2x_a%rAttr(index_a2x_Faxa_swnet,ig) = cam_out(c)%netsw(i) + a2x_a%rAttr(index_a2x_Faxa_lwdn ,ig) = cam_out(c)%flwds(i) + a2x_a%rAttr(index_a2x_Faxa_rainc,ig) = (cam_out(c)%precc(i)-cam_out(c)%precsc(i))*1000._r8 + a2x_a%rAttr(index_a2x_Faxa_rainl,ig) = (cam_out(c)%precl(i)-cam_out(c)%precsl(i))*1000._r8 + a2x_a%rAttr(index_a2x_Faxa_snowc,ig) = cam_out(c)%precsc(i)*1000._r8 + a2x_a%rAttr(index_a2x_Faxa_snowl,ig) = cam_out(c)%precsl(i)*1000._r8 + a2x_a%rAttr(index_a2x_Faxa_swndr,ig) = cam_out(c)%soll(i) + a2x_a%rAttr(index_a2x_Faxa_swvdr,ig) = cam_out(c)%sols(i) + a2x_a%rAttr(index_a2x_Faxa_swndf,ig) = cam_out(c)%solld(i) + a2x_a%rAttr(index_a2x_Faxa_swvdf,ig) = cam_out(c)%solsd(i) + + ! aerosol deposition fluxes + a2x_a%rAttr(index_a2x_Faxa_bcphidry,ig) = cam_out(c)%bcphidry(i) + a2x_a%rAttr(index_a2x_Faxa_bcphodry,ig) = cam_out(c)%bcphodry(i) + a2x_a%rAttr(index_a2x_Faxa_bcphiwet,ig) = cam_out(c)%bcphiwet(i) + a2x_a%rAttr(index_a2x_Faxa_ocphidry,ig) = cam_out(c)%ocphidry(i) + a2x_a%rAttr(index_a2x_Faxa_ocphodry,ig) = cam_out(c)%ocphodry(i) + a2x_a%rAttr(index_a2x_Faxa_ocphiwet,ig) = cam_out(c)%ocphiwet(i) + a2x_a%rAttr(index_a2x_Faxa_dstwet1,ig) = cam_out(c)%dstwet1(i) + a2x_a%rAttr(index_a2x_Faxa_dstdry1,ig) = cam_out(c)%dstdry1(i) + a2x_a%rAttr(index_a2x_Faxa_dstwet2,ig) = cam_out(c)%dstwet2(i) + a2x_a%rAttr(index_a2x_Faxa_dstdry2,ig) = cam_out(c)%dstdry2(i) + a2x_a%rAttr(index_a2x_Faxa_dstwet3,ig) = cam_out(c)%dstwet3(i) + a2x_a%rAttr(index_a2x_Faxa_dstdry3,ig) = cam_out(c)%dstdry3(i) + a2x_a%rAttr(index_a2x_Faxa_dstwet4,ig) = cam_out(c)%dstwet4(i) + a2x_a%rAttr(index_a2x_Faxa_dstdry4,ig) = cam_out(c)%dstdry4(i) + + if (index_a2x_Sa_co2prog /= 0) then + a2x_a%rAttr(index_a2x_Sa_co2prog,ig) = cam_out(c)%co2prog(i) ! atm prognostic co2 + end if + if (index_a2x_Sa_co2diag /= 0) then + a2x_a%rAttr(index_a2x_Sa_co2diag,ig) = cam_out(c)%co2diag(i) ! atm diagnostic co2 + end if + + ig=ig+1 + end do + end do + + end subroutine atm_export_mct + +!=============================================================================== + + subroutine atm_domain_mct( lsize, gsMap_a, dom_a ) + + !------------------------------------------------------------------- + ! + ! Arguments + ! + integer , intent(in) :: lsize + type(mct_gsMap), intent(in) :: gsMap_a + type(mct_ggrid), intent(inout):: dom_a + ! + ! Local Variables + ! + integer :: n,i,c,ncols ! indices + real(r8) :: lats(pcols) ! array of chunk latitudes + real(r8) :: lons(pcols) ! array of chunk longitude + real(r8) :: area(pcols) ! area in radians squared for each grid point + real(r8), pointer :: data(:) ! temporary + integer , pointer :: idata(:) ! temporary + real(r8), parameter:: radtodeg = 180.0_r8/SHR_CONST_PI + !------------------------------------------------------------------- + ! + ! Initialize mct atm domain + ! + call mct_gGrid_init( GGrid=dom_a, CoordChars=trim(seq_flds_dom_coord), OtherChars=trim(seq_flds_dom_other), lsize=lsize ) + ! + ! Allocate memory + ! + allocate(data(lsize)) + ! + ! Initialize attribute vector with special value + ! + call mct_gsMap_orderedPoints(gsMap_a, iam, idata) + call mct_gGrid_importIAttr(dom_a,'GlobGridNum',idata,lsize) + ! + ! Determine domain (numbering scheme is: West to East and South to North to South pole) + ! Initialize attribute vector with special value + ! + data(:) = -9999.0_R8 + call mct_gGrid_importRAttr(dom_a,"lat" ,data,lsize) + call mct_gGrid_importRAttr(dom_a,"lon" ,data,lsize) + call mct_gGrid_importRAttr(dom_a,"area" ,data,lsize) + call mct_gGrid_importRAttr(dom_a,"aream",data,lsize) + data(:) = 0.0_R8 + call mct_gGrid_importRAttr(dom_a,"mask" ,data,lsize) + data(:) = 1.0_R8 + call mct_gGrid_importRAttr(dom_a,"frac" ,data,lsize) + ! + ! Fill in correct values for domain components + ! + n=0 + do c = begchunk, endchunk + ncols = get_ncols_p(c) + call get_rlat_all_p(c, ncols, lats) + do i=1,ncols + n = n+1 + data(n) = lats(i)*radtodeg + end do + end do + call mct_gGrid_importRAttr(dom_a,"lat",data,lsize) + + n=0 + do c = begchunk, endchunk + ncols = get_ncols_p(c) + call get_rlon_all_p(c, ncols, lons) + do i=1,ncols + n = n+1 + data(n) = lons(i)*radtodeg + end do + end do + call mct_gGrid_importRAttr(dom_a,"lon",data,lsize) + + n=0 + do c = begchunk, endchunk + ncols = get_ncols_p(c) + call get_area_all_p(c, ncols, area) + do i=1,ncols + n = n+1 + data(n) = area(i) + end do + end do + call mct_gGrid_importRAttr(dom_a,"area",data,lsize) + + n=0 + do c = begchunk, endchunk + ncols = get_ncols_p(c) + do i=1,ncols + n = n+1 + data(n) = 1._r8 ! mask + end do + end do + call mct_gGrid_importRAttr(dom_a,"mask" ,data,lsize) + deallocate(data) + + end subroutine atm_domain_mct + +!=========================================================================================== +! + subroutine atm_read_srfrest_mct( EClock, cdata_a, x2a_a, a2x_a) + use cam_pio_utils + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(ESMF_Clock),intent(in) :: EClock + type(seq_cdata), intent(inout) :: cdata_a + type(mct_aVect), intent(inout) :: x2a_a + type(mct_aVect), intent(inout) :: a2x_a + ! + ! Local variables + ! + integer :: npts ! array size + integer :: rcode ! return error code + type(mct_aVect) :: gData ! global/gathered bundle data + integer :: yr_spec ! Current year + integer :: mon_spec ! Current month + integer :: day_spec ! Current day + integer :: sec_spec ! Current time of day (sec) + + character(len=4) :: str_year + character(len=2) :: str_month + character(len=2) :: str_day + character(len=5) :: str_sec + !----------------------------------------------------------------------- + ! + ! Determine and open surface restart dataset + ! + integer, pointer :: dof(:) + integer :: lnx, nf_x2a, nf_a2x, k + real(r8), allocatable :: tmp(:) + type(file_desc_t) :: file + type(io_desc_t) :: iodesc + type(var_desc_t) :: varid + character(CL) :: itemc ! string converted to char + type(mct_string) :: mstring ! mct char type + + + + call seq_timemgr_EClockGetData( EClock, curr_yr=yr_spec,curr_mon=mon_spec, & + curr_day=day_spec, curr_tod=sec_spec ) + + if (dart_mode) then + write(str_year ,'(i4.4)') yr_spec + write(str_month,'(i2.2)') mon_spec + write(str_day ,'(i2.2)') day_spec + write(str_sec ,'(i5.5)') sec_spec + fname_srf_cam = trim(caseid) //".cam"// trim(inst_suffix) //".rs."// str_year //"-"// str_month //"-"// str_day //"-"// str_sec //".nc" + call getfil(fname_srf_cam, fname_srf_cam) + else + fname_srf_cam = interpret_filename_spec( rsfilename_spec_cam, case=get_restcase(), & + yr_spec=yr_spec, mon_spec=mon_spec, day_spec=day_spec, sec_spec= sec_spec ) + pname_srf_cam = trim(get_restartdir() )//fname_srf_cam + call getfil(pname_srf_cam, fname_srf_cam) + end if + + call cam_pio_openfile(File, fname_srf_cam, 0) + call mct_gsmap_OrderedPoints(cdata_a%gsmap, iam, Dof) + lnx = mct_gsmap_gsize(cdata_a%gsmap) + call pio_initdecomp(pio_subsystem, pio_double, (/lnx/), dof, iodesc) + allocate(tmp(size(dof))) + deallocate(dof) + + nf_x2a = mct_aVect_nRattr(x2a_a) + + do k=1,nf_x2a + call mct_aVect_getRList(mstring,k,x2a_a) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) + + call pio_seterrorhandling(File, pio_bcast_error) + rcode = pio_inq_varid(File,'x2a_'//trim(itemc) ,varid) + if (rcode == pio_noerr) then + call pio_read_darray(File, varid, iodesc, tmp, rcode) + x2a_a%rattr(k,:) = tmp(:) + else + if (masterproc) then + write(iulog,*)'srfrest warning: field ',trim(itemc),' is not on restart file' + write(iulog,*)'for backwards compatibility will set it to 0' + end if + x2a_a%rattr(k,:) = 0._r8 + end if + call pio_seterrorhandling(File, pio_internal_error) + end do + + nf_a2x = mct_aVect_nRattr(a2x_a) + + do k=1,nf_a2x + call mct_aVect_getRList(mstring,k,a2x_a) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) + + rcode = pio_inq_varid(File,'a2x_'//trim(itemc) ,varid) + call pio_read_darray(File, varid, iodesc, tmp, rcode) + a2x_a%rattr(k,:) = tmp(:) + end do + + call pio_freedecomp(File,iodesc) + call pio_closefile(File) + deallocate(tmp) + + end subroutine atm_read_srfrest_mct +! +!=========================================================================================== +! + subroutine atm_write_srfrest_mct( cdata_a, x2a_a, a2x_a, & + yr_spec, mon_spec, day_spec, sec_spec) + use cam_pio_utils + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(seq_cdata), intent(in) :: cdata_a + type(mct_aVect), intent(in) :: x2a_a + type(mct_aVect), intent(in) :: a2x_a + integer , intent(in) :: yr_spec ! Simulation year + integer , intent(in) :: mon_spec ! Simulation month + integer , intent(in) :: day_spec ! Simulation day + integer , intent(in) :: sec_spec ! Seconds into current simulation day + ! + ! Local variables + ! + integer :: rcode ! return error code + type(mct_aVect) :: gData ! global/gathered bundle data + !----------------------------------------------------------------------- + ! + ! Determine and open surface restart dataset + ! + + integer, pointer :: dof(:) + integer :: nf_x2a, nf_a2x, lnx, dimid(1), k + type(file_desc_t) :: file + type(var_desc_t), pointer :: varid_x2a(:), varid_a2x(:) + type(io_desc_t) :: iodesc + character(CL) :: itemc ! string converted to char + type(mct_string) :: mstring ! mct char type + + + fname_srf_cam = interpret_filename_spec( rsfilename_spec_cam, & + yr_spec=yr_spec, mon_spec=mon_spec, day_spec=day_spec, sec_spec= sec_spec ) + call cam_pio_createfile(File, fname_srf_cam, 0) + + call mct_gsmap_OrderedPoints(cdata_a%gsmap, iam, Dof) + lnx = mct_gsmap_gsize(cdata_a%gsmap) + call pio_initdecomp(pio_subsystem, pio_double, (/lnx/), dof, iodesc) + + deallocate(dof) + + nf_x2a = mct_aVect_nRattr(x2a_a) + allocate(varid_x2a(nf_x2a)) + + rcode = pio_def_dim(File,'x2a_nx',lnx,dimid(1)) + do k = 1,nf_x2a + call mct_aVect_getRList(mstring,k,x2a_a) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) + rcode = pio_def_var(File,'x2a_'//trim(itemc),PIO_DOUBLE,dimid,varid_x2a(k)) + rcode = pio_put_att(File,varid_x2a(k),"_fillvalue",fillvalue) + enddo + + nf_a2x = mct_aVect_nRattr(a2x_a) + allocate(varid_a2x(nf_a2x)) + + rcode = pio_def_dim(File,'a2x_nx',lnx,dimid(1)) + do k = 1,nf_a2x + call mct_aVect_getRList(mstring,k,a2x_a) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) + rcode = PIO_def_var(File,'a2x_'//trim(itemc),PIO_DOUBLE,dimid,varid_a2x(k)) + rcode = PIO_put_att(File,varid_a2x(k),"_fillvalue",fillvalue) + enddo + + rcode = pio_enddef(File) ! don't check return code, might be enddef already + + + do k=1,nf_x2a + call pio_write_darray(File, varid_x2a(k), iodesc, x2a_a%rattr(k,:), rcode) + end do + + do k=1,nf_a2x + call pio_write_darray(File, varid_a2x(k), iodesc, a2x_a%rattr(k,:), rcode) + end do + + deallocate(varid_x2a, varid_a2x) + + call pio_freedecomp(File,iodesc) + call pio_closefile(file) + + + end subroutine atm_write_srfrest_mct + +!================================================================================ + +end module atm_comp_mct diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/dynamics/fv/cd_core.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/dynamics/fv/cd_core.F90 new file mode 100644 index 0000000000..cd5f09c571 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/dynamics/fv/cd_core.F90 @@ -0,0 +1,1602 @@ + +! DART note: this file started life as: +! /glade/p/cesmdata/cseg/collections/cesm1_1/models/atm/cam/src/dynamics/fv/cd_core.F90 + +!----------------------------------------------------------------------- +!BOP +! !ROUTINE: cd_core --- Dynamical core for both C- and D-grid Lagrangian +! dynamics +! +! !INTERFACE: + subroutine cd_core(grid, nx, u, v, pt, & + delp, pe, pk, ns, dt, & + ptopin, umax, pi, ae, cp, akap, & + iord_c, jord_c, iord_d, jord_d, ipe, & + om, hs, cx3 , cy3, mfx, mfy, & + delpf, uc, vc, ptc, dpt, ptk, & + wz3, pkc, wz, hsxy, ptxy, pkxy, & + pexy, pkcc, wzc, wzxy, delpxy, & + pkkp, wzkp, cx_om, cy_om, filtcw, s_trac, & + mlt, ncx, ncy, nmfx, nmfy, iremote, & + cxtag, cytag, mfxtag, mfytag, & + cxreqs, cyreqs, mfxreqs, mfyreqs) + +! !USES: + use shr_kind_mod, only : r8 => shr_kind_r8 + use sw_core, only : d2a2c_winds, c_sw, d_sw + use pft_module, only : pft2d + use dynamics_vars, only : T_FVDYCORE_GRID + use FVperf_module, only : FVstartclock, FVstopclock, FVbarrierclock + use cam_logfile, only : iulog + use fv_control_mod, only: div24del2flag, del2coef + use spmd_utils, only: masterproc + use abortutils, only: endrun + +#if defined( SPMD ) + use mod_comm, only : mp_send4d_ns, mp_recv4d_ns, & + mp_send2_ns, mp_recv2_ns, & + mp_send3d_2, mp_recv3d_2, & + mp_send3d, mp_recv3d, mp_sendirr, & + mp_recvirr + use mpishorthand +#endif + +#if defined( OFFLINE_DYN ) + use metdata, only : get_met_fields, met_winds_on_walls +#endif + use metdata, only : met_rlx + + implicit none + +! !INPUT PARAMETERS: + + type (T_FVDYCORE_GRID), intent(inout) :: grid! grid (for YZ decomp) + integer, intent(in) :: nx ! # of split pieces in longitude direction + integer, intent(in) :: ipe ! ipe=1: end of cd_core() + ! ipe=-1,-2: start of cd_core() + ! ipe=-2,2: second to last call to cd_core() + ! ipe=0 : + integer, intent(in) :: ns ! Number of internal time steps (splitting) + integer, intent(in) :: iord_c, jord_c ! scheme order on C grid in X and Y dir. + integer, intent(in) :: iord_d, jord_d ! scheme order on D grid in X and Y dir. + integer, intent(in) :: filtcw ! flag for filtering C-grid winds + +! ct_overlap data + logical, intent(in) :: s_trac ! true to post send for ct_overlap or + ! tracer decomposition information + integer, intent(in) :: mlt ! multiplicity of sends + integer, intent(in) :: ncx, ncy, nmfx, nmfy ! array sizes + integer, intent(in) :: cxtag(mlt), cytag(mlt) ! tags + integer, intent(in) :: mfxtag(mlt), mfytag(mlt) ! tags + integer, intent(in) :: iremote(mlt) ! target tasks + integer, intent(in) :: cxreqs(mlt), cyreqs(mlt) ! mpi requests + integer, intent(in) :: mfxreqs(mlt), mfyreqs(mlt) ! mpi requests + + + real(r8), intent(in) :: pi + real(r8), intent(in) :: ae ! Radius of the Earth (m) + real(r8), intent(in) :: om ! rotation rate + real(r8), intent(in) :: ptopin + real(r8), intent(in) :: umax + real(r8), intent(in) :: dt !small time step in seconds + real(r8), intent(in) :: cp + real(r8), intent(in) :: akap + +! Input time independent arrays: + real(r8), intent(in) :: & + hs(grid%im,grid%jfirst:grid%jlast) !surface geopotential + real(r8), intent(in) :: & + hsxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy) !surface geopotential XY-decomp. + +! !INPUT/OUTPUT PARAMETERS: + + real(r8), intent(inout) :: & + u(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_s,grid%kfirst:grid%klast) ! u-Wind (m/s) + real(r8), intent(inout) :: & + v(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) ! v-Wind (m/s) + + real(r8), intent(inout) :: & + delp(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) ! Delta pressure (pascal) + real(r8), intent(inout) :: & + pt(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast)! Scaled-Pot. temp. + +! Input/output: accumulated winds & mass fluxes on c-grid for large- +! time-step transport + real(r8), intent(inout) :: & + cx3(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast)! Accum. Courant no. in X + real(r8), intent(inout) :: & + cy3(grid%im,grid%jfirst:grid%jlast+1,grid%kfirst:grid%klast) ! Accumulated Courant no. in Y + real(r8), intent(inout) :: & + mfx(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) ! Mass flux in X (unghosted) + real(r8), intent(inout) :: & + mfy(grid%im,grid%jfirst:grid%jlast+1,grid%kfirst:grid%klast) ! Mass flux in Y + +! Input/output work arrays: + real(r8), intent(inout) :: & + delpf(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) ! filtered delp + real(r8), intent(inout) :: & + uc(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) ! u-Winds on C-grid + real(r8), intent(inout) :: & + vc(grid%im,grid%jfirst-2: grid%jlast+2, grid%kfirst:grid%klast) ! v-Winds on C-grid + + real(r8), intent(inout) :: & + dpt(grid%im,grid%jfirst-1:grid%jlast+1,grid%kfirst:grid%klast) + real(r8), intent(inout) :: & + wz3(grid%im,grid%jfirst-1:grid%jlast ,grid%kfirst:grid%klast+1) + real(r8), intent(inout) :: & + pkc(grid%im,grid%jfirst-1:grid%jlast+1,grid%kfirst:grid%klast+1) + real(r8), intent(inout) :: & + wz(grid%im,grid%jfirst-1:grid%jlast+1,grid%kfirst:grid%klast+1) + real(r8), intent(inout) :: & + pkcc(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) + real(r8), intent(inout) :: & + wzc(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) + real(r8), intent(inout) :: & + wzxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km+1) + real(r8), intent(inout) :: & + delpxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) + real(r8), intent(inout) :: & + pkkp(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) + real(r8), intent(inout) :: & + wzkp(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) + +! !OUTPUT PARAMETERS: + real(r8), intent(out) :: & + pe(grid%im,grid%kfirst:grid%klast+1,grid%jfirst:grid%jlast) ! Edge pressure (pascal) + real(r8), intent(out) :: & + pk(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) ! Pressure to the kappa + real(r8), intent(out) :: & + ptxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! Potential temperature XY decomp + real(r8), intent(out) :: & + pkxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km+1) ! P-to-the-kappa XY decomp + real(r8), intent(out) :: & + pexy(grid%ifirstxy:grid%ilastxy,grid%km+1,grid%jfirstxy:grid%jlastxy) ! Edge pressure XY decomp + real(r8), intent(out) :: & + ptc(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) + real(r8), intent(out) :: & + ptk(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) +! Work arrays + +! ! !DESCRIPTION: +! Perform a dynamical update for one small time step; the small +! time step is limitted by the fastest wave within the Lagrangian control- +! volume +! +! !REVISION HISTORY: +! SJL 99.01.01: Original SMP version +! WS 99.04.13: Added jfirst:jlast concept +! SJL 99.07.15: Merged c_core and d_core to this routine +! WS 99.09.07: Restructuring, cleaning, documentation +! WS 99.10.18: Walkthrough corrections; frozen for 1.0.7 +! WS 99.11.23: Pruning of some 2-D arrays +! SJL 99.12.23: More comments; general optimization; reduction +! of redundant computation & communication +! WS 00.05.14: Modified ghost indices per Kevin's definition +! WS 00.07.13: Changed PILGRIM API +! WS 00.08.28: Cosmetic changes: removed old loop limit comments +! AAM 00.08.30: Introduced kfirst,klast +! WS 00.12.01: Replaced MPI_ON with SPMD; hs now distributed +! WS 01.04.11: PILGRIM optimizations for begin/endtransfer +! WS 01.05.08: Optimizations in the call of c_sw and d_sw +! AAM 01.06.27: Reinstituted 2D decomposition for use in ccm +! WS 01.12.10: Ghosted PT, code now uses mod_comm primitives +! WS 01.12.31: Removed vorticity damping, ghosted U,V,PT +! WS 02.01.15: Completed transition to mod_comm +! WS 02.07.04: Fixed 2D decomposition bug dest/src for mp_send3d +! WS 02.09.04: Integrated fvgcm-1_3_71 zero diff. changes by Lin +! WS 03.07.22: Removed HIGH_P option; this is outdated +! WS 03.10.15: Fixed hack of 00.04.13 for JORD>1 JCD=1, in clean way +! WS 03.12.03: Added grid as argument, some dynamics_vars removed +! WS 04.08.25: Interface simplified with GRID argument +! WS 04.10.07: Removed dependency on spmd_dyn; info now in GRID +! WS 05.05.24: Incorporated OFFLINE_DYN; merge of CAM/GEOS5 +! PW 05.07.26: Changes for Cray X1 +! PW 05.10.12: More changes for Cray X1(E), avoiding array segment copying +! WS 06.09.08: Isolated magic numbers as F90 parameters +! WS 06.09.15: PI now passed as argument +! CC 07.01.29: Corrected calculation of OMEGA +! PW 08.06.29: Added options to call geopk_d and swap-based transposes +! +!EOP +!--------------------------------------------------------------------- +!BOC + +! Local 2D arrays: + real(r8) :: wk(grid%im+2,grid%jfirst: grid%jlast+2) + real(r8) :: wk1(grid%im,grid%jfirst-1:grid%jlast+1) + real(r8) :: wk2(grid%im+1,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) + real(r8) :: wk3(grid%im,grid%jfirst-1:grid%jlast+1) + + real(r8) :: p1d(grid%im) + +! fvitt cell centered u- and v-Winds (m/s) + real(r8) :: u_cen(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) + real(r8) :: v_cen(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) + real(r8) :: ua(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) + real(r8) :: va(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) + + +! Local scalars + + real(r8), parameter :: D0_0 = 0.0_r8 + real(r8), parameter :: D0_1 = 0.1_r8 + real(r8), parameter :: D0_5 = 0.5_r8 + real(r8), parameter :: D1_0 = 1.0_r8 + real(r8), parameter :: D4_0 = 4.0_r8 + real(r8), parameter :: D8_0 = 8.0_r8 + real(r8), parameter :: D10_0 = 10.0_r8 + real(r8), parameter :: D64_0 = 64.0_r8 + real(r8), parameter :: D128_0 = 128.0_r8 + real(r8), parameter :: D180_0 = 180.0_r8 + real(r8), parameter :: D1E5 = 1.0e5_r8 + + real(r8), parameter :: ratmax = 0.81_r8 + real(r8), parameter :: tiny = 1.0e-10_r8 + + real(r8) :: press + real(r8) :: rat, ycrit + real(r8) :: dt5 + + integer :: msgtag ! MPI message tag + + integer :: im, jm, km ! problem dimensions + integer :: nq ! # of tracers to be advected by trac2d + integer :: ifirstxy,ilastxy ! xy-decomp. longitude ranges + integer :: jfirstxy,jlastxy ! xy-decomp. latitude ranges + integer :: ng_c ! ghost latitudes on C grid + integer :: ng_d ! ghost lats on D (Max NS dependencies, ng_d >= ng_c) + integer :: ng_s ! max(ng_c+1,ng_d) significant if ng_c = ng_d + + integer :: jfirst + integer :: jlast + integer :: kfirst + integer :: klast + integer :: klastp ! klast, except km+1 when klast=km + + integer :: iam + integer :: npr_y + integer :: npes_xy + integer :: npes_yz + + integer i, j, k, ml + integer js1g1, js2g0, js2g1, jn2g1 + integer jn2g0, jn1g1 + integer iord , jord + integer ktot, ktotp + + real(r8) :: tau, fac, pk4 + real(r8) :: tau4 ! coefficient for 4th-order divergence damping + +#if defined( SPMD ) + integer dest, src +#endif + + logical :: reset_winds = .false. + logical :: everytime = .false. + ! + ! set damping options: + ! + ! - ldel2: 2nd-order velocity-component damping targetted to top layers, + ! with coefficient del2coef (default 3E5) + ! + ! - ldiv2: 2nd-order divergence damping everywhere and increasing in top layers + ! (default cam3.5 setting) + ! + ! - ldiv4: 4th-order divergence damping everywhere and increasing in top layers + ! + ! - div24del2flag: 2 for ldiv2 (default), 4 for ldiv4, 42 for ldiv4 + ldel2 + ! - ldiv2 and ldel2 cannot coexist + ! + logical :: ldiv2 = .true. + logical :: ldiv4 = .false. + logical :: ldel2 = .false. + + +! C.-C. Chen, omega calculation + real(r8), intent(out) :: & + cx_om(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) ! Courant in X + real(r8), intent(out) :: & + cy_om(grid%im,grid%jfirst:grid%jlast+1,grid%kfirst:grid%klast) ! Courant in Y + +!****************************************************************** +!****************************************************************** +! +! IMPORTANT CODE OPTIONS - SEE BELOW +! +!****************************************************************** +!****************************************************************** + +! Option for which version of geopk to use with yz decomposition. +! If geopkdist=false, variables are transposed to/from xy decomposition +! for use in geopk. +! If geopkdist=true, either geopk_d or geopk16 is used. Both +! compute local partial sums in z and then communicate those +! sums to combine them. geopk_d does not try to parallelize in the +! z-direction except in a pipeline fashion controlled by the +! parameter geopkblocks, and is bit-for-bit the same as the +! transpose-based algorithm. geopk16 exploits z-direction +! parallelism and requires 16-byte arithmetic (DSIZE=16) +! to reproduce the same numerics (and to be reproducible with +! respect to process count). The geopk16 default is to use +! 8-byte arithmetic (DSIZE=8). This is faster than +! 16-byte, but also gives up reproducibility. On many systems +! performance of geopk_d is comparable to geopk16 even with +! 8-byte numerics. +! On the last two small timesteps (ipe=1,2 or 1,-2) for D-grid, +! the version of geopk that uses transposes is called regardless, +! as some transposed quantities are required for the te_map phase +! and for the calculation of omega. +! For non-SPMD mode, geopk_[cd]dist are set to false. + + logical geopk_cdist, geopk_ddist + + geopk_cdist = .false. + geopk_ddist = .false. +#if defined( SPMD ) + if (grid%geopkdist) then + geopk_cdist = .true. + if ((ipe == -1) .or. (ipe == 0)) geopk_ddist = .true. + endif +#endif + +!****************************************************************** + + npes_xy = grid%npes_xy + npes_yz = grid%npes_yz + + im = grid%im + jm = grid%jm + km = grid%km + nq = grid%nq + + ng_c = grid%ng_c + ng_d = grid%ng_d + ng_s = grid%ng_s + + jfirst = grid%jfirst + jlast = grid%jlast + kfirst = grid%kfirst + klast = grid%klast + klastp = grid%klastp + + iam = grid%iam + npr_y = grid%npr_y + + ifirstxy = grid%ifirstxy + ilastxy = grid%ilastxy + jfirstxy = grid%jfirstxy + jlastxy = grid%jlastxy + + ktot = klast - kfirst + 1 + ktotp = ktot + 1 + + if (iam .lt. npes_yz) then + + call FVstartclock(grid,'---PRE_C_CORE') + +#if defined( SPMD ) + call FVstartclock(grid,'---PRE_C_CORE_COMM') + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_s, u ) + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_s, ng_d, v ) + call FVstopclock(grid,'---PRE_C_CORE_COMM') +#endif + +! Set general loop limits +! jfirst >= 1; jlast <= jm + js1g1 = max(1,jfirst-1) + js2g0 = max(2,jfirst) + js2g1 = max(2,jfirst-1) + jn2g0 = min(jm-1,jlast) + jn1g1 = min(jm,jlast+1) + jn2g1 = min(jm-1,jlast+1) + + if( abs(grid%dt0-dt) > D0_1 ) then + + grid%dt0 = dt + dt5 = D0_5*dt + + grid%rdy = D1_0/(ae*grid%dp) + grid%dtdy = dt *grid%rdy + grid%dtdy5 = dt5*grid%rdy + grid%dydt = (ae*grid%dp) / dt + grid%tdy5 = D0_5/grid%dtdy + + do j=2,jm-1 + grid%dx(j) = grid%dl*ae*grid%cosp(j) + grid%rdx(j) = D1_0 / grid%dx(j) + grid%dtdx(j) = dt /grid% dx(j) + grid%dxdt(j) = grid%dx(j) / dt + grid%dtdx2(j) = D0_5*grid%dtdx(j) + grid%dtdx4(j) = D0_5*grid%dtdx2(j) + grid%dycp(j) = ae*grid%dp/grid%cosp(j) + grid%cy(j) = grid%rdy * grid%acosp(j) + enddo + + do j=2,jm + grid%dxe(j) = ae*grid%dl*grid%cose(j) + grid%rdxe(j) = D1_0 / grid%dxe(j) + grid%dtdxe(j) = dt / grid%dxe(j) + grid%dtxe5(j) = D0_5*grid%dtdxe(j) + grid%txe5(j) = D0_5/grid%dtdxe(j) + grid%cye(j) = D1_0 / (ae*grid%cose(j)*grid%dp) + grid%dyce(j) = ae*grid%dp/grid%cose(j) + enddo + +! C-grid +#ifndef WACCM_MOZART + grid%zt_c = abs(umax*dt5) / (grid%dl*ae) +#else + grid%zt_c = cos( D10_0 * pi / D180_0 ) +#endif + +! D-grid +#ifndef WACCM_MOZART + grid%zt_d = abs(umax*dt) / (grid%dl*ae) +#else + grid%zt_d = cos( D10_0 * pi / D180_0 ) +#endif + + if ( ptopin /= grid%ptop) then + write(iulog,*) 'PTOP as input to cd_core != ptop from T_FVDYCORE_GRID' + stop + endif + + ! + ! damping code + ! + if (div24del2flag == 2) then + ! + ! cam3.5 default damping setting + ! + ldiv2 = .true. + ldiv4 = .false. + ldel2 = .false. + if (masterproc) write(iulog,*) 'Divergence damping: use 2nd order damping' + elseif (div24del2flag == 4) then + ! + ! fourth order divergence damping and no velocity diffusion + ! + ldiv2 = .false. + ldiv4 = .true. + ldel2 = .false. + if (masterproc) write(iulog,*) 'Divergence damping: use 4th order damping' + elseif (div24del2flag == 42) then + ! + ! fourth order divergence damping with velocity diffusion + ! + ldiv2 = .false. + ldiv4 = .true. + ldel2 = .true. + if (masterproc) write(iulog,*) 'Divergence damping: use 4th order damping' + if (masterproc) write(iulog,*) 'Velocity del2 damping with coefficient ', del2coef + else + ldiv2 = .true. + ldiv4 = .false. + ldel2 = .false. + if (masterproc) write(iulog,*) 'Inadmissable velocity smoothing option - div24del2flag = ', div24del2flag + call endrun('Inadmissable value of div24del2flag') + endif + + do k=kfirst,klast + + if (ldel2) then + ! + !*********************************** + ! + ! Laplacian on velocity components + ! + !*********************************** + ! + press = D0_5 * ( grid%ak(k)+grid%ak(k+1) + & + (grid%bk(k)+grid%bk(k+1))*D1E5 ) + tau = D8_0 * (D1_0+ tanh(D1_0*log(grid%ptop/press)) ) + ! + ! tau is strength of damping + ! + if (tau < 0.3_r8) then + ! + ! no del2 damping at lower levels + ! + tau = 0.0_r8 + end if + + do j=js2g0,jn1g1 + ! + ! fac must include dt for the momentum equation + ! i.e. diffusion coefficient is fac/dt + ! + ! del2 diffusion coefficient in spectral core is 2.5e5 + ! + fac = tau * dt * del2coef + ! + ! all these coefficients are necessary because of the staggering of the + ! wind components + ! + grid%cdxde(j,k) = fac/(ae*ae*grid%cose(j)*grid%cose(j)*grid%dl*grid%dl) + grid%cdyde(j,k) = fac/(ae*ae*grid%cose(j)*grid%dp*grid%dp) + end do + do j=js2g0,jn2g1 + fac = tau * dt * del2coef + grid%cdxdp(j,k) = fac/(ae*ae*grid%cosp(j)*grid%cosp(j)*grid%dl*grid%dl) + grid%cdydp(j,k) = fac/(ae*ae*grid%cosp(j)*grid%dp*grid%dp) + end do + end if + + if (ldiv2) then + ! + !*********************************************** + ! + ! cam3 default second-order divergence damping + ! + !*********************************************** + ! + press = D0_5 * ( grid%ak(k)+grid%ak(k+1) + & + (grid%bk(k)+grid%bk(k+1))*D1E5 ) + tau = D8_0 * (D1_0+ tanh(D1_0*log(grid%ptop/press)) ) + + ! DART this change is specific for WACCM. This entire file + ! (cd_core.F90) is not used in the SourceMods when not using WACCM. + ! The DART/CESM setup scripts remove this file when not using WACCM. + ! That ensures the use of the default CESM values. + tau = max(D1_0, tau) / (D64_0*abs(dt)) + + do j=js2g0,jn1g1 + !----------------------------------------- + ! Explanation of divergence damping coeff. + ! ======================================== + ! + ! Divergence damping is added to the momentum + ! equations through a term tau*div where + ! + ! tau = C*L**2/dt + ! + ! where L is the length scale given by + ! + ! L**2 = a**2*dl*dp + ! + ! and divergence is given by + ! + ! div = divx + divy + ! + ! where + ! + ! divx = (1/(a*cos(p)))*du/dl + ! divy = (1/(a*cos(p)))*(d(cos(theta)*v)/dp)) + ! + ! du and (d(cos(theta*v)/dp)) are computed in sw_core + ! + ! The constant terms in divx*tau and divy*tau are + ! + ! cdx = (1/(a*cos(p)))* (1/dl) * C * a**2 * dl * dp / dt = C * (a*dp/(cos(p)))/dt + ! cdy = (1/(a*cos(p)))* (1/dp) * C * a**2 * dl * dp / dt = C * (a*dl/(cos(p)))/dt + ! + !----------------------------------------- + fac = tau * ae / grid%cose(j) !default + grid%cdx(j,k) = fac*grid%dp !default + grid%cdy(j,k) = fac*grid%dl !default + end do + end if + + if (ldiv4) then + ! + ! 4th-order divergence damping + ! + tau4 = 0.01_r8 / (abs(dt)) + ! + !************************************** + ! + ! fourth order divergence damping + ! + !************************************** + ! + do j=1,jm + ! + ! divergence computation coefficients + ! + grid%cdxdiv (j,k) = D1_0/(grid%cose(j)*grid%dl) + grid%cdydiv (j,k) = D1_0/(grid%cose(j)*grid%dp) + end do + do j=js2g0,jn1g1 + ! + ! div4 coefficients + ! + fac = grid%dl*grid%cose(j)!*ae + grid%cdx4 (j,k) = D1_0/(fac*fac) + fac = grid%dp*grid%dp*grid%cose(j)!*ae*ae + grid%cdy4 (j,k) = D1_0/fac + fac = grid%cose(j)*grid%dp*grid%dl + grid%cdtau4(j,k) = -ae*tau4*fac*fac + end do + endif + end do + end if + + + if ( ipe < 0 .or. ns == 1 ) then ! starting cd_core + call FVstartclock(grid,'---C_DELP_LOOP') +!$omp parallel do private(i, j, k, wk, wk2) +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (I, J, K, WK, WK2) +#endif + do k=kfirst,klast + do j=jfirst,jlast + do i=1,im + delpf(i,j,k) = delp(i,j,k) + enddo + enddo + call pft2d( delpf(1,js2g0,k), grid%sc, & + grid%dc, im, jn2g0-js2g0+1, & + wk, wk2 ) + enddo +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + call FVstopclock(grid,'---C_DELP_LOOP') + + endif + +#if defined( SPMD ) + call FVstartclock(grid,'---PRE_C_CORE_COMM') + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_s, u ) + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_s, ng_d, v ) + + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, pt ) + if ( ipe < 0 .or. ns == 1 ) then ! starting cd_core + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, delpf ) + endif ! end if ipe < 0 check + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, pt ) + if ( ipe < 0 .or. ns == 1 ) then ! starting cd_core + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, delpf ) + endif ! end if ipe < 0 check + call FVstopclock(grid,'---PRE_C_CORE_COMM') +#endif + +! +! Get the cell centered winds if needed for the sub-step +! +#if ( defined OFFLINE_DYN ) + if ( ( (ipe < 0) .or. (everytime) ) .and. (.not. met_winds_on_walls()) ) then + call get_met_fields( grid, u_cen, v_cen ) + reset_winds = .true. + else + reset_winds = .false. + endif +#endif + + +! Get D-grid V-wind at the poles and interpolate winds to A- and C-grids; +! This calculation was formerly done in subroutine c_sw but is being done here to +! avoid communication in OpenMP loops + +!$omp parallel do private(k, wk, wk2) + +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (K, WK, WK2) +#endif + do k=kfirst,klast + call d2a2c_winds(grid, u(1,jfirst-ng_d,k), v(1,jfirst-ng_s,k), & + ua(1,jfirst-ng_d,k), va(1,jfirst-ng_s,k), & + uc(1,jfirst-ng_d,k), vc(1,jfirst-2,k), & + u_cen(1,jfirst-ng_d,k), v_cen(1,jfirst-ng_s,k), & + reset_winds, met_rlx(k) ) + +! Optionally filter advecting C-grid winds + if (filtcw .gt. 0) then + call pft2d(uc(1,js2g0,k), grid%sc, grid%dc, im, jn2g0-js2g0+1, wk, wk2 ) + call pft2d(vc(1,js2g0,k), grid%se, grid%de, im, jlast-js2g0+1, wk, wk2 ) + endif + + enddo +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + +! Fill C-grid advecting winds Halo regions +! vc only needs to be ghosted at jlast+1 +#if defined( SPMD ) + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, uc ) + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, 2, 2, vc ) + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, uc ) + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, 2, 2, vc ) +#endif + + call FVstopclock(grid,'---PRE_C_CORE') + + call FVbarrierclock(grid,'sync_c_core', grid%commyz) + call FVstartclock(grid,'---C_CORE') + +#if !defined(INNER_OMP) +!$omp parallel do private(i, j, k, iord, jord) +#endif + +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (K, IORD, JORD) +#endif + + do k=kfirst,klast ! This is the main parallel loop. + + if ( k <= km/8 ) then + iord = 1 + jord = 1 + else + iord = iord_c + jord = jord_c + endif + +!----------------------------------------------------------------- +! Call the vertical independent part of the dynamics on the C-grid +!----------------------------------------------------------------- + + call c_sw( grid, u(1,jfirst-ng_d,k), v(1,jfirst-ng_s,k), & + pt(1,jfirst-ng_d,k), delp(1,jfirst,k), & + ua(1,jfirst-ng_d,k), va(1,jfirst-ng_s,k), & + uc(1,jfirst-ng_d,k), vc(1,jfirst-2,k), & + ptc(1,jfirst,k), delpf(1,jfirst-ng_d,k), & + ptk(1,jfirst,k), tiny, iord, jord) + enddo +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + + call FVstopclock(grid,'---C_CORE') + +! MPI note: uc, vc, ptk, and ptc computed within the above k-look from jfirst to jlast +! Needed by D-core: uc(jfirst-ng_d:jlast+ng_d), vc(jfirst:jlast+1) + + call FVbarrierclock(grid,'sync_c_geop', grid%commyz) + + end if ! (iam .lt. npes_yz) + + if (geopk_cdist) then + + if (iam .lt. npes_yz) then + +! +! Stay in yz space and use z communications +! + + if (grid%geopk16byte) then + call FVstartclock(grid,'---C_GEOP16') + call geopk16(grid, pe, ptk, pkcc, wzc, hs, ptc, & + 0, cp, akap) + else + call FVstartclock(grid,'---C_GEOP_D') + call geopk_d(grid, pe, ptk, pkcc, wzc, hs, ptc, & + 0, cp, akap) + endif + +! +! Geopk does not need j ghost zones of pkc and wz +! + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + pkc(i,j,k) = pkcc(i,j,k) + wz(i,j,k) = wzc(i,j,k) + enddo + enddo + enddo + + if (grid%geopk16byte) then + call FVstopclock(grid,'---C_GEOP16') + else + call FVstopclock(grid,'---C_GEOP_D') + endif + + end if ! (iam .lt. npes_yz) + + else + +! Begin xy geopotential section + + call FVstartclock(grid,'---C_GEOP') + + if (grid%twod_decomp == 1) then + +! +! Transpose to xy decomposition +! + +#if defined( SPMD ) + call FVstartclock(grid,'YZ_TO_XY_C_GEOP') + if (grid%modc_onetwo .eq. 1) then + call mp_sendirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptk, delpxy, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptk, delpxy, & + modc=grid%modc_cdcore ) + call mp_sendirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptc, ptxy, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptc, ptxy, & + modc=grid%modc_cdcore ) + else + call mp_sendirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptk, delpxy, & + ptc, ptxy, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptk, delpxy, & + ptc, ptxy, & + modc=grid%modc_cdcore ) + endif + call FVstopclock(grid,'YZ_TO_XY_C_GEOP') +#endif + + else + +!$omp parallel do private(i, j, k) + do k = kfirst, klast + do j = jfirst, jlast + do i = 1, im + delpxy(i,j,k) = ptk(i,j,k) + ptxy(i,j,k) = ptc(i,j,k) + enddo + enddo + enddo + + endif + + call geopk(grid, pexy, delpxy, pkxy, wzxy, hsxy, ptxy, & + cp, akap, nx) + + if (grid%twod_decomp == 1) then +! +! Transpose back to yz decomposition. +! pexy is not output quantity on this call. +! pkkp and wzkp are holding arrays, whose specific z-dimensions +! are required by Pilgrim. +! Z edge ghost points (klast+1) are automatically filled in +! + +#if defined( SPMD ) + + call FVstartclock(grid,'XY_TO_YZ_C_GEOP') + if (grid%modc_onetwo .eq. 1) then + call mp_sendirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + modc=grid%modc_cdcore ) + call mp_sendirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, wzxy, wzkp, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, wzxy, wzkp, & + modc=grid%modc_cdcore ) + else + call mp_sendirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + wzxy, wzkp, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + wzxy, wzkp, & + modc=grid%modc_cdcore ) + endif + call FVstopclock(grid,'XY_TO_YZ_C_GEOP') + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + pkc(i,j,k) = pkkp(i,j,k) + enddo + enddo + enddo + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + wz(i,j,k) = wzkp(i,j,k) + enddo + enddo + enddo + +#endif + + else + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + pkc(i,j,k) = pkxy(i,j,k) + wz(i,j,k) = wzxy(i,j,k) + enddo + enddo + enddo + + endif + + call FVstopclock(grid,'---C_GEOP') + +! End xy geopotential section + + endif ! geopk_cdist + + if (iam .lt. npes_yz) then + + call FVbarrierclock(grid,'sync_pre_d_core', grid%commyz) + call FVstartclock(grid,'---PRE_D_CORE') + +! Upon exit from geopk, the quantities pe, pkc and wz will have been +! updated at klast+1 + + +#if defined( SPMD ) +! +! pkc & wz need to be ghosted only at jfirst-1 +! + call FVstartclock(grid,'---PRE_D_CORE_COMM') + dest = iam+1 + src = iam-1 + if ( mod(iam+1,npr_y) == 0 ) dest = -1 + if ( mod(iam,npr_y) == 0 ) src = -1 + call mp_send3d_2( grid%commyz, dest, src, im, jm, km+1, & + 1, im, jfirst-1, jlast+1, kfirst, klast+1, & + 1, im, jlast, jlast, kfirst, klast+1, pkc, wz) + call FVstopclock(grid,'---PRE_D_CORE_COMM') +#endif + + + call FVstartclock(grid,'---C_U_LOOP') +! Beware k+1 references directly below (AAM) +! +!$omp parallel do private(i, j, k, p1d, wk, wk2) + +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (I, J, K, P1D, WK, WK2) +#endif + do k=kfirst,klast + do j=js2g0,jn2g0 + do i=1,im + p1d(i) = pkc(i,j,k+1) - pkc(i,j,k) + enddo + + uc(1,j,k) = uc(1,j,k) + grid%dtdx2(j) * ( & + (wz(im,j,k+1)-wz(1,j,k))*(pkc(1,j,k+1)-pkc(im,j,k)) & + + (wz(im,j,k)-wz(1,j,k+1))*(pkc(im,j,k+1)-pkc(1,j,k))) & + / (p1d(1)+p1d(im)) + do i=2,im + uc(i,j,k) = uc(i,j,k) + grid%dtdx2(j) * ( & + (wz(i-1,j,k+1)-wz(i,j,k))*(pkc(i,j,k+1)-pkc(i-1,j,k)) & + + (wz(i-1,j,k)-wz(i,j,k+1))*(pkc(i-1,j,k+1)-pkc(i,j,k))) & + / (p1d(i)+p1d(i-1)) + enddo + +! C.-C. Chen + do i=1,im + cx_om(i,j,k) = grid%dtdx(j)*uc(i,j,k) + enddo + enddo + call pft2d(uc(1,js2g0,k), grid%sc, & + grid%dc, im, jn2g0-js2g0+1, & + wk, wk2 ) + if ( jfirst == 1 ) then ! Clean up + do i=1,im + uc(i,1,k) = D0_0 + cx_om(i,1,k) = D0_0 + enddo + endif + if ( jlast == jm ) then ! Clean up + do i=1,im + uc(i,jm,k) = D0_0 + cx_om(i,jm,k) = D0_0 + enddo + endif + + enddo +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + call FVstopclock(grid,'---C_U_LOOP') + +#if defined( SPMD ) + call FVstartclock(grid,'---PRE_D_CORE_COMM') + call mp_recv3d_2( grid%commyz, src, im, jm, km+1, & + 1, im, jfirst-1, jlast+1, kfirst, klast+1, & + 1, im, jfirst-1, jfirst-1, kfirst, klast+1, pkc, wz) + + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, uc ) + call FVstopclock(grid,'---PRE_D_CORE_COMM') +#endif + + call FVstartclock(grid,'---C_V_PGRAD') +! +! Beware k+1 references directly below (AAM) +! +!$omp parallel do private(i, j, k, wk, wk1 ) + +! pkc and wz need only to be ghosted jfirst-1 + +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (I, J, K, WK, WK1 ) +#endif + do k=kfirst,klast + do j=js1g1,jlast + do i=1,im + wk1(i,j) = pkc(i,j,k+1) - pkc(i,j,k) + enddo + enddo + + do j=js2g0,jlast + do i=1,im + vc(i,j,k) = vc(i,j,k) + grid%dtdy5/(wk1(i,j)+wk1(i,j-1)) * & + ( (wz(i,j-1,k+1)-wz(i,j,k))*(pkc(i,j,k+1)-pkc(i,j-1,k)) & + + (wz(i,j-1,k)-wz(i,j,k+1))*(pkc(i,j-1,k+1)-pkc(i,j,k)) ) + +! C.-C. Chen + cy_om(i,j,k) = grid%dtdy*vc(i,j,k) + enddo + enddo + + call pft2d(vc(1,js2g0,k), grid%se, & + grid%de, im, jlast-js2g0+1, wk, wk1 ) + enddo +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + + call FVstopclock(grid,'---C_V_PGRAD') + +#if defined( SPMD ) + call FVstartclock(grid,'---PRE_D_CORE_COMM') + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, uc ) + +! vc only needs to be ghosted at jlast+1 + dest = iam-1 + src = iam+1 + if ( mod(iam,npr_y) == 0 ) dest = -1 + if ( mod(iam+1,npr_y) == 0 ) src = -1 + call mp_send3d( grid%commyz, dest, src, im, jm, km, & + 1, im, jfirst-2, jlast+2, kfirst, klast, & + 1, im, jfirst, jfirst, kfirst, klast, vc ) + call mp_recv3d( grid%commyz, src, im, jm, km, & + 1, im, jfirst-2, jlast+2, kfirst, klast, & + 1, im, jlast+1, jlast+1, kfirst, klast, vc ) + call FVstopclock(grid,'---PRE_D_CORE_COMM') + +! C.-C. Chen + call mp_send3d( grid%commyz, dest, src, im, jm, km, & + 1, im, jfirst, jlast+1, kfirst, klast, & + 1, im, jfirst, jfirst, kfirst, klast, cy_om ) + call mp_recv3d( grid%commyz, src, im, jm, km, & + 1, im, jfirst, jlast+1, kfirst, klast, & + 1, im, jlast+1, jlast+1, kfirst, klast, cy_om ) +#endif + + call FVstopclock(grid,'---PRE_D_CORE') + + call FVbarrierclock(grid,'sync_d_core', grid%commyz) + call FVstartclock(grid,'---D_CORE') + +#if !defined(INNER_OMP) +!$omp parallel do private(i, j, k, iord, jord) +#endif +#if !defined(USE_OMP) +!CSD$ PARALLEL DO PRIVATE (K, IORD, JORD) +#endif + + do k=kfirst,klast + + if( k <= km/8 ) then + if( k == 1 ) then + iord = 1 + jord = 1 + else + iord = min(2, iord_d) + jord = min(2, jord_d) + endif + else + iord = iord_d + jord = jord_d + endif + +!----------------------------------------------------------------- +! Call the vertical independent part of the dynamics on the D-grid +!----------------------------------------------------------------- + + call d_sw( grid, u(1,jfirst-ng_d,k), v(1,jfirst-ng_s,k), & + uc(1,jfirst-ng_d,k), vc(1,jfirst-2,k), & + pt(1,jfirst-ng_d,k), delp(1,jfirst,k), & + delpf(1,jfirst-ng_d,k), cx3(1,jfirst-ng_d,k), & + cy3(1,jfirst,k), mfx(1,jfirst,k), & + mfy(1,jfirst,k), & + grid%cdx (js2g0:,k),grid%cdy (js2g0:,k), & + grid%cdxde (js2g0:,k),grid%cdxdp (js2g0:,k), & + grid%cdyde(js2g0:,k) ,grid%cdydp(js2g0:,k), & + grid%cdxdiv(:,k),grid%cdydiv(:,k) , & + grid%cdx4 (js2g0:,k),grid%cdy4(js2g0:,k) , & + grid%cdtau4(js2g0:,k), ldiv2, ldiv4, ldel2, & + iord, jord, tiny ) + + enddo +#if !defined(USE_OMP) +!CSD$ END PARALLEL DO +#endif + + call FVstopclock(grid,'---D_CORE') + + call FVbarrierclock(grid,'sync_d_geop', grid%commyz) + +#if defined( SPMD ) + if (s_trac) then +! post sends for ct_overlap or tracer decomposition information + do ml = 1, mlt + call mpiisend(cx3, ncx, mpir8, iremote(ml), cxtag(ml), grid%commnyz, cxreqs(ml)) + call mpiisend(cy3, ncy, mpir8, iremote(ml), cytag(ml), grid%commnyz, cyreqs(ml)) + call mpiisend(mfx, nmfx, mpir8, iremote(ml), mfxtag(ml), grid%commnyz, mfxreqs(ml)) + call mpiisend(mfy, nmfy, mpir8, iremote(ml), mfytag(ml), grid%commnyz, mfyreqs(ml)) + enddo + endif +#endif + + end if ! (iam .lt. npes_yz) + + if (geopk_ddist) then + + if (iam .lt. npes_yz) then + +! +! Stay in yz space and use z communications + + if (grid%geopk16byte) then + call FVstartclock(grid,'---D_GEOP16') + call geopk16(grid, pe, delp, pkcc, wzc, hs, pt, & + ng_d, cp, akap) + else + call FVstartclock(grid,'---D_GEOP_D') + call geopk_d(grid, pe, delp, pkcc, wzc, hs, pt, & + ng_d, cp, akap) + endif + +! +! Geopk does not need j ghost zones of pkc and wz +! + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + pkc(i,j,k) = pkcc(i,j,k) + wz(i,j,k) = wzc(i,j,k) + enddo + enddo + enddo + + if (grid%geopk16byte) then + call FVstopclock(grid,'---D_GEOP16') + else + call FVstopclock(grid,'---D_GEOP_D') + endif + + end if ! (iam .lt. npes_yz) + + else + +! Begin xy geopotential section + + call FVstartclock(grid,'---D_GEOP') + + if (grid%twod_decomp == 1) then +! +! Transpose to xy decomposition +! + +#if defined( SPMD ) + +!$omp parallel do private(i,j,k) + do k=kfirst,klast + do j=jfirst,jlast + do i=1,im + ptc(i,j,k) = pt(i,j,k) + enddo + enddo + enddo + + call FVstartclock(grid,'YZ_TO_XY_D_GEOP') + if (grid%modc_onetwo .eq. 1) then + call mp_sendirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, delp, delpxy, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, delp, delpxy, & + modc=grid%modc_cdcore ) + call mp_sendirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptc, ptxy, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptc, ptxy, & + modc=grid%modc_cdcore ) + else + call mp_sendirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, delp, delpxy, & + ptc, ptxy, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, delp, delpxy, & + ptc, ptxy, & + modc=grid%modc_cdcore ) + endif + call FVstopclock(grid,'YZ_TO_XY_D_GEOP') +#endif + + else + +!$omp parallel do private(i,j,k) + do k=kfirst,klast + do j=jfirst,jlast + do i=1,im + delpxy(i,j,k) = delp(i,j,k) + ptxy(i,j,k) = pt(i,j,k) + enddo + enddo + enddo + + endif + + call geopk(grid, pexy, delpxy, pkxy, wzxy, hsxy, ptxy, & + cp, akap, nx) + + if (grid%twod_decomp == 1) then +! +! Transpose back to yz decomposition +! Z edge ghost points (klast+1) are automatically filled in +! pexy is output quantity on last small timestep +! + +#if defined( SPMD ) + + call FVstartclock(grid,'XY_TO_YZ_D_GEOP') + if (grid%modc_onetwo .eq. 1) then + call mp_sendirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + modc=grid%modc_cdcore ) + call mp_sendirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, wzxy, wzkp, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, wzxy, wzkp, & + modc=grid%modc_cdcore ) + else + call mp_sendirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + wzxy, wzkp, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + wzxy, wzkp, & + modc=grid%modc_cdcore ) + endif + call FVstopclock(grid,'XY_TO_YZ_D_GEOP') + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + pkc(i,j,k) = pkkp(i,j,k) + enddo + enddo + enddo + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + wz(i,j,k) = wzkp(i,j,k) + enddo + enddo + enddo +#endif + + else + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + pkc(i,j,k) = pkxy(i,j,k) + wz(i,j,k) = wzxy(i,j,k) + enddo + enddo + enddo + + endif + + call FVstopclock(grid,'---D_GEOP') + +! End xy geopotential section + + endif ! geopk_ddist + + if (iam .lt. npes_yz) then + + call FVbarrierclock(grid,'sync_pre_d_pgrad', grid%commyz) + +! +! Upon exit from geopk, the quantities pe, pkc and wz will have been +! updated at klast+1 + + call FVstartclock(grid,'---PRE_D_PGRAD') + +#if defined( SPMD ) + call FVstartclock(grid,'---PRE_D_PGRAD_COMM_1') +! Exchange boundary regions on north and south for pkc and wz + call mp_send2_ns( grid%commyz, im, jm, km+1, jfirst, jlast, & + kfirst, klast+1, 1, pkc, wz) + call FVstopclock(grid,'---PRE_D_PGRAD_COMM_1') +#endif + + if ( ipe /= 1 ) then ! not the last call +! +! Perform some work while sending data on the way +! + + call FVstartclock(grid,'---D_DELP_LOOP') + +!$omp parallel do private(i, j, k, wk, wk2) + +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (I, J, K, WK, WK2) +#endif + do k=kfirst,klast + do j=jfirst,jlast + do i=1,im + delpf(i,j,k) = delp(i,j,k) + enddo + enddo + call pft2d( delpf(1,js2g0,k), grid%sc, & + grid%dc, im, jn2g0-js2g0+1, & + wk, wk2 ) + enddo +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + call FVstopclock(grid,'---D_DELP_LOOP') + + else +! Last call +!$omp parallel do private(i, j, k) + do k=kfirst,klast+1 + do j=jfirst,jlast + do i=1,im + pk(i,j,k) = pkc(i,j,k) + enddo + enddo + enddo + endif + +#if defined( SPMD ) + call FVstartclock(grid,'---PRE_D_PGRAD_COMM_1') + call mp_recv2_ns( grid%commyz, im, jm, km+1, jfirst, jlast, & + kfirst, klast+1, 1, pkc, wz) + if ( ipe /= 1 ) then ! not the last call + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, delpf ) + endif + call FVstopclock(grid,'---PRE_D_PGRAD_COMM_1') +#endif + + +! +! Beware k+1 references directly below (AAM) +! +!$omp parallel do private(i, j, k) + + do k=kfirst,klast + do j=js1g1,jn1g1 ! dpt needed NS + do i=1,im ! wz, pkc ghosted NS + dpt(i,j,k)=(wz(i,j,k+1)+wz(i,j,k))*(pkc(i,j,k+1)-pkc(i,j,k)) + enddo + enddo + enddo + +! GHOSTING: wz (input) NS ; pkc (input) NS + + call FVstopclock(grid,'---PRE_D_PGRAD') + call FVstartclock(grid,'---D_PGRAD_1') + +!$omp parallel do private(i, j, k, wk3, wk1) +#if !defined(USE_OMP) +!CSD$ PARALLEL DO PRIVATE (I, J, K, WK3, WK1) +#endif + do k=kfirst,klast+1 + + if (k == 1) then + do j=js2g0,jlast + do i=1,im + wz3(i,j,1) = D0_0 + wz(i,j,1) = D0_0 + enddo + enddo + pk4 = D4_0*grid%ptop**akap + do j=js2g0,jn1g1 + do i=1,im + pkc(i,j,1) = pk4 + enddo + enddo + go to 4500 + endif + + do j=js2g1,jn2g0 ! wk3 needed S + wk3(1,j) = (wz(1,j,k)+wz(im,j,k)) * & + (pkc(1,j,k)-pkc(im,j,k)) + do i=2,im + wk3(i,j) = (wz(i,j,k)+wz(i-1,j,k)) * & + (pkc(i,j,k)-pkc(i-1,j,k)) + enddo + enddo + + do j=js2g1,jn2g0 + do i=1,im-1 + wk1(i,j) = wk3(i,j) + wk3(i+1,j) + enddo + wk1(im,j) = wk3(im,j) + wk3(1,j) ! wk3 ghosted S + enddo + + if ( jfirst == 1 ) then + do i=1,im + wk1(i, 1) = D0_0 + enddo + endif + + if ( jlast == jm ) then + do i=1,im + wk1(i,jm) = D0_0 + enddo + endif + + do j=js2g0,jlast ! wk1 ghosted S + do i=1,im + wz3(i,j,k) = wk1(i,j) + wk1(i,j-1) + enddo + enddo + +! N-S walls + + do j=js2g0,jn1g1 ! wk1 needed N + do i=1,im ! wz, pkc ghosted NS + wk1(i,j) = (wz(i,j,k)+wz(i,j-1,k))*(pkc(i,j,k)-pkc(i,j-1,k)) + enddo + enddo + + do j=js2g0,jn1g1 ! wk3 needed N + wk3(1,j) = wk1(1,j) + wk1(im,j) ! wk1 ghosted N + do i=2,im + wk3(i,j) = wk1(i,j) + wk1(i-1,j) ! wk1 ghosted N + enddo + enddo + + do j=js2g0,jn2g0 + do i=1,im + wz(i,j,k) = wk3(i,j) + wk3(i,j+1) ! wk3 ghosted N + enddo + enddo + + do j=js1g1,jn1g1 + wk1(1,j) = pkc(1,j,k) + pkc(im,j,k) + do i=2,im + wk1(i,j) = pkc(i,j,k) + pkc(i-1,j,k) + enddo + enddo + + do j=js2g0,jn1g1 + do i=1,im + pkc(i,j,k) = wk1(i,j) + wk1(i,j-1) + enddo + enddo + +4500 continue + enddo + +#if !defined(USE_OMP) +!CSD$ END PARALLEL DO +#endif + call FVstopclock(grid,'---D_PGRAD_1') + call FVstartclock(grid,'---D_PGRAD_2') + +! GHOSTING: dpt (loop 4000) NS ; pkc (loop 4500) N +! +! Beware k+1 references directly below (AAM) +! +!$omp parallel do private(i, j, k, wk, wk1, wk2, wk3) +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (i, j, k, wk, wk1, wk2, wk3) +#endif + do 6000 k=kfirst,klast + + do j=js1g1,jn1g1 + wk1(1,j) = dpt(1,j,k) + dpt(im,j,k) + do i=2,im + wk1(i,j) = dpt(i,j,k) + dpt(i-1,j,k) + enddo + enddo + + do j=js2g0,jn1g1 + do i=1,im + wk2(i,j) = wk1(i,j) + wk1(i,j-1) + wk(i,j) = pkc(i,j,k+1) - pkc(i,j,k) + enddo + enddo + + do j=js2g0,jlast + do i=1,im-1 + wk3(i,j) = uc(i,j,k) + grid%dtdxe(j)/(wk(i,j) + wk(i+1,j)) & + * (wk2(i,j)-wk2(i+1,j)+wz3(i,j,k+1)-wz3(i,j,k)) + enddo + wk3(im,j) = uc(im,j,k) + grid%dtdxe(j)/(wk(im,j) + wk(1,j)) & + * (wk2(im,j)-wk2(1,j)+wz3(im,j,k+1)-wz3(im,j,k)) + enddo + + do j=js2g0,jn2g0 ! Assumes wk2 ghosted on N + do i=1,im + wk1(i,j) = vc(i,j,k) + grid%dtdy/(wk(i,j)+wk(i,j+1)) * & + (wk2(i,j)-wk2(i,j+1)+wz(i,j,k+1)-wz(i,j,k)) + enddo + enddo + + call pft2d( wk3(1,js2g0), grid%se, & + grid%de, im, jlast-js2g0+1, & + wk, wk2 ) + call pft2d( wk1(1,js2g0), grid%sc, & + grid%dc, im, jn2g0-js2g0+1, & + wk, wk2 ) + + do j=js2g0,jn2g0 + do i=1,im + v(i,j,k) = v(i,j,k) + wk1(i,j) + u(i,j,k) = u(i,j,k) + wk3(i,j) + enddo + enddo + + if ( jlast == jm ) then + do i=1,im + u(i,jlast,k) = u(i,jlast,k) + wk3(i,jlast) + enddo + endif + +6000 continue +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + call FVstopclock(grid,'---D_PGRAD_2') + +#if defined( SPMD ) + if ( ipe /= 1 ) then + call FVstartclock(grid,'---PRE_D_PGRAD_COMM_2') + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, delpf ) + call FVstopclock(grid,'---PRE_D_PGRAD_COMM_2') + endif +#endif + + end if ! (iam .lt. npes_yz) + + return +!EOC + end subroutine cd_core +!----------------------------------------------------------------------- diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/dynamics/homme/dyn_comp.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/dynamics/homme/dyn_comp.F90 new file mode 100644 index 0000000000..8bd86ca83d --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/dynamics/homme/dyn_comp.F90 @@ -0,0 +1,492 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1_1/models/atm/cam/src/dynamics/homme/dyn_comp.F90 + +Module dyn_comp + + use shr_kind_mod, only: r8 => shr_kind_r8 + use domain_mod, only : domain1d_t + use element_mod, only : element_t, elem_state_t + use time_mod, only : TimeLevel_t + use hybvcoord_mod, only : hvcoord_t + use hybrid_mod, only : hybrid_t + use perf_mod, only: t_startf, t_stopf + use cam_logfile, only : iulog + use time_manager, only: is_first_step + use spmd_utils, only : iam, npes_cam => npes + use pio, only: file_desc_t + use cslam_control_volume_mod, only : cslam_struct + + implicit none + private + + + ! PUBLIC MEMBER FUNCTIONS: + public dyn_init1, dyn_init2, dyn_run, dyn_final + + ! PUBLIC DATA MEMBERS: + public dyn_import_t, dyn_export_t + + + type (TimeLevel_t) , public :: TimeLevel ! main time level struct (used by tracers) + +! type (elem_state_t), save, target :: dyn_state + + type dyn_import_t + type (element_t), pointer :: elem(:) + type (cslam_struct), pointer :: cslam(:) + end type dyn_import_t + + type dyn_export_t + type (element_t), pointer :: elem(:) + type (cslam_struct), pointer :: cslam(:) + end type dyn_export_t + type (hvcoord_t) :: hvcoord + integer, parameter :: DYN_RUN_SUCCESS = 0 + integer, parameter :: DYN_RUN_FAILURE = -1 + + ! !DESCRIPTION: This module implements the HOMME Dynamical Core as + ! an ESMF gridded component. It is specific to HOMME + ! and does not use ESMF. + ! + ! \paragraph{Overview} + ! + ! This module contains an ESMF wrapper for the Homme + ! Dynamical Core used in the Community Atmospheric Model. + ! + ! !REVISION HISTORY: + ! + ! JPE 06.05.31: created + ! + !---------------------------------------------------------------------- + + ! Enumeration of DYNAMICS_IN_COUPLINGS + + + logical, parameter :: DEBUG = .true. + + real(r8), parameter :: ONE = 1.0D0 + + character(*), parameter, public :: MODULE_NAME = "dyn_comp" + character(*), parameter, public :: VERSION = "$Id$" + type (domain1d_t), pointer, public :: dom_mt(:) + + +CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine dyn_init1(fh, NLFileName, dyn_in, dyn_out) + + ! Initialize the dynamical core + + use pio, only: file_desc_t + use hycoef, only: hycoef_init + use ref_pres, only: ref_pres_init + + use pmgrid, only: dyndecomp_set + use dyn_grid, only: dyn_grid_init, cslam, elem, set_horiz_grid_cnt_d, & + get_dyn_grid_parm, set_horiz_grid_cnt_d + use rgrid, only: fullgrid + use spmd_utils, only: mpi_integer, mpicom, mpi_logical + use spmd_dyn, only: spmd_readnl + use interpolate_mod, only: interpolate_analysis + use native_mapping, only: create_native_mapping_files, native_mapping_readnl + + use dimensions_mod, only: globaluniquecols, nelem, nelemd, nelemdmax + use prim_driver_mod, only: prim_init1 + use thread_mod, only: nthreads + use parallel_mod, only: par, initmp + use namelist_mod, only: readnl + use control_mod, only: runtype + + ! PARAMETERS: + type(file_desc_t), intent(in) :: fh ! PIO file handle for initial or restart file + character(len=*), intent(in) :: NLFileName + type (dyn_import_t), intent(OUT) :: dyn_in + type (dyn_export_t), intent(OUT) :: dyn_out + +#ifdef _OPENMP + integer omp_get_num_threads +#endif + integer :: neltmp(3) + logical :: nellogtmp(7) + integer :: npes_homme + + ! Initialize dynamics grid + call dyn_grid_init() + + ! Read in the number of tasks to be assigned to Homme (needed by initmp) + call spmd_readnl(NLFileName, npes_homme) + ! Initialize the homme structure that holds the MPI decomposition information + par=initmp(npes_homme) + + ! Read the homme specific part of the namelist + call readnl(par, NLFileName) + + ! override the setting in the homme namelist, it's redundent anyway + if (.not. is_first_step()) runtype = 1 + + ! Initialize hybrid coordinate arrays. + call hycoef_init(fh) + + ! Initialize physics grid reference pressures (needed by initialize_radbuffer) + call ref_pres_init() + + ! legacy reduced grid code -- should be removed + fullgrid=.true. + +#ifdef _OPENMP +! Set by driver +!$omp parallel + nthreads = omp_get_num_threads() +!$omp end parallel + if(par%masterproc) then + write(iulog,*) " " + write(iulog,*) "dyn_init1: number of OpenMP threads = ", nthreads + write(iulog,*) " " + endif +#if defined (ELEMENT_OPENMP) + if(par%masterproc) then + write(iulog,*) " " + write(iulog,*) "dyn_init1: using OpenMP within element instead of across elements" + write(iulog,*) " " + endif +#endif +#else + nthreads = 1 + if(par%masterproc) then + write(iulog,*) " " + write(iulog,*) "dyn_init1: openmp not activated" + write(iulog,*) " " + endif +#endif + if(iam < par%nprocs) then + call prim_init1(elem,cslam,par,dom_mt,TimeLevel) + + dyn_in%elem => elem + dyn_out%elem => elem + dyn_in%cslam => cslam + dyn_out%cslam => cslam + + call set_horiz_grid_cnt_d(GlobalUniqueCols) + + + neltmp(1) = nelemdmax + neltmp(2) = nelem + neltmp(3) = get_dyn_grid_parm('plon') + nellogtmp(1:7) = interpolate_analysis(1:7) + else + nelemd = 0 + neltmp(1) = 0 + neltmp(2) = 0 + neltmp(3) = 0 + nellogtmp(1:7) = .true. + endif + + dyndecomp_set = .true. + + + + if (par%nprocs .lt. npes_cam) then +! Broadcast quantities to auxiliary processes + call mpibcast(neltmp, 3, mpi_integer, 0, mpicom) + call mpibcast(nellogtmp, 7, mpi_logical, 0, mpicom) + if (iam .ge. par%nprocs) then + nelemdmax = neltmp(1) + nelem = neltmp(2) + call set_horiz_grid_cnt_d(neltmp(3)) + interpolate_analysis(1:7) = nellogtmp(1:7) + endif + endif + + + ! + ! This subroutine creates mapping files using homme basis functions if requested + ! + call native_mapping_readnl(NLFileName) + call create_native_mapping_files( par, elem,'native') + call create_native_mapping_files( par, elem,'bilin') + + end subroutine dyn_init1 + + + subroutine dyn_init2(dyn_in) + use dimensions_mod, only: nlev, nelemd + use prim_driver_mod, only: prim_init2, prim_run + use prim_si_ref_mod, only: prim_set_mass + use hybrid_mod, only: hybrid_create + use hycoef, only: hyam, hybm, hyai, hybi, ps0 + use parallel_mod, only: par + use time_manager, only: dtime,get_nstep ! physics timestep + use time_mod, only: se_nsplit=>nsplit, tstep, time_at + use control_mod, only: moisture, runtype, qsplit + use thread_mod, only: nthreads + use thread_mod, only: omp_get_thread_num + use cam_control_mod, only: aqua_planet, ideal_phys, adiabatic + use comsrf, only: landm, sgh, sgh30 + use nctopo_util_mod, only: nctopo_util_driver +! KDR to prevent multiple HommeMapping writes + use cam_instance, only: inst_index + + + type (dyn_import_t), intent(inout) :: dyn_in + + type(element_t), pointer :: elem(:) + type(cslam_struct), pointer :: cslam(:) + + integer :: ithr, nets, nete, ie, k + real(r8), parameter :: Tinit=300.0_r8 + real(r8) :: dyn_ps0 + type(hybrid_t) :: hybrid + + ! + ! Note: dtime = progress made in one timestep. value in namelist + ! dtime = the frequency at which physics is called + ! tstep = the dynamics timestep: + ! + ! Leapfrog looks like: u(3) = u(1) + 2*tstep*u(2) + ! u(1) = time-tstep + ! u(2) = time + ! u(3) = time+tstep + ! + ! Physics looks like: u(3) = u(1) + dt_phys*PHYSICS(U(1)) + ! + ! so with se_nsplit=1: dtime=tstep dt_phys=2*tstep + ! + ! In general: dtime=se_nsplit*tstep, dt_phys=se_nsplit*tstep + tstep + ! + + elem => dyn_in%elem + cslam => dyn_in%cslam + + dyn_ps0=ps0/100.D0 + hvcoord%hyam=hyam + hvcoord%hyai=hyai + hvcoord%hybm=hybm + hvcoord%hybi=hybi + hvcoord%ps0=dyn_ps0 + do k=1,nlev + hvcoord%hybd(k) = hvcoord%hybi(k+1) - hvcoord%hybi(k) + end do + if(iam < par%nprocs) then + +#if (! defined ELEMENT_OPENMP) + !$OMP PARALLEL DEFAULT(SHARED), PRIVATE(ie,ithr,nets,nete,hybrid) +#endif + ithr=omp_get_thread_num() + nets=dom_mt(ithr)%start + nete=dom_mt(ithr)%end + hybrid = hybrid_create(par,ithr,NThreads) + + tstep = dtime/float(se_nsplit*qsplit) + + moisture='moist' + + if(adiabatic) then + moisture='dry' + if(runtype == 0) then + do ie=nets,nete + elem(ie)%state%q(:,:,:,:,:)=0.0D0 + elem(ie)%derived%fq(:,:,:,:,:)=0.0D0 + end do + end if + else if(ideal_phys) then + moisture='dry' + if(runtype == 0) then + do ie=nets,nete + elem(ie)%state%lnps(:,:,:) =LOG(dyn_ps0) + + elem(ie)%state%ps_v(:,:,:) =dyn_ps0 + + elem(ie)%state%phis(:,:)=0.0D0 + + elem(ie)%state%T(:,:,:,:) =Tinit + + elem(ie)%state%v(:,:,:,:,:) =0.0D0 + + elem(ie)%state%q(:,:,:,:,:)=0.0D0 + + end do + end if + else if(aqua_planet .and. runtype==0) then + do ie=nets,nete + ! elem(ie)%state%lnps(:,:,:) =LOG(dyn_ps0) + ! elem(ie)%state%ps_v(:,:,:) =dyn_ps0 + elem(ie)%state%phis(:,:)=0.0D0 + end do + if(allocated(landm)) landm=0.0_r8 + if(allocated(sgh)) sgh=0.0_r8 + if(allocated(sgh30)) sgh30=0.0_r8 + end if + + do ie=nets,nete + elem(ie)%derived%FM=0.0D0 + elem(ie)%derived%FT=0.0D0 + elem(ie)%derived%FQ=0.0D0 + end do + + ! initial homme (subcycled) nstep + TimeLevel%nstep = get_nstep()*se_nsplit*qsplit + + ! scale PS to achieve prescribed dry mass + if (runtype == 1) then + ! exact restart + TimeLevel%nstep0=TimeLevel%nstep+1 + else + ! new run, scale mass to value given in namelist, if needed + call prim_set_mass(elem, TimeLevel,hybrid,hvcoord,nets,nete) + TimeLevel%nstep0=2 ! This will be the first full leapfrog step + endif + call prim_init2(elem,cslam,hybrid,nets,nete, TimeLevel, hvcoord) + ! + ! This subroutine is used to create nc_topo files, if requested + ! + call nctopo_util_driver(elem,hybrid,nets,nete) +#if (! defined ELEMENT_OPENMP) + !$OMP END PARALLEL +#endif + end if + +! KDR; there should be a restriction that only instance X write out this file. + if(inst_index==1) then + call write_grid_mapping(par, elem) + end if + + end subroutine dyn_init2 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !----------------------------------------------------------------------- + !BOP + ! !ROUTINE: RUN --- Driver for the + ! + ! !INTERFACE: + subroutine dyn_run( dyn_state, rc ) + + ! !USES: + use parallel_mod, only : par + use prim_driver_mod, only: prim_run, prim_run_subcycle + use dimensions_mod, only : nlev + use thread_mod, only: omp_get_thread_num, nthreads + use time_mod, only: se_nsplit=>nsplit, tstep + use control_mod, only: tstep_type + use hybrid_mod, only: hybrid_create +! use perf_mod, only : t_startf, t_stopf + implicit none + + + type (dyn_export_t), intent(inout) :: dyn_state ! container + type(hybrid_t) :: hybrid + + integer, intent(out) :: rc ! Return code + integer :: n + integer :: nets, nete, ithr + integer :: ie + real(r8) :: tstep_tmp + + ! !DESCRIPTION: + ! + if(iam < par%nprocs) then +#if (! defined ELEMENT_OPENMP) + !$OMP PARALLEL DEFAULT(SHARED), PRIVATE(ithr,nets,nete,hybrid,n) +#endif + ithr=omp_get_thread_num() + nets=dom_mt(ithr)%start + nete=dom_mt(ithr)%end + hybrid = hybrid_create(par,ithr,NThreads) + + do n=1,se_nsplit + if (tstep_type==1) then + ! forward-in-time RK, with subcycling + call prim_run_subcycle(dyn_state%elem,dyn_state%cslam,hybrid,nets,nete,& + tstep, TimeLevel, hvcoord) + else + ! leapfrog + call prim_run(dyn_state%elem, hybrid,nets,nete, tstep, TimeLevel, hvcoord, "leapfrog") + endif + end do + + +#if (! defined ELEMENT_OPENMP) + !$OMP END PARALLEL +#endif + end if + rc = DYN_RUN_SUCCESS + + !EOC + end subroutine dyn_run + !----------------------------------------------------------------------- + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine dyn_final(DYN_STATE, RESTART_FILE) + + type (elem_state_t), target :: DYN_STATE + character(LEN=*) , intent(IN) :: RESTART_FILE + + + + end subroutine dyn_final + + + + subroutine write_grid_mapping(par, elem) + use parallel_mod, only: parallel_t + use element_mod, only : element_t + use cam_pio_utils, only : cam_pio_createfile, pio_subsystem + use pio, only : file_desc_t, pio_def_dim, var_desc_t, pio_int, pio_def_var, & + pio_enddef, pio_closefile, pio_initdecomp, io_desc_t, pio_write_darray, & + pio_freedecomp, pio_setdebuglevel + use dimensions_mod, only : np, nelem, nelemd + use dof_mod, only : createmetadata + + type(parallel_t) :: par + type(element_t) :: elem(:) + type(file_desc_t) :: nc + type(var_desc_t) :: vid + type(io_desc_t) :: iodesc + integer :: dim1, dim2, ierr, i, j, ie, cc, base, ii, jj + integer, parameter :: npm12 = (np-1)*(np-1) + integer :: subelement_corners(npm12*nelemd,4) + integer :: dof(npm12*nelemd*4) + + + ! Create a CS grid mapping file for postprocessing tools + + ! write meta data for physics on GLL nodes + call cam_pio_createfile(nc, 'HommeMapping.nc', 0) + + ierr = pio_def_dim(nc, 'ncenters', npm12*nelem, dim1) + ierr = pio_def_dim(nc, 'ncorners', 4, dim2) + ierr = pio_def_var(nc, 'element_corners', PIO_INT, (/dim1,dim2/),vid) + + ierr = pio_enddef(nc) + call createmetadata(par, elem, subelement_corners) + + jj=0 + do cc=0,3 + do ie=1,nelemd + base = ((elem(ie)%globalid-1)+cc*nelem)*npm12 + ii=0 + do j=1,np-1 + do i=1,np-1 + ii=ii+1 + jj=jj+1 + dof(jj) = base+ii + end do + end do + end do + end do + + call pio_initdecomp(pio_subsystem, pio_int, (/nelem*npm12,4/), dof, iodesc) + + call pio_write_darray(nc, vid, iodesc, reshape(subelement_corners,(/nelemd*npm12*4/)), ierr) + + call pio_freedecomp(nc, iodesc) + + call pio_closefile(nc) + + end subroutine write_grid_mapping + +end module dyn_comp + + + diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/dynamics/homme/interp_mod.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/dynamics/homme/interp_mod.F90 new file mode 100644 index 0000000000..e7705ee0d0 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cam/dynamics/homme/interp_mod.F90 @@ -0,0 +1,506 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1_1/models/atm/cam/src/dynamics/homme/interp_mod.F90 + +module interp_mod + use cam_logfile, only : iulog + use shr_kind_mod, only : r8 => shr_kind_r8 + use dimensions_mod, only : nelemd, np + use interpolate_mod, only : interpolate_scalar, setup_latlon_interp, set_interp_parameter, get_interp_lat, get_interp_lon, & + var_is_vector_uvar, var_is_vector_vvar, interpolate_vector, interpdata_t, get_interp_gweight + use dyn_grid, only : elem, w + use spmd_utils, only : masterproc, iam + use cam_pio_utils, only: phys_decomp, fillvalue + use hybrid_mod, only : hybrid_t, hybrid_create + use abortutils, only: endrun + + implicit none + private + type(interpdata_t), pointer :: cam_interpolate(:) + + public get_interp_lat, get_interp_lon, setup_history_interpolation, write_interpolated + public var_is_vector_uvar, var_is_vector_vvar, latlon_interpolation, add_interp_attributes + + interface write_interpolated + module procedure write_interpolated_scalar + module procedure write_interpolated_vector + end interface + type(hybrid_t) :: hybrid + +contains + + subroutine add_interp_attributes(file) + use pio, only : file_desc_t, pio_put_att, pio_global + use interpolate_mod, only : get_interp_parameter + type(file_desc_t) :: file + + integer :: ierr + integer :: itmp + + itmp = get_interp_parameter('itype') + if(itmp == 0) then + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_type', 'homme basis functions') + else if(itmp == 1) then + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_type', 'bilinear') + else + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_type', itmp) + end if + + itmp = get_interp_parameter('gridtype') + select case(itmp) + case(1) + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_outputgridtype', 'equally spaced with poles') + case(2) + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_outputgridtype', 'Gauss') + case(3) + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_outputgridtype', 'equally spaced no poles') + case default + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_outputgridtype', itmp) + end select + + + end subroutine add_interp_attributes + + subroutine setup_history_interpolation(mtapes) + + use dyn_comp, only : dom_mt + use parallel_mod, only: par + use thread_mod, only: omp_get_thread_num + use interpolate_mod, only : interpolate_analysis, get_interp_parameter + implicit none + + integer, intent(in) :: mtapes + integer :: ithr, nthreads + + if(iam>= par%nprocs) return + + ithr=omp_get_thread_num() + hybrid = hybrid_create(par,ithr,1) + + if(any(interpolate_analysis(1:mtapes))) then + allocate(cam_interpolate(nelemd)) + call setup_latlon_interp(elem, cam_interpolate, par) + allocate(w(get_interp_parameter('nlat'))) + w = get_interp_gweight() + end if + + end subroutine setup_history_interpolation + + function latlon_interpolation(t) + use interpolate_mod, only : interpolate_analysis + integer, intent(in) :: t + + logical :: latlon_interpolation + + latlon_interpolation = interpolate_analysis(t) + end function latlon_interpolation + + + + subroutine write_interpolated_scalar(File, varid, fld, numlev, data_type, decomp_type) + use pio, only : file_desc_t, io_desc_t, var_desc_t, pio_write_darray, iosystem_desc_t, pio_initdecomp, pio_freedecomp, pio_setdebuglevel + use spmd_dyn, only: local_dp_map, block_buf_nrecs, chunk_buf_nrecs + use ppgrid, only : begchunk, endchunk, pcols, pver + use phys_grid, only : get_gcol_all_p, get_ncols_p, chunk_to_block_send_pters, chunk_to_block_recv_pters, & + transpose_chunk_to_block + use dyn_grid, only: get_gcol_block_d + use dimensions_mod, only: npsq + use element_mod, only : element_t + use dof_mod, only : PutUniquePoints + use interpolate_mod, only : get_interp_parameter + use shr_pio_mod, only : shr_pio_getiosys + use edge_mod, only : edgebuffer_t, edgevpack, edgevunpack, initedgebuffer, freeedgebuffer + use bndry_mod, only : bndry_exchangeV + use parallel_mod, only: par + use abortutils, only : endrun + + ! KDR BUGFIX: allow write_interpolated_YYY to call shr_pio_getiosys with + ! 'ATM####' instead of 'ATM'. #### is the instance number. + use cam_instance, only: atm_id + + implicit none + type(file_desc_t), intent(inout) :: File + type(var_desc_t), intent(inout) :: varid + real(r8), intent(in) :: fld(:,:,:) + integer, intent(in) :: numlev, data_type, decomp_type + + type(io_desc_t) :: iodesc + + integer :: lchnk, i, j, m, icol, ncols, pgcols(pcols), ierr + integer :: idmb1(1), idmb2(1), idmb3(1) + integer :: bpter(npsq,0:pver) ! offsets into block buffer for packing data + integer :: cpter(pcols,0:pver) ! offsets into chunk buffer for unpacking data + + real(r8), pointer :: dest(:,:,:,:) + real(r8), pointer :: bbuffer(:), cbuffer(:), fldout(:,:) + real(r8) :: fld_dyn(npsq,numlev,nelemd) + integer :: st, en, ie, ioff, ncnt_out, k + integer, pointer :: idof(:) + integer :: nlon, nlat, ncol + logical :: usefillvalues=.false. + type(iosystem_desc_t), pointer :: pio_subsystem + type (EdgeBuffer_t) :: edgebuf ! edge buffer + + + + nlon=get_interp_parameter('nlon') + nlat=get_interp_parameter('nlat') + ! KDR 'ATM' doesn't work for multi-instance runs. + ! pio_subsystem => shr_pio_getiosys('ATM') + pio_subsystem => shr_pio_getiosys(atm_id) + + if(decomp_type==phys_decomp) then + fld_dyn = -999_R8 + if(local_dp_map) then + !$omp parallel do private (lchnk, ncols, pgcols, icol, idmb1, idmb2, idmb3, ie, ioff, m) + do lchnk=begchunk,endchunk + ncols=get_ncols_p(lchnk) + call get_gcol_all_p(lchnk,pcols,pgcols) + do icol=1,ncols + call get_gcol_block_d(pgcols(icol),1,idmb1,idmb2,idmb3) + ie = idmb3(1) + ioff=idmb2(1) + do k=1,numlev + fld_dyn(ioff,k,ie) = fld(icol, k, lchnk-begchunk+1) + end do + end do + + end do + else + + allocate( bbuffer(block_buf_nrecs*numlev) ) + allocate( cbuffer(chunk_buf_nrecs*numlev) ) + + !$omp parallel do private (lchnk, ncols, cpter, i, icol) + do lchnk = begchunk,endchunk + ncols = get_ncols_p(lchnk) + + call chunk_to_block_send_pters(lchnk,pcols,pver+1,1,cpter) + + do i=1,ncols + cbuffer(cpter(i,1):cpter(i,1)) = 0.0_r8 + end do + + do icol=1,ncols + + cbuffer (cpter(icol,:)) = fld(icol,:,lchnk-begchunk+1) + end do + + end do + + call transpose_chunk_to_block(1, cbuffer, bbuffer) + if(iam < par%nprocs) then +!$omp parallel do private (ie, bpter, icol) + do ie=1,nelemd + + call chunk_to_block_recv_pters(elem(ie)%GlobalID,npsq,pver+1,1,bpter) + ncols = elem(ie)%idxp%NumUniquePts + do icol=1,ncols + fld_dyn (icol,:,ie) = bbuffer(bpter(icol,:)) + end do + + end do + end if + deallocate( bbuffer ) + deallocate( cbuffer ) + + end if + allocate(dest(np,np,numlev,nelemd)) + call initEdgeBuffer(edgebuf, numlev) + + do ie=1,nelemd + ncols = elem(ie)%idxp%NumUniquePts + call putUniquePoints(elem(ie)%idxP, numlev, fld_dyn(1:ncols,:,ie), dest(:,:,:,ie)) + call edgeVpack(edgebuf, dest(:,:,:,ie), numlev, 0, elem(ie)%desc) + enddo + if(iam < par%nprocs) then + call bndry_exchangeV(par, edgebuf) + end if + do ie=1,nelemd + call edgeVunpack(edgebuf, dest(:,:,:,ie), numlev, 0, elem(ie)%desc) + end do + call freeEdgeBuffer(edgebuf) + usefillvalues = any(dest == fillvalue) + else + usefillvalues=any(fld==fillvalue) + allocate(dest(np,np,numlev,1)) + end if + + ncnt_out = sum(cam_interpolate(1:nelemd)%n_interp) + allocate(fldout(ncnt_out,numlev)) + allocate(idof(ncnt_out*numlev)) + fldout = -999_r8 + idof = 0 + st = 1 + + + + do ie=1,nelemd + ncol = cam_interpolate(ie)%n_interp + do k=0,numlev-1 + do i=1,ncol + idof(st+i-1+k*ncnt_out)=cam_interpolate(ie)%ilon(i)+nlon*(cam_interpolate(ie)%ilat(i)-1)+nlon*nlat*k + enddo + enddo + + ! Now that we have the field on the dyn grid we need to interpolate + en = st+cam_interpolate(ie)%n_interp-1 + if(decomp_type==phys_decomp) then + if(usefillvalues) then + call interpolate_scalar(cam_interpolate(ie),dest(:,:,:,ie), np, numlev, fldout(st:en,:), fillvalue) + else + call interpolate_scalar(cam_interpolate(ie),dest(:,:,:,ie), np, numlev, fldout(st:en,:)) + end if + else + do j=1,np + do i=1,np + dest(i,j,:,1) = fld(i+(j-1)*np,:,ie) + end do + end do + if(usefillvalues) then + call interpolate_scalar(cam_interpolate(ie),dest(:,:,:,1), & + np, numlev, fldout(st:en,:), fillvalue) + else + call interpolate_scalar(cam_interpolate(ie),dest(:,:,:,1), & + np, numlev, fldout(st:en,:)) + end if + end if + + + st = en+1 + end do + + + if(numlev==1) then + call pio_initdecomp(pio_subsystem, data_type, (/nlon,nlat/), idof, iodesc) + else + call pio_initdecomp(pio_subsystem, data_type, (/nlon,nlat,numlev/), idof, iodesc) + end if + call pio_write_darray(File, varid, iodesc, fldout, ierr) + + deallocate(dest) + + deallocate(fldout) + deallocate(idof) + call pio_freedecomp(file,iodesc) + + end subroutine write_interpolated_scalar + + + + + subroutine write_interpolated_vector(File, varidu, varidv, fldu, fldv, numlev, data_type, decomp_type) + use pio, only : file_desc_t, io_desc_t, var_desc_t, pio_write_darray, iosystem_desc_t, pio_initdecomp, pio_freedecomp, pio_setdebuglevel + use spmd_dyn, only: local_dp_map, block_buf_nrecs, chunk_buf_nrecs + use ppgrid, only : begchunk, endchunk, pcols, pver + use phys_grid, only : get_gcol_all_p, get_ncols_p, chunk_to_block_send_pters, chunk_to_block_recv_pters, & + transpose_chunk_to_block + use dyn_grid, only: get_gcol_block_d + use dimensions_mod, only: npsq + use element_mod, only : element_t + use dof_mod, only : PutUniquePoints + use interpolate_mod, only : get_interp_parameter + use shr_pio_mod, only : shr_pio_getiosys + use edge_mod, only : edgebuffer_t, edgevpack, edgevunpack, initedgebuffer, freeedgebuffer + use bndry_mod, only : bndry_exchangeV + use parallel_mod, only: par + + ! KDR BUGFIX: allow write_interpolated_YYY to call shr_pio_getiosys with + ! 'ATM####' instead of 'ATM'. #### is the instance number. + use cam_instance, only: atm_id + + implicit none + type(file_desc_t), intent(inout) :: File + type(var_desc_t), intent(inout) :: varidu, varidv + real(r8), intent(in) :: fldu(:,:,:), fldv(:,:,:) + integer, intent(in) :: numlev, data_type, decomp_type + + type(io_desc_t) :: iodesc + + integer :: lchnk, i, j, m, icol, ncols, pgcols(pcols), ierr + integer :: idmb1(1), idmb2(1), idmb3(1) + integer :: bpter(npsq,0:pver) ! offsets into block buffer for packing data + integer :: cpter(pcols,0:pver) ! offsets into chunk buffer for unpacking data + + real(r8), allocatable :: dest(:,:,:,:,:) + real(r8), pointer :: bbuffer(:), cbuffer(:), fldout(:,:,:) + real(r8) :: fld_dyn(npsq,2,numlev,nelemd) + integer :: st, en, ie, ioff, ncnt_out, k + integer, pointer :: idof(:) + integer :: nlon, nlat, ncol + logical :: usefillvalues=.false. + + type(iosystem_desc_t), pointer :: pio_subsystem + type (EdgeBuffer_t) :: edgebuf ! edge buffer + + + + nlon=get_interp_parameter('nlon') + nlat=get_interp_parameter('nlat') + ! KDR 'ATM' doesn't work for multi-instance runs. + ! pio_subsystem => shr_pio_getiosys('ATM') + pio_subsystem => shr_pio_getiosys(atm_id) + + fld_dyn = -999_R8 + if(decomp_type==phys_decomp) then + allocate(dest(np,np,2,numlev,nelemd)) + if(local_dp_map) then + !$omp parallel do private (lchnk, ncols, pgcols, icol, idmb1, idmb2, idmb3, ie, ioff, m) + do lchnk=begchunk,endchunk + ncols=get_ncols_p(lchnk) + call get_gcol_all_p(lchnk,pcols,pgcols) + + do icol=1,ncols + call get_gcol_block_d(pgcols(icol),1,idmb1,idmb2,idmb3) + ie = idmb3(1) + ioff=idmb2(1) + do k=1,numlev + fld_dyn(ioff,1,k,ie) = fldu(icol, k, lchnk-begchunk+1) + fld_dyn(ioff,2,k,ie) = fldv(icol, k, lchnk-begchunk+1) + end do + end do + + end do + else + + allocate( bbuffer(2*block_buf_nrecs*numlev) ) + allocate( cbuffer(2*chunk_buf_nrecs*numlev) ) + + !$omp parallel do private (lchnk, ncols, cpter, i, icol) + do lchnk = begchunk,endchunk + ncols = get_ncols_p(lchnk) + + call chunk_to_block_send_pters(lchnk,pcols,pver+1,2,cpter) + + do i=1,ncols + cbuffer(cpter(i,1):cpter(i,1)) = 0.0_r8 + end do + + do icol=1,ncols + do k=1,numlev + cbuffer (cpter(icol,k)) = fldu(icol,k,lchnk-begchunk+1) + cbuffer (cpter(icol,k)+1) = fldv(icol,k,lchnk-begchunk+1) + end do + end do + + end do + + call transpose_chunk_to_block(2, cbuffer, bbuffer) + if(iam < par%nprocs) then + !$omp parallel do private (ie, bpter, icol) + do ie=1,nelemd + + call chunk_to_block_recv_pters(elem(ie)%GlobalID,npsq,pver+1,2,bpter) + ncols = elem(ie)%idxp%NumUniquePts + do icol=1,ncols + do k=1,numlev + fld_dyn (icol,1,k,ie) = bbuffer(bpter(icol,k)) + fld_dyn (icol,2,k,ie) = bbuffer(bpter(icol,k)+1) + enddo + end do + + end do + end if + deallocate( bbuffer ) + deallocate( cbuffer ) + + end if + call initEdgeBuffer(edgebuf, 2*numlev) + + do ie=1,nelemd + ncols = elem(ie)%idxp%NumUniquePts + call putUniquePoints(elem(ie)%idxP, 2, numlev, fld_dyn(1:ncols,:,:,ie), dest(:,:,:,:,ie)) + + call edgeVpack(edgebuf, dest(:,:,:,:,ie), 2*numlev, 0, elem(ie)%desc) + enddo + if(iam < par%nprocs) then + call bndry_exchangeV(par, edgebuf) + end if + + do ie=1,nelemd + call edgeVunpack(edgebuf, dest(:,:,:,:,ie), 2*numlev, 0, elem(ie)%desc) + enddo + call freeEdgeBuffer(edgebuf) + usefillvalues = any(dest==fillvalue) + else + usefillvalues = (any(fldu==fillvalue) .or. any(fldv==fillvalue)) + allocate(dest(np,np,2,numlev,1)) + endif + ncnt_out = sum(cam_interpolate(1:nelemd)%n_interp) + allocate(fldout(ncnt_out,numlev,2)) + allocate(idof(ncnt_out*numlev)) + + fldout = -999_r8 + idof = 0 + st = 1 + do ie=1,nelemd + ncol = cam_interpolate(ie)%n_interp + do k=0,numlev-1 + do i=1,ncol + idof(st+i-1+k*ncnt_out)=cam_interpolate(ie)%ilon(i)+nlon*(cam_interpolate(ie)%ilat(i)-1)+nlon*nlat*k + enddo + enddo + + + ! Now that we have the field on the dyn grid we need to interpolate + en = st+cam_interpolate(ie)%n_interp-1 + if(decomp_type==phys_decomp) then + if(usefillvalues) then + call interpolate_vector(cam_interpolate(ie),elem(ie), & + dest(:,:,:,:,ie), np, numlev, fldout(st:en,:,:), 0, fillvalue) + else + call interpolate_vector(cam_interpolate(ie),elem(ie),& + dest(:,:,:,:,ie), np, numlev, fldout(st:en,:,:), 0) + endif + else + do k=1,numlev + do j=1,np + do i=1,np + dest(i,j,1,k,1) = fldu(i+(j-1)*np,k,ie) + dest(i,j,1,k,1) = fldv(i+(j-1)*np,k,ie) + end do + end do + end do + if(usefillvalues) then + call interpolate_vector(cam_interpolate(ie),elem(ie),& + dest(:,:,:,:,1), np, numlev, fldout(st:en,:,:), 0, fillvalue) + else + call interpolate_vector(cam_interpolate(ie),elem(ie),& + dest(:,:,:,:,1), np, numlev, fldout(st:en,:,:), 0) + end if + end if + + st = en+1 + end do + + if(numlev==1) then + call pio_initdecomp(pio_subsystem, data_type, (/nlon,nlat/), idof, iodesc) + else + call pio_initdecomp(pio_subsystem, data_type, (/nlon,nlat,numlev/), idof, iodesc) + end if + + call pio_write_darray(File, varidu, iodesc, fldout(:,:,1), ierr) + + call pio_write_darray(File, varidv, iodesc, fldout(:,:,2), ierr) + + + deallocate(fldout) + deallocate(idof) + deallocate(dest) + call pio_freedecomp(file,iodesc) + + end subroutine write_interpolated_vector + + + + + + + + + + + + +end module interp_mod + diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cice/ice_aerosol.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cice/ice_aerosol.F90 new file mode 100644 index 0000000000..6f246b1798 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cice/ice_aerosol.F90 @@ -0,0 +1,779 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1/models/ice/cice/src/source/ice_aerosol.F90 + +!======================================================================= +! +!BOP +! +! !MODULE: ice_aerosol - Aerosol tracer within sea ice +! +! !DESCRIPTION: +! +! !REVISION HISTORY: +! SVN:$$ +! +! authors Marika Holland, NCAR +! David Bailey, NCAR +! +! !INTERFACE: +! + module ice_aerosol +! +! !USES: +! + use ice_kinds_mod + use ice_constants + use ice_fileunits + use ice_restart, only: lenstr, restart_dir, restart_file, & + pointer_file, runtype + use ice_communicate, only: my_task, master_task + use ice_exit, only: abort_ice +! +!EOP +! + implicit none + + logical (kind=log_kind) :: & + restart_aero ! if .true., read aerosol tracer restart file + +!======================================================================= + + contains + +!======================================================================= +!BOP +! +! !ROUTINE: init_aerosol +! +! !DESCRIPTION: +! +! Initialize ice aerosol tracer (call prior to reading restart data) +! +! !REVISION HISTORY: same as module +! +! !INTERFACE: +! + subroutine init_aerosol +! +! !USES: +! + use ice_state, only: filename_aero +! +!EOP +! + + if (trim(filename_aero) /= 'none') restart_aero = .true. + + if (restart_aero) then + if (trim(runtype) == 'continue') then + call read_restart_aero + else + call read_restart_aero(filename_aero) + endif + endif + + end subroutine init_aerosol + +!======================================================================= + +!BOP +! +! !ROUTINE: update_aerosol +! +! !DESCRIPTION: +! +! Increase aerosol in ice or snow surface due to deposition +! +! !REVISION HISTORY: same as module +! +! !INTERFACE: +! + subroutine update_aerosol (nx_block, ny_block, & + dt, icells, & + indxi, indxj, & + meltt, melts, & + meltb, congel, & + snoice, & + fsnow, & + trcrn, & + aice_old, & + vice_old, vsno_old, & + vicen, vsnon, aicen, & + faero, fsoot) +! +! !USES: +! + use ice_domain_size, only: max_ntrcr, nilyr, nslyr, n_aero, n_aeromx + use ice_state, only: nt_aero +! +! !INPUT/OUTPUT PARAMETERS: +! + integer (kind=int_kind), intent(in) :: & + nx_block, ny_block, & ! block dimensions + icells ! number of cells with ice present + + integer (kind=int_kind), dimension (nx_block*ny_block), & + intent(in) :: & + indxi, indxj ! compressed indices for cells with ice + + real (kind=dbl_kind), intent(in) :: & + dt ! time step + + real (kind=dbl_kind), dimension(nx_block,ny_block), & + intent(in) :: & + meltt, & + melts, & + meltb, & + congel, & + snoice, & + fsnow, & + vicen, & + vsnon, & + aicen, & + aice_old, & + vice_old, & + vsno_old + + real (kind=dbl_kind), dimension(nx_block,ny_block,n_aeromx), & + intent(in) :: & + faero + + real (kind=dbl_kind), dimension(nx_block,ny_block,n_aeromx), & + intent(inout) :: & + fsoot + + real (kind=dbl_kind), dimension(nx_block,ny_block,max_ntrcr), & + intent(inout) :: & + trcrn + +! +! local variables +! + integer (kind=int_kind) :: i, j, ij, k + integer (kind=int_kind) :: n ! print_points +! + real (kind=dbl_kind), dimension(icells) :: & + dzssl, & + dzint, & + dzssli, & + dzinti + + real (kind=dbl_kind), dimension(icells) :: & + dhs_evap, dhi_evap, & + dhs_melts, dhs_snoice, dhi_meltt, dhi_snoice, & + dhi_congel, dhi_meltb + real (kind=dbl_kind), dimension(icells,n_aeromx) :: & + aerotot, aerotot0 ! for diagnostics + + real (kind=dbl_kind) :: & + dzssl_new, & + dzint_new, & + dzssli_new, & + dzinti_new, & + dznew + + real (kind=dbl_kind), dimension(nx_block,ny_block,n_aeromx,2) :: & + aerosno, aeroice, & + aerosno0, aeroice0 ! for diagnostic prints + + real (kind=dbl_kind), dimension(nx_block,ny_block,n_aeromx) :: & + fsoot_old + + real (kind=dbl_kind) :: & + hs_old, hi_old, hslyr_old, hilyr_old, dhs, dhi, hs, hi, & + hslyr, hilyr, sloss1, sloss2 + real (kind=dbl_kind), dimension(n_aeromx) :: & + kscav, kscavsi + +!MH These need to be the same as in the DE code. Put in a common place? + real (kind=dbl_kind) :: & + hi_ssl, hs_ssl + + data hs_ssl / .040_dbl_kind / + data hi_ssl / .050_dbl_kind / + data kscav / .03_dbl_kind, .20_dbl_kind,& + .02_dbl_kind,.02_dbl_kind,.01_dbl_kind,.01_dbl_kind / + data kscavsi / .03_dbl_kind, .20_dbl_kind,& + .02_dbl_kind,.02_dbl_kind,.01_dbl_kind,.01_dbl_kind / + + aerosno(:,:,:,:) = c0 + aeroice(:,:,:,:) = c0 + aerosno0(:,:,:,:) = c0 + aeroice0(:,:,:,:) = c0 + fsoot_old(:,:,:) = fsoot(:,:,:) + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + + hs_old=vsno_old(i,j)/aice_old(i,j) + hi_old=vice_old(i,j)/aice_old(i,j) + hslyr_old=hs_old/real(nslyr,kind=dbl_kind) + hilyr_old=hi_old/real(nilyr,kind=dbl_kind) + + dzssl(ij)=min(hslyr_old/c2,hs_ssl) + dzint(ij)=hs_old-dzssl(ij) + dzssli(ij)=min(hilyr_old/c2,hi_ssl) + dzinti(ij)=hi_old-dzssli(ij) + + if (aicen(i,j) > c0) then + hs = vsnon(i,j)/aicen(i,j) + hi = vicen(i,j)/aicen(i,j) + dhs_melts(ij)=-melts(i,j)/aicen(i,j) + dhi_snoice(ij)=snoice(i,j)/aicen(i,j) + dhs_snoice(ij)=dhi_snoice(ij)*rhoi/rhos + dhi_meltt(ij)=-meltt(i,j)/aicen(i,j) + dhi_meltb(ij)=-meltb(i,j)/aicen(i,j) + dhi_congel(ij)=congel(i,j)/aicen(i,j) + else + hs = vsnon(i,j)/aice_old(i,j) + hi = vicen(i,j)/aice_old(i,j) + dhs_melts(ij)=-melts(i,j)/aice_old(i,j) + dhi_snoice(ij)=snoice(i,j)/aice_old(i,j) + dhs_snoice(ij)=dhi_snoice(ij)*rhoi/rhos + dhi_meltt(ij)=-meltt(i,j)/aice_old(i,j) + dhi_meltb(ij)=-meltb(i,j)/aice_old(i,j) + dhi_congel(ij)=congel(i,j)/aice_old(i,j) + endif + + dhs_evap(ij)=hs-(hs_old+dhs_melts(ij)-dhs_snoice(ij)+& + fsnow(i,j)/rhos*dt) + dhi_evap(ij)=hi-(hi_old+dhi_meltt(ij)+dhi_meltb(ij)+ & + dhi_congel(ij)+dhi_snoice(ij)) + enddo + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + do k=1,n_aero + aerosno(i,j,k,:)=& + trcrn(i,j,nt_aero+(k-1)*4 :nt_aero+(k-1)*4+1)*vsno_old(i,j) ! aerosol in snow + aeroice(i,j,k,:)=& + trcrn(i,j,nt_aero+(k-1)*4+2:nt_aero+(k-1)*4+3)*vice_old(i,j) ! aerosol in ice + aerosno0(i,j,k,:)=aerosno(i,j,k,:) + aeroice0(i,j,k,:)=aeroice(i,j,k,:) + aerotot0(ij,k)=aerosno(i,j,k,2)+aerosno(i,j,k,1) & + +aeroice(i,j,k,2)+aeroice(i,j,k,1) + enddo + enddo + +! apply evaporation + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + dzint(ij)=dzint(ij) + min(dzssl(ij)+dhs_evap(ij),c0) + dzssl(ij)=max(dzssl(ij)+dhs_evap(ij),c0) + dzinti(ij)=dzinti(ij) + min(dzssli(ij)+dhi_evap(ij),c0) + dzssli(ij)=max(dzssli(ij)+dhi_evap(ij),c0) + enddo + +! basal ice growth + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + dzinti(ij)=dzinti(ij)+dhi_congel(ij) + enddo + +! surface snow melt + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (-dhs_melts(ij) > puny) then + do k=1,n_aero + sloss1=c0 + sloss2=c0 + if (dzssl(ij) > puny) & + sloss1=kscav(k)*aerosno(i,j,k,1) & + *min(-dhs_melts(ij),dzssl(ij))/dzssl(ij) + aerosno(i,j,k,1)=aerosno(i,j,k,1)-sloss1 + if (dzint(ij) > puny) & + sloss2=kscav(k)*aerosno(i,j,k,2) & + *max(-dhs_melts(ij)-dzssl(ij),c0)/dzint(ij) + aerosno(i,j,k,2)=aerosno(i,j,k,2)-sloss2 + fsoot(i,j,k)=fsoot(i,j,k)+(sloss1+sloss2)/dt + enddo ! n_aero + +! update snow thickness + dzint(ij)=dzint(ij)+min(dzssl(ij)+dhs_melts(ij),c0) + dzssl(ij)=max(dzssl(ij)+dhs_melts(ij),c0) + + if ( dzssl(ij) <= puny ) then ! ssl melts away + aerosno(i,j,:,2)=aerosno(i,j,:,1)+aerosno(i,j,:,2) + aerosno(i,j,:,1)=c0 + dzssl(ij)=max(dzssl(ij),c0) + endif + if (dzint(ij) <= puny ) then ! all snow melts away + aeroice(i,j,:,1)=& + aeroice(i,j,:,1)+aerosno(i,j,:,1)+aerosno(i,j,:,2) + aerosno(i,j,:,:)=c0 + dzint(ij)=max(dzint(ij),c0) + endif + endif + enddo + +! surface ice melt + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (-dhi_meltt(ij) > puny) then + do k=1,n_aero + sloss1=c0 + sloss2=c0 + if (dzssli(ij) > puny) & + sloss1=kscav(k)*aeroice(i,j,k,1) & + *min(-dhi_meltt(ij),dzssli(ij))/dzssli(ij) + aeroice(i,j,k,1)=aeroice(i,j,k,1)-sloss1 + if (dzinti(ij) > puny) & + sloss2=kscav(k)*aeroice(i,j,k,2) & + *max(-dhi_meltt(ij)-dzssli(ij),c0)/dzinti(ij) + aeroice(i,j,k,2)=aeroice(i,j,k,2)-sloss2 + fsoot(i,j,k)=fsoot(i,j,k)+(sloss1+sloss2)/dt + enddo + + dzinti(ij)=dzinti(ij)+min(dzssli(ij)+dhi_meltt(ij),c0) + dzssli(ij)=max(dzssli(ij)+dhi_meltt(ij),c0) + if (dzssli(ij) <= puny) then ! ssl ice melts away + do k=1,n_aero + aeroice(i,j,k,2)=aeroice(i,j,k,1)+aeroice(i,j,k,2) + aeroice(i,j,k,1)=c0 + enddo + dzssli(ij)=max(dzssli(ij),c0) + endif + if (dzinti(ij) <= puny) then ! all ice melts away + do k=1,n_aero + fsoot(i,j,k)=fsoot(i,j,k) & + +(aeroice(i,j,k,1)+aeroice(i,j,k,2))/dt + aeroice(i,j,k,:)=c0 + enddo + dzinti(ij)=max(dzinti(ij),c0) + endif + endif + enddo + +! basal ice melt. Assume all soot lost in basal melt + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (-dhi_meltb(ij) > puny) then + do k=1,n_aero + sloss1=c0 + sloss2=c0 + if (dzssli(ij) > puny) & + sloss1=max(-dhi_meltb(ij)-dzinti(ij),c0) & + *aeroice(i,j,k,1)/dzssli(ij) + aeroice(i,j,k,1)=aeroice(i,j,k,1)-sloss1 + if (dzinti(ij) > puny) & + sloss2=min(-dhi_meltb(ij),dzinti(ij)) & + *aeroice(i,j,k,2)/dzinti(ij) + aeroice(i,j,k,2)=aeroice(i,j,k,2)-sloss2 + fsoot(i,j,k)=fsoot(i,j,k)+(sloss1+sloss2)/dt + enddo + + dzssli(ij) = dzssli(ij)+min(dzinti(ij)+dhi_meltb(ij), c0) + dzinti(ij) = max(dzinti(ij)+dhi_meltb(ij), c0) + endif + enddo + +! snowfall + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (fsnow(i,j) > c0) & + dzssl(ij)=dzssl(ij)+fsnow(i,j)/rhos*dt + enddo + +! snoice formation + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (dhs_snoice(ij) > puny) then + do k=1,n_aero + sloss1=c0 + sloss2=c0 + if (dzint(ij) > puny) & + sloss2 = min(dhs_snoice(ij),dzint(ij)) & + *aerosno(i,j,k,2)/dzint(ij) + aerosno(i,j,k,2) = aerosno(i,j,k,2) - sloss2 + if (dzssl(ij) > puny) & + sloss1 = max(dhs_snoice(ij)-dzint(ij),c0) & + *aerosno(i,j,k,1)/dzssl(ij) + aerosno(i,j,k,1) = aerosno(i,j,k,1) - sloss1 + aeroice(i,j,k,1) = aeroice(i,j,k,1) & + + (c1-kscavsi(k))*(sloss2+sloss1) + fsoot(i,j,k)=fsoot(i,j,k)+kscavsi(k)*(sloss2+sloss1)/dt + enddo + dzssl(ij)=dzssl(ij)-max(dhs_snoice(ij)-dzint(ij),c0) + dzint(ij)=max(dzint(ij)-dhs_snoice(ij),c0) + dzssli(ij)=dzssli(ij)+dhi_snoice(ij) + endif + enddo + +! aerosol deposition + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (aicen(i,j) > c0) then + hs = vsnon(i,j) / aicen(i,j) + else + hs = c0 + endif + if (hs > hsmin) then ! should this really be hsmin or 0? + ! should use same hsmin value as in radiation + do k=1,n_aero + aerosno(i,j,k,1)=aerosno(i,j,k,1) & + + faero(i,j,k)*dt*aicen(i,j) + enddo + else + do k=1,n_aero + aeroice(i,j,k,1)=aeroice(i,j,k,1) & + + faero(i,j,k)*dt*aicen(i,j) + enddo + endif + enddo + +! redistribute aerosol within vertical layers + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (aicen(i,j) > c0) then + hs = vsnon(i,j) / aicen(i,j) ! new snow thickness + hi = vicen(i,j) / aicen(i,j) ! new ice thickness + else + hs = c0 + hi = c0 + endif + if (dzssl(ij) <= puny) then ! nothing in SSL + do k=1,n_aero + aerosno(i,j,k,2)=aerosno(i,j,k,2)+aerosno(i,j,k,1) + aerosno(i,j,k,1)=c0 + enddo + endif + if (dzint(ij) <= puny) then ! nothing in Snow Int + do k=1,n_aero + aeroice(i,j,k,1)=aeroice(i,j,k,1)+aerosno(i,j,k,2) + aerosno(i,j,k,2)=c0 + enddo + endif + if (dzssli(ij) <= puny) then ! nothing in Ice SSL + do k=1,n_aero + aeroice(i,j,k,2)=aeroice(i,j,k,2)+aeroice(i,j,k,1) + aeroice(i,j,k,1)=c0 + enddo + endif + + if (dzinti(ij) <= puny) then ! nothing in Ice INT + do k=1,n_aero + fsoot(i,j,k)=fsoot(i,j,k)+& + (aeroice(i,j,k,1)+aeroice(i,j,k,2))/dt + aeroice(i,j,k,:)=c0 + enddo + endif + + hslyr=hs/real(nslyr,kind=dbl_kind) + hilyr=hi/real(nilyr,kind=dbl_kind) + dzssl_new=min(hslyr/c2,hs_ssl) ! ssl for snow + dzint_new=hs-dzssl_new + dzssli_new=min(hilyr/c2,hi_ssl) ! ssl for ice + dzinti_new=hi-dzssli_new + + if (hs > hsmin) then + do k=1,n_aero + dznew=min(dzssl_new-dzssl(ij),c0) + sloss1=c0 + if (dzssl(ij) > puny) & + sloss1=dznew*aerosno(i,j,k,1)/dzssl(ij) ! not neccesarily a loss term + dznew=max(dzssl_new-dzssl(ij),c0) + if (dzint(ij) > puny) & + sloss1=sloss1+aerosno(i,j,k,2)*dznew/dzint(ij) ! not really a loss term + aerosno(i,j,k,1) =aerosno(i,j,k,1)+sloss1 + aerosno(i,j,k,2) =aerosno(i,j,k,2)-sloss1 + enddo + else + aeroice(i,j,:,1)=aeroice(i,j,:,1) & + +aerosno(i,j,:,1)+aerosno(i,j,:,2) + aerosno(i,j,:,:) = c0 + endif + + if (vicen(i,j) > puny) then ! may want a limit on hi instead? + do k=1,n_aero + sloss2=c0 + dznew=min(dzssli_new-dzssli(ij),c0) + if (dzssli(ij) > puny) & + sloss2=dznew*aeroice(i,j,k,1)/dzssli(ij) + dznew=max(dzssli_new-dzssli(ij),c0) + if (dzinti(ij) > puny) & + sloss2=sloss2+aeroice(i,j,k,2)*dznew/dzinti(ij) ! not really a loss term + aeroice(i,j,k,1) =aeroice(i,j,k,1)+sloss2 + aeroice(i,j,k,2) =aeroice(i,j,k,2)-sloss2 + enddo + else + fsoot(i,j,:)=fsoot(i,j,:)+(aeroice(i,j,:,1)+aeroice(i,j,:,2))/dt + aeroice(i,j,:,:) = c0 + endif + + do k=1,n_aero + aerotot(ij,k)=aerosno(i,j,k,2)+aerosno(i,j,k,1) & + +aeroice(i,j,k,2)+aeroice(i,j,k,1) + if ( ( (aerotot(ij,k)-aerotot0(ij,k)) & + - ( faero(i,j,k)*aicen(i,j) & + - (fsoot(i,j,k)-fsoot_old(i,j,k)) )*dt ) > 0.00001) then +!AK write(nu_diag,*) 'aerosol tracer: ',k +!AK write(nu_diag,*) 'aerotot-aerotot0 ',aerotot(ij,k)-aerotot0(ij,k) +!AK write(nu_diag,*) 'faero-fsoot ',faero(i,j,k)*aicen(i,j)*dt & +!AK -(fsoot(i,j,k)-fsoot_old(i,j,k))*dt + endif + enddo + enddo + +! reload tracers + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (vicen(i,j) > puny) & + aeroice(i,j,:,:)=aeroice(i,j,:,:)/vicen(i,j) + if (vsnon(i,j) > puny) & + aerosno(i,j,:,:)=aerosno(i,j,:,:)/vsnon(i,j) + do k=1,n_aero + do n=1,2 + trcrn(i,j,nt_aero+(k-1)*4+n-1)=aerosno(i,j,k,n) + trcrn(i,j,nt_aero+(k-1)*4+n+1)=aeroice(i,j,k,n) + enddo +! do n=1,4 +! if (trcrn(i,j,nt_aero+(k-1)*4+n-1) < puny) then +! fsoot(i,j,k)=fsoot(i,j,k)+ & +! trcrn(i,j,nt_aero+(k-1)*4+n-1)/dt +! trcrn(i,j,nt_aero+(k-1)*4+n-1)=c0 +! endif +! enddo + enddo + enddo + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (trcrn(i,j,nt_aero) < -puny .or. trcrn(i,j,nt_aero+1) < -puny & + .or. trcrn(i,j,nt_aero+2) < -puny .or. trcrn(i,j,nt_aero+3) < -puny) then + if (my_task == master_task) then !AK + write(nu_diag,*) 'MH aerosol negative in aerosol code' + write(nu_diag,*) 'MH INT neg in aerosol my_task = ',& + my_task & + ,' printing point = ',n & + ,' i and j = ',i,j +!AK write(nu_diag,*) 'MH Int Neg aero snowssl= ',aerosno0(i,j,1,1) +!AK write(nu_diag,*) 'MH Int Neg aero new snowssl= ',aerosno(i,j,1,1) +!AK write(nu_diag,*) 'MH Int Neg aero snowint= ',aerosno0(i,j,1,2) +!AK write(nu_diag,*) 'MH Int Neg aero new snowint= ',aerosno(i,j,1,2) +!AK write(nu_diag,*) 'MH Int Neg aero ice_ssl= ',aeroice0(i,j,1,1) +!AK write(nu_diag,*) 'MH Int Neg aero new ice_ssl= ',aeroice(i,j,1,1) +!AK write(nu_diag,*) 'MH Int Neg aero ice_int= ',aeroice0(i,j,1,2) +!AK write(nu_diag,*) 'MH Int Neg aero new ice_int= ',aeroice(i,j,1,2) +!AK write(nu_diag,*) 'MH Int Neg aero aicen= ',aicen(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero vicen= ',vicen(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero vsnon= ',vsnon(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero viceold= ',vice_old(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero vsnoold= ',vsno_old(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero melts= ',melts(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero meltt= ',meltt(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero meltb= ',meltb(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero congel= ',congel(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero snoice= ',snoice(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero evap sno?= ',dhs_evap(ij) +!AK write(nu_diag,*) 'MH Int Neg aero evap ice?= ',dhi_evap(ij) +!AK write(nu_diag,*) 'MH Int Neg aero fsnow= ',fsnow(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero faero= ',faero(i,j,1) +!AK write(nu_diag,*) 'MH Int Neg aero fsoot= ',fsoot(i,j,1) + end if ! + trcrn(i,j,nt_aero)=max(trcrn(i,j,nt_aero),c0) + trcrn(i,j,nt_aero+1)=max(trcrn(i,j,nt_aero+1),c0) + trcrn(i,j,nt_aero+2)=max(trcrn(i,j,nt_aero+2),c0) + trcrn(i,j,nt_aero+3)=max(trcrn(i,j,nt_aero+3),c0) + endif + enddo + + end subroutine update_aerosol + + + +!======================================================================= +!---! these subroutines write/read Fortran unformatted data files .. +!======================================================================= +! +!BOP +! +! !IROUTINE: write_restart_aero - dumps all fields required for restart +! +! !INTERFACE: +! + subroutine write_restart_aero(filename_spec) +! +! !DESCRIPTION: +! +! Dumps all values needed for restarting +! +! !REVISION HISTORY: +! +! authors Elizabeth Hunke, LANL (original version) +! David Bailey, NCAR +! Marika Holland, NCAR +! +! !USES: +! + use ice_domain_size + use ice_calendar, only: sec, month, mday, nyr, istep1, & + time, time_forc, idate, year_init + use ice_state + use ice_read_write + use ice_restart, only: lenstr, restart_dir, restart_file, pointer_file +! +! !INPUT/OUTPUT PARAMETERS: +! + character(len=char_len_long), intent(in), optional :: filename_spec + +!EOP +! + integer (kind=int_kind) :: & + i, j, k, n, it, iblk, & ! counting indices + iyear, imonth, iday ! year, month, day + + character(len=char_len_long) :: filename + + logical (kind=log_kind) :: diag + + ! construct path/file + if (present(filename_spec)) then + filename = trim(filename_spec) + else + iyear = nyr + year_init - 1 + imonth = month + iday = mday + + write(filename,'(a,a,a,i4.4,a,i2.2,a,i2.2,a,i5.5)') & + restart_dir(1:lenstr(restart_dir)), & + restart_file(1:lenstr(restart_file)),'.aero.', & + iyear,'-',month,'-',mday,'-',sec + end if + + ! begin writing restart data + call ice_open(nu_dump_aero,filename,0) + + if (my_task == master_task) then + write(nu_dump_aero) istep1,time,time_forc + write(nu_diag,*) 'Writing ',filename(1:lenstr(filename)) + endif + + diag = .true. + + !----------------------------------------------------------------- + + do k = 1, n_aero + do n = 1, ncat + call ice_write(nu_dump_aero,0,trcrn(:,:,nt_aero +(k-1)*4,n,:),'ruf8',diag) + call ice_write(nu_dump_aero,0,trcrn(:,:,nt_aero+1+(k-1)*4,n,:),'ruf8',diag) + call ice_write(nu_dump_aero,0,trcrn(:,:,nt_aero+2+(k-1)*4,n,:),'ruf8',diag) + call ice_write(nu_dump_aero,0,trcrn(:,:,nt_aero+3+(k-1)*4,n,:),'ruf8',diag) + enddo + enddo + + if (my_task == master_task) close(nu_dump_aero) + + end subroutine write_restart_aero + +!======================================================================= +!BOP +! +! !IROUTINE: read_restart_aero - reads all fields required for restart +! +! !INTERFACE: +! + subroutine read_restart_aero(filename_spec) +! +! !DESCRIPTION: +! +! Reads all values needed for an ice aerosol restart +! +! !REVISION HISTORY: +! +! authors Elizabeth Hunke, LANL (original version) +! David Bailey, NCAR +! Marika Holland, NCAR +! +! !USES: +! + use ice_domain_size + use ice_calendar, only: sec, month, mday, nyr, istep1, & + time, time_forc, idate, year_init + use ice_state + use ice_read_write + use ice_restart, only: lenstr, restart_dir, restart_file, pointer_file +! +! !INPUT/OUTPUT PARAMETERS: +! + character(len=char_len_long), intent(in), optional :: filename_spec + +!EOP +! + integer (kind=int_kind) :: & + i, j, k, n, it, iblk, & ! counting indices + iyear, imonth, iday ! year, month, day + + character(len=char_len_long) :: & + filename, filename0, string1, string2 + + logical (kind=log_kind) :: & + diag + + if (my_task == master_task) then + ! reconstruct path/file + if (present(filename_spec)) then + filename = filename_spec + else + open(nu_rst_pointer,file=pointer_file) + read(nu_rst_pointer,'(a)') filename0 + filename = trim(filename0) + close(nu_rst_pointer) + + n = index(filename0,trim(restart_file)) + if (n == 0) call abort_ice('soot restart: filename discrepancy') + string1 = trim(filename0(1:n-1)) + string2 = trim(filename0(n+lenstr(restart_file):lenstr(filename0))) + write(filename,'(a,a,a,a)') & + string1(1:lenstr(string1)), & + restart_file(1:lenstr(restart_file)),'.aero', & + string2(1:lenstr(string2)) + endif + endif ! master_task + + call ice_open(nu_restart_aero,filename,0) + + if (my_task == master_task) then + read(nu_restart_aero) istep1,time,time_forc + write(nu_diag,*) 'Reading ',filename(1:lenstr(filename)) + endif + + diag = .true. + + !----------------------------------------------------------------- + + do k = 1, n_aero + do n = 1, ncat + call ice_read(nu_restart_aero,0,trcrn(:,:,nt_aero +(k-1)*4,n,:),'ruf8',& + diag,field_type=field_type_scalar,field_loc=field_loc_center) + call ice_read(nu_restart_aero,0,trcrn(:,:,nt_aero+1+(k-1)*4,n,:),'ruf8',& + diag,field_type=field_type_scalar,field_loc=field_loc_center) + call ice_read(nu_restart_aero,0,trcrn(:,:,nt_aero+2+(k-1)*4,n,:),'ruf8',& + diag,field_type=field_type_scalar,field_loc=field_loc_center) + call ice_read(nu_restart_aero,0,trcrn(:,:,nt_aero+3+(k-1)*4,n,:),'ruf8',& + diag,field_type=field_type_scalar,field_loc=field_loc_center) + enddo + enddo + + if (my_task == master_task) close(nu_restart_aero) + + end subroutine read_restart_aero + +!======================================================================= + + end module ice_aerosol + +!======================================================================= diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cice/ice_diagnostics.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cice/ice_diagnostics.F90 new file mode 100644 index 0000000000..e67722434a --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.cice/ice_diagnostics.F90 @@ -0,0 +1,1382 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1/models/ice/cice/src/source/ice_diagnostics.F90 + +!======================================================================= +!BOP +! +! !MODULE: ice_diagnostics - diagnostic information output during run +! +! !DESCRIPTION: +! +! Diagnostic information output during run +! +! !REVISION HISTORY: +! SVN:$Id: ice_diagnostics.F90 52 2007-01-30 18:04:24Z eclare $ +! +! authors: Elizabeth C. Hunke, LANL +! Bruce P. Briegleb, NCAR +! +! 2004: Block structure added by William Lipscomb +! 2006: Converted to free source form (F90) by Elizabeth Hunke +! +! !INTERFACE: +! + module ice_diagnostics +! +! !USES: +! + use ice_kinds_mod + use ice_communicate, only: my_task, master_task + use ice_constants + use ice_calendar, only: diagfreq, istep1, istep + use ice_fileunits + use ice_domain_size +! +!EOP +! + implicit none + save + + ! diagnostic output file + character (len=char_len) :: diag_file + + ! point print data + + logical (kind=log_kind) :: & + print_points , & ! if true, print point data + print_global ! if true, print global data + + integer (kind=int_kind), parameter :: & + npnt = 2 ! total number of points to be printed + + ! Set to true to identify unstable fast-moving ice. + logical (kind=log_kind), parameter :: & + check_umax = .false. ! if true, check for speed > umax_stab + + real (kind=dbl_kind), parameter :: & + umax_stab = 1.0_dbl_kind , & ! ice speed threshold for instability (m/s) + aice_extmin = 0.15_dbl_kind ! min aice value for ice extent calc + + real (kind=dbl_kind), dimension(npnt) :: & + latpnt , & ! latitude of diagnostic points + lonpnt ! longitude of diagnostic points + + integer (kind=int_kind) :: & + iindx , & ! i index for points + jindx , & ! j index for points + bindx ! block index for points + + ! for water and heat budgets + real (kind=dbl_kind), dimension(npnt) :: & + pdhi , & ! change in mean ice thickness (m) + pdhs , & ! change in mean snow thickness (m) + pde , & ! change in ice and snow energy (J m-2) + plat, plon ! latitude, longitude of points + + integer (kind=int_kind), dimension(npnt) :: & + piloc, pjloc, pbloc, pmloc ! location of diagnostic points + + ! for hemispheric water and heat budgets + real (kind=dbl_kind) :: & + totmn , & ! total ice/snow water mass (nh) + totms , & ! total ice/snow water mass (sh) + totmin , & ! total ice water mass (nh) + totmis , & ! total ice water mass (sh) + toten , & ! total ice/snow energy (J) + totes ! total ice/snow energy (J) + real (kind=dbl_kind), dimension(n_aeromx) :: & + totaeron , & ! total aerosol mass + totaeros ! total aerosol mass + + ! printing info for routine print_state + ! iblkp, ip, jp, mtask identify the grid cell to print + character (char_len) :: plabel + integer (kind=int_kind), parameter :: & + check_step = 999999999, & ! begin printing at istep1=check_step + iblkp = 1, & ! block number + ip = 3, & ! i index + jp = 5, & ! j index + mtask = 0 ! my_task + +!======================================================================= + + contains + +!======================================================================= +!BOP +! +! !IROUTINE: runtime_diags - writes max,min,global sums to standard out +! +! !INTERFACE: +! + subroutine runtime_diags (dt) +! +! !DESCRIPTION: +! +! Writes diagnostic info (max, min, global sums, etc) to standard out +! +! !REVISION HISTORY: +! +! authors: Elizabeth C. Hunke, LANL +! Bruce P. Briegleb, NCAR +! Cecilia M. Bitz, UW +! +! !USES: +! + use ice_broadcast + use ice_global_reductions + use ice_blocks + use ice_domain +!MH use ice_domain_size + use ice_flux + use ice_state + use ice_grid, only: lmask_n, lmask_s, tarean, tareas, grid_type + use ice_therm_vertical, only: calc_Tsfc + +#ifdef CCSMCOUPLED + use ice_prescribed_mod, only : prescribed_ice +#endif +! +! !INPUT/OUTPUT PARAMETERS: +! + real (kind=dbl_kind), intent(in) :: & + dt ! time step +! +!EOP +! + integer (kind=int_kind) :: & + i, j, k, n, ii,jj, iblk + + ! hemispheric state quantities + real (kind=dbl_kind) :: & + umaxn, hmaxn, shmaxn, arean, snwmxn, extentn, & + umaxs, hmaxs, shmaxs, areas, snwmxs, extents, & + etotn, mtotn, micen, msnwn, pmaxn, ketotn, & + etots, mtots, mices, msnws, pmaxs, ketots, & + urmsn, albtotn, arean_alb, & + urmss, albtots, areas_alb + + ! hemispheric flux quantities + real (kind=dbl_kind) :: & + rnn, snn, frzn, hnetn, fhocnn, fhatmn, fhfrzn, & + rns, sns, frzs, hnets, fhocns, fhatms, fhfrzs, & + sfsaltn, sfreshn, evpn, fluxn , delmxn, delmin, & + sfsalts, sfreshs, evps, fluxs , delmxs, delmis, & + delein, werrn, herrn, msltn, delmsltn, serrn, & + deleis, werrs, herrs, mslts, delmslts, serrs, & + ftmp,faeron,faeros,fsootn,fsoots + +! MH for aerosol diagnostics + integer (kind=int_kind) :: & + kaero, naero + real (kind=dbl_kind) :: & + aeromx1n, aeromx1s, aeromx2n, aeromx2s, & + aeromx3n, aeromx3s, aoermx4, & + aerototn, aerotots !MH + + ! fields at diagnostic points + real (kind=dbl_kind), dimension(npnt) :: & + paice, pTair, pQa, pfsnow, pfrain, pfsw, pflw, & + pTsfc, pevap, pfswabs, pflwout, pflat, pfsens, & + pfsurf, pfcondtop, psst, pTf, hiavg, hsavg, pfhocn, & + pmeltt, pmeltb, pmeltl, psnoice, pfrazil, pcongel + + real (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: & + work1, work2 + + !----------------------------------------------------------------- + ! state of the ice + !----------------------------------------------------------------- + ! hemispheric quantities + + ! total ice area + arean = global_sum(aice, distrb_info, field_loc_center, tarean) + areas = global_sum(aice, distrb_info, field_loc_center, tareas) + arean = arean * m2_to_km2 + areas = areas * m2_to_km2 + + ! ice extent (= area of grid cells with aice > aice_extmin) + work1(:,:,:) = c0 + + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + if (aice(i,j,iblk) >= aice_extmin) work1(i,j,iblk) = c1 + enddo + enddo + enddo + !$OMP END PARALLEL DO + extentn = global_sum(work1, distrb_info, field_loc_center, & + tarean) + extents = global_sum(work1, distrb_info, field_loc_center, & + tareas) + extentn = extentn * m2_to_km2 + extents = extents * m2_to_km2 + + ! total ice volume + shmaxn = global_sum(vice, distrb_info, field_loc_center, tarean) + shmaxs = global_sum(vice, distrb_info, field_loc_center, tareas) + + ! total snow volume + snwmxn = global_sum(vsno, distrb_info, field_loc_center, tarean) + snwmxs = global_sum(vsno, distrb_info, field_loc_center, tareas) + + ! total ice-snow kinetic energy + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = p5 & + * (rhos*vsno(i,j,iblk) + rhoi*vice(i,j,iblk)) & + * (uvel(i,j,iblk)**2 + vvel(i,j,iblk)**2) + enddo + enddo + enddo + !$OMP END PARALLEL DO + ketotn = global_sum(work1, distrb_info, field_loc_center, tarean) + ketots = global_sum(work1, distrb_info, field_loc_center, tareas) + + ! rms ice speed + urmsn = c2*ketotn/(rhoi*shmaxn + rhos*snwmxn + puny) + if (urmsn > puny) then + urmsn = sqrt(urmsn) + else + urmsn = c0 + endif + + urmss = c2*ketots/(rhoi*shmaxs + rhos*snwmxs + puny) + if (urmss > puny) then + urmss = sqrt(urmss) + else + urmss = c0 + endif + + ! average ice albedo + ! mask out cells where sun is below horizon (for delta-Eddington) + + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = alvdr(i,j,iblk)*awtvdr & + + alidr(i,j,iblk)*awtidr & + + alvdf(i,j,iblk)*awtvdf & + + alidf(i,j,iblk)*awtidf + enddo + enddo + enddo + !$OMP END PARALLEL DO + + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + if (coszen(i,j,iblk) > puny) then + work2(i,j,iblk) = tarean(i,j,iblk) + else + work2(i,j,iblk) = c0 + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + + arean_alb = global_sum(aice, distrb_info, field_loc_center, work2) + + albtotn = global_sum_prod(aice, work1, distrb_info, & + field_loc_center, work2) + + if (arean_alb > c0) then + albtotn = albtotn / arean_alb + else + albtotn = c0 + endif + + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + if (coszen(i,j,iblk) > puny) then + work2(i,j,iblk) = tareas(i,j,iblk) + else + work2(i,j,iblk) = c0 + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + + areas_alb = global_sum(aice, distrb_info, field_loc_center, work2) + + albtots = global_sum_prod(aice, work1, distrb_info, & + field_loc_center, work2) + + if (areas_alb > c0) then + albtots = albtots / areas_alb + else + albtots = c0 + endif + + ! maximum ice volume (= mean thickness including open water) + hmaxn = global_maxval(vice, distrb_info, lmask_n) + hmaxs = global_maxval(vice, distrb_info, lmask_s) + +! MH put in aerosol diagnostics + if (tr_aero) then + ! aerosols + do naero=1,n_aero + faeron = global_sum_prod(faero(:,:,naero,:), aice_init, distrb_info, & + field_loc_center, tarean) + faeros = global_sum_prod(faero(:,:,naero,:), aice_init, distrb_info, & + field_loc_center, tareas) + faeron = faeron*dt + faeros = faeros*dt + + fsootn = global_sum_prod(fsoot(:,:,naero,:), aice, distrb_info, & + field_loc_center, tarean) + fsoots = global_sum_prod(fsoot(:,:,naero,:), aice, distrb_info, & + field_loc_center, tareas) + fsootn = fsootn*dt + fsoots = fsoots*dt + + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = trcr(i,j,nt_aero +4*(naero-1),iblk) *vsno(i,j,iblk) & + + trcr(i,j,nt_aero+1+4*(naero-1),iblk)*vsno(i,j,iblk) & + + trcr(i,j,nt_aero+2+4*(naero-1),iblk)*vice(i,j,iblk) & + + trcr(i,j,nt_aero+3+4*(naero-1),iblk)*vice(i,j,iblk) + enddo + enddo + enddo + aerototn= global_sum(work1, distrb_info, field_loc_center, tarean) + aerotots= global_sum(work1, distrb_info, field_loc_center, tareas) + aeromx1n = global_maxval(work1, distrb_info, lmask_n) + aeromx1s = global_maxval(work1, distrb_info, lmask_s) + if (my_task == master_task) then + write(nu_diag,*) 'aero: ',naero,' faero : ',& + faeron, faeros + write(nu_diag,*) 'aero: ',naero,' fsoot : ',& + fsootn, fsoots + write(nu_diag,*) 'aero: ',naero,' faero-fsoot : ',& + faeron-fsootn, faeros-fsoots + write(nu_diag,*) 'aero: ',naero,' aerotot : ',& + aerototn, aerotots + write(nu_diag,*) 'aero: ',naero,' aerotot change: ',& + aerototn-totaeron(naero), aerotots-totaeros(naero) + write(nu_diag,*) 'aero: ',naero,' aeromax agg: ',& + aeromx1n,aeromx1s + endif + +! do kaero=1,ncat +! do iblk = 1, nblocks +! do j = 1, ny_block +! do i = 1, nx_block +! work1(i,j,iblk) = trcrn(i,j,nt_aero,kaero,iblk) +! enddo +! enddo +! enddo +! aeromx1n = global_maxval(work1, distrb_info, lmask_n) +! aeromx1s = global_maxval(work1, distrb_info, lmask_s) +! if (my_task == master_task) & +! write(nu_diag,*) 'MH aeromx1s: ',aeromx1n,aeromx1s,kaero +! enddo + +! do iblk = 1, nblocks +! do j = 1, ny_block +! do i = 1, nx_block +! work1(i,j,iblk) = trcrn(i,j,nt_aero+1,1,iblk) +! enddo +! enddo +! enddo +! aeromx2n = global_maxval(work1, distrb_info, lmask_n) +! write(nu_diag,*) 'MH aeromx2n: ',aeromx2n +! aeromx2s = global_maxval(work1, distrb_info, lmask_s) +! write(nu_diag,*) 'MH aeromx2s: ',aeromx2s +! +! do iblk = 1, nblocks +! do j = 1, ny_block +! do i = 1, nx_block +! work1(i,j,iblk) = trcrn(i,j,nt_aero+2,1,iblk) +! enddo +! enddo +! enddo +! aeromx3n = global_maxval(work1, distrb_info, lmask_n) +! write(nu_diag,*) 'MH aeromx2n: ',aeromx3n +! aeromx3s = global_maxval(work1, distrb_info, lmask_s) +! write(nu_diag,*) 'MH aeromx2s: ',aeromx3s + enddo ! n_aero + endif ! tr_aero + + ! maximum ice speed + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = sqrt(uvel(i,j,iblk)**2 & + + vvel(i,j,iblk)**2) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + umaxn = global_maxval(work1, distrb_info, lmask_n) + umaxs = global_maxval(work1, distrb_info, lmask_s) + + ! Write warning message if ice speed is too big + ! (Ice speeds of ~1 m/s or more usually indicate instability) + + if (check_umax) then + if (umaxn > umax_stab) then + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + if (abs(work1(i,j,iblk) - umaxn) < puny) then + if (my_task == master_task) then + write(nu_diag,*) ' ' + write(nu_diag,*) 'Warning, large ice speed' + write(nu_diag,*) 'my_task, iblk, i, j, umaxn:', & + my_task, iblk, i, j, umaxn + end if + endif + enddo + enddo + enddo + elseif (umaxs > umax_stab) then + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + if (abs(work1(i,j,iblk) - umaxs) < puny) then + if (my_task == master_task) then + write(nu_diag,*) ' ' + write(nu_diag,*) 'Warning, large ice speed' + write(nu_diag,*) 'my_task, iblk, i, j, umaxs:', & + my_task, iblk, i, j, umaxs + end if + endif + enddo + enddo + enddo + endif ! umax + endif ! check_umax + + ! maximum ice strength + + pmaxn = global_maxval(strength, distrb_info, lmask_n) + pmaxs = global_maxval(strength, distrb_info, lmask_s) + + pmaxn = pmaxn / c1000 ! convert to kN/m + pmaxs = pmaxs / c1000 + + if (print_global) then + + ! total ice/snow internal energy + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = esno(i,j,iblk) + eice(i,j,iblk) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + etotn = global_sum(work1, distrb_info, & + field_loc_center, tarean) + etots = global_sum(work1, distrb_info, & + field_loc_center, tareas) + + !----------------------------------------------------------------- + ! various fluxes + !----------------------------------------------------------------- + ! evap, fsens, and flwout need to be multiplied by aice because + ! regrettably they have been divided by aice for the coupler + !----------------------------------------------------------------- + + ! evaporation + + evpn = global_sum_prod(evap, aice, distrb_info, & + field_loc_center, tarean) + evps = global_sum_prod(evap, aice, distrb_info, & + field_loc_center, tareas) + evpn = evpn*dt + evps = evps*dt + + ! salt flux + sfsaltn = global_sum(fsalt_gbm, distrb_info, & + field_loc_center, tarean) + sfsalts = global_sum(fsalt_gbm, distrb_info, & + field_loc_center, tareas) + sfsaltn = sfsaltn*dt + sfsalts = sfsalts*dt + + ! fresh water flux + sfreshn = global_sum(fresh_gbm, distrb_info, & + field_loc_center, tarean) + sfreshs = global_sum(fresh_gbm, distrb_info, & + field_loc_center, tareas) + sfreshn = sfreshn*dt + sfreshs = sfreshs*dt + + ! ocean heat + ! Note: fswthru not included because it does not heat ice + fhocnn = global_sum(fhocn_gbm, distrb_info, & + field_loc_center, tarean) + fhocns = global_sum(fhocn_gbm, distrb_info, & + field_loc_center, tareas) + + ! latent heat + ! You may be wondering, where is the latent heat flux? + ! It is not included here because it cancels with + ! the evaporative flux times the enthalpy of the + ! ice/snow that evaporated. + + ! atmo heat flux + ! Note: flwout includes the reflected longwave down, needed by the + ! atmosphere as an upwards radiative boundary condition. + ! Also note: fswabs includes solar radiation absorbed in ocean, + ! which must be subtracted here. + + if (calc_Tsfc) then + + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = & + (fswabs(i,j,iblk) - fswthru(i,j,iblk) & + + flwout(i,j,iblk) & + + fsens (i,j,iblk)) * aice(i,j,iblk) & + + flw (i,j,iblk) * aice_init(i,j,iblk) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + else ! fsurf is computed by atmosphere model + + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = & + (fsurf(i,j,iblk) - flat(i,j,iblk)) & + * aice(i,j,iblk) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + endif ! calc_Tsfc + + fhatmn = global_sum(work1, distrb_info, & + field_loc_center, tarean) + fhatms = global_sum(work1, distrb_info, & + field_loc_center, tareas) + + ! freezing potential + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = max(c0,frzmlt(i,j,iblk)) + enddo + enddo + enddo + !$OMP END PARALLEL DO + fhfrzn = global_sum(work1, distrb_info, & + field_loc_center, tarean) + fhfrzs = global_sum(work1, distrb_info, & + field_loc_center, tareas) + + ! rain + rnn = global_sum_prod(frain, aice_init, distrb_info, & + field_loc_center, tarean) + rns = global_sum_prod(frain, aice_init, distrb_info, & + field_loc_center, tareas) + rnn = rnn*dt + rns = rns*dt + + ! snow + snn = global_sum_prod(fsnow, aice_init, distrb_info, & + field_loc_center, tarean) + sns = global_sum_prod(fsnow, aice_init, distrb_info, & + field_loc_center, tareas) + snn = snn*dt + sns = sns*dt + + ! frazil ice growth !! should not be multiplied by aice + ! m/step->kg/m^2/s + work1(:,:,:) = frazil(:,:,:)*rhoi/dt + frzn = global_sum(work1, distrb_info, & + field_loc_center, tarean) + frzs = global_sum(work1, distrb_info, field_loc_center, & + tareas) + frzn = frzn*dt + frzs = frzs*dt + + ! ice and snow mass + micen = rhoi*shmaxn + msnwn = rhos*snwmxn + mices = rhoi*shmaxs + msnws = rhos*snwmxs + + mtotn = micen + msnwn + mtots = mices + msnws + + ! mass change since beginning of time step + delmin = mtotn - totmn + delmis = mtots - totms + + ! ice mass change including frazil ice formation + delmxn = micen - totmin + delmxs = mices - totmis + if (.not. update_ocn_f) then + ! ice mass change excluding frazil ice formation + delmxn = delmxn - frzn + delmxs = delmxs - frzs + endif + + ! total water flux + fluxn = c0 + fluxs = c0 + if( arean > c0) then + ! water associated with frazil ice included in fresh + fluxn = rnn + snn + evpn - sfreshn + if (.not. update_ocn_f) then + fluxn = fluxn + frzn + endif + endif + if( areas > c0) then + ! water associated with frazil ice included in fresh + fluxs = rns + sns + evps - sfreshs + if (.not. update_ocn_f) then + fluxs = fluxs + frzs + endif + endif + + werrn = (fluxn-delmin)/(mtotn+c1) + werrs = (fluxs-delmis)/(mtots+c1) + + ! energy change + delein = etotn - toten + deleis = etots - totes + + fhatmn = fhatmn + ( - snn * Lfresh + evpn * Lvap ) / dt + fhatms = fhatms + ( - sns * Lfresh + evps * Lvap ) / dt + + hnetn = (fhatmn - fhocnn - fhfrzn) * dt + hnets = (fhatms - fhocns - fhfrzs) * dt + + herrn = (hnetn - delein) / (etotn - c1) + herrs = (hnets - deleis) / (etots - c1) + + ! salt mass + msltn = micen*ice_ref_salinity*p001 + mslts = mices*ice_ref_salinity*p001 + + ! change in salt mass + delmsltn = delmxn*ice_ref_salinity*p001 + delmslts = delmxs*ice_ref_salinity*p001 + + ! salt error + serrn = (sfsaltn + delmsltn) / (msltn + c1) + serrs = (sfsalts + delmslts) / (mslts + c1) + + endif ! print_global + + if (print_points) then + + !----------------------------------------------------------------- + ! state of the ice and associated fluxes for 2 defined points + ! NOTE these are computed for the last timestep only (not avg) + !----------------------------------------------------------------- + + do n = 1, npnt + if (my_task == pmloc(n)) then + i = piloc(n) + j = pjloc(n) + iblk = pbloc(n) + + pTair(n) = Tair(i,j,iblk) - Tffresh ! air temperature + pQa(n) = Qa(i,j,iblk) ! specific humidity + pfsnow(n) = fsnow(i,j,iblk)*dt/rhos ! snowfall + pfrain(n) = frain(i,j,iblk)*dt/rhow ! rainfall + pfsw(n) = fsw(i,j,iblk) ! shortwave radiation + pflw(n) = flw(i,j,iblk) ! longwave radiation + paice(n) = aice(i,j,iblk) ! ice area + + hiavg(n) = c0 ! avg snow/ice thickness + hsavg(n) = c0 + if (paice(n) /= c0) then + hiavg(n) = vice(i,j,iblk)/paice(n) + hsavg(n) = vsno(i,j,iblk)/paice(n) + endif + pTsfc(n) = trcr(i,j,nt_Tsfc,iblk) ! ice/snow sfc temperature + pevap(n) = evap(i,j,iblk)*dt/rhoi ! sublimation/condensation + pfswabs(n) = fswabs(i,j,iblk) ! absorbed solar flux + pflwout(n) = flwout(i,j,iblk) ! outward longwave flux + pflat(n) = flat(i,j,iblk) ! latent heat flux + pfsens(n) = fsens(i,j,iblk) ! sensible heat flux + pfsurf(n) = fsurf(i,j,iblk) ! total sfc heat flux + pfcondtop(n) = fcondtop(i,j,iblk) ! top sfc cond flux + pmeltt(n) = meltt(i,j,iblk) ! top melt + pmeltb(n) = meltb(i,j,iblk) ! bottom melt + pmeltl(n) = meltl(i,j,iblk) ! lateral melt + psnoice(n) = snoice(i,j,iblk) ! snow ice + pfrazil(n) = frazil(i,j,iblk) ! frazil ice + pcongel(n) = congel(i,j,iblk) ! congelation ice + pdhi(n) = vice(i,j,iblk) - pdhi(n) ! ice thickness change + pdhs(n) = vsno(i,j,iblk) - pdhs(n) ! snow thickness change + pde(n) = -(eice(i,j,iblk) & ! ice/snow energy change + + esno(i,j,iblk) - pde(n)) / dt + psst(n) = sst(i,j,iblk) ! sea surface temperature + pTf(n) = Tf(i,j,iblk) ! freezing temperature + pfhocn(n) = -fhocn(i,j,iblk) ! ocean heat used by ice + + endif ! my_task = pmloc + + call broadcast_scalar(pTair (n), pmloc(n)) + call broadcast_scalar(pQa (n), pmloc(n)) + call broadcast_scalar(pfsnow (n), pmloc(n)) + call broadcast_scalar(pfrain (n), pmloc(n)) + call broadcast_scalar(pfsw (n), pmloc(n)) + call broadcast_scalar(pflw (n), pmloc(n)) + call broadcast_scalar(paice (n), pmloc(n)) + call broadcast_scalar(hsavg (n), pmloc(n)) + call broadcast_scalar(hiavg (n), pmloc(n)) + call broadcast_scalar(pTsfc (n), pmloc(n)) + call broadcast_scalar(pevap (n), pmloc(n)) + call broadcast_scalar(pfswabs (n), pmloc(n)) + call broadcast_scalar(pflwout (n), pmloc(n)) + call broadcast_scalar(pflat (n), pmloc(n)) + call broadcast_scalar(pfsens (n), pmloc(n)) + call broadcast_scalar(pfsurf (n), pmloc(n)) + call broadcast_scalar(pfcondtop(n), pmloc(n)) + call broadcast_scalar(pmeltt (n), pmloc(n)) + call broadcast_scalar(pmeltb (n), pmloc(n)) + call broadcast_scalar(pmeltl (n), pmloc(n)) + call broadcast_scalar(psnoice (n), pmloc(n)) + call broadcast_scalar(pfrazil (n), pmloc(n)) + call broadcast_scalar(pcongel (n), pmloc(n)) + call broadcast_scalar(pdhi (n), pmloc(n)) + call broadcast_scalar(pdhs (n), pmloc(n)) + call broadcast_scalar(pde (n), pmloc(n)) + call broadcast_scalar(psst (n), pmloc(n)) + call broadcast_scalar(pTf (n), pmloc(n)) + call broadcast_scalar(pfhocn (n), pmloc(n)) + + enddo ! npnt + endif ! print_points + + !----------------------------------------------------------------- + ! start spewing + !----------------------------------------------------------------- + + if (my_task == master_task) then + if (grid_type == 'panarctic') then ! Arctic only + write (nu_diag,799) 'Arctic diagnostics' + write (nu_diag,801) 'total ice area (km^2) = ',arean + write (nu_diag,801) 'total ice extent(km^2) = ',extentn + write (nu_diag,801) 'total ice volume (m^3) = ',shmaxn + write (nu_diag,801) 'total snw volume (m^3) = ',snwmxn + write (nu_diag,801) 'tot kinetic energy (J) = ',ketotn + write (nu_diag,800) 'rms ice speed (m/s) = ',urmsn + write (nu_diag,800) 'average albedo = ',albtotn + write (nu_diag,800) 'max ice volume (m) = ',hmaxn + write (nu_diag,800) 'max ice speed (m/s) = ',umaxn + write (nu_diag,900) 'max strength (kN/m) = ',pmaxn + + if (print_global) then ! global diags for conservations checks + +#ifdef CCSMCOUPLED + if (prescribed_ice) then + write (nu_diag,*) '----------------------------' + write (nu_diag,*) 'This is the prescribed ice option.' + write (nu_diag,*) 'Heat and water will not be conserved.' + else +#endif + + write (nu_diag,*) '----------------------------' + write (nu_diag,801) 'arwt rain h2o kg in dt = ',rnn + write (nu_diag,801) 'arwt snow h2o kg in dt = ',snn + write (nu_diag,801) 'arwt evap h2o kg in dt = ',evpn + write (nu_diag,801) 'arwt frzl h2o kg in dt = ',frzn + write (nu_diag,801) 'arwt frsh h2o kg in dt = ',sfreshn + + write (nu_diag,801) 'arwt ice mass (kg) = ',micen + write (nu_diag,801) 'arwt snw mass (kg) = ',msnwn + + write (nu_diag,801) 'arwt tot mass (kg) = ',mtotn + write (nu_diag,801) 'arwt tot mass chng(kg) = ',delmin + write (nu_diag,801) 'arwt water flux = ',fluxn + if (update_ocn_f) then + write (nu_diag,*) '(=rain+snow+evap-fresh) ' + else + write (nu_diag,*) '(=rain+snow+evap+frzl-fresh) ' + endif + write (nu_diag,801) 'water flux error = ',werrn +#ifdef CCSMCOUPLED + endif ! prescribed_ice +#endif + write (nu_diag,*) '----------------------------' + write (nu_diag,801) 'arwt atm heat flux (W) = ',fhatmn + write (nu_diag,801) 'arwt ocn heat flux (W) = ',fhocnn + write (nu_diag,801) 'arwt frzl heat flux(W) = ',fhfrzn + write (nu_diag,801) 'arwt tot energy (J) = ',etotn + write (nu_diag,801) 'arwt net heat (J) = ',hnetn + write (nu_diag,801) 'arwt tot energy chng(J)= ',delein + write (nu_diag,801) 'arwt heat error = ',herrn + + write (nu_diag,*) '----------------------------' + write (nu_diag,801) 'arwt salt mass (kg) = ',msltn + write (nu_diag,801) 'arwt salt mass chng(kg)= ',delmsltn + write (nu_diag,801) 'arwt salt flx in dt(kg)= ',sfsaltn + write (nu_diag,801) 'arwt salt flx error = ',serrn + write (nu_diag,*) '----------------------------' + + endif ! print_global + + else ! global grid + + write(nu_diag,899) 'Arctic','Antarctic' + + write(nu_diag,901) 'total ice area (km^2) = ',arean, areas + write(nu_diag,901) 'total ice extent(km^2) = ',extentn,extents + write(nu_diag,901) 'total ice volume (m^3) = ',shmaxn, shmaxs + write(nu_diag,901) 'total snw volume (m^3) = ',snwmxn, snwmxs + write(nu_diag,901) 'tot kinetic energy (J) = ',ketotn, ketots + write(nu_diag,900) 'rms ice speed (m/s) = ',urmsn, urmss + write(nu_diag,900) 'average albedo = ',albtotn,albtots + write(nu_diag,900) 'max ice volume (m) = ',hmaxn, hmaxs + write(nu_diag,900) 'max ice speed (m/s) = ',umaxn, umaxs + write(nu_diag,900) 'max strength (kN/m) = ',pmaxn, pmaxs + + if (print_global) then ! global diags for conservations checks + + write(nu_diag,*) '----------------------------' + write(nu_diag,901) 'arwt rain h2o kg in dt = ',rnn,rns + write(nu_diag,901) 'arwt snow h2o kg in dt = ',snn,sns + write(nu_diag,901) 'arwt evap h2o kg in dt = ',evpn,evps + write(nu_diag,901) 'arwt frzl h2o kg in dt = ',frzn,frzs + write(nu_diag,901) 'arwt frsh h2o kg in dt = ',sfreshn,sfreshs + + write(nu_diag,901) 'arwt ice mass (kg) = ',micen,mices + write(nu_diag,901) 'arwt snw mass (kg) = ',msnwn,msnws + + write(nu_diag,901) 'arwt tot mass (kg) = ',mtotn,mtots + write(nu_diag,901) 'arwt tot mass chng(kg) = ',delmin,delmis + write(nu_diag,901) 'arwt water flux = ',fluxn,fluxs + if (update_ocn_f) then + write (nu_diag,*) '(=rain+snow+evap-fresh) ' + else + write (nu_diag,*) '(=rain+snow+evap+frzl-fresh) ' + endif + write(nu_diag,901) 'water flux error = ',werrn,werrs + + write(nu_diag,*) '----------------------------' + write(nu_diag,901) 'arwt atm heat flux (W) = ',fhatmn,fhatms + write(nu_diag,901) 'arwt ocn heat flux (W) = ',fhocnn,fhocns + write(nu_diag,901) 'arwt frzl heat flux(W) = ',fhfrzn,fhfrzs + write(nu_diag,901) 'arwt tot energy (J) = ',etotn,etots + write(nu_diag,901) 'arwt net heat (J) = ',hnetn,hnets + write(nu_diag,901) 'arwt tot energy chng(J)= ',delein,deleis + write(nu_diag,901) 'arwt heat error = ',herrn,herrs + + write(nu_diag,*) '----------------------------' + write(nu_diag,901) 'arwt salt mass (kg) = ',msltn,mslts + write(nu_diag,901) 'arwt salt mass chng(kg)= ',delmsltn, & + delmslts + write(nu_diag,901) 'arwt salt flx in dt(kg)= ',sfsaltn, & + sfsalts + write(nu_diag,901) 'arwt salt flx error = ',serrn,serrs + write(nu_diag,*) '----------------------------' + + endif ! print_global + endif ! grid_type + + call flush_fileunit(nu_diag) + + !----------------------------------------------------------------- + ! diagnostics for Arctic and Antarctic points + !----------------------------------------------------------------- + + if (print_points) then + + write(nu_diag,*) ' ' + write(nu_diag,902) ' Lat, Long ',plat(1),plon(1), & + plat(2),plon(2) + write(nu_diag,903) ' my_task, iblk, i, j ', & + pmloc(1),pbloc(1),piloc(1),pjloc(1), & + pmloc(2),pbloc(2),piloc(2),pjloc(2) + write(nu_diag,*) '----------atm----------' + write(nu_diag,900) 'air temperature (C) = ',pTair(1),pTair(2) + write(nu_diag,900) 'specific humidity = ',pQa(1),pQa(2) + write(nu_diag,900) 'snowfall (m) = ',pfsnow(1), & + pfsnow(2) + write(nu_diag,900) 'rainfall (m) = ',pfrain(1), & + pfrain(2) + if (.not.calc_Tsfc) then + write(nu_diag,900) 'total surface heat flux= ',pfsurf(1),pfsurf(2) + write(nu_diag,900) 'top sfc conductive flux= ',pfcondtop(1), & + pfcondtop(2) + write(nu_diag,900) 'latent heat flx = ',pflat(1),pflat(2) + else + write(nu_diag,900) 'shortwave radiation sum= ',pfsw(1),pfsw(2) + write(nu_diag,900) 'longwave radiation = ',pflw(1),pflw(2) + endif + write(nu_diag,*) '----------ice----------' + write(nu_diag,900) 'area fraction = ',paice(1),paice(2) + write(nu_diag,900) 'avg ice thickness (m) = ',hiavg(1),hiavg(2) + write(nu_diag,900) 'avg snow depth (m) = ',hsavg(1),hsavg(2) + if (calc_Tsfc) then + write(nu_diag,900) 'surface temperature(C) = ',pTsfc(1),pTsfc(2) + write(nu_diag,900) 'absorbed shortwave flx = ',pfswabs(1), & + pfswabs(2) + write(nu_diag,900) 'outward longwave flx = ',pflwout(1), & + pflwout(2) + write(nu_diag,900) 'sensible heat flx = ',pfsens(1), & + pfsens(2) + write(nu_diag,900) 'latent heat flx = ',pflat(1),pflat(2) + endif + write(nu_diag,900) 'subl/cond (m ice) = ',pevap(1),pevap(2) + write(nu_diag,900) 'top melt (m) = ',pmeltt(1) & + ,pmeltt(2) + write(nu_diag,900) 'bottom melt (m) = ',pmeltb(1) & + ,pmeltb(2) + write(nu_diag,900) 'lateral melt (m) = ',pmeltl(1) & + ,pmeltl(2) + write(nu_diag,900) 'new ice (m) = ',pfrazil(1), & + pfrazil(2) + write(nu_diag,900) 'congelation (m) = ',pcongel(1), & + pcongel(2) + write(nu_diag,900) 'snow-ice (m) = ',psnoice(1), & + psnoice(2) + write(nu_diag,900) 'effective dhi (m) = ',pdhi(1),pdhi(2) + write(nu_diag,900) 'effective dhs (m) = ',pdhs(1),pdhs(2) + write(nu_diag,900) 'intnl enrgy chng(W/m^2)= ',pde (1),pde (2) + write(nu_diag,*) '----------ocn----------' + write(nu_diag,900) 'sst (C) = ',psst(1),psst(2) + write(nu_diag,900) 'freezing temp (C) = ',pTf(1),pTf(2) + write(nu_diag,900) 'heat used (W/m^2) = ',pfhocn(1), & + pfhocn(2) + + endif ! print_points + endif ! my_task = master_task + + 799 format (27x,a24) + 800 format (a25,2x,f24.17) + 801 format (a25,2x,1pe24.17) + 899 format (27x,a24,2x,a24) + 900 format (a25,2x,f24.17,2x,f24.17) + 901 format (a25,2x,1pe24.17,2x,1pe24.17) + 902 format (a25,10x,f6.1,1x,f6.1,9x,f6.1,1x,f6.1) + 903 format (a25,5x,i4,1x,i4,1x,i4,1x,i4,7x,i4,1x,i4,1x,i4,1x,i4) + + end subroutine runtime_diags + +!======================================================================= +!BOP +! +! !IROUTINE: init_mass_diags - computes global combined ice and snow mass sum +! +! !INTERFACE: +! + subroutine init_mass_diags +! +! !DESCRIPTION: +! +! Computes global combined ice and snow mass sum +! +! !REVISION HISTORY: +! +! author: Elizabeth C. Hunke, LANL +! +! !USES: +! + use ice_global_reductions + use ice_grid + use ice_state + use ice_broadcast +! +! !INPUT/OUTPUT PARAMETERS: +! +!EOP +! + integer (kind=int_kind) :: n, k, ii, jj, i, j, iblk + integer (kind=int_kind) :: naero + + real (kind=dbl_kind) :: & + shmaxn, snwmxn, shmaxs, snwmxs + + real (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: & + work1, work2 + + + ! total ice volume + shmaxn = global_sum(vice, distrb_info, field_loc_center, tarean) + shmaxs = global_sum(vice, distrb_info, field_loc_center, tareas) + + ! total snow volume + snwmxn = global_sum(vsno, distrb_info, field_loc_center, tarean) + snwmxs = global_sum(vsno, distrb_info, field_loc_center, tareas) + + ! north/south ice mass + totmin = rhoi*shmaxn + totmis = rhoi*shmaxs + + ! north/south ice+snow mass + totmn = totmin + rhos*snwmxn + totms = totmis + rhos*snwmxs + + ! north/south ice+snow energy + ! total ice/snow energy + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j=1,ny_block + do i=1,nx_block + work1(i,j,iblk) = esno(i,j,iblk) + eice(i,j,iblk) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + toten = global_sum(work1, distrb_info, field_loc_center, tarean) + totes = global_sum(work1, distrb_info, field_loc_center, tareas) + + if (tr_aero) then + do naero=1,n_aero + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = trcr(i,j,nt_aero +4*(naero-1),iblk)*vsno(i,j,iblk) & + + trcr(i,j,nt_aero+1+4*(naero-1),iblk)*vsno(i,j,iblk) & + + trcr(i,j,nt_aero+2+4*(naero-1),iblk)*vice(i,j,iblk) & + + trcr(i,j,nt_aero+3+4*(naero-1),iblk)*vice(i,j,iblk) + enddo + enddo + enddo + totaeron(naero)= global_sum(work1, distrb_info, field_loc_center, tarean) + totaeros(naero)= global_sum(work1, distrb_info, field_loc_center, tareas) + enddo + endif + + if (print_points) then + + do n = 1, npnt + + if (my_task == pmloc(n)) then + i = piloc(n) + j = pjloc(n) + iblk = pbloc(n) + + pdhi(n) = vice(i,j,iblk) + pdhs(n) = vsno(i,j,iblk) + pde(n) = esno(i,j,iblk) + eice(i,j,iblk) + endif + + enddo ! npnt + + endif ! print_points + + end subroutine init_mass_diags + +!======================================================================= +!BOP +! +! !IROUTINE: init_diags - find tasks for diagnostic points +! +! !INTERFACE: +! + subroutine init_diags +! +! !DESCRIPTION: +! +! Find tasks for diagnostic points. +! +! +! !REVISION HISTORY: +! +! authors: Elizabeth C. Hunke and William H. Lipscomb, LANL +! +! !USES: + use ice_grid + use ice_blocks + use ice_broadcast + use ice_global_reductions + use ice_gather_scatter +! +! !INPUT/OUTPUT PARAMETERS: +! +!EOP +! + real (kind=dbl_kind) :: & + latdis , & ! latitude distance + londis , & ! longitude distance + totdis , & ! total distance + mindis , & ! minimum distance from desired location + mindis_g ! global minimum distance from desired location + + integer (kind=int_kind) :: & + n , & ! index for point search + i,j , & ! grid indices + iblk , & ! block index + ilo,ihi,jlo,jhi ! beginning and end of physical domain + + character (char_len) :: label(npnt) + + type (block) :: & + this_block ! block information for current block + + if (print_points) then + + if (my_task==master_task) then + write(nu_diag,*) ' ' + write(nu_diag,*) ' Find indices of diagnostic points ' + endif + + ! initialize labels + label(1)(1:40) = 'Near North Pole pack ice ' + label(2)(1:40) = 'Weddell Sea ' + + piloc(:) = 0 + pjloc(:) = 0 + pbloc(:) = 0 + pmloc(:) = -999 + plat(:) = -999._dbl_kind + plon(:) = -999._dbl_kind + + ! find minimum distance to diagnostic points on this processor + do n = 1, npnt + if (lonpnt(n) > c180) lonpnt(n) = lonpnt(n) - c360 + + iindx = 0 + jindx = 0 + bindx = 0 + mindis = 540.0_dbl_kind ! 360. + 180. + + !$OMP PARALLEL DO PRIVATE(iblk,this_block,ilo,ihi,jlo,jhi,j,i, & + !$OMP latdis,londis,totdis,mindis, & + !$OMP jindx,iindx,bindx) + do iblk = 1, nblocks + this_block = get_block(blocks_ice(iblk),iblk) + ilo = this_block%ilo + ihi = this_block%ihi + jlo = this_block%jlo + jhi = this_block%jhi + + do j = jlo, jhi + do i = ilo, ihi + if (hm(i,j,iblk) > p5) then + latdis = abs(latpnt(n)-TLAT(i,j,iblk)*rad_to_deg) + londis = abs(lonpnt(n)-TLON(i,j,iblk)*rad_to_deg) & + * cos(TLAT(i,j,iblk)) + totdis = sqrt(latdis**2 + londis**2) + if (totdis < mindis) then + mindis = totdis + jindx = j + iindx = i + bindx = iblk + endif ! totdis < mindis + endif ! hm > p5 + enddo ! i + enddo ! j + enddo ! iblk + !$OMP END PARALLEL DO + + ! find global minimum distance to diagnostic points + mindis_g = global_minval(mindis, distrb_info) + + ! save indices of minimum-distance grid cell + if (abs(mindis_g - mindis) < puny) then + piloc(n) = iindx + pjloc(n) = jindx + pbloc(n) = bindx + pmloc(n) = my_task + plat(n) = TLAT(iindx,jindx,bindx)*rad_to_deg + plon(n) = TLON(iindx,jindx,bindx)*rad_to_deg + endif + + ! communicate to all processors + piloc(n) = global_maxval(piloc(n), distrb_info) + pjloc(n) = global_maxval(pjloc(n), distrb_info) + pbloc(n) = global_maxval(pbloc(n), distrb_info) + pmloc(n) = global_maxval(pmloc(n), distrb_info) + plat(n) = global_maxval(plat(n), distrb_info) + plon(n) = global_maxval(plon(n), distrb_info) + + ! write to log file + if (my_task==master_task) then + write(nu_diag,*) ' ' + write(nu_diag,100) n,latpnt(n),lonpnt(n),plat(n),plon(n), & + piloc(n), pjloc(n), pbloc(n), pmloc(n) + endif + 100 format(' found point',i4/ & + ' lat lon TLAT TLON i j block task'/ & + 4(f6.1,1x),1x,4(i4,2x) ) + + enddo ! npnt + endif ! print_points + + end subroutine init_diags + +!======================================================================= +!BOP +! +! !IROUTINE: print_state - print ice state for specified grid point +! +! !INTERFACE: +! + subroutine print_state(plabel,i,j,iblk) +! +! !DESCRIPTION: +! +! This routine is useful for debugging. +! Calls to it should be inserted in the form (after thermo, for example) +! do iblk = 1, nblocks +! do j=jlo,jhi +! do i=ilo,ihi +! plabel = 'post thermo' +! if (istep1 >= check_step .and. iblk==iblkp .and i==ip & +! .and. j==jp .and. my_task == mtask) & +! call print_state(plabel,i,j,iblk) +! enddo +! enddo +! enddo +! +! 'use ice_diagnostics' may need to be inserted also +! +! !REVISION HISTORY: +! +! author: Elizabeth C. Hunke, LANL +! +! !USES: +! +!MH use ice_domain_size + use ice_state + use ice_itd + use ice_flux +! +! !INPUT/OUTPUT PARAMETERS: +! + character (len=20), intent(in) :: plabel + + integer (kind=int_kind), intent(in) :: & + i, j , & ! horizontal indices + iblk ! block index +! +!EOP +! + real (kind=dbl_kind) :: & + eidebug, esdebug, & + qi, qs, Tsnow + + integer (kind=int_kind) :: n, k + + write(nu_diag,*) plabel + write(nu_diag,*) 'istep1, my_task, i, j, iblk:', & + istep1, my_task, i, j, iblk + write(nu_diag,*) ' ' + write(nu_diag,*) 'aice0', aice0(i,j,iblk) + do n = 1, ncat + write(nu_diag,*) ' ' + write(nu_diag,*) 'n =',n + write(nu_diag,*) 'aicen', aicen(i,j,n,iblk) + write(nu_diag,*) 'vicen', vicen(i,j,n,iblk) + write(nu_diag,*) 'vsnon', vsnon(i,j,n,iblk) + if (aicen(i,j,n,iblk) > puny) then + write(nu_diag,*) 'hin', vicen(i,j,n,iblk)/aicen(i,j,n,iblk) + write(nu_diag,*) 'hsn', vsnon(i,j,n,iblk)/aicen(i,j,n,iblk) + endif + write(nu_diag,*) 'Tsfcn',trcrn(i,j,nt_Tsfc,n,iblk) + write(nu_diag,*) ' ' + enddo ! n + + eidebug = c0 + do n = 1,ncat + do k = 1,nilyr + write(nu_diag,*) 'eicen, cat ',n,' layer ',k, & + eicen(i,j,ilyr1(n)+k-1,iblk) + eidebug = eidebug + eicen(i,j,ilyr1(n)+k-1,iblk) + if (aicen(i,j,n,iblk) > puny) then + qi = eicen(i,j,ilyr1(n)+k-1,iblk) / & ! qi, eicen < 0 + (vicen(i,j,n,iblk)/real(nilyr,kind=dbl_kind)) + write(nu_diag,*) 'qi/rhoi', qi/rhoi + endif + enddo + write(nu_diag,*) ' ' + enddo + write(nu_diag,*) 'eice(i,j)',eidebug + write(nu_diag,*) ' ' + + esdebug = c0 + do n = 1,ncat + if (vsnon(i,j,n,iblk) > puny) then + do k = 1,nslyr + write(nu_diag,*) 'esnon, cat ',n,' layer ',k, & + esnon(i,j,slyr1(n)+k-1,iblk) + esdebug = esdebug + esnon(i,j,slyr1(n)+k-1,iblk) + qs = esnon(i,j,slyr1(n)+k-1,iblk) / & ! qs, esnon < 0 + (vsnon(i,j,n,iblk)/real(nslyr,kind=dbl_kind)) + Tsnow = (Lfresh + qs/rhos) / cp_ice + write(nu_diag,*) 'qs/rhos', qs/rhos + write(nu_diag,*) 'Tsnow', Tsnow + enddo + write(nu_diag,*) ' ' + endif + enddo + write(nu_diag,*) 'esno(i,j)',esdebug + write(nu_diag,*) ' ' + + write(nu_diag,*) 'uvel(i,j)',uvel(i,j,iblk) + write(nu_diag,*) 'vvel(i,j)',vvel(i,j,iblk) + + write(nu_diag,*) ' ' + write(nu_diag,*) 'atm states and fluxes' + write(nu_diag,*) ' uatm = ',uatm (i,j,iblk) + write(nu_diag,*) ' vatm = ',vatm (i,j,iblk) + write(nu_diag,*) ' potT = ',potT (i,j,iblk) + write(nu_diag,*) ' Tair = ',Tair (i,j,iblk) + write(nu_diag,*) ' Qa = ',Qa (i,j,iblk) + write(nu_diag,*) ' rhoa = ',rhoa (i,j,iblk) + write(nu_diag,*) ' swvdr = ',swvdr(i,j,iblk) + write(nu_diag,*) ' swvdf = ',swvdf(i,j,iblk) + write(nu_diag,*) ' swidr = ',swidr(i,j,iblk) + write(nu_diag,*) ' swidf = ',swidf(i,j,iblk) + write(nu_diag,*) ' flw = ',flw (i,j,iblk) + write(nu_diag,*) ' frain = ',frain(i,j,iblk) + write(nu_diag,*) ' fsnow = ',fsnow(i,j,iblk) + write(nu_diag,*) ' ' + write(nu_diag,*) 'ocn states and fluxes' + write(nu_diag,*) ' frzmlt = ',frzmlt (i,j,iblk) + write(nu_diag,*) ' sst = ',sst (i,j,iblk) + write(nu_diag,*) ' sss = ',sss (i,j,iblk) + write(nu_diag,*) ' Tf = ',Tf (i,j,iblk) + write(nu_diag,*) ' uocn = ',uocn (i,j,iblk) + write(nu_diag,*) ' vocn = ',vocn (i,j,iblk) + write(nu_diag,*) ' strtltx = ',strtltx(i,j,iblk) + write(nu_diag,*) ' strtlty = ',strtlty(i,j,iblk) + write(nu_diag,*) ' ' + write(nu_diag,*) 'srf states and fluxes' + write(nu_diag,*) ' Tref = ',Tref (i,j,iblk) + write(nu_diag,*) ' Qref = ',Qref (i,j,iblk) + write(nu_diag,*) ' fsens = ',fsens (i,j,iblk) + write(nu_diag,*) ' flat = ',flat (i,j,iblk) + write(nu_diag,*) ' evap = ',evap (i,j,iblk) + write(nu_diag,*) ' flwout = ',flwout(i,j,iblk) + write(nu_diag,*) ' ' + + end subroutine print_state + +!======================================================================= + + end module ice_diagnostics + +!======================================================================= + + + + + diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.clm/BalanceCheckMod.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.clm/BalanceCheckMod.F90 new file mode 100644 index 0000000000..6c4b2089c1 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.clm/BalanceCheckMod.F90 @@ -0,0 +1,701 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1/models/lnd/clm/src/biogeophys/BalanceCheckMod.F90 + +module BalanceCheckMod + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: BalanceCheckMod +! +! !DESCRIPTION: +! Water and energy balance check. +! +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use abortutils, only: endrun + use clm_varctl, only: iulog +! +! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + public :: BeginWaterBalance ! Initialize water balance check + public :: BalanceCheck ! Water and energy balance check +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +!EOP +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BeginWaterBalance +! +! !INTERFACE: + subroutine BeginWaterBalance(lbc, ubc, lbp, ubp, & + num_nolakec, filter_nolakec, num_lakec, filter_lakec, & + num_hydrologyc, filter_hydrologyc) +! +! !DESCRIPTION: +! Initialize column-level water balance at beginning of time step +! +! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use clmtype + use clm_varpar , only : nlevgrnd, nlevsoi + use subgridAveMod, only : p2c + use clm_varcon , only : icol_roof, icol_sunwall, icol_shadewall, icol_road_perv, & + icol_road_imperv +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column-index bounds + integer, intent(in) :: lbp, ubp ! pft-index bounds + integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points + integer, intent(in) :: num_lakec ! number of column non-lake points in column filter + integer, intent(in) :: filter_lakec(ubc-lbc+1) ! column filter for non-lake points + integer , intent(in) :: num_hydrologyc ! number of column soil points in column filter + integer , intent(in) :: filter_hydrologyc(ubc-lbc+1) ! column filter for soil points +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! Created by Peter Thornton +! +!EOP +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in variables +! + real(r8), pointer :: h2osno(:) ! snow water (mm H2O) + real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) + real(r8), pointer :: h2ocan_pft(:) ! canopy water (mm H2O) (pft-level) + real(r8), pointer :: wa(:) ! water in the unconfined aquifer (mm) + integer , pointer :: ctype(:) ! column type + real(r8), pointer :: zwt(:) ! water table depth (m) + real(r8), pointer :: zi(:,:) ! interface level below a "z" level (m) +! +! local pointers to original implicit out variables +! + real(r8), pointer :: h2ocan_col(:) ! canopy water (mm H2O) (column level) + real(r8), pointer :: begwb(:) ! water mass begining of the time step +! +! !OTHER LOCAL VARIABLES: +! + integer :: c, p, f, j, fc ! indices +!----------------------------------------------------------------------- + + ! Assign local pointers to derived type members (column-level) + + h2osno => clm3%g%l%c%cws%h2osno + h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice + h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq + begwb => clm3%g%l%c%cwbal%begwb + h2ocan_col => clm3%g%l%c%cws%pws_a%h2ocan + wa => clm3%g%l%c%cws%wa + ctype => clm3%g%l%c%itype + zwt => clm3%g%l%c%cws%zwt + zi => clm3%g%l%c%cps%zi + + ! Assign local pointers to derived type members (pft-level) + + h2ocan_pft => clm3%g%l%c%p%pws%h2ocan + + ! Determine beginning water balance for time step + ! pft-level canopy water averaged to column + call p2c(num_nolakec, filter_nolakec, h2ocan_pft, h2ocan_col) + + do f = 1, num_hydrologyc + c = filter_hydrologyc(f) + if(zwt(c) <= zi(c,nlevsoi)) then + wa(c) = 5000._r8 + end if + end do + + do f = 1, num_nolakec + c = filter_nolakec(f) + if (ctype(c) == icol_roof .or. ctype(c) == icol_sunwall & + .or. ctype(c) == icol_shadewall .or. ctype(c) == icol_road_imperv) then + begwb(c) = h2ocan_col(c) + h2osno(c) + else + begwb(c) = h2ocan_col(c) + h2osno(c) + wa(c) + end if + end do + do j = 1, nlevgrnd + do f = 1, num_nolakec + c = filter_nolakec(f) + begwb(c) = begwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + end do + end do + + do f = 1, num_lakec + c = filter_lakec(f) + begwb(c) = h2osno(c) + end do + + end subroutine BeginWaterBalance +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BalanceCheck +! +! !INTERFACE: + subroutine BalanceCheck(lbp, ubp, lbc, ubc, lbl, ubl, lbg, ubg) +! +! !DESCRIPTION: +! This subroutine accumulates the numerical truncation errors of the water +! and energy balance calculation. It is helpful to see the performance of +! the process of integration. +! +! The error for energy balance: +! +! error = abs(Net radiation - change of internal energy - Sensible heat +! - Latent heat) +! +! The error for water balance: +! +! error = abs(precipitation - change of water storage - evaporation - runoff) +! +! !USES: + use clmtype + use clm_atmlnd , only : clm_a2l + use subgridAveMod + use clm_time_manager , only : get_step_size, get_nstep, is_first_restart_step + use clm_varcon , only : isturb, icol_roof, icol_sunwall, icol_shadewall, & + spval, icol_road_perv, icol_road_imperv, istice_mec, & + istdlak, istslak + use clm_varctl , only : glc_dyntopo +! +! !ARGUMENTS: + implicit none + integer :: lbp, ubp ! pft-index bounds + integer :: lbc, ubc ! column-index bounds + integer :: lbl, ubl ! landunit-index bounds + integer :: lbg, ubg ! grid-index bounds +! +! !CALLED FROM: +! subroutine clm_driver +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 10 November 2000: Mariana Vertenstein +! Migrated to new data structures by Mariana Vertenstein and +! Peter Thornton +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in arguments +! + integer , pointer :: pgridcell(:) ! pft's gridcell index + integer , pointer :: plandunit(:) ! pft's landunit index + integer , pointer :: cgridcell(:) ! column's gridcell index + integer , pointer :: clandunit(:) ! column's landunit index + integer , pointer :: ltype(:) ! landunit type + integer , pointer :: ctype(:) ! column type + real(r8), pointer :: pwtgcell(:) ! pft's weight relative to corresponding gridcell + real(r8), pointer :: cwtgcell(:) ! column's weight relative to corresponding gridcell + real(r8), pointer :: forc_rain(:) ! rain rate [mm/s] + real(r8), pointer :: forc_snow(:) ! snow rate [mm/s] + real(r8), pointer :: forc_lwrad(:) ! downward infrared (longwave) radiation (W/m**2) + real(r8), pointer :: endwb(:) ! water mass end of the time step + real(r8), pointer :: begwb(:) ! water mass begining of the time step + real(r8), pointer :: fsa(:) ! solar radiation absorbed (total) (W/m**2) + real(r8), pointer :: fsr(:) ! solar radiation reflected (W/m**2) + real(r8), pointer :: eflx_lwrad_out(:) ! emitted infrared (longwave) radiation (W/m**2) + real(r8), pointer :: eflx_lwrad_net(:) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(r8), pointer :: sabv(:) ! solar radiation absorbed by vegetation (W/m**2) + real(r8), pointer :: sabg(:) ! solar radiation absorbed by ground (W/m**2) + real(r8), pointer :: eflx_sh_tot(:) ! total sensible heat flux (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_totg(:) ! total sensible heat flux at grid level (W/m**2) [+ to atm] + real(r8), pointer :: eflx_dynbal(:) ! energy conversion flux due to dynamic land cover change(W/m**2) [+ to atm] + real(r8), pointer :: eflx_lh_tot(:) ! total latent heat flux (W/m8*2) [+ to atm] + real(r8), pointer :: eflx_soil_grnd(:) ! soil heat flux (W/m**2) [+ = into soil] + real(r8), pointer :: qflx_evap_tot(:) ! qflx_evap_soi + qflx_evap_can + qflx_tran_veg + real(r8), pointer :: qflx_irrig(:) ! irrigation flux (mm H2O /s) + real(r8), pointer :: qflx_surf(:) ! surface runoff (mm H2O /s) + real(r8), pointer :: qflx_qrgwl(:) ! qflx_surf at glaciers, wetlands, lakes + real(r8), pointer :: qflx_drain(:) ! sub-surface runoff (mm H2O /s) + real(r8), pointer :: qflx_runoff(:) ! total runoff (mm H2O /s) + real(r8), pointer :: qflx_runoffg(:) ! total runoff at gridcell level inc land cover change flux (mm H2O /s) + real(r8), pointer :: qflx_liq_dynbal(:) ! liq runoff due to dynamic land cover change (mm H2O /s) + real(r8), pointer :: qflx_snwcp_ice(:) ! excess snowfall due to snow capping (mm H2O /s) [+]` + real(r8), pointer :: qflx_glcice(:) ! flux of new glacier ice (mm H2O /s) [+ if ice grows] + real(r8), pointer :: qflx_glcice_frz(:) ! ice growth (mm H2O/s) [+] + real(r8), pointer :: qflx_snwcp_iceg(:) ! excess snowfall due to snow cap inc land cover change flux (mm H20/s) + real(r8), pointer :: qflx_ice_dynbal(:) ! ice runoff due to dynamic land cover change (mm H2O /s) + real(r8), pointer :: forc_solad(:,:) ! direct beam radiation (vis=forc_sols , nir=forc_soll ) + real(r8), pointer :: forc_solai(:,:) ! diffuse radiation (vis=forc_solsd, nir=forc_solld) + real(r8), pointer :: eflx_traffic_pft(:) ! traffic sensible heat flux (W/m**2) + real(r8), pointer :: eflx_wasteheat_pft(:) ! sensible heat flux from urban heating/cooling sources of waste heat (W/m**2) + real(r8), pointer :: canyon_hwr(:) ! ratio of building height to street width + real(r8), pointer :: eflx_heat_from_ac_pft(:) !sensible heat flux put back into canyon due to removal by AC (W/m**2) + real(r8), pointer :: h2osno(:) ! snow water (mm H2O) + real(r8), pointer :: h2osno_old(:) ! snow water (mm H2O) at previous time step + real(r8), pointer :: qflx_dew_snow(:) ! surface dew added to snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_sub_snow(:) ! sublimation rate from snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_top_soil(:) ! net water input into soil from top (mm/s) + real(r8), pointer :: qflx_dew_grnd(:) ! ground surface dew formation (mm H2O /s) [+] + real(r8), pointer :: qflx_evap_grnd(:) ! ground surface evaporation rate (mm H2O/s) [+] + real(r8), pointer :: qflx_prec_grnd(:) ! water onto ground including canopy runoff [kg/(m2 s)] + real(r8), pointer :: qflx_snwcp_liq(:) ! excess liquid water due to snow capping (mm H2O /s) [+]` + real(r8), pointer :: qflx_sl_top_soil(:) ! liquid water + ice from layer above soil to top soil layer or sent to qflx_qrgwl (mm H2O/s) + integer , pointer :: snl(:) ! number of snow layers +! +! local pointers to original implicit out arguments +! + real(r8), pointer :: errh2o(:) ! water conservation error (mm H2O) + real(r8), pointer :: errsol(:) ! solar radiation conservation error (W/m**2) + real(r8), pointer :: errlon(:) ! longwave radiation conservation error (W/m**2) + real(r8), pointer :: errseb(:) ! surface energy conservation error (W/m**2) + real(r8), pointer :: netrad(:) ! net radiation (positive downward) (W/m**2) + real(r8), pointer :: errsoi_col(:) ! column-level soil/lake energy conservation error (W/m**2) + real(r8), pointer :: snow_sources(:) ! snow sources (mm H2O /s) + real(r8), pointer :: snow_sinks(:) ! snow sinks (mm H2O /s) + real(r8), pointer :: errh2osno(:) ! error in h2osno (kg m-2) +! +!EOP +! +! !OTHER LOCAL VARIABLES: + integer :: p,c,l,g ! indices + real(r8) :: dtime ! land model time step (sec) + integer :: nstep ! time step number + logical :: found ! flag in search loop + integer :: indexp,indexc,indexl,indexg ! index of first found in search loop + real(r8) :: forc_rain_col(lbc:ubc) ! column level rain rate [mm/s] + real(r8) :: forc_snow_col(lbc:ubc) ! column level snow rate [mm/s] + +!----------------------------------------------------------------------- + + ! Assign local pointers to derived type scalar members (gridcell-level) + + forc_rain => clm_a2l%forc_rain + forc_snow => clm_a2l%forc_snow + forc_lwrad => clm_a2l%forc_lwrad + forc_solad => clm_a2l%forc_solad + forc_solai => clm_a2l%forc_solai + + ! Assign local pointers to derived type scalar members (landunit-level) + + ltype => clm3%g%l%itype + canyon_hwr => clm3%g%l%canyon_hwr + + ! Assign local pointers to derived type scalar members (column-level) + + ctype => clm3%g%l%c%itype + cgridcell => clm3%g%l%c%gridcell + clandunit => clm3%g%l%c%landunit + cwtgcell => clm3%g%l%c%wtgcell + endwb => clm3%g%l%c%cwbal%endwb + begwb => clm3%g%l%c%cwbal%begwb + qflx_irrig => clm3%g%l%c%cwf%qflx_irrig + qflx_surf => clm3%g%l%c%cwf%qflx_surf + qflx_qrgwl => clm3%g%l%c%cwf%qflx_qrgwl + qflx_drain => clm3%g%l%c%cwf%qflx_drain + qflx_runoff => clm3%g%l%c%cwf%qflx_runoff + qflx_snwcp_ice => clm3%g%l%c%cwf%pwf_a%qflx_snwcp_ice + qflx_evap_tot => clm3%g%l%c%cwf%pwf_a%qflx_evap_tot + qflx_glcice => clm3%g%l%c%cwf%qflx_glcice + qflx_glcice_frz => clm3%g%l%c%cwf%qflx_glcice_frz + errh2o => clm3%g%l%c%cwbal%errh2o + errsoi_col => clm3%g%l%c%cebal%errsoi + h2osno => clm3%g%l%c%cws%h2osno + h2osno_old => clm3%g%l%c%cws%h2osno_old + qflx_dew_snow => clm3%g%l%c%cwf%pwf_a%qflx_dew_snow + qflx_sub_snow => clm3%g%l%c%cwf%pwf_a%qflx_sub_snow + qflx_top_soil => clm3%g%l%c%cwf%qflx_top_soil + qflx_evap_grnd => clm3%g%l%c%cwf%pwf_a%qflx_evap_grnd + qflx_dew_grnd => clm3%g%l%c%cwf%pwf_a%qflx_dew_grnd + qflx_prec_grnd => clm3%g%l%c%cwf%pwf_a%qflx_prec_grnd + qflx_snwcp_liq => clm3%g%l%c%cwf%pwf_a%qflx_snwcp_liq + qflx_sl_top_soil => clm3%g%l%c%cwf%qflx_sl_top_soil + snow_sources => clm3%g%l%c%cws%snow_sources + snow_sinks => clm3%g%l%c%cws%snow_sinks + errh2osno => clm3%g%l%c%cws%errh2osno + snl => clm3%g%l%c%cps%snl + + ! Assign local pointers to derived type scalar members (pft-level) + + pgridcell => clm3%g%l%c%p%gridcell + plandunit => clm3%g%l%c%p%landunit + pwtgcell => clm3%g%l%c%p%wtgcell + fsa => clm3%g%l%c%p%pef%fsa + fsr => clm3%g%l%c%p%pef%fsr + eflx_lwrad_out => clm3%g%l%c%p%pef%eflx_lwrad_out + eflx_lwrad_net => clm3%g%l%c%p%pef%eflx_lwrad_net + sabv => clm3%g%l%c%p%pef%sabv + sabg => clm3%g%l%c%p%pef%sabg + eflx_sh_tot => clm3%g%l%c%p%pef%eflx_sh_tot + eflx_lh_tot => clm3%g%l%c%p%pef%eflx_lh_tot + eflx_soil_grnd => clm3%g%l%c%p%pef%eflx_soil_grnd + errsol => clm3%g%l%c%p%pebal%errsol + errseb => clm3%g%l%c%p%pebal%errseb + errlon => clm3%g%l%c%p%pebal%errlon + netrad => clm3%g%l%c%p%pef%netrad + eflx_wasteheat_pft => clm3%g%l%c%p%pef%eflx_wasteheat_pft + eflx_heat_from_ac_pft => clm3%g%l%c%p%pef%eflx_heat_from_ac_pft + eflx_traffic_pft => clm3%g%l%c%p%pef%eflx_traffic_pft + + ! Assign local pointers to derived type scalar members (gridcell-level) + + qflx_runoffg => clm3%g%gwf%qflx_runoffg + qflx_liq_dynbal => clm3%g%gwf%qflx_liq_dynbal + qflx_snwcp_iceg => clm3%g%gwf%qflx_snwcp_iceg + qflx_ice_dynbal => clm3%g%gwf%qflx_ice_dynbal + eflx_sh_totg => clm3%g%gef%eflx_sh_totg + eflx_dynbal => clm3%g%gef%eflx_dynbal + + ! Get step size and time step + + nstep = get_nstep() + dtime = get_step_size() + + ! Determine column level incoming snow and rain + ! Assume no incident precipitation on urban wall columns (as in Hydrology1Mod.F90). + + do c = lbc,ubc + g = cgridcell(c) + if (ctype(c) == icol_sunwall .or. ctype(c) == icol_shadewall) then + forc_rain_col(c) = 0. + forc_snow_col(c) = 0. + else + forc_rain_col(c) = forc_rain(g) + forc_snow_col(c) = forc_snow(g) + end if + end do + + ! Water balance check + + do c = lbc, ubc + g = cgridcell(c) + l = clandunit(c) + + ! Note: Some glacier_mec cols may have zero weight + if (cwtgcell(c) > 0._r8 .or. ltype(l)==istice_mec)then + errh2o(c) = endwb(c) - begwb(c) & + - (forc_rain_col(c) + forc_snow_col(c) + qflx_irrig(c) & + - qflx_evap_tot(c) - qflx_surf(c) & + - qflx_qrgwl(c) - qflx_drain(c) - qflx_snwcp_ice(c)) * dtime + + ! Suppose glc_dyntopo = T: + ! (1) We have qflx_snwcp_ice = 0, and excess snow has been incorporated in qflx_glcice. + ! This flux must be included here to complete the water balance. + ! (2) Meltwater from ice is allowed to run off and is included in qflx_qrgwl, + ! but the water content of the ice column has not changed (at least for now) because + ! an equivalent ice mass has been "borrowed" from the base of the column. That + ! meltwater is included in qflx_glcice. + ! + ! Note that qflx_glcice is only valid over ice_mec landunits; elsewhere it is spval + + if (glc_dyntopo .and. ltype(l)==istice_mec) then + errh2o(c) = errh2o(c) + qflx_glcice(c)*dtime + end if + + else + + errh2o(c) = 0.0_r8 + + end if + + end do + + found = .false. + do c = lbc, ubc + if (abs(errh2o(c)) > 1e-7_r8) then + found = .true. + indexc = c + end if + end do + if ( found .and. (.not. is_first_restart_step()) ) then ! TJH + write(iulog,*)'WARNING: water balance error ',& + ' nstep = ',nstep,' indexc= ',indexc,' errh2o= ',errh2o(indexc) + if ((ctype(indexc) .eq. icol_roof .or. ctype(indexc) .eq. icol_road_imperv .or. & + ctype(indexc) .eq. icol_road_perv) .and. abs(errh2o(indexc)) > 1.e-1 .and. (nstep > 2) ) then + write(iulog,*)'clm urban model is stopping - error is greater than 1.e-1' + write(iulog,*)'nstep = ',nstep,' indexc= ',indexc,' errh2o= ',errh2o(indexc) + write(iulog,*)'ctype(indexc): ',ctype(indexc) + write(iulog,*)'forc_rain = ',forc_rain_col(indexc) + write(iulog,*)'forc_snow = ',forc_snow_col(indexc) + write(iulog,*)'endwb = ',endwb(indexc) + write(iulog,*)'begwb = ',begwb(indexc) + write(iulog,*)'qflx_evap_tot= ',qflx_evap_tot(indexc) + write(iulog,*)'qflx_irrig = ',qflx_irrig(indexc) + write(iulog,*)'qflx_surf = ',qflx_surf(indexc) + write(iulog,*)'qflx_qrgwl = ',qflx_qrgwl(indexc) + write(iulog,*)'qflx_drain = ',qflx_drain(indexc) + write(iulog,*)'qflx_snwcp_ice = ',qflx_snwcp_ice(indexc) + write(iulog,*)'clm model is stopping' + call endrun('clm urban model is stopping - water balance error is greater than 1.e-1') + else if (abs(errh2o(indexc)) > .10_r8 .and. (nstep > 2) ) then + write(iulog,*)'clm model is stopping - error is greater than .10' + write(iulog,*)'nstep = ',nstep,' indexc= ',indexc,' errh2o= ',errh2o(indexc) + write(iulog,*)'ctype(indexc): ',ctype(indexc) + write(iulog,*)'forc_rain = ',forc_rain_col(indexc) + write(iulog,*)'forc_snow = ',forc_snow_col(indexc) + write(iulog,*)'endwb = ',endwb(indexc) + write(iulog,*)'begwb = ',begwb(indexc) + write(iulog,*)'qflx_evap_tot= ',qflx_evap_tot(indexc) + write(iulog,*)'qflx_irrig = ',qflx_irrig(indexc) + write(iulog,*)'qflx_surf = ',qflx_surf(indexc) + write(iulog,*)'qflx_qrgwl = ',qflx_qrgwl(indexc) + write(iulog,*)'qflx_drain = ',qflx_drain(indexc) + write(iulog,*)'qflx_snwcp_ice = ',qflx_snwcp_ice(indexc) + write(iulog,*)'clm model is stopping' + call endrun('clm model is stopping - water balance error is greater than .10') + end if + end if + + ! Snow balance check + + do c = lbc, ubc + g = cgridcell(c) + l = clandunit(c) + if (ltype(l) == istdlak .or. ltype(l) == istslak )then + ! As defined here, snow_sources - snow_sinks will equal the change in h2osno at + ! any given time step. + if (h2osno(c) .eq. 0._r8) then + snow_sources(c) = 0._r8 + snow_sinks(c) = 0._r8 + errh2osno(c) = 0._r8 + else + snow_sources(c) = qflx_prec_grnd(c) + qflx_dew_snow(c) + qflx_dew_grnd(c) + snow_sinks(c) = qflx_sub_snow(c) + qflx_evap_grnd(c) + qflx_top_soil(c) & + + qflx_snwcp_ice(c) + qflx_snwcp_liq(c) + errh2osno(c) = (h2osno(c) - h2osno_old(c)) - (snow_sources(c) - snow_sinks(c)) * dtime + end if + else ! non-lake + ! As defined here, snow_sources - snow_sinks will equal the change in h2osno at + ! any given time step but only if there is at least one snow layer. h2osno + ! also includes snow that is part of the soil column (an initial snow layer is + ! only created if h2osno > 10mm). + if (snl(c) .lt. 0) then + snow_sources(c) = qflx_prec_grnd(c) + qflx_dew_snow(c) + qflx_dew_grnd(c) + snow_sinks(c) = qflx_sub_snow(c) + qflx_evap_grnd(c) + qflx_top_soil(c) & + + qflx_snwcp_ice(c) + qflx_snwcp_liq(c) + qflx_sl_top_soil(c) + + ! For ice_mec landunits, if glc_dyntopo is true, then qflx_snwcp_ice = 0, + ! and qflx_glcice_frz instead stores this flux + if (ltype(l) == istice_mec .and. glc_dyntopo) then + snow_sinks(c) = snow_sinks(c) + qflx_glcice_frz(c) + end if + + errh2osno(c) = (h2osno(c) - h2osno_old(c)) - (snow_sources(c) - snow_sinks(c)) * dtime + else + snow_sources(c) = 0._r8 + snow_sinks(c) = 0._r8 + errh2osno(c) = 0._r8 + end if + end if + end do + + found = .false. + do c = lbc, ubc + l = clandunit(c) + if ((cwtgcell(c) > 0._r8 .or. ltype(l)==istice_mec) .and. abs(errh2osno(c)) > 1.0e-7_r8) then + found = .true. + indexc = c + end if + end do + if ( found .and. (.not. is_first_restart_step()) ) then ! TJH + write(iulog,*)'WARNING: snow balance error ',& + ' nstep = ',nstep,' indexc= ',indexc,' errh2osno= ',errh2osno(indexc) + if (abs(errh2osno(indexc)) > 0.1_r8 .and. (nstep > 2) ) then + write(iulog,*)'clm model is stopping - error is greater than .10' + write(iulog,*)'nstep = ',nstep,' indexc= ',indexc,' errh2osno= ',errh2osno(indexc) + write(iulog,*)'ltype: ', ltype(clandunit(indexc)) + write(iulog,*)'ctype(indexc): ',ctype(indexc) + write(iulog,*)'snl: ',snl(indexc) + write(iulog,*)'h2osno: ',h2osno(indexc) + write(iulog,*)'h2osno_old: ',h2osno_old(indexc) + write(iulog,*)'snow_sources: ', snow_sources(indexc) + write(iulog,*)'snow_sinks: ', snow_sinks(indexc) + write(iulog,*)'qflx_prec_grnd: ',qflx_prec_grnd(indexc)*dtime + write(iulog,*)'qflx_sub_snow: ',qflx_sub_snow(indexc)*dtime + write(iulog,*)'qflx_evap_grnd: ',qflx_evap_grnd(indexc)*dtime + write(iulog,*)'qflx_top_soil: ',qflx_top_soil(indexc)*dtime + write(iulog,*)'qflx_dew_snow: ',qflx_dew_snow(indexc)*dtime + write(iulog,*)'qflx_dew_grnd: ',qflx_dew_grnd(indexc)*dtime + write(iulog,*)'qflx_snwcp_ice: ',qflx_snwcp_ice(indexc)*dtime + write(iulog,*)'qflx_snwcp_liq: ',qflx_snwcp_liq(indexc)*dtime + write(iulog,*)'qflx_sl_top_soil: ',qflx_sl_top_soil(indexc)*dtime + write(iulog,*)'qflx_glcice_frz: ',qflx_glcice_frz(indexc)*dtime + write(iulog,*)'clm model is stopping' + call endrun('clm model is stopping - snow balance error is greater than .10') + end if + end if + + ! Energy balance checks + + do p = lbp, ubp + l = plandunit(p) + ! Note: Some glacier_mec pfts may have zero weight + if (pwtgcell(p)>0._r8 .or. ltype(l)==istice_mec) then + g = pgridcell(p) + + ! Solar radiation energy balance + ! Do not do this check for an urban pft since it will not balance on a per-column + ! level because of interactions between columns and since a separate check is done + ! in the urban radiation module + if (ltype(l) /= isturb) then + errsol(p) = fsa(p) + fsr(p) & + - (forc_solad(g,1) + forc_solad(g,2) + forc_solai(g,1) + forc_solai(g,2)) + else + errsol(p) = spval + end if + + ! Longwave radiation energy balance + ! Do not do this check for an urban pft since it will not balance on a per-column + ! level because of interactions between columns and since a separate check is done + ! in the urban radiation module + if (ltype(l) /= isturb) then + errlon(p) = eflx_lwrad_out(p) - eflx_lwrad_net(p) - forc_lwrad(g) + else + errlon(p) = spval + end if + + ! Surface energy balance + ! Changed to using (eflx_lwrad_net) here instead of (forc_lwrad - eflx_lwrad_out) because + ! there are longwave interactions between urban columns (and therefore pfts). + ! For surfaces other than urban, (eflx_lwrad_net) equals (forc_lwrad - eflx_lwrad_out), + ! and a separate check is done above for these terms. + + if (ltype(l) /= isturb) then + errseb(p) = sabv(p) + sabg(p) + forc_lwrad(g) - eflx_lwrad_out(p) & + - eflx_sh_tot(p) - eflx_lh_tot(p) - eflx_soil_grnd(p) + else + errseb(p) = sabv(p) + sabg(p) & + - eflx_lwrad_net(p) & + - eflx_sh_tot(p) - eflx_lh_tot(p) - eflx_soil_grnd(p) & + + eflx_wasteheat_pft(p) + eflx_heat_from_ac_pft(p) + eflx_traffic_pft(p) + end if + netrad(p) = fsa(p) - eflx_lwrad_net(p) + end if + end do + + ! Solar radiation energy balance check + + found = .false. + do p = lbp, ubp + l = plandunit(p) + if (pwtgcell(p)>0._r8 .or. ltype(l)==istice_mec) then + if ( (errsol(p) /= spval) .and. (abs(errsol(p)) > .10_r8) ) then + found = .true. + indexp = p + indexg = pgridcell(p) + end if + end if + end do + if ( found .and. (nstep > 2) .and. (.not. is_first_restart_step() ) ) then ! TJH + write(iulog,100)'BalanceCheck: solar radiation balance error', nstep, indexp, errsol(indexp) + write(iulog,*)'fsa = ',fsa(indexp) + write(iulog,*)'fsr = ',fsr(indexp) + write(iulog,*)'forc_solad(1)= ',forc_solad(indexg,1) + write(iulog,*)'forc_solad(2)= ',forc_solad(indexg,2) + write(iulog,*)'forc_solai(1)= ',forc_solai(indexg,1) + write(iulog,*)'forc_solai(2)= ',forc_solai(indexg,2) + write(iulog,*)'forc_tot = ',forc_solad(indexg,1)+forc_solad(indexg,2)& + +forc_solai(indexg,1)+forc_solai(indexg,2) + write(iulog,*)'clm model is stopping' + call endrun('BalanceCheck: solar radiation balance error') + end if + + ! Longwave radiation energy balance check + + found = .false. + do p = lbp, ubp + l = plandunit(p) + if (pwtgcell(p)>0._r8 .or. ltype(l)==istice_mec) then + if ( (errlon(p) /= spval) .and. (abs(errlon(p)) > .10_r8) ) then + found = .true. + indexp = p + end if + end if + end do + if ( found .and. (nstep > 2) .and. (.not. is_first_restart_step() ) ) then ! TJH + write(iulog,100)'BalanceCheck: longwave energy balance error',nstep,indexp,errlon(indexp) + write(iulog,*)'clm model is stopping' + call endrun('BalanceCheck: longwave energy balance error') + end if + + ! Surface energy balance check + + found = .false. + do p = lbp, ubp + l = plandunit(p) + if (pwtgcell(p)>0._r8 .or. ltype(l)==istice_mec) then + if (abs(errseb(p)) > .10_r8 ) then + found = .true. + indexp = p + end if + end if + end do + if ( found .and. (nstep > 2) .and. (.not. is_first_restart_step() ) ) then ! TJH + write(iulog,100)'BalanceCheck: surface flux energy balance error',nstep,indexp,errseb(indexp) + write(iulog,*)' sabv = ',sabv(indexp) + write(iulog,*)' sabg = ',sabg(indexp) + write(iulog,*)' eflx_lwrad_net = ',eflx_lwrad_net(indexp) + write(iulog,*)' eflx_sh_tot = ',eflx_sh_tot(indexp) + write(iulog,*)' eflx_lh_tot = ',eflx_lh_tot(indexp) + write(iulog,*)' eflx_soil_grnd = ',eflx_soil_grnd(indexp) + write(iulog,*)'clm model is stopping' + call endrun('BalanceCheck: surface flux energy balance error') + end if + + ! Soil energy balance check + + found = .false. + do c = lbc, ubc + if (abs(errsoi_col(c)) > 1.0e-7_r8 ) then + found = .true. + indexc = c + end if + end do + if ( found .and. (.not. is_first_restart_step() ) ) then ! TJH + write(iulog,100)'BalanceCheck: soil balance error',nstep,indexc,errsoi_col(indexc) + if (abs(errsoi_col(indexc)) > .10_r8 .and. (nstep > 2) ) then + write(iulog,*)'clm model is stopping' + call endrun('BalanceCheck: soil balance error') + end if + end if + + ! Update SH and RUNOFF for dynamic land cover change energy and water fluxes + call c2g( lbc, ubc, lbl, ubl, lbg, ubg, & + qflx_runoff(lbc:ubc), qflx_runoffg(lbg:ubg), & + c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) + do g = lbg, ubg + qflx_runoffg(g) = qflx_runoffg(g) - qflx_liq_dynbal(g) + enddo + + call c2g( lbc, ubc, lbl, ubl, lbg, ubg, & + qflx_snwcp_ice(lbc:ubc), qflx_snwcp_iceg(lbg:ubg), & + c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) + do g = lbg, ubg + qflx_snwcp_iceg(g) = qflx_snwcp_iceg(g) - qflx_ice_dynbal(g) + enddo + + call p2g( lbp, ubp, lbc, ubc, lbl, ubl, lbg, ubg, & + eflx_sh_tot(lbp:ubp), eflx_sh_totg(lbg:ubg), & + p2c_scale_type='unity',c2l_scale_type='urbanf',l2g_scale_type='unity') + do g = lbg, ubg + eflx_sh_totg(g) = eflx_sh_totg(g) - eflx_dynbal(g) + enddo + +100 format (1x,a,' nstep =',i10,' point =',i6,' imbalance =',f12.6,' W/m2') +200 format (1x,a,' nstep =',i10,' point =',i6,' imbalance =',f12.6,' mm') + + end subroutine BalanceCheck + +end module BalanceCheckMod diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.clm/CNBalanceCheckMod.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.clm/CNBalanceCheckMod.F90 new file mode 100644 index 0000000000..468d724184 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.clm/CNBalanceCheckMod.F90 @@ -0,0 +1,402 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1/models/lnd/clm/src/biogeochem/CNBalanceCheckMod.F90 + +module CNBalanceCheckMod +#ifdef CN + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: CNBalanceCheckMod +! +! !DESCRIPTION: +! Module for carbon mass balance checking. +! +! !USES: + use abortutils , only: endrun + use shr_kind_mod, only: r8 => shr_kind_r8 + use clm_varctl , only: iulog + implicit none + save + private +! !PUBLIC MEMBER FUNCTIONS: + public :: BeginCBalance + public :: BeginNBalance + public :: CBalanceCheck + public :: NBalanceCheck +! +! !REVISION HISTORY: +! 4/23/2004: Created by Peter Thornton +! +!EOP +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BeginCBalance +! +! !INTERFACE: +subroutine BeginCBalance(lbc, ubc, num_soilc, filter_soilc) +! +! !DESCRIPTION: +! On the radiation time step, calculate the beginning carbon balance for mass +! conservation checks. +! +! !USES: + use clmtype +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_soilc ! number of soil columns filter + integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! 2/4/05: Created by Peter Thornton +! +! !LOCAL VARIABLES: +! local pointers to implicit in arrays + real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool +! +! local pointers to implicit out arrays + real(r8), pointer :: col_begcb(:) ! carbon mass, beginning of time step (gC/m**2) +! +! !OTHER LOCAL VARIABLES: + integer :: c ! indices + integer :: fc ! lake filter indices +! +!EOP +!----------------------------------------------------------------------- + ! assign local pointers at the column level + col_begcb => clm3%g%l%c%ccbal%begcb + totcolc => clm3%g%l%c%ccs%totcolc + + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! calculate beginning column-level carbon balance, + ! for mass conservation check + + col_begcb(c) = totcolc(c) + + end do ! end of columns loop + + +end subroutine BeginCBalance +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BeginNBalance +! +! !INTERFACE: +subroutine BeginNBalance(lbc, ubc, num_soilc, filter_soilc) +! +! !DESCRIPTION: +! On the radiation time step, calculate the beginning nitrogen balance for mass +! conservation checks. +! +! !USES: + use clmtype +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_soilc ! number of soil columns filter + integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! 2/4/05: Created by Peter Thornton +! +! !LOCAL VARIABLES: +! local pointers to implicit in arrays + real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg +! +! local pointers to implicit out arrays + real(r8), pointer :: col_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2) +! +! !OTHER LOCAL VARIABLES: + integer :: c ! indices + integer :: fc ! lake filter indices +! +!EOP +!----------------------------------------------------------------------- + ! assign local pointers at the column level + col_begnb => clm3%g%l%c%cnbal%begnb + totcoln => clm3%g%l%c%cns%totcoln + + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! calculate beginning column-level nitrogen balance, + ! for mass conservation check + + col_begnb(c) = totcoln(c) + + end do ! end of columns loop + +end subroutine BeginNBalance +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: CBalanceCheck +! +! !INTERFACE: +subroutine CBalanceCheck(lbc, ubc, num_soilc, filter_soilc) +! +! !DESCRIPTION: +! On the radiation time step, perform carbon mass conservation check for column and pft +! +! !USES: + use clmtype + use clm_time_manager, only: get_step_size, is_first_restart_step +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_soilc ! number of soil columns in filter + integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! 12/9/03: Created by Peter Thornton +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arrays + real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool + real(r8), pointer :: gpp(:) ! (gC/m2/s) gross primary production + real(r8), pointer :: er(:) ! (gC/m2/s) total ecosystem respiration, autotrophic + heterotrophic + real(r8), pointer :: col_fire_closs(:) ! (gC/m2/s) total column-level fire C loss + real(r8), pointer :: col_hrv_xsmrpool_to_atm(:) ! excess MR pool harvest mortality (gC/m2/s) + real(r8), pointer :: dwt_closs(:) ! (gC/m2/s) total carbon loss from product pools and conversion + real(r8), pointer :: product_closs(:) ! (gC/m2/s) total wood product carbon loss +! +! local pointers to implicit out arrays + real(r8), pointer :: col_cinputs(:) ! (gC/m2/s) total column-level carbon inputs (for balance check) + real(r8), pointer :: col_coutputs(:) ! (gC/m2/s) total column-level carbon outputs (for balance check) + real(r8), pointer :: col_begcb(:) ! carbon mass, beginning of time step (gC/m**2) + real(r8), pointer :: col_endcb(:) ! carbon mass, end of time step (gC/m**2) + real(r8), pointer :: col_errcb(:) ! carbon balance error for the timestep (gC/m**2) +! +! !OTHER LOCAL VARIABLES: + integer :: c,err_index ! indices + integer :: fc ! lake filter indices + logical :: err_found ! error flag + real(r8):: dt ! radiation time step (seconds) +!EOP +!----------------------------------------------------------------------- + + ! assign local pointers to column-level arrays + totcolc => clm3%g%l%c%ccs%totcolc + gpp => clm3%g%l%c%ccf%pcf_a%gpp + er => clm3%g%l%c%ccf%er + col_fire_closs => clm3%g%l%c%ccf%col_fire_closs + col_hrv_xsmrpool_to_atm => clm3%g%l%c%ccf%pcf_a%hrv_xsmrpool_to_atm + dwt_closs => clm3%g%l%c%ccf%dwt_closs + product_closs => clm3%g%l%c%ccf%product_closs + + col_cinputs => clm3%g%l%c%ccf%col_cinputs + col_coutputs => clm3%g%l%c%ccf%col_coutputs + col_begcb => clm3%g%l%c%ccbal%begcb + col_endcb => clm3%g%l%c%ccbal%endcb + col_errcb => clm3%g%l%c%ccbal%errcb + + ! set time steps + dt = real( get_step_size(), r8 ) + + err_found = .false. + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! calculate the total column-level carbon storage, for mass conservation check + + col_endcb(c) = totcolc(c) + + ! calculate total column-level inputs + + col_cinputs(c) = gpp(c) + + ! calculate total column-level outputs + ! er = ar + hr, col_fire_closs includes pft-level fire losses + + col_coutputs(c) = er(c) + col_fire_closs(c) + dwt_closs(c) + product_closs(c) + col_hrv_xsmrpool_to_atm(c) + + ! calculate the total column-level carbon balance error for this time step + + col_errcb(c) = (col_cinputs(c) - col_coutputs(c))*dt - & + (col_endcb(c) - col_begcb(c)) + + ! check for significant errors + if (abs(col_errcb(c)) > 1e-8_r8) then + err_found = .true. + err_index = c + end if + + end do ! end of columns loop + + if ( err_found .and. (.not. is_first_restart_step()) ) then ! TJH + c = err_index + write(iulog,*)'column cbalance error = ', col_errcb(c), c + write(iulog,*)'begcb = ',col_begcb(c) + write(iulog,*)'endcb = ',col_endcb(c) + write(iulog,*)'delta store = ',col_endcb(c)-col_begcb(c) + write(iulog,*)'input mass = ',col_cinputs(c)*dt + write(iulog,*)'output mass = ',col_coutputs(c)*dt + write(iulog,*)'net flux = ',(col_cinputs(c)-col_coutputs(c))*dt + write(iulog,*)'nee = ',clm3%g%l%c%ccf%nee(c) * dt + write(iulog,*)'gpp = ',gpp(c) * dt + write(iulog,*)'er = ',er(c) * dt + write(iulog,*)'col_fire_closs = ',col_fire_closs(c) * dt + write(iulog,*)'col_hrv_xsmrpool_to_atm = ',col_hrv_xsmrpool_to_atm(c) * dt + write(iulog,*)'dwt_closs = ',dwt_closs(c) * dt + write(iulog,*)'product_closs = ',product_closs(c) * dt + call endrun('column carbon balance') + end if + + +end subroutine CBalanceCheck +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: NBalanceCheck +! +! !INTERFACE: +subroutine NBalanceCheck(lbc, ubc, num_soilc, filter_soilc) +! +! !DESCRIPTION: +! On the radiation time step, perform nitrogen mass conservation check +! for column and pft +! +! !USES: + use clmtype + use clm_time_manager, only: get_step_size, is_first_restart_step +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_soilc ! number of soil columns in filter + integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! 12/9/03: Created by Peter Thornton +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arrays + real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg + real(r8), pointer :: ndep_to_sminn(:) ! atmospheric N deposition to soil mineral N (gN/m2/s) + real(r8), pointer :: nfix_to_sminn(:) ! symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s) + real(r8), pointer :: supplement_to_sminn(:) ! supplemental N supply (gN/m2/s) + real(r8), pointer :: denit(:) ! total rate of denitrification (gN/m2/s) + real(r8), pointer :: sminn_leached(:) ! soil mineral N pool loss to leaching (gN/m2/s) + real(r8), pointer :: col_fire_nloss(:) ! total column-level fire N loss (gN/m2/s) + real(r8), pointer :: dwt_nloss(:) ! (gN/m2/s) total nitrogen loss from product pools and conversion + real(r8), pointer :: product_nloss(:) ! (gN/m2/s) total wood product nitrogen loss +! +! local pointers to implicit in/out arrays +! +! local pointers to implicit out arrays + real(r8), pointer :: col_ninputs(:) ! column-level N inputs (gN/m2/s) + real(r8), pointer :: col_noutputs(:) ! column-level N outputs (gN/m2/s) + real(r8), pointer :: col_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2) + real(r8), pointer :: col_endnb(:) ! nitrogen mass, end of time step (gN/m**2) + real(r8), pointer :: col_errnb(:) ! nitrogen balance error for the timestep (gN/m**2) +! +! !OTHER LOCAL VARIABLES: + integer :: c,err_index ! indices + integer :: fc ! lake filter indices + logical :: err_found ! error flag + real(r8):: dt ! radiation time step (seconds) +!EOP +!----------------------------------------------------------------------- + ! assign local pointers to column-level arrays + + totcoln => clm3%g%l%c%cns%totcoln + ndep_to_sminn => clm3%g%l%c%cnf%ndep_to_sminn + nfix_to_sminn => clm3%g%l%c%cnf%nfix_to_sminn + supplement_to_sminn => clm3%g%l%c%cnf%supplement_to_sminn + denit => clm3%g%l%c%cnf%denit + sminn_leached => clm3%g%l%c%cnf%sminn_leached + col_fire_nloss => clm3%g%l%c%cnf%col_fire_nloss + dwt_nloss => clm3%g%l%c%cnf%dwt_nloss + product_nloss => clm3%g%l%c%cnf%product_nloss + + col_ninputs => clm3%g%l%c%cnf%col_ninputs + col_noutputs => clm3%g%l%c%cnf%col_noutputs + col_begnb => clm3%g%l%c%cnbal%begnb + col_endnb => clm3%g%l%c%cnbal%endnb + col_errnb => clm3%g%l%c%cnbal%errnb + + ! set time steps + dt = real( get_step_size(), r8 ) + + err_found = .false. + ! column loop + do fc = 1,num_soilc + c=filter_soilc(fc) + + ! calculate the total column-level nitrogen storage, for mass conservation check + + col_endnb(c) = totcoln(c) + + ! calculate total column-level inputs + + col_ninputs(c) = ndep_to_sminn(c) + nfix_to_sminn(c) + supplement_to_sminn(c) + + ! calculate total column-level outputs + + col_noutputs(c) = denit(c) + sminn_leached(c) + col_fire_nloss(c) + dwt_nloss(c) + product_nloss(c) + + ! calculate the total column-level nitrogen balance error for this time step + + col_errnb(c) = (col_ninputs(c) - col_noutputs(c))*dt - & + (col_endnb(c) - col_begnb(c)) + + if (abs(col_errnb(c)) > 1e-8_r8) then + err_found = .true. + err_index = c + end if + + end do ! end of columns loop + + if ( err_found .and. (.not. is_first_restart_step()) ) then ! TJH + c = err_index + write(iulog,*)'column nbalance error = ', col_errnb(c), c + write(iulog,*)'begnb = ',col_begnb(c) + write(iulog,*)'endnb = ',col_endnb(c) + write(iulog,*)'delta store = ',col_endnb(c)-col_begnb(c) + write(iulog,*)'input mass = ',col_ninputs(c)*dt + write(iulog,*)'output mass = ',col_noutputs(c)*dt + write(iulog,*)'net flux = ',(col_ninputs(c)-col_noutputs(c))*dt + call endrun('column nitrogen balance error') + end if + +end subroutine NBalanceCheck +!----------------------------------------------------------------------- +#endif + +end module CNBalanceCheckMod diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.clm/SnowHydrologyMod.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.clm/SnowHydrologyMod.F90 new file mode 100644 index 0000000000..2762ddb51c --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.clm/SnowHydrologyMod.F90 @@ -0,0 +1,1672 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1_1/models/lnd/clm/src/biogeophys/SnowHydrologyMod.F90 +! +! NOTE: It includes a modified snow grain radius computation documented in bugzilla +! report 1934. + +module SnowHydrologyMod + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: SnowHydrologyMod +! +! !DESCRIPTION: +! Calculate snow hydrology. +! +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use clm_varpar , only : nlevsno +! +! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + public :: SnowWater ! Change of snow mass and the snow water onto soil + public :: SnowCompaction ! Change in snow layer thickness due to compaction + public :: CombineSnowLayers ! Combine snow layers less than a min thickness + public :: DivideSnowLayers ! Subdivide snow layers if they exceed maximum thickness + public :: BuildSnowFilter ! Construct snow/no-snow filters +! +! !PRIVATE MEMBER FUNCTIONS: + private :: Combo ! Returns the combined variables: dz, t, wliq, wice. +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +!EOP +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: SnowWater +! +! !INTERFACE: + subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & + num_nosnowc, filter_nosnowc) +! +! !DESCRIPTION: +! Evaluate the change of snow mass and the snow water onto soil. +! Water flow within snow is computed by an explicit and non-physical +! based scheme, which permits a part of liquid water over the holding +! capacity (a tentative value is used, i.e. equal to 0.033*porosity) to +! percolate into the underlying layer. Except for cases where the +! porosity of one of the two neighboring layers is less than 0.05, zero +! flow is assumed. The water flow out of the bottom of the snow pack will +! participate as the input of the soil water and runoff. This subroutine +! uses a filter for columns containing snow which must be constructed prior +! to being called. +! +! !USES: + use clmtype + use clm_varcon , only : denh2o, denice, wimp, ssi + use clm_time_manager, only : get_step_size + use clm_atmlnd , only : clm_a2l + use SNICARMod , only : scvng_fct_mlt_bcphi, scvng_fct_mlt_bcpho, & + scvng_fct_mlt_ocphi, scvng_fct_mlt_ocpho, & + scvng_fct_mlt_dst1, scvng_fct_mlt_dst2, & + scvng_fct_mlt_dst3, scvng_fct_mlt_dst4 +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_snowc ! number of snow points in column filter + integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer, intent(in) :: num_nosnowc ! number of non-snow points in column filter + integer, intent(in) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points +! +! !CALLED FROM: +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 15 November 2000: Mariana Vertenstein +! 2/26/02, Peter Thornton: Migrated to new data structures. +! 03/28/08, Mark Flanner: Added aerosol deposition and flushing with meltwater +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arguments +! + integer , pointer :: snl(:) !number of snow layers + logical , pointer :: do_capsnow(:) !true => do snow capping + real(r8), pointer :: qflx_snomelt(:) !snow melt (mm H2O /s) + real(r8), pointer :: qflx_rain_grnd(:) !rain on ground after interception (mm H2O/s) [+] + real(r8), pointer :: qflx_sub_snow(:) !sublimation rate from snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_evap_grnd(:) !ground surface evaporation rate (mm H2O/s) [+] + real(r8), pointer :: qflx_dew_snow(:) !surface dew added to snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_dew_grnd(:) !ground surface dew formation (mm H2O /s) [+] + real(r8), pointer :: dz(:,:) !layer depth (m) +! +! local pointers to implicit out arguments +! + real(r8), pointer :: qflx_top_soil(:) !net water input into soil from top (mm/s) +! +! local pointers to implicit inout arguments +! + real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) + integer , pointer :: cgridcell(:) ! columns's gridcell (col) + real(r8), pointer :: mss_bcphi(:,:) ! hydrophillic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_bcpho(:,:) ! hydrophobic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocphi(:,:) ! hydrophillic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocpho(:,:) ! hydrophobic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst1(:,:) ! mass of dust species 1 in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst2(:,:) ! mass of dust species 2 in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst3(:,:) ! mass of dust species 3 in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst4(:,:) ! mass of dust species 4 in snow (col,lyr) [kg] + real(r8), pointer :: flx_bc_dep_dry(:) ! dry BC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_bc_dep_wet(:) ! wet BC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_bc_dep(:) ! total BC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_bc_dep_pho(:) ! hydrophobic BC deposition (col) [kg m-1 s-1] + real(r8), pointer :: flx_bc_dep_phi(:) ! hydrophillic BC deposition (col) [kg m-1 s-1] + real(r8), pointer :: flx_oc_dep_dry(:) ! dry OC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_oc_dep_wet(:) ! wet OC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_oc_dep(:) ! total OC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_oc_dep_pho(:) ! hydrophobic OC deposition (col) [kg m-1 s-1] + real(r8), pointer :: flx_oc_dep_phi(:) ! hydrophillic OC deposition (col) [kg m-1 s-1] + real(r8), pointer :: flx_dst_dep_dry1(:) ! dry dust (species 1) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_wet1(:) ! wet dust (species 1) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_dry2(:) ! dry dust (species 2) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_wet2(:) ! wet dust (species 2) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_dry3(:) ! dry dust (species 3) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_wet3(:) ! wet dust (species 3) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_dry4(:) ! dry dust (species 4) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_wet4(:) ! wet dust (species 4) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep(:) ! total dust deposition (col) [kg m-2 s-1] + real(r8), pointer :: forc_aer(:,:) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] +! +! +! !OTHER LOCAL VARIABLES: +!EOP +! + integer :: c, j, fc !do loop/array indices + real(r8) :: dtime !land model time step (sec) + real(r8) :: qin(lbc:ubc) !water flow into the elmement (mm/s) + real(r8) :: qout(lbc:ubc) !water flow out of the elmement (mm/s) + real(r8) :: wgdif !ice mass after minus sublimation + real(r8) :: vol_liq(lbc:ubc,-nlevsno+1:0) !partial volume of liquid water in layer + real(r8) :: vol_ice(lbc:ubc,-nlevsno+1:0) !partial volume of ice lens in layer + real(r8) :: eff_porosity(lbc:ubc,-nlevsno+1:0) !effective porosity = porosity - vol_ice + integer :: g ! gridcell loop index + real(r8) :: qin_bc_phi(lbc:ubc) ! flux of hydrophilic BC into layer [kg] + real(r8) :: qout_bc_phi(lbc:ubc) ! flux of hydrophilic BC out of layer [kg] + real(r8) :: qin_bc_pho(lbc:ubc) ! flux of hydrophobic BC into layer [kg] + real(r8) :: qout_bc_pho(lbc:ubc) ! flux of hydrophobic BC out of layer [kg] + real(r8) :: qin_oc_phi(lbc:ubc) ! flux of hydrophilic OC into layer [kg] + real(r8) :: qout_oc_phi(lbc:ubc) ! flux of hydrophilic OC out of layer [kg] + real(r8) :: qin_oc_pho(lbc:ubc) ! flux of hydrophobic OC into layer [kg] + real(r8) :: qout_oc_pho(lbc:ubc) ! flux of hydrophobic OC out of layer [kg] + real(r8) :: qin_dst1(lbc:ubc) ! flux of dust species 1 into layer [kg] + real(r8) :: qout_dst1(lbc:ubc) ! flux of dust species 1 out of layer [kg] + real(r8) :: qin_dst2(lbc:ubc) ! flux of dust species 2 into layer [kg] + real(r8) :: qout_dst2(lbc:ubc) ! flux of dust species 2 out of layer [kg] + real(r8) :: qin_dst3(lbc:ubc) ! flux of dust species 3 into layer [kg] + real(r8) :: qout_dst3(lbc:ubc) ! flux of dust species 3 out of layer [kg] + real(r8) :: qin_dst4(lbc:ubc) ! flux of dust species 4 into layer [kg] + real(r8) :: qout_dst4(lbc:ubc) ! flux of dust species 4 out of layer [kg] + real(r8) :: mss_liqice ! mass of liquid+ice in a layer + +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtype components (column-level) + + snl => clm3%g%l%c%cps%snl + do_capsnow => clm3%g%l%c%cps%do_capsnow + qflx_snomelt => clm3%g%l%c%cwf%qflx_snomelt + qflx_rain_grnd => clm3%g%l%c%cwf%pwf_a%qflx_rain_grnd + qflx_sub_snow => clm3%g%l%c%cwf%pwf_a%qflx_sub_snow + qflx_evap_grnd => clm3%g%l%c%cwf%pwf_a%qflx_evap_grnd + qflx_dew_snow => clm3%g%l%c%cwf%pwf_a%qflx_dew_snow + qflx_dew_grnd => clm3%g%l%c%cwf%pwf_a%qflx_dew_grnd + qflx_top_soil => clm3%g%l%c%cwf%qflx_top_soil + dz => clm3%g%l%c%cps%dz + h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice + h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq + cgridcell => clm3%g%l%c%gridcell + mss_bcphi => clm3%g%l%c%cps%mss_bcphi + mss_bcpho => clm3%g%l%c%cps%mss_bcpho + mss_ocphi => clm3%g%l%c%cps%mss_ocphi + mss_ocpho => clm3%g%l%c%cps%mss_ocpho + mss_dst1 => clm3%g%l%c%cps%mss_dst1 + mss_dst2 => clm3%g%l%c%cps%mss_dst2 + mss_dst3 => clm3%g%l%c%cps%mss_dst3 + mss_dst4 => clm3%g%l%c%cps%mss_dst4 + flx_bc_dep => clm3%g%l%c%cwf%flx_bc_dep + flx_bc_dep_wet => clm3%g%l%c%cwf%flx_bc_dep_wet + flx_bc_dep_dry => clm3%g%l%c%cwf%flx_bc_dep_dry + flx_bc_dep_phi => clm3%g%l%c%cwf%flx_bc_dep_phi + flx_bc_dep_pho => clm3%g%l%c%cwf%flx_bc_dep_pho + flx_oc_dep => clm3%g%l%c%cwf%flx_oc_dep + flx_oc_dep_wet => clm3%g%l%c%cwf%flx_oc_dep_wet + flx_oc_dep_dry => clm3%g%l%c%cwf%flx_oc_dep_dry + flx_oc_dep_phi => clm3%g%l%c%cwf%flx_oc_dep_phi + flx_oc_dep_pho => clm3%g%l%c%cwf%flx_oc_dep_pho + flx_dst_dep => clm3%g%l%c%cwf%flx_dst_dep + flx_dst_dep_wet1 => clm3%g%l%c%cwf%flx_dst_dep_wet1 + flx_dst_dep_dry1 => clm3%g%l%c%cwf%flx_dst_dep_dry1 + flx_dst_dep_wet2 => clm3%g%l%c%cwf%flx_dst_dep_wet2 + flx_dst_dep_dry2 => clm3%g%l%c%cwf%flx_dst_dep_dry2 + flx_dst_dep_wet3 => clm3%g%l%c%cwf%flx_dst_dep_wet3 + flx_dst_dep_dry3 => clm3%g%l%c%cwf%flx_dst_dep_dry3 + flx_dst_dep_wet4 => clm3%g%l%c%cwf%flx_dst_dep_wet4 + flx_dst_dep_dry4 => clm3%g%l%c%cwf%flx_dst_dep_dry4 + forc_aer => clm_a2l%forc_aer + + ! Determine model time step + + dtime = get_step_size() + + ! Renew the mass of ice lens (h2osoi_ice) and liquid (h2osoi_liq) in the + ! surface snow layer resulting from sublimation (frost) / evaporation (condense) + + do fc = 1,num_snowc + c = filter_snowc(fc) + if (do_capsnow(c)) then + wgdif = h2osoi_ice(c,snl(c)+1) - qflx_sub_snow(c)*dtime + h2osoi_ice(c,snl(c)+1) = wgdif + if (wgdif < 0._r8) then + h2osoi_ice(c,snl(c)+1) = 0._r8 + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif + end if + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) - qflx_evap_grnd(c) * dtime + else + wgdif = h2osoi_ice(c,snl(c)+1) + (qflx_dew_snow(c) - qflx_sub_snow(c)) * dtime + h2osoi_ice(c,snl(c)+1) = wgdif + if (wgdif < 0._r8) then + h2osoi_ice(c,snl(c)+1) = 0._r8 + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif + end if + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + & + (qflx_rain_grnd(c) + qflx_dew_grnd(c) - qflx_evap_grnd(c)) * dtime + end if + h2osoi_liq(c,snl(c)+1) = max(0._r8, h2osoi_liq(c,snl(c)+1)) + end do + + ! Porosity and partial volume + + do j = -nlevsno+1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + vol_ice(c,j) = min(1._r8, h2osoi_ice(c,j)/(dz(c,j)*denice)) + eff_porosity(c,j) = 1._r8 - vol_ice(c,j) + vol_liq(c,j) = min(eff_porosity(c,j),h2osoi_liq(c,j)/(dz(c,j)*denh2o)) + end if + end do + end do + + ! Capillary forces within snow are usually two or more orders of magnitude + ! less than those of gravity. Only gravity terms are considered. + ! the genernal expression for water flow is "K * ss**3", however, + ! no effective parameterization for "K". Thus, a very simple consideration + ! (not physically based) is introduced: + ! when the liquid water of layer exceeds the layer's holding + ! capacity, the excess meltwater adds to the underlying neighbor layer. + + ! Also compute aerosol fluxes through snowpack in this loop: + ! 1) compute aerosol mass in each layer + ! 2) add aerosol mass flux from above layer to mass of this layer + ! 3) qout_xxx is mass flux of aerosol species xxx out bottom of + ! layer in water flow, proportional to (current) concentration + ! of aerosol in layer multiplied by a scavenging ratio. + ! 4) update mass of aerosol in top layer, accordingly + ! 5) update mass concentration of aerosol accordingly + + qin(:) = 0._r8 + qin_bc_phi(:) = 0._r8 + qin_bc_pho(:) = 0._r8 + qin_oc_phi(:) = 0._r8 + qin_oc_pho(:) = 0._r8 + qin_dst1(:) = 0._r8 + qin_dst2(:) = 0._r8 + qin_dst3(:) = 0._r8 + qin_dst4(:) = 0._r8 + + do j = -nlevsno+1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + h2osoi_liq(c,j) = h2osoi_liq(c,j) + qin(c) + + mss_bcphi(c,j) = mss_bcphi(c,j) + qin_bc_phi(c) + mss_bcpho(c,j) = mss_bcpho(c,j) + qin_bc_pho(c) + mss_ocphi(c,j) = mss_ocphi(c,j) + qin_oc_phi(c) + mss_ocpho(c,j) = mss_ocpho(c,j) + qin_oc_pho(c) + mss_dst1(c,j) = mss_dst1(c,j) + qin_dst1(c) + mss_dst2(c,j) = mss_dst2(c,j) + qin_dst2(c) + mss_dst3(c,j) = mss_dst3(c,j) + qin_dst3(c) + mss_dst4(c,j) = mss_dst4(c,j) + qin_dst4(c) + + if (j <= -1) then + ! No runoff over snow surface, just ponding on surface + if (eff_porosity(c,j) < wimp .OR. eff_porosity(c,j+1) < wimp) then + qout(c) = 0._r8 + else + qout(c) = max(0._r8,(vol_liq(c,j)-ssi*eff_porosity(c,j))*dz(c,j)) + qout(c) = min(qout(c),(1._r8-vol_ice(c,j+1)-vol_liq(c,j+1))*dz(c,j+1)) + end if + else + qout(c) = max(0._r8,(vol_liq(c,j) - ssi*eff_porosity(c,j))*dz(c,j)) + end if + qout(c) = qout(c)*1000._r8 + h2osoi_liq(c,j) = h2osoi_liq(c,j) - qout(c) + qin(c) = qout(c) + + ! mass of ice+water: in extremely rare circumstances, this can + ! be zero, even though there is a snow layer defined. In + ! this case, set the mass to a very small value to + ! prevent division by zero. + mss_liqice = h2osoi_liq(c,j)+h2osoi_ice(c,j) + if (mss_liqice < 1E-30_r8) then + mss_liqice = 1E-30_r8 + endif + + ! BCPHI: + ! 1. flux with meltwater: + qout_bc_phi(c) = qout(c)*scvng_fct_mlt_bcphi*(mss_bcphi(c,j)/mss_liqice) + if (qout_bc_phi(c) > mss_bcphi(c,j)) then + qout_bc_phi(c) = mss_bcphi(c,j) + endif + mss_bcphi(c,j) = mss_bcphi(c,j) - qout_bc_phi(c) + qin_bc_phi(c) = qout_bc_phi(c) + + ! BCPHO: + ! 1. flux with meltwater: + qout_bc_pho(c) = qout(c)*scvng_fct_mlt_bcpho*(mss_bcpho(c,j)/mss_liqice) + if (qout_bc_pho(c) > mss_bcpho(c,j)) then + qout_bc_pho(c) = mss_bcpho(c,j) + endif + mss_bcpho(c,j) = mss_bcpho(c,j) - qout_bc_pho(c) + qin_bc_pho(c) = qout_bc_pho(c) + + ! OCPHI: + ! 1. flux with meltwater: + qout_oc_phi(c) = qout(c)*scvng_fct_mlt_ocphi*(mss_ocphi(c,j)/mss_liqice) + if (qout_oc_phi(c) > mss_ocphi(c,j)) then + qout_oc_phi(c) = mss_ocphi(c,j) + endif + mss_ocphi(c,j) = mss_ocphi(c,j) - qout_oc_phi(c) + qin_oc_phi(c) = qout_oc_phi(c) + + ! OCPHO: + ! 1. flux with meltwater: + qout_oc_pho(c) = qout(c)*scvng_fct_mlt_ocpho*(mss_ocpho(c,j)/mss_liqice) + if (qout_oc_pho(c) > mss_ocpho(c,j)) then + qout_oc_pho(c) = mss_ocpho(c,j) + endif + mss_ocpho(c,j) = mss_ocpho(c,j) - qout_oc_pho(c) + qin_oc_pho(c) = qout_oc_pho(c) + + ! DUST 1: + ! 1. flux with meltwater: + qout_dst1(c) = qout(c)*scvng_fct_mlt_dst1*(mss_dst1(c,j)/mss_liqice) + if (qout_dst1(c) > mss_dst1(c,j)) then + qout_dst1(c) = mss_dst1(c,j) + endif + mss_dst1(c,j) = mss_dst1(c,j) - qout_dst1(c) + qin_dst1(c) = qout_dst1(c) + + ! DUST 2: + ! 1. flux with meltwater: + qout_dst2(c) = qout(c)*scvng_fct_mlt_dst2*(mss_dst2(c,j)/mss_liqice) + if (qout_dst2(c) > mss_dst2(c,j)) then + qout_dst2(c) = mss_dst2(c,j) + endif + mss_dst2(c,j) = mss_dst2(c,j) - qout_dst2(c) + qin_dst2(c) = qout_dst2(c) + + ! DUST 3: + ! 1. flux with meltwater: + qout_dst3(c) = qout(c)*scvng_fct_mlt_dst3*(mss_dst3(c,j)/mss_liqice) + if (qout_dst3(c) > mss_dst3(c,j)) then + qout_dst3(c) = mss_dst3(c,j) + endif + mss_dst3(c,j) = mss_dst3(c,j) - qout_dst3(c) + qin_dst3(c) = qout_dst3(c) + + ! DUST 4: + ! 1. flux with meltwater: + qout_dst4(c) = qout(c)*scvng_fct_mlt_dst4*(mss_dst4(c,j)/mss_liqice) + if (qout_dst4(c) > mss_dst4(c,j)) then + qout_dst4(c) = mss_dst4(c,j) + endif + mss_dst4(c,j) = mss_dst4(c,j) - qout_dst4(c) + qin_dst4(c) = qout_dst4(c) + + end if + end do + end do + + ! Adjust layer thickness for any water+ice content changes in excess of previous + ! layer thickness. Strictly speaking, only necessary for top snow layer, but doing + ! it for all snow layers will catch problems with older initial files. + ! Layer interfaces (zi) and node depths (z) do not need adjustment here because they + ! are adjusted in CombineSnowLayers and are not used up to that point. + + do j = -nlevsno+1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + dz(c,j) = max(dz(c,j),h2osoi_liq(c,j)/denh2o + h2osoi_ice(c,j)/denice) + end if + end do + end do + + do fc = 1, num_snowc + c = filter_snowc(fc) + ! Qout from snow bottom + qflx_top_soil(c) = qout(c) / dtime + end do + + do fc = 1, num_nosnowc + c = filter_nosnowc(fc) + qflx_top_soil(c) = qflx_rain_grnd(c) + qflx_snomelt(c) + end do + + + ! set aerosol deposition fluxes from forcing array + ! The forcing array is either set from an external file + ! or from fluxes received from the atmosphere model + do c = lbc,ubc + g = cgridcell(c) + + flx_bc_dep_dry(c) = forc_aer(g,1) + forc_aer(g,2) + flx_bc_dep_wet(c) = forc_aer(g,3) + flx_bc_dep_phi(c) = forc_aer(g,1) + forc_aer(g,3) + flx_bc_dep_pho(c) = forc_aer(g,2) + flx_bc_dep(c) = forc_aer(g,1) + forc_aer(g,2) + forc_aer(g,3) + + flx_oc_dep_dry(c) = forc_aer(g,4) + forc_aer(g,5) + flx_oc_dep_wet(c) = forc_aer(g,6) + flx_oc_dep_phi(c) = forc_aer(g,4) + forc_aer(g,6) + flx_oc_dep_pho(c) = forc_aer(g,5) + flx_oc_dep(c) = forc_aer(g,4) + forc_aer(g,5) + forc_aer(g,6) + + flx_dst_dep_wet1(c) = forc_aer(g,7) + flx_dst_dep_dry1(c) = forc_aer(g,8) + flx_dst_dep_wet2(c) = forc_aer(g,9) + flx_dst_dep_dry2(c) = forc_aer(g,10) + flx_dst_dep_wet3(c) = forc_aer(g,11) + flx_dst_dep_dry3(c) = forc_aer(g,12) + flx_dst_dep_wet4(c) = forc_aer(g,13) + flx_dst_dep_dry4(c) = forc_aer(g,14) + flx_dst_dep(c) = forc_aer(g,7) + forc_aer(g,8) + forc_aer(g,9) + & + forc_aer(g,10) + forc_aer(g,11) + forc_aer(g,12) + & + forc_aer(g,13) + forc_aer(g,14) + + end do + + ! aerosol deposition fluxes into top layer + ! This is done after the inter-layer fluxes so that some aerosol + ! is in the top layer after deposition, and is not immediately + ! washed out before radiative calculations are done + do fc = 1, num_snowc + c = filter_snowc(fc) + mss_bcphi(c,snl(c)+1) = mss_bcphi(c,snl(c)+1) + (flx_bc_dep_phi(c)*dtime) + mss_bcpho(c,snl(c)+1) = mss_bcpho(c,snl(c)+1) + (flx_bc_dep_pho(c)*dtime) + mss_ocphi(c,snl(c)+1) = mss_ocphi(c,snl(c)+1) + (flx_oc_dep_phi(c)*dtime) + mss_ocpho(c,snl(c)+1) = mss_ocpho(c,snl(c)+1) + (flx_oc_dep_pho(c)*dtime) + + mss_dst1(c,snl(c)+1) = mss_dst1(c,snl(c)+1) + (flx_dst_dep_dry1(c) + flx_dst_dep_wet1(c))*dtime + mss_dst2(c,snl(c)+1) = mss_dst2(c,snl(c)+1) + (flx_dst_dep_dry2(c) + flx_dst_dep_wet2(c))*dtime + mss_dst3(c,snl(c)+1) = mss_dst3(c,snl(c)+1) + (flx_dst_dep_dry3(c) + flx_dst_dep_wet3(c))*dtime + mss_dst4(c,snl(c)+1) = mss_dst4(c,snl(c)+1) + (flx_dst_dep_dry4(c) + flx_dst_dep_wet4(c))*dtime + end do + + end subroutine SnowWater + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: SnowCompaction +! +! !INTERFACE: + subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc) +! +! !DESCRIPTION: +! Determine the change in snow layer thickness due to compaction and +! settling. +! Three metamorphisms of changing snow characteristics are implemented, +! i.e., destructive, overburden, and melt. The treatments of the former +! two are from SNTHERM.89 and SNTHERM.99 (1991, 1999). The contribution +! due to melt metamorphism is simply taken as a ratio of snow ice +! fraction after the melting versus before the melting. +! +! !USES: + use clmtype + use clm_time_manager, only : get_step_size + use clm_varcon , only : denice, denh2o, tfrz, istice_mec +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_snowc ! number of column snow points in column filter + integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in module Hydrology2Mod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/28/02, Peter Thornton: Migrated to new data structures +! 2/29/08, David Lawrence: Revised snow overburden to be include 0.5 weight of current layer +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in scalars +! + integer, pointer :: snl(:) !number of snow layers +! +! local pointers to implicit in arguments +! + integer, pointer :: imelt(:,:) !flag for melting (=1), freezing (=2), Not=0 + real(r8), pointer :: frac_iceold(:,:) !fraction of ice relative to the tot water + real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin) + real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) +! +! local pointers to implicit inout arguments +! + real(r8), pointer :: dz(:,:) !layer depth (m) +! +! +! !OTHER LOCAL VARIABLES: +!EOP +! + integer :: j, l, c, fc ! indices + real(r8):: dtime ! land model time step (sec) + real(r8), parameter :: c2 = 23.e-3_r8 ! [m3/kg] + real(r8), parameter :: c3 = 2.777e-6_r8 ! [1/s] + real(r8), parameter :: c4 = 0.04_r8 ! [1/K] + real(r8), parameter :: c5 = 2.0_r8 ! + real(r8), parameter :: dm = 100.0_r8 ! Upper Limit on Destructive Metamorphism Compaction [kg/m3] + real(r8), parameter :: eta0 = 9.e+5_r8 ! The Viscosity Coefficient Eta0 [kg-s/m2] + real(r8) :: burden(lbc:ubc) ! pressure of overlying snow [kg/m2] + real(r8) :: ddz1 ! Rate of settling of snowpack due to destructive metamorphism. + real(r8) :: ddz2 ! Rate of compaction of snowpack due to overburden. + real(r8) :: ddz3 ! Rate of compaction of snowpack due to melt [1/s] + real(r8) :: dexpf ! expf=exp(-c4*(273.15-t_soisno)). + real(r8) :: fi ! Fraction of ice relative to the total water content at current time step + real(r8) :: td ! t_soisno - tfrz [K] + real(r8) :: pdzdtc ! Nodal rate of change in fractional-thickness due to compaction [fraction/s] + real(r8) :: void ! void (1 - vol_ice - vol_liq) + real(r8) :: wx ! water mass (ice+liquid) [kg/m2] + real(r8) :: bi ! partial density of ice [kg/m3] + + integer, pointer :: clandunit(:) !landunit index for each column + integer, pointer :: ltype(:) !landunit type + +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtypes (column-level) + + snl => clm3%g%l%c%cps%snl + dz => clm3%g%l%c%cps%dz + imelt => clm3%g%l%c%cps%imelt + frac_iceold => clm3%g%l%c%cps%frac_iceold + t_soisno => clm3%g%l%c%ces%t_soisno + h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice + h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq + clandunit => clm3%g%l%c%landunit + ltype => clm3%g%l%itype + + ! Get time step + + dtime = get_step_size() + + ! Begin calculation - note that the following column loops are only invoked if snl(c) < 0 + + burden(:) = 0._r8 + + do j = -nlevsno+1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + + wx = h2osoi_ice(c,j) + h2osoi_liq(c,j) + void = 1._r8 - (h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o) / dz(c,j) + + ! If void is negative, then increase dz such that void = 0. + ! This should be done for any landunit, but for now is done only for glacier_mec 1andunits. + l = clandunit(c) + if (ltype(l)==istice_mec .and. void < 0._r8) then + dz(c,j) = h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o + void = 0._r8 + endif + + ! Allow compaction only for non-saturated node and higher ice lens node. + if (void > 0.001_r8 .and. h2osoi_ice(c,j) > .1_r8) then + bi = h2osoi_ice(c,j) / dz(c,j) + fi = h2osoi_ice(c,j) / wx + td = tfrz-t_soisno(c,j) + dexpf = exp(-c4*td) + + ! Settling as a result of destructive metamorphism + + ddz1 = -c3*dexpf + if (bi > dm) ddz1 = ddz1*exp(-46.0e-3_r8*(bi-dm)) + + ! Liquid water term + + if (h2osoi_liq(c,j) > 0.01_r8*dz(c,j)) ddz1=ddz1*c5 + + ! Compaction due to overburden + + ddz2 = -(burden(c)+wx/2._r8)*exp(-0.08_r8*td - c2*bi)/eta0 + + ! Compaction occurring during melt + + if (imelt(c,j) == 1) then + ddz3 = - 1._r8/dtime * max(0._r8,(frac_iceold(c,j) - fi)/frac_iceold(c,j)) + else + ddz3 = 0._r8 + end if + + ! Time rate of fractional change in dz (units of s-1) + + pdzdtc = ddz1 + ddz2 + ddz3 + + ! The change in dz due to compaction + ! Limit compaction to no less than fully saturated layer thickness + + dz(c,j) = max(dz(c,j) * (1._r8+pdzdtc*dtime),h2osoi_ice(c,j)/denice & + + h2osoi_liq(c,j)/denh2o) + + end if + + ! Pressure of overlying snow + + burden(c) = burden(c) + wx + + end if + end do + end do + + end subroutine SnowCompaction + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: CombineSnowLayers +! +! !INTERFACE: + subroutine CombineSnowLayers(lbc, ubc, num_snowc, filter_snowc) +! +! !DESCRIPTION: +! Combine snow layers that are less than a minimum thickness or mass +! If the snow element thickness or mass is less than a prescribed minimum, +! then it is combined with a neighboring element. The subroutine +! clm\_combo.f90 then executes the combination of mass and energy. +! +! !USES: + use clmtype + use clm_varcon, only : istsoil, isturb + use clm_varcon, only : istcrop + use clm_time_manager, only : get_step_size +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(inout) :: num_snowc ! number of column snow points in column filter + integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in module Hydrology2Mod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/28/02, Peter Thornton: Migrated to new data structures. +! 03/28/08, Mark Flanner: Added aerosol masses and snow grain radius +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arguments +! + integer, pointer :: clandunit(:) !landunit index for each column + integer, pointer :: ltype(:) !landunit type +! +! local pointers to implicit inout arguments +! + integer , pointer :: snl(:) !number of snow layers + real(r8), pointer :: h2osno(:) !snow water (mm H2O) + real(r8), pointer :: snowdp(:) !snow height (m) + real(r8), pointer :: dz(:,:) !layer depth (m) + real(r8), pointer :: zi(:,:) !interface level below a "z" level (m) + real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin) + real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) +! +! local pointers to implicit out arguments +! + real(r8), pointer :: z(:,:) ! layer thickness (m) + real(r8), pointer :: mss_bcphi(:,:) ! hydrophilic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_bcpho(:,:) ! hydrophobic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocphi(:,:) ! hydrophilic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocpho(:,:) ! hydrophobic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst1(:,:) ! dust species 1 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst2(:,:) ! dust species 2 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst3(:,:) ! dust species 3 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst4(:,:) ! dust species 4 mass in snow (col,lyr) [kg] + real(r8), pointer :: snw_rds(:,:) ! effective snow grain radius (col,lyr) [microns, m^-6] + real(r8), pointer :: qflx_sl_top_soil(:) ! liquid water + ice from layer above soil to top soil layer or sent to qflx_qrgwl (mm H2O/s) +! +! +! !OTHER LOCAL VARIABLES: +!EOP +! + integer :: c, fc ! column indices + integer :: i,k ! loop indices + integer :: j,l ! node indices + integer :: msn_old(lbc:ubc) ! number of top snow layer + integer :: mssi(lbc:ubc) ! node index + integer :: neibor ! adjacent node selected for combination + real(r8):: zwice(lbc:ubc) ! total ice mass in snow + real(r8):: zwliq (lbc:ubc) ! total liquid water in snow + real(r8):: dzmin(5) ! minimum of top snow layer + real(r8) :: dtime !land model time step (sec) + + data dzmin /0.010_r8, 0.015_r8, 0.025_r8, 0.055_r8, 0.115_r8/ +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtypes (landunit-level) + + ltype => clm3%g%l%itype + + ! Assign local pointers to derived subtypes (column-level) + + clandunit => clm3%g%l%c%landunit + snl => clm3%g%l%c%cps%snl + snowdp => clm3%g%l%c%cps%snowdp + h2osno => clm3%g%l%c%cws%h2osno + dz => clm3%g%l%c%cps%dz + zi => clm3%g%l%c%cps%zi + z => clm3%g%l%c%cps%z + t_soisno => clm3%g%l%c%ces%t_soisno + h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice + h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq + mss_bcphi => clm3%g%l%c%cps%mss_bcphi + mss_bcpho => clm3%g%l%c%cps%mss_bcpho + mss_ocphi => clm3%g%l%c%cps%mss_ocphi + mss_ocpho => clm3%g%l%c%cps%mss_ocpho + mss_dst1 => clm3%g%l%c%cps%mss_dst1 + mss_dst2 => clm3%g%l%c%cps%mss_dst2 + mss_dst3 => clm3%g%l%c%cps%mss_dst3 + mss_dst4 => clm3%g%l%c%cps%mss_dst4 + snw_rds => clm3%g%l%c%cps%snw_rds + qflx_sl_top_soil => clm3%g%l%c%cwf%qflx_sl_top_soil + + ! Determine model time step + + dtime = get_step_size() + + + ! Check the mass of ice lens of snow, when the total is less than a small value, + ! combine it with the underlying neighbor. + + do fc = 1, num_snowc + c = filter_snowc(fc) + msn_old(c) = snl(c) + qflx_sl_top_soil(c) = 0._r8 + end do + + ! The following loop is NOT VECTORIZED + + do fc = 1, num_snowc + c = filter_snowc(fc) + l = clandunit(c) + do j = msn_old(c)+1,0 + if (h2osoi_ice(c,j) <= .1_r8) then + if (ltype(l) == istsoil .or. ltype(l)==isturb .or. ltype(l) == istcrop) then + h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j) + h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j) + + if (j == 0) then + qflx_sl_top_soil(c) = (h2osoi_liq(c,j) + h2osoi_ice(c,j))/dtime + end if + + if (j /= 0) dz(c,j+1) = dz(c,j+1) + dz(c,j) + + ! NOTE: Temperature, and similarly snw_rds, of the + ! underlying snow layer are NOT adjusted in this case. + ! Because the layer being eliminated has a small mass, + ! this should not make a large difference, but it + ! would be more thorough to do so. + if (j /= 0) then + mss_bcphi(c,j+1) = mss_bcphi(c,j+1) + mss_bcphi(c,j) + mss_bcpho(c,j+1) = mss_bcpho(c,j+1) + mss_bcpho(c,j) + mss_ocphi(c,j+1) = mss_ocphi(c,j+1) + mss_ocphi(c,j) + mss_ocpho(c,j+1) = mss_ocpho(c,j+1) + mss_ocpho(c,j) + mss_dst1(c,j+1) = mss_dst1(c,j+1) + mss_dst1(c,j) + mss_dst2(c,j+1) = mss_dst2(c,j+1) + mss_dst2(c,j) + mss_dst3(c,j+1) = mss_dst3(c,j+1) + mss_dst3(c,j) + mss_dst4(c,j+1) = mss_dst4(c,j+1) + mss_dst4(c,j) + end if + + else if (ltype(l) /= istsoil .and. ltype(l) /= isturb .and. ltype(l) /= istcrop .and. j /= 0) then + h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j) + h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j) + dz(c,j+1) = dz(c,j+1) + dz(c,j) + + mss_bcphi(c,j+1) = mss_bcphi(c,j+1) + mss_bcphi(c,j) + mss_bcpho(c,j+1) = mss_bcpho(c,j+1) + mss_bcpho(c,j) + mss_ocphi(c,j+1) = mss_ocphi(c,j+1) + mss_ocphi(c,j) + mss_ocpho(c,j+1) = mss_ocpho(c,j+1) + mss_ocpho(c,j) + mss_dst1(c,j+1) = mss_dst1(c,j+1) + mss_dst1(c,j) + mss_dst2(c,j+1) = mss_dst2(c,j+1) + mss_dst2(c,j) + mss_dst3(c,j+1) = mss_dst3(c,j+1) + mss_dst3(c,j) + mss_dst4(c,j+1) = mss_dst4(c,j+1) + mss_dst4(c,j) + + end if + + ! shift all elements above this down one. + if (j > snl(c)+1 .and. snl(c) < -1) then + do i = j, snl(c)+2, -1 + ! If the layer closest to the surface is less than 0.1 mm and the ltype is not + ! urban, soil or crop, the h2osoi_liq and h2osoi_ice associated with this layer is sent + ! to qflx_qrgwl later on in the code. To keep track of this for the snow balance + ! error check, we add this to qflx_sl_top_soil here + if (ltype(l) /= istsoil .and. ltype(l) /= istcrop .and. ltype(l) /= isturb .and. i == 0) then + qflx_sl_top_soil(c) = (h2osoi_liq(c,i) + h2osoi_ice(c,i))/dtime + end if + + t_soisno(c,i) = t_soisno(c,i-1) + h2osoi_liq(c,i) = h2osoi_liq(c,i-1) + h2osoi_ice(c,i) = h2osoi_ice(c,i-1) + + mss_bcphi(c,i) = mss_bcphi(c,i-1) + mss_bcpho(c,i) = mss_bcpho(c,i-1) + mss_ocphi(c,i) = mss_ocphi(c,i-1) + mss_ocpho(c,i) = mss_ocpho(c,i-1) + mss_dst1(c,i) = mss_dst1(c,i-1) + mss_dst2(c,i) = mss_dst2(c,i-1) + mss_dst3(c,i) = mss_dst3(c,i-1) + mss_dst4(c,i) = mss_dst4(c,i-1) + snw_rds(c,i) = snw_rds(c,i-1) + + dz(c,i) = dz(c,i-1) + end do + end if + snl(c) = snl(c) + 1 + end if + end do + end do + + do fc = 1, num_snowc + c = filter_snowc(fc) + h2osno(c) = 0._r8 + snowdp(c) = 0._r8 + zwice(c) = 0._r8 + zwliq(c) = 0._r8 + end do + + do j = -nlevsno+1,0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + h2osno(c) = h2osno(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + snowdp(c) = snowdp(c) + dz(c,j) + zwice(c) = zwice(c) + h2osoi_ice(c,j) + zwliq(c) = zwliq(c) + h2osoi_liq(c,j) + end if + end do + end do + + ! Check the snow depth - all snow gone + ! The liquid water assumes ponding on soil surface. + + do fc = 1, num_snowc + c = filter_snowc(fc) + l = clandunit(c) + if (snowdp(c) < 0.01_r8 .and. snowdp(c) > 0._r8) then + snl(c) = 0 + h2osno(c) = zwice(c) + + mss_bcphi(c,:) = 0._r8 + mss_bcpho(c,:) = 0._r8 + mss_ocphi(c,:) = 0._r8 + mss_ocpho(c,:) = 0._r8 + mss_dst1(c,:) = 0._r8 + mss_dst2(c,:) = 0._r8 + mss_dst3(c,:) = 0._r8 + mss_dst4(c,:) = 0._r8 + + if (h2osno(c) <= 0._r8) snowdp(c) = 0._r8 + if (ltype(l) == istsoil .or. ltype(l) == isturb .or. ltype(l) == istcrop) then + h2osoi_liq(c,1) = h2osoi_liq(c,1) + zwliq(c) + end if + end if + end do + + ! Check the snow depth - snow layers combined + ! The following loop IS NOT VECTORIZED + + do fc = 1, num_snowc + c = filter_snowc(fc) + + ! Two or more layers + + if (snl(c) < -1) then + + msn_old(c) = snl(c) + mssi(c) = 1 + + do i = msn_old(c)+1,0 + if (dz(c,i) < dzmin(mssi(c))) then + + if (i == snl(c)+1) then + ! If top node is removed, combine with bottom neighbor. + neibor = i + 1 + else if (i == 0) then + ! If the bottom neighbor is not snow, combine with the top neighbor. + neibor = i - 1 + else + ! If none of the above special cases apply, combine with the thinnest neighbor + neibor = i + 1 + if ((dz(c,i-1)+dz(c,i)) < (dz(c,i+1)+dz(c,i))) neibor = i-1 + end if + + ! Node l and j are combined and stored as node j. + if (neibor > i) then + j = neibor + l = i + else + j = i + l = neibor + end if + + ! this should be included in 'Combo' for consistency, + ! but functionally it is the same to do it here + mss_bcphi(c,j)=mss_bcphi(c,j)+mss_bcphi(c,l) + mss_bcpho(c,j)=mss_bcpho(c,j)+mss_bcpho(c,l) + mss_ocphi(c,j)=mss_ocphi(c,j)+mss_ocphi(c,l) + mss_ocpho(c,j)=mss_ocpho(c,j)+mss_ocpho(c,l) + mss_dst1(c,j)=mss_dst1(c,j)+mss_dst1(c,l) + mss_dst2(c,j)=mss_dst2(c,j)+mss_dst2(c,l) + mss_dst3(c,j)=mss_dst3(c,j)+mss_dst3(c,l) + mss_dst4(c,j)=mss_dst4(c,j)+mss_dst4(c,l) + ! mass-weighted combination of effective grain size: + snw_rds(c,j) = (snw_rds(c,j)*(h2osoi_liq(c,j)+h2osoi_ice(c,j)) + & + snw_rds(c,l)*(h2osoi_liq(c,l)+h2osoi_ice(c,l))) / & + (h2osoi_liq(c,j)+h2osoi_ice(c,j)+h2osoi_liq(c,l)+h2osoi_ice(c,l)) + + call Combo (dz(c,j), h2osoi_liq(c,j), h2osoi_ice(c,j), & + t_soisno(c,j), dz(c,l), h2osoi_liq(c,l), h2osoi_ice(c,l), t_soisno(c,l) ) + + ! Now shift all elements above this down one. + if (j-1 > snl(c)+1) then + do k = j-1, snl(c)+2, -1 + t_soisno(c,k) = t_soisno(c,k-1) + h2osoi_ice(c,k) = h2osoi_ice(c,k-1) + h2osoi_liq(c,k) = h2osoi_liq(c,k-1) + + mss_bcphi(c,k) = mss_bcphi(c,k-1) + mss_bcpho(c,k) = mss_bcpho(c,k-1) + mss_ocphi(c,k) = mss_ocphi(c,k-1) + mss_ocpho(c,k) = mss_ocpho(c,k-1) + mss_dst1(c,k) = mss_dst1(c,k-1) + mss_dst2(c,k) = mss_dst2(c,k-1) + mss_dst3(c,k) = mss_dst3(c,k-1) + mss_dst4(c,k) = mss_dst4(c,k-1) + snw_rds(c,k) = snw_rds(c,k-1) + + dz(c,k) = dz(c,k-1) + end do + end if + + ! Decrease the number of snow layers + snl(c) = snl(c) + 1 + if (snl(c) >= -1) EXIT + + else + + ! The layer thickness is greater than the prescribed minimum value + mssi(c) = mssi(c) + 1 + + end if + end do + + end if + + end do + + ! Reset the node depth and the depth of layer interface + + do j = 0, -nlevsno+1, -1 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c) + 1) then + z(c,j) = zi(c,j) - 0.5_r8*dz(c,j) + zi(c,j-1) = zi(c,j) - dz(c,j) + end if + end do + end do + + end subroutine CombineSnowLayers + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: DivideSnowLayers +! +! !INTERFACE: + subroutine DivideSnowLayers(lbc, ubc, num_snowc, filter_snowc) +! +! !DESCRIPTION: +! Subdivides snow layers if they exceed their prescribed maximum thickness. +! +! !USES: + use clmtype + use clm_varcon, only : tfrz +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(inout) :: num_snowc ! number of column snow points in column filter + integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in module Hydrology2Mod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/28/02, Peter Thornton: Migrated to new data structures. +! 2/29/08, David Lawrence: Snowpack T profile maintained during layer splitting +! 03/28/08, Mark Flanner: Added aerosol masses and snow grain radius +! +! !LOCAL VARIABLES: +! +! local pointers to implicit inout arguments +! + integer , pointer :: snl(:) !number of snow layers + real(r8), pointer :: dz(:,:) !layer depth (m) + real(r8), pointer :: zi(:,:) !interface level below a "z" level (m) + real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin) + real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) +! +! local pointers to implicit out arguments +! + real(r8), pointer :: z(:,:) ! layer thickness (m) + real(r8), pointer :: mss_bcphi(:,:) ! hydrophilic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_bcpho(:,:) ! hydrophobic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocphi(:,:) ! hydrophilic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocpho(:,:) ! hydrophobic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst1(:,:) ! dust species 1 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst2(:,:) ! dust species 2 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst3(:,:) ! dust species 3 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst4(:,:) ! dust species 4 mass in snow (col,lyr) [kg] + real(r8), pointer :: snw_rds(:,:) ! effective snow grain radius (col,lyr) [microns, m^-6] +! +! +! !OTHER LOCAL VARIABLES: +!EOP +! + integer :: j, c, fc ! indices + real(r8) :: drr ! thickness of the combined [m] + integer :: msno ! number of snow layer 1 (top) to msno (bottom) + real(r8) :: dzsno(lbc:ubc,nlevsno) ! Snow layer thickness [m] + real(r8) :: swice(lbc:ubc,nlevsno) ! Partial volume of ice [m3/m3] + real(r8) :: swliq(lbc:ubc,nlevsno) ! Partial volume of liquid water [m3/m3] + real(r8) :: tsno(lbc:ubc ,nlevsno) ! Nodel temperature [K] + real(r8) :: zwice ! temporary + real(r8) :: zwliq ! temporary + real(r8) :: propor ! temporary + real(r8) :: dtdz ! temporary + + ! temporary variables mimicking the structure of other layer division variables + real(r8) :: mbc_phi(lbc:ubc,nlevsno) ! mass of BC in each snow layer + real(r8) :: zmbc_phi ! temporary + real(r8) :: mbc_pho(lbc:ubc,nlevsno) ! mass of BC in each snow layer + real(r8) :: zmbc_pho ! temporary + real(r8) :: moc_phi(lbc:ubc,nlevsno) ! mass of OC in each snow layer + real(r8) :: zmoc_phi ! temporary + real(r8) :: moc_pho(lbc:ubc,nlevsno) ! mass of OC in each snow layer + real(r8) :: zmoc_pho ! temporary + real(r8) :: mdst1(lbc:ubc,nlevsno) ! mass of dust 1 in each snow layer + real(r8) :: zmdst1 ! temporary + real(r8) :: mdst2(lbc:ubc,nlevsno) ! mass of dust 2 in each snow layer + real(r8) :: zmdst2 ! temporary + real(r8) :: mdst3(lbc:ubc,nlevsno) ! mass of dust 3 in each snow layer + real(r8) :: zmdst3 ! temporary + real(r8) :: mdst4(lbc:ubc,nlevsno) ! mass of dust 4 in each snow layer + real(r8) :: zmdst4 ! temporary + real(r8) :: rds(lbc:ubc,nlevsno) + +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtype components (column-level) + + snl => clm3%g%l%c%cps%snl + dz => clm3%g%l%c%cps%dz + zi => clm3%g%l%c%cps%zi + z => clm3%g%l%c%cps%z + t_soisno => clm3%g%l%c%ces%t_soisno + h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice + h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq + mss_bcphi => clm3%g%l%c%cps%mss_bcphi + mss_bcpho => clm3%g%l%c%cps%mss_bcpho + mss_ocphi => clm3%g%l%c%cps%mss_ocphi + mss_ocpho => clm3%g%l%c%cps%mss_ocpho + mss_dst1 => clm3%g%l%c%cps%mss_dst1 + mss_dst2 => clm3%g%l%c%cps%mss_dst2 + mss_dst3 => clm3%g%l%c%cps%mss_dst3 + mss_dst4 => clm3%g%l%c%cps%mss_dst4 + snw_rds => clm3%g%l%c%cps%snw_rds + + + ! Begin calculation - note that the following column loops are only invoked + ! for snow-covered columns + + do j = 1,nlevsno + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j <= abs(snl(c))) then + dzsno(c,j) = dz(c,j+snl(c)) + swice(c,j) = h2osoi_ice(c,j+snl(c)) + swliq(c,j) = h2osoi_liq(c,j+snl(c)) + tsno(c,j) = t_soisno(c,j+snl(c)) + + mbc_phi(c,j) = mss_bcphi(c,j+snl(c)) + mbc_pho(c,j) = mss_bcpho(c,j+snl(c)) + moc_phi(c,j) = mss_ocphi(c,j+snl(c)) + moc_pho(c,j) = mss_ocpho(c,j+snl(c)) + mdst1(c,j) = mss_dst1(c,j+snl(c)) + mdst2(c,j) = mss_dst2(c,j+snl(c)) + mdst3(c,j) = mss_dst3(c,j+snl(c)) + mdst4(c,j) = mss_dst4(c,j+snl(c)) + rds(c,j) = snw_rds(c,j+snl(c)) + + end if + end do + end do + + do fc = 1, num_snowc + c = filter_snowc(fc) + + msno = abs(snl(c)) + + if (msno == 1) then + ! Specify a new snow layer + if (dzsno(c,1) > 0.03_r8) then + msno = 2 + dzsno(c,1) = dzsno(c,1)/2._r8 + swice(c,1) = swice(c,1)/2._r8 + swliq(c,1) = swliq(c,1)/2._r8 + dzsno(c,2) = dzsno(c,1) + swice(c,2) = swice(c,1) + swliq(c,2) = swliq(c,1) + tsno(c,2) = tsno(c,1) + + mbc_phi(c,1) = mbc_phi(c,1)/2._r8 + mbc_phi(c,2) = mbc_phi(c,1) + mbc_pho(c,1) = mbc_pho(c,1)/2._r8 + mbc_pho(c,2) = mbc_pho(c,1) + moc_phi(c,1) = moc_phi(c,1)/2._r8 + moc_phi(c,2) = moc_phi(c,1) + moc_pho(c,1) = moc_pho(c,1)/2._r8 + moc_pho(c,2) = moc_pho(c,1) + mdst1(c,1) = mdst1(c,1)/2._r8 + mdst1(c,2) = mdst1(c,1) + mdst2(c,1) = mdst2(c,1)/2._r8 + mdst2(c,2) = mdst2(c,1) + mdst3(c,1) = mdst3(c,1)/2._r8 + mdst3(c,2) = mdst3(c,1) + mdst4(c,1) = mdst4(c,1)/2._r8 + mdst4(c,2) = mdst4(c,1) + rds(c,2) = rds(c,1) + + end if + end if + + if (msno > 1) then + if (dzsno(c,1) > 0.02_r8) then + drr = dzsno(c,1) - 0.02_r8 + propor = drr/dzsno(c,1) + zwice = propor*swice(c,1) + zwliq = propor*swliq(c,1) + + zmbc_phi = propor*mbc_phi(c,1) + zmbc_pho = propor*mbc_pho(c,1) + zmoc_phi = propor*moc_phi(c,1) + zmoc_pho = propor*moc_pho(c,1) + zmdst1 = propor*mdst1(c,1) + zmdst2 = propor*mdst2(c,1) + zmdst3 = propor*mdst3(c,1) + zmdst4 = propor*mdst4(c,1) + + propor = 0.02_r8/dzsno(c,1) + swice(c,1) = propor*swice(c,1) + swliq(c,1) = propor*swliq(c,1) + + mbc_phi(c,1) = propor*mbc_phi(c,1) + mbc_pho(c,1) = propor*mbc_pho(c,1) + moc_phi(c,1) = propor*moc_phi(c,1) + moc_pho(c,1) = propor*moc_pho(c,1) + mdst1(c,1) = propor*mdst1(c,1) + mdst2(c,1) = propor*mdst2(c,1) + mdst3(c,1) = propor*mdst3(c,1) + mdst4(c,1) = propor*mdst4(c,1) + + dzsno(c,1) = 0.02_r8 + + mbc_phi(c,2) = mbc_phi(c,2)+zmbc_phi ! (combo) + mbc_pho(c,2) = mbc_pho(c,2)+zmbc_pho ! (combo) + moc_phi(c,2) = moc_phi(c,2)+zmoc_phi ! (combo) + moc_pho(c,2) = moc_pho(c,2)+zmoc_pho ! (combo) + mdst1(c,2) = mdst1(c,2)+zmdst1 ! (combo) + mdst2(c,2) = mdst2(c,2)+zmdst2 ! (combo) + mdst3(c,2) = mdst3(c,2)+zmdst3 ! (combo) + mdst4(c,2) = mdst4(c,2)+zmdst4 ! (combo) + !mgf++ 20140225: Mass-weighted combination of radius ... bugzilla 1934 + !rds(c,2) = rds(c,1) ! (combo) + rds(c,2) = (rds(c,2)*(swliq(c,2)+swice(c,2)) + & + rds(c,1)*(zwliq+zwice))/(swliq(c,2)+swice(c,2)+zwliq+zwice) + !mgf-- bugzilla 1934 + + call Combo (dzsno(c,2), swliq(c,2), swice(c,2), tsno(c,2), drr, & + zwliq, zwice, tsno(c,1)) + + ! Subdivide a new layer + if (msno <= 2 .and. dzsno(c,2) > 0.07_r8) then + msno = 3 + dtdz = (tsno(c,1) - tsno(c,2))/((dzsno(c,1)+dzsno(c,2))/2._r8) + dzsno(c,2) = dzsno(c,2)/2._r8 + swice(c,2) = swice(c,2)/2._r8 + swliq(c,2) = swliq(c,2)/2._r8 + dzsno(c,3) = dzsno(c,2) + swice(c,3) = swice(c,2) + swliq(c,3) = swliq(c,2) + tsno(c,3) = tsno(c,2) - dtdz*dzsno(c,2)/2._r8 + if (tsno(c,3) >= tfrz) then + tsno(c,3) = tsno(c,2) + else + tsno(c,2) = tsno(c,2) + dtdz*dzsno(c,2)/2._r8 + endif + + mbc_phi(c,2) = mbc_phi(c,2)/2._r8 + mbc_phi(c,3) = mbc_phi(c,2) + mbc_pho(c,2) = mbc_pho(c,2)/2._r8 + mbc_pho(c,3) = mbc_pho(c,2) + moc_phi(c,2) = moc_phi(c,2)/2._r8 + moc_phi(c,3) = moc_phi(c,2) + moc_pho(c,2) = moc_pho(c,2)/2._r8 + moc_pho(c,3) = moc_pho(c,2) + mdst1(c,2) = mdst1(c,2)/2._r8 + mdst1(c,3) = mdst1(c,2) + mdst2(c,2) = mdst2(c,2)/2._r8 + mdst2(c,3) = mdst2(c,2) + mdst3(c,2) = mdst3(c,2)/2._r8 + mdst3(c,3) = mdst3(c,2) + mdst4(c,2) = mdst4(c,2)/2._r8 + mdst4(c,3) = mdst4(c,2) + rds(c,3) = rds(c,2) + + end if + end if + end if + + if (msno > 2) then + if (dzsno(c,2) > 0.05_r8) then + drr = dzsno(c,2) - 0.05_r8 + propor = drr/dzsno(c,2) + zwice = propor*swice(c,2) + zwliq = propor*swliq(c,2) + + zmbc_phi = propor*mbc_phi(c,2) + zmbc_pho = propor*mbc_pho(c,2) + zmoc_phi = propor*moc_phi(c,2) + zmoc_pho = propor*moc_pho(c,2) + zmdst1 = propor*mdst1(c,2) + zmdst2 = propor*mdst2(c,2) + zmdst3 = propor*mdst3(c,2) + zmdst4 = propor*mdst4(c,2) + + propor = 0.05_r8/dzsno(c,2) + swice(c,2) = propor*swice(c,2) + swliq(c,2) = propor*swliq(c,2) + + mbc_phi(c,2) = propor*mbc_phi(c,2) + mbc_pho(c,2) = propor*mbc_pho(c,2) + moc_phi(c,2) = propor*moc_phi(c,2) + moc_pho(c,2) = propor*moc_pho(c,2) + mdst1(c,2) = propor*mdst1(c,2) + mdst2(c,2) = propor*mdst2(c,2) + mdst3(c,2) = propor*mdst3(c,2) + mdst4(c,2) = propor*mdst4(c,2) + + dzsno(c,2) = 0.05_r8 + + mbc_phi(c,3) = mbc_phi(c,3)+zmbc_phi ! (combo) + mbc_pho(c,3) = mbc_pho(c,3)+zmbc_pho ! (combo) + moc_phi(c,3) = moc_phi(c,3)+zmoc_phi ! (combo) + moc_pho(c,3) = moc_pho(c,3)+zmoc_pho ! (combo) + mdst1(c,3) = mdst1(c,3)+zmdst1 ! (combo) + mdst2(c,3) = mdst2(c,3)+zmdst2 ! (combo) + mdst3(c,3) = mdst3(c,3)+zmdst3 ! (combo) + mdst4(c,3) = mdst4(c,3)+zmdst4 ! (combo) + !mgf++ 20140225: Mass-weighted combination of radius ... bugzilla 1934 + !rds(c,3) = rds(c,2) ! (combo) + rds(c,3) = (rds(c,3)*(swliq(c,3)+swice(c,3)) + & + rds(c,2)*(zwliq+zwice))/(swliq(c,3)+swice(c,3)+zwliq+zwice) + !mgf-- bugzilla 1934 + + + call Combo (dzsno(c,3), swliq(c,3), swice(c,3), tsno(c,3), drr, & + zwliq, zwice, tsno(c,2)) + + ! Subdivided a new layer + if (msno <= 3 .and. dzsno(c,3) > 0.18_r8) then + msno = 4 + dtdz = (tsno(c,2) - tsno(c,3))/((dzsno(c,2)+dzsno(c,3))/2._r8) + dzsno(c,3) = dzsno(c,3)/2._r8 + swice(c,3) = swice(c,3)/2._r8 + swliq(c,3) = swliq(c,3)/2._r8 + dzsno(c,4) = dzsno(c,3) + swice(c,4) = swice(c,3) + swliq(c,4) = swliq(c,3) + tsno(c,4) = tsno(c,3) - dtdz*dzsno(c,3)/2._r8 + if (tsno(c,4) >= tfrz) then + tsno(c,4) = tsno(c,3) + else + tsno(c,3) = tsno(c,3) + dtdz*dzsno(c,3)/2._r8 + endif + + mbc_phi(c,3) = mbc_phi(c,3)/2._r8 + mbc_phi(c,4) = mbc_phi(c,3) + mbc_pho(c,3) = mbc_pho(c,3)/2._r8 + mbc_pho(c,4) = mbc_pho(c,3) + moc_phi(c,3) = moc_phi(c,3)/2._r8 + moc_phi(c,4) = moc_phi(c,3) + moc_pho(c,3) = moc_pho(c,3)/2._r8 + moc_pho(c,4) = moc_pho(c,3) + mdst1(c,3) = mdst1(c,3)/2._r8 + mdst1(c,4) = mdst1(c,3) + mdst2(c,3) = mdst2(c,3)/2._r8 + mdst2(c,4) = mdst2(c,3) + mdst3(c,3) = mdst3(c,3)/2._r8 + mdst3(c,4) = mdst3(c,3) + mdst4(c,3) = mdst4(c,3)/2._r8 + mdst4(c,4) = mdst4(c,3) + rds(c,4) = rds(c,3) + + end if + end if + end if + + if (msno > 3) then + if (dzsno(c,3) > 0.11_r8) then + drr = dzsno(c,3) - 0.11_r8 + propor = drr/dzsno(c,3) + zwice = propor*swice(c,3) + zwliq = propor*swliq(c,3) + + zmbc_phi = propor*mbc_phi(c,3) + zmbc_pho = propor*mbc_pho(c,3) + zmoc_phi = propor*moc_phi(c,3) + zmoc_pho = propor*moc_pho(c,3) + zmdst1 = propor*mdst1(c,3) + zmdst2 = propor*mdst2(c,3) + zmdst3 = propor*mdst3(c,3) + zmdst4 = propor*mdst4(c,3) + + propor = 0.11_r8/dzsno(c,3) + swice(c,3) = propor*swice(c,3) + swliq(c,3) = propor*swliq(c,3) + + mbc_phi(c,3) = propor*mbc_phi(c,3) + mbc_pho(c,3) = propor*mbc_pho(c,3) + moc_phi(c,3) = propor*moc_phi(c,3) + moc_pho(c,3) = propor*moc_pho(c,3) + mdst1(c,3) = propor*mdst1(c,3) + mdst2(c,3) = propor*mdst2(c,3) + mdst3(c,3) = propor*mdst3(c,3) + mdst4(c,3) = propor*mdst4(c,3) + + dzsno(c,3) = 0.11_r8 + + mbc_phi(c,4) = mbc_phi(c,4)+zmbc_phi ! (combo) + mbc_pho(c,4) = mbc_pho(c,4)+zmbc_pho ! (combo) + moc_phi(c,4) = moc_phi(c,4)+zmoc_phi ! (combo) + moc_pho(c,4) = moc_pho(c,4)+zmoc_pho ! (combo) + mdst1(c,4) = mdst1(c,4)+zmdst1 ! (combo) + mdst2(c,4) = mdst2(c,4)+zmdst2 ! (combo) + mdst3(c,4) = mdst3(c,4)+zmdst3 ! (combo) + mdst4(c,4) = mdst4(c,4)+zmdst4 ! (combo) + !mgf++ 20140225: Mass-weighted combination of radius ... bugzilla 1934 + !rds(c,4) = rds(c,3) ! (combo) + rds(c,4) = (rds(c,4)*(swliq(c,4)+swice(c,4)) + & + rds(c,3)*(zwliq+zwice))/(swliq(c,4)+swice(c,4)+zwliq+zwice) + !mgf-- bugzilla 1934 + + + call Combo (dzsno(c,4), swliq(c,4), swice(c,4), tsno(c,4), drr, & + zwliq, zwice, tsno(c,3)) + + ! Subdivided a new layer + if (msno <= 4 .and. dzsno(c,4) > 0.41_r8) then + msno = 5 + dtdz = (tsno(c,3) - tsno(c,4))/((dzsno(c,3)+dzsno(c,4))/2._r8) + dzsno(c,4) = dzsno(c,4)/2._r8 + swice(c,4) = swice(c,4)/2._r8 + swliq(c,4) = swliq(c,4)/2._r8 + dzsno(c,5) = dzsno(c,4) + swice(c,5) = swice(c,4) + swliq(c,5) = swliq(c,4) + tsno(c,5) = tsno(c,4) - dtdz*dzsno(c,4)/2._r8 + if (tsno(c,5) >= tfrz) then + tsno(c,5) = tsno(c,4) + else + tsno(c,4) = tsno(c,4) + dtdz*dzsno(c,4)/2._r8 + endif + + mbc_phi(c,4) = mbc_phi(c,4)/2._r8 + mbc_phi(c,5) = mbc_phi(c,4) + mbc_pho(c,4) = mbc_pho(c,4)/2._r8 + mbc_pho(c,5) = mbc_pho(c,4) + moc_phi(c,4) = moc_phi(c,4)/2._r8 + moc_phi(c,5) = moc_phi(c,4) + moc_pho(c,4) = moc_pho(c,4)/2._r8 + moc_pho(c,5) = moc_pho(c,4) + mdst1(c,4) = mdst1(c,4)/2._r8 + mdst1(c,5) = mdst1(c,4) + mdst2(c,4) = mdst2(c,4)/2._r8 + mdst2(c,5) = mdst2(c,4) + mdst3(c,4) = mdst3(c,4)/2._r8 + mdst3(c,5) = mdst3(c,4) + mdst4(c,4) = mdst4(c,4)/2._r8 + mdst4(c,5) = mdst4(c,4) + rds(c,5) = rds(c,4) + + end if + end if + end if + + if (msno > 4) then + if (dzsno(c,4) > 0.23_r8) then + drr = dzsno(c,4) - 0.23_r8 + propor = drr/dzsno(c,4) + zwice = propor*swice(c,4) + zwliq = propor*swliq(c,4) + + zmbc_phi = propor*mbc_phi(c,4) + zmbc_pho = propor*mbc_pho(c,4) + zmoc_phi = propor*moc_phi(c,4) + zmoc_pho = propor*moc_pho(c,4) + zmdst1 = propor*mdst1(c,4) + zmdst2 = propor*mdst2(c,4) + zmdst3 = propor*mdst3(c,4) + zmdst4 = propor*mdst4(c,4) + + propor = 0.23_r8/dzsno(c,4) + swice(c,4) = propor*swice(c,4) + swliq(c,4) = propor*swliq(c,4) + + mbc_phi(c,4) = propor*mbc_phi(c,4) + mbc_pho(c,4) = propor*mbc_pho(c,4) + moc_phi(c,4) = propor*moc_phi(c,4) + moc_pho(c,4) = propor*moc_pho(c,4) + mdst1(c,4) = propor*mdst1(c,4) + mdst2(c,4) = propor*mdst2(c,4) + mdst3(c,4) = propor*mdst3(c,4) + mdst4(c,4) = propor*mdst4(c,4) + + dzsno(c,4) = 0.23_r8 + + mbc_phi(c,5) = mbc_phi(c,5)+zmbc_phi ! (combo) + mbc_pho(c,5) = mbc_pho(c,5)+zmbc_pho ! (combo) + moc_phi(c,5) = moc_phi(c,5)+zmoc_phi ! (combo) + moc_pho(c,5) = moc_pho(c,5)+zmoc_pho ! (combo) + mdst1(c,5) = mdst1(c,5)+zmdst1 ! (combo) + mdst2(c,5) = mdst2(c,5)+zmdst2 ! (combo) + mdst3(c,5) = mdst3(c,5)+zmdst3 ! (combo) + mdst4(c,5) = mdst4(c,5)+zmdst4 ! (combo) + !mgf++ 20140225: Mass-weighted combination of radius ... bugzilla 1934 + !rds(c,5) = rds(c,4) ! (combo) + rds(c,5) = (rds(c,5)*(swliq(c,5)+swice(c,5)) + & + rds(c,4)*(zwliq+zwice))/(swliq(c,5)+swice(c,5)+zwliq+zwice) + !mgf-- bugzilla 1934 + + call Combo (dzsno(c,5), swliq(c,5), swice(c,5), tsno(c,5), drr, & + zwliq, zwice, tsno(c,4)) + end if + end if + + snl(c) = -msno + + end do + + do j = -nlevsno+1,0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + dz(c,j) = dzsno(c,j-snl(c)) + h2osoi_ice(c,j) = swice(c,j-snl(c)) + h2osoi_liq(c,j) = swliq(c,j-snl(c)) + t_soisno(c,j) = tsno(c,j-snl(c)) + + mss_bcphi(c,j) = mbc_phi(c,j-snl(c)) + mss_bcpho(c,j) = mbc_pho(c,j-snl(c)) + mss_ocphi(c,j) = moc_phi(c,j-snl(c)) + mss_ocpho(c,j) = moc_pho(c,j-snl(c)) + mss_dst1(c,j) = mdst1(c,j-snl(c)) + mss_dst2(c,j) = mdst2(c,j-snl(c)) + mss_dst3(c,j) = mdst3(c,j-snl(c)) + mss_dst4(c,j) = mdst4(c,j-snl(c)) + snw_rds(c,j) = rds(c,j-snl(c)) + + end if + end do + end do + + do j = 0, -nlevsno+1, -1 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + z(c,j) = zi(c,j) - 0.5_r8*dz(c,j) + zi(c,j-1) = zi(c,j) - dz(c,j) + end if + end do + end do + + end subroutine DivideSnowLayers + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: Combo +! +! !INTERFACE: + subroutine Combo(dz, wliq, wice, t, dz2, wliq2, wice2, t2) +! +! !DESCRIPTION: +! Combines two elements and returns the following combined +! variables: dz, t, wliq, wice. +! The combined temperature is based on the equation: +! the sum of the enthalpies of the two elements = +! that of the combined element. +! +! !USES: + use clm_varcon, only : cpice, cpliq, tfrz, hfus +! +! !ARGUMENTS: + implicit none + real(r8), intent(in) :: dz2 ! nodal thickness of 2 elements being combined [m] + real(r8), intent(in) :: wliq2 ! liquid water of element 2 [kg/m2] + real(r8), intent(in) :: wice2 ! ice of element 2 [kg/m2] + real(r8), intent(in) :: t2 ! nodal temperature of element 2 [K] + real(r8), intent(inout) :: dz ! nodal thickness of 1 elements being combined [m] + real(r8), intent(inout) :: wliq ! liquid water of element 1 + real(r8), intent(inout) :: wice ! ice of element 1 [kg/m2] + real(r8), intent(inout) :: t ! nodel temperature of elment 1 [K] +! +! !CALLED FROM: +! subroutine CombineSnowLayers in this module +! subroutine DivideSnowLayers in this module +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! +! +! !LOCAL VARIABLES: +!EOP +! + real(r8) :: dzc ! Total thickness of nodes 1 and 2 (dzc=dz+dz2). + real(r8) :: wliqc ! Combined liquid water [kg/m2] + real(r8) :: wicec ! Combined ice [kg/m2] + real(r8) :: tc ! Combined node temperature [K] + real(r8) :: h ! enthalpy of element 1 [J/m2] + real(r8) :: h2 ! enthalpy of element 2 [J/m2] + real(r8) :: hc ! temporary +!----------------------------------------------------------------------- + + dzc = dz+dz2 + wicec = (wice+wice2) + wliqc = (wliq+wliq2) + h = (cpice*wice+cpliq*wliq) * (t-tfrz)+hfus*wliq + h2= (cpice*wice2+cpliq*wliq2) * (t2-tfrz)+hfus*wliq2 + + hc = h + h2 + tc = tfrz + (hc - hfus*wliqc) / (cpice*wicec + cpliq*wliqc) + + dz = dzc + wice = wicec + wliq = wliqc + t = tc + + end subroutine Combo + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BuildSnowFilter +! +! !INTERFACE: + subroutine BuildSnowFilter(lbc, ubc, num_nolakec, filter_nolakec, & + num_snowc, filter_snowc, & + num_nosnowc, filter_nosnowc) +! +! !DESCRIPTION: +! Constructs snow filter for use in vectorized loops for snow hydrology. +! +! !USES: + use clmtype +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points + integer, intent(out) :: num_snowc ! number of column snow points in column filter + integer, intent(out) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer, intent(out) :: num_nosnowc ! number of column non-snow points in column filter + integer, intent(out) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in Hydrology2Mod +! subroutine CombineSnowLayers in this module +! +! !REVISION HISTORY: +! 2003 July 31: Forrest Hoffman +! +! !LOCAL VARIABLES: +! local pointers to implicit in arguments + integer , pointer :: snl(:) ! number of snow layers +! +! +! !OTHER LOCAL VARIABLES: +!EOP + integer :: fc, c +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtype components (column-level) + + snl => clm3%g%l%c%cps%snl + + ! Build snow/no-snow filters for other subroutines + + num_snowc = 0 + num_nosnowc = 0 + do fc = 1, num_nolakec + c = filter_nolakec(fc) + if (snl(c) < 0) then + num_snowc = num_snowc + 1 + filter_snowc(num_snowc) = c + else + num_nosnowc = num_nosnowc + 1 + filter_nosnowc(num_nosnowc) = c + end if + end do + + end subroutine BuildSnowFilter + +end module SnowHydrologyMod diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.clm/histFileMod.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.clm/histFileMod.F90 new file mode 100644 index 0000000000..cedca26335 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.clm/histFileMod.F90 @@ -0,0 +1,4470 @@ +module histFileMod + +! DART note: this file started life as: +! /glade/p/cesmdata/cseg/collections/cesm1_1_1/models/lnd/clm/src/main/histFileMod.F90 + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: histFileMod +! +! !DESCRIPTION: +! Module containing methods to for CLM history file handling. +! +! !USES: + use shr_kind_mod, only : r8 => shr_kind_r8 + use spmdMod , only : masterproc + use shr_sys_mod , only : shr_sys_flush + use abortutils , only : endrun + use clm_varcon , only : spval,ispval + use clm_varctl , only : iulog + use clmtype , only : grlnd, nameg, namel, namec, namep + use decompMod , only : get_proc_bounds, get_proc_global + use ncdio_pio + implicit none + save + private + +! +! !PUBLIC TYPES: +! +! Constants +! + integer , public, parameter :: max_tapes = 6 ! max number of history tapes + integer , public, parameter :: max_flds = 1500 ! max number of history fields + integer , public, parameter :: max_namlen = 32 ! maximum number of characters for field name +! +! Counters +! + integer , public :: ntapes = 0 ! index of max history file requested +! +! Namelist +! + integer :: ni ! implicit index below + logical, public :: & + hist_empty_htapes = .false. ! namelist: flag indicates no default history fields + integer, public :: & + hist_ndens(max_tapes) = 2 ! namelist: output density of netcdf history files + integer, public :: & + hist_mfilt(max_tapes) = 30 ! namelist: number of time samples per tape + logical, public :: & + hist_dov2xy(max_tapes) = (/.true.,(.true.,ni=2,max_tapes)/) ! namelist: true=> do grid averaging + integer, public :: & + hist_nhtfrq(max_tapes) = (/0, (-24, ni=2,max_tapes)/) ! namelist: history write freq(0=monthly) + character(len=1), public :: & + hist_avgflag_pertape(max_tapes) = (/(' ',ni=1,max_tapes)/) ! namelist: per tape averaging flag + character(len=max_namlen), public :: & + hist_type1d_pertape(max_tapes) = (/(' ',ni=1,max_tapes)/) ! namelist: per tape type1d + + character(len=max_namlen+2), public :: & + fincl(max_flds,max_tapes) ! namelist-equivalence list of fields to add + + character(len=max_namlen+2), public :: & + hist_fincl1(max_flds) = ' ' ! namelist: list of fields to add + character(len=max_namlen+2), public :: & + hist_fincl2(max_flds) = ' ' ! namelist: list of fields to add + character(len=max_namlen+2), public :: & + hist_fincl3(max_flds) = ' ' ! namelist: list of fields to add + character(len=max_namlen+2), public :: & + hist_fincl4(max_flds) = ' ' ! namelist: list of fields to add + character(len=max_namlen+2), public :: & + hist_fincl5(max_flds) = ' ' ! namelist: list of fields to add + character(len=max_namlen+2), public :: & + hist_fincl6(max_flds) = ' ' ! namelist: list of fields to add + + character(len=max_namlen+2), public :: & + fexcl(max_flds,max_tapes) ! namelist-equivalence list of fields to remove + + character(len=max_namlen+2), public :: & + hist_fexcl1(max_flds) = ' ' ! namelist: list of fields to remove + character(len=max_namlen+2), public :: & + hist_fexcl2(max_flds) = ' ' ! namelist: list of fields to remove + character(len=max_namlen+2), public :: & + hist_fexcl3(max_flds) = ' ' ! namelist: list of fields to remove + character(len=max_namlen+2), public :: & + hist_fexcl4(max_flds) = ' ' ! namelist: list of fields to remove + character(len=max_namlen+2), public :: & + hist_fexcl5(max_flds) = ' ' ! namelist: list of fields to remove + character(len=max_namlen+2), public :: & + hist_fexcl6(max_flds) = ' ' ! namelist: list of fields to remove +! +! Restart +! + logical, private :: if_disphist(max_tapes) ! true => save history file +! +! !PUBLIC MEMBER FUNCTIONS: + public :: hist_addfld1d ! Add a 1d single-level field to the master field list + public :: hist_addfld2d ! Add a 2d multi-level field to the master field list + public :: hist_add_subscript ! Add a 2d subscript dimension + public :: hist_printflds ! Print summary of master field list + public :: hist_htapes_build ! Initialize history file handler for initial or continue run + public :: hist_update_hbuf ! Updates history buffer for all fields and tapes + public :: hist_htapes_wrapup ! Write history tape(s) + public :: hist_restart_ncd ! Read/write history file restart data +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !PRIVATE MEMBER FUNCTIONS: + private :: masterlist_make_active ! Add a field to a history file default "on" list + private :: masterlist_addfld ! Add a field to the master field list + private :: masterlist_change_timeavg ! Override default history tape contents for specific tape + private :: htapes_fieldlist ! Define the contents of each history file based on namelist + private :: htape_addfld ! Add a field to the active list for a history tape + private :: htape_create ! Define contents of history file t + private :: htape_timeconst ! Write time constant values to history tape + private :: htape_timeconst3D ! Write time constant 3D values to primary history tape + private :: hfields_normalize ! Normalize history file fields by number of accumulations + private :: hfields_zero ! Zero out accumulation and hsitory buffers for a tape + private :: hfields_write ! Write a variable to a history tape + private :: hfields_1dinfo ! Define/output 1d subgrid info if appropriate + private :: hist_update_hbuf_field_1d ! Updates history buffer for specific field and tape + private :: hist_update_hbuf_field_2d ! Updates history buffer for specific field and tape + private :: list_index ! Find index of field in exclude list + private :: set_hist_filename ! Determine history dataset filenames + private :: getname ! Retrieve name portion of input "inname" + private :: getflag ! Retrieve flag + private :: pointer_index ! Track data pointer indices + private :: max_nFields ! The max number of fields on any tape + +! !PRIVATE TYPES: +! Constants +! + integer, parameter :: max_chars = 128 ! max chars for char variables +! +! Subscript dimensions +! + integer, parameter :: max_subs = 100 ! max number of subscripts + integer :: num_subs = 0 ! actual number of subscripts + character(len=32) :: subs_name(max_subs) ! name of subscript + integer :: subs_dim(max_subs) ! dimension of subscript +! +! Derived types +! + type field_info + character(len=max_namlen) :: name ! field name + character(len=max_chars) :: long_name ! long name + character(len=max_chars) :: units ! units + character(len=8) :: type1d ! clm pointer first dimension type + ! from clmtype (nameg, etc) + character(len=8) :: type1d_out ! hbuf first dimension type + ! from clmtype (nameg, etc) + character(len=8) :: type2d ! hbuf second dimension type + ! ["levgrnd","levlak","numrad","subname(n)"] + integer :: beg1d ! on-node 1d clm pointer start index + integer :: end1d ! on-node 1d clm pointer end index + integer :: num1d ! size of clm pointer first dimension (all nodes) + integer :: beg1d_out ! on-node 1d hbuf pointer start index + integer :: end1d_out ! on-node 1d hbuf pointer end index + integer :: num1d_out ! size of hbuf first dimension (all nodes) + integer :: num2d ! size of hbuf second dimension (e.g. number of vertical levels) + integer :: hpindex ! history pointer index + character(len=8) :: p2c_scale_type ! scale factor when averaging pft to column + character(len=8) :: c2l_scale_type ! scale factor when averaging column to landunit + character(len=8) :: l2g_scale_type ! scale factor when averaging landunit to gridcell + end type field_info + + type master_entry + type (field_info) :: field ! field information + logical :: actflag(max_tapes) ! active/inactive flag + character(len=1) :: avgflag(max_tapes) ! time averaging flag ("X","A","M" or "I",) + end type master_entry + + type history_entry + type (field_info) :: field ! field information + character(len=1) :: avgflag ! time averaging flag + real(r8), pointer :: hbuf(:,:) ! history buffer (dimensions: dim1d x num2d) + integer , pointer :: nacs(:,:) ! accumulation counter (dimensions: dim1d x num2d) + end type history_entry + + type history_tape + integer :: nflds ! number of active fields on tape + integer :: ntimes ! current number of time samples on tape + integer :: mfilt ! maximum number of time samples per tape + integer :: nhtfrq ! number of time samples per tape + integer :: ncprec ! netcdf output precision + logical :: dov2xy ! true => do xy average for all fields + logical :: is_endhist ! true => current time step is end of history interval + real(r8) :: begtime ! time at beginning of history averaging interval + type (history_entry) :: hlist(max_flds) ! array of active history tape entries + end type history_tape + + type clmpoint_rs ! Pointer to real scalar data (1D) + real(r8), pointer :: ptr(:) + end type clmpoint_rs + type clmpoint_ra ! Pointer to real array data (2D) + real(r8), pointer :: ptr(:,:) + end type clmpoint_ra +!EOP +! +! Pointers into clmtype arrays +! + integer, parameter :: max_mapflds = 1500 ! Maximum number of fields to track + type (clmpoint_rs) :: clmptr_rs(max_mapflds) ! Real scalar data (1D) + type (clmpoint_ra) :: clmptr_ra(max_mapflds) ! Real array data (2D) +! +! Master list: an array of master_entry entities +! + type (master_entry) :: masterlist(max_flds) ! master field list +! +! History tape: an array of history_tape entities (only active fields) +! + type (history_tape) :: tape(max_tapes) ! array history tapes +! +! Namelist input +! +! Counters +! + integer :: nfmaster = 0 ! number of fields in master field list +! +! Other variables +! + character(len=max_chars) :: locfnh(max_tapes) ! local history file names + character(len=max_chars) :: locfnhr(max_tapes) ! local history restart file names + logical :: htapes_defined = .false. ! flag indicates history contents have been defined +! +! NetCDF Id's +! + type(file_desc_t) :: nfid(max_tapes) ! file ids + type(file_desc_t) :: ncid_hist(max_tapes) ! file ids for history restart files + integer :: time_dimid ! time dimension id + integer :: hist_interval_dimid ! time bounds dimension id + integer :: strlen_dimid ! string dimension id + +! +! Time Constant variable names and filename +! + character(len=max_chars) :: TimeConst3DVars_Filename = ' ' + character(len=max_chars) :: TimeConst3DVars = ' ' +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_printflds +! +! !INTERFACE: + subroutine hist_printflds() +! +! !DESCRIPTION: +! Print summary of master field list. +! +! !USES: +! +! !ARGUMENTS: + implicit none +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein 03/2003 +! +! +! !LOCAL VARIABLES: +!EOP + integer nf + character(len=*),parameter :: subname = 'CLM_hist_printflds' +!----------------------------------------------------------------------- + + if (masterproc) then + write(iulog,*) trim(subname),' : number of master fields = ',nfmaster + write(iulog,*)' ******* MASTER FIELD LIST *******' + do nf = 1,nfmaster + write(iulog,9000)nf, masterlist(nf)%field%name, masterlist(nf)%field%units +9000 format (i5,1x,a32,1x,a16) + end do + call shr_sys_flush(iulog) + end if + + end subroutine hist_printflds + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: masterlist_addfld +! +! !INTERFACE: + subroutine masterlist_addfld (fname, type1d, type1d_out, & + type2d, num2d, units, avgflag, long_name, hpindex, & + p2c_scale_type, c2l_scale_type, l2g_scale_type) +! +! !DESCRIPTION: +! Add a field to the master field list. Put input arguments of +! field name, units, number of levels, averaging flag, and long name +! into a type entry in the global master field list (masterlist). +! +! !USES: +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: fname ! field name + character(len=*), intent(in) :: type1d ! 1d data type + character(len=*), intent(in) :: type1d_out ! 1d output type + character(len=*), intent(in) :: type2d ! 2d output type + integer , intent(in) :: num2d ! size of second dimension (e.g. number of vertical levels) + character(len=*), intent(in) :: units ! units of field + character(len=1), intent(in) :: avgflag ! time averaging flag + character(len=*), intent(in) :: long_name ! long name of field + integer , intent(in) :: hpindex ! clmtype index for history buffer output + character(len=*), intent(in) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column + character(len=*), intent(in) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits + character(len=*), intent(in) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: n ! loop index + integer :: f ! masterlist index + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: numa ! total number of atm cells across all processors + integer :: numg ! total number of gridcells across all processors + integer :: numl ! total number of landunits across all processors + integer :: numc ! total number of columns across all processors + integer :: nump ! total number of pfts across all processors + character(len=*),parameter :: subname = 'masterlist_addfld' +!------------------------------------------------------------------------ + + ! Determine bounds + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + call get_proc_global(numg, numl, numc, nump) + ! Ensure that new field is not all blanks + + if (fname == ' ') then + write(iulog,*) trim(subname),' ERROR: blank field name not allowed' + call endrun() + end if + + ! Ensure that new field doesn't already exist + + do n = 1,nfmaster + if (masterlist(n)%field%name == fname) then + write(iulog,*) trim(subname),' ERROR:', fname, ' already on list' + call endrun() + end if + end do + + ! Increase number of fields on master field list + + nfmaster = nfmaster + 1 + f = nfmaster + + ! Check number of fields in master list against maximum number for master list + + if (nfmaster > max_flds) then + write(iulog,*) trim(subname),' ERROR: too many fields for primary history file ', & + '-- max_flds,nfmaster=', max_flds, nfmaster + call endrun() + end if + + ! Add field to master list + + masterlist(f)%field%name = fname + masterlist(f)%field%long_name = long_name + masterlist(f)%field%units = units + masterlist(f)%field%type1d = type1d + masterlist(f)%field%type1d_out = type1d_out + masterlist(f)%field%type2d = type2d + masterlist(f)%field%num2d = num2d + masterlist(f)%field%hpindex = hpindex + masterlist(f)%field%p2c_scale_type = p2c_scale_type + masterlist(f)%field%c2l_scale_type = c2l_scale_type + masterlist(f)%field%l2g_scale_type = l2g_scale_type + + select case (type1d) + case (grlnd) + masterlist(f)%field%beg1d = begg + masterlist(f)%field%end1d = endg + masterlist(f)%field%num1d = numg + case (nameg) + masterlist(f)%field%beg1d = begg + masterlist(f)%field%end1d = endg + masterlist(f)%field%num1d = numg + case (namel) + masterlist(f)%field%beg1d = begl + masterlist(f)%field%end1d = endl + masterlist(f)%field%num1d = numl + case (namec) + masterlist(f)%field%beg1d = begc + masterlist(f)%field%end1d = endc + masterlist(f)%field%num1d = numc + case (namep) + masterlist(f)%field%beg1d = begp + masterlist(f)%field%end1d = endp + masterlist(f)%field%num1d = nump + case default + write(iulog,*) trim(subname),' ERROR: unknown 1d output type= ',type1d + call endrun() + end select + + ! The following two fields are used only in master field list, + ! NOT in the runtime active field list + ! ALL FIELDS IN THE MASTER LIST ARE INITIALIZED WITH THE ACTIVE + ! FLAG SET TO FALSE + + masterlist(f)%avgflag(:) = avgflag + masterlist(f)%actflag(:) = .false. + + end subroutine masterlist_addfld + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_htapes_build +! +! !INTERFACE: + subroutine hist_htapes_build () +! +! !DESCRIPTION: +! Initialize history file for initial or continuation run. For example, +! on an initial run, this routine initializes ``ntapes'' history files. +! On a restart run, this routine only initializes history files declared +! beyond what existed on the previous run. Files which already existed on +! the previous run have already been initialized (i.e. named and opened) +! in routine restart\_history. Loop over tapes and fields per tape setting +! appropriate variables and calling appropriate routines +! +! !USES: + use clm_time_manager, only: get_prev_time + use clm_varcon , only: secspday +! +! !ARGUMENTS: + implicit none +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: i ! index + integer :: ier ! error code + integer :: t, f ! tape, field indices + integer :: day, sec ! day and seconds from base date + character(len=*),parameter :: subname = 'hist_htapes_build' +!----------------------------------------------------------------------- + + if (masterproc) then + write(iulog,*) trim(subname),' Initializing clm2 history files' + write(iulog,'(72a1)') ("-",i=1,60) + call shr_sys_flush(iulog) + endif + + ! Override averaging flag for all fields on a particular tape + ! if namelist input so specifies + + do t=1,max_tapes + if (hist_avgflag_pertape(t) /= ' ') then + call masterlist_change_timeavg (t) + end if + end do + + fincl(:,1) = hist_fincl1(:) + fincl(:,2) = hist_fincl2(:) + fincl(:,3) = hist_fincl3(:) + fincl(:,4) = hist_fincl4(:) + fincl(:,5) = hist_fincl5(:) + fincl(:,6) = hist_fincl6(:) + + fexcl(:,1) = hist_fexcl1(:) + fexcl(:,2) = hist_fexcl2(:) + fexcl(:,3) = hist_fexcl3(:) + fexcl(:,4) = hist_fexcl4(:) + fexcl(:,5) = hist_fexcl5(:) + fexcl(:,6) = hist_fexcl6(:) + + ! Define field list information for all history files. + ! Update ntapes to reflect number of active history files + ! Note - branch runs can have additional auxiliary history files + ! declared). + + call htapes_fieldlist() + + ! Determine if gridcell (xy) averaging is done for all fields on tape + + do t=1,ntapes + tape(t)%dov2xy = hist_dov2xy(t) + write(iulog,*)trim(subname),' hist tape = ',t,& + ' written with dov2xy= ',tape(t)%dov2xy + end do + + ! Set number of time samples in each history file and + ! Note - the following entries will be overwritten by history restart + ! Note - with netcdf, only 1 (ncd_double) and 2 (ncd_float) are allowed + + do t=1,ntapes + tape(t)%ntimes = 0 + tape(t)%dov2xy = hist_dov2xy(t) + tape(t)%nhtfrq = hist_nhtfrq(t) + tape(t)%mfilt = hist_mfilt(t) + if (hist_ndens(t) == 1) then + tape(t)%ncprec = ncd_double + else + tape(t)%ncprec = ncd_float + endif + end do + + ! Set time of beginning of current averaging interval + ! First etermine elapased time since reference date + + call get_prev_time(day, sec) + do t=1,ntapes + tape(t)%begtime = day + sec/secspday + end do + + if (masterproc) then + write(iulog,*) trim(subname),' Successfully initialized clm2 history files' + write(iulog,'(72a1)') ("-",i=1,60) + call shr_sys_flush(iulog) + endif + + end subroutine hist_htapes_build + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: masterlist_make_active +! +! !INTERFACE: + subroutine masterlist_make_active (name, tape_index, avgflag) +! +! !DESCRIPTION: +! Add a field to the default ``on'' list for a given history file. +! Also change the default time averaging flag if requested. +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: name ! field name + integer, intent(in) :: tape_index ! history tape index + character(len=1), intent(in), optional :: avgflag ! time averaging flag +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + logical :: found ! flag indicates field found in masterlist + character(len=*),parameter :: subname = 'masterlist_make_active' +!----------------------------------------------------------------------- + + ! Check validity of input arguments + + if (tape_index > max_tapes) then + write(iulog,*) trim(subname),' ERROR: tape index=', tape_index, ' is too big' + call endrun() + end if + + if (present(avgflag)) then + if ( avgflag /= ' ' .and. & + avgflag /= 'A' .and. avgflag /= 'I' .and. & + avgflag /= 'X' .and. avgflag /= 'M') then + write(iulog,*) trim(subname),' ERROR: unknown averaging flag=', avgflag + call endrun() + endif + end if + + ! Look through master list for input field name. + ! When found, set active flag for that tape to true. + ! Also reset averaging flag if told to use other than default. + + found = .false. + do f = 1,nfmaster + if (trim(name) == trim(masterlist(f)%field%name)) then + masterlist(f)%actflag(tape_index) = .true. + if (present(avgflag)) then + if (avgflag/= ' ') masterlist(f)%avgflag(tape_index) = avgflag + end if + found = .true. + exit + end if + end do + if (.not. found) then + write(iulog,*) trim(subname),' ERROR: field=', name, ' not found' + call endrun() + end if + + end subroutine masterlist_make_active + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: masterlist_change_timeavg +! +! !INTERFACE: + subroutine masterlist_change_timeavg (t) +! +! !DESCRIPTION: +! Override default history tape contents for a specific tape. +! Copy the flag into the master field list. +! +! !USES: +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! history tape index +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + character(len=1) :: avgflag ! lcl equiv of hist_avgflag_pertape(t) + character(len=*),parameter :: subname = 'masterlist_change_timeavg' +!----------------------------------------------------------------------- + + avgflag = hist_avgflag_pertape(t) + + do f = 1,nfmaster + select case (avgflag) + case ('A') + masterlist(f)%avgflag(t) = avgflag + case ('I') + masterlist(f)%avgflag(t) = avgflag + case ('X') + masterlist(f)%avgflag(t) = avgflag + case ('M') + masterlist(f)%avgflag(t) = avgflag + case default + write(iulog,*) trim(subname),' ERROR: unknown avgflag=',avgflag + call endrun () + end select + end do + + end subroutine masterlist_change_timeavg + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: htapes_fieldlist +! +! !INTERFACE: + subroutine htapes_fieldlist() +! +! !DESCRIPTION: +! Define the contents of each history file based on namelist +! input for initial or branch run, and restart data if a restart run. +! Use arrays fincl and fexcl to modify default history tape contents. +! Then sort the result alphanumerically. +! +! !USES: +! +! !ARGUMENTS: + implicit none +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: t, f ! tape, field indices + integer :: ff ! index into include, exclude and fprec list + character(len=max_namlen) :: name ! field name portion of fincl (i.e. no avgflag separator) + character(len=max_namlen) :: mastername ! name from masterlist field + character(len=1) :: avgflag ! averaging flag + character(len=1) :: prec_acc ! history buffer precision flag + character(len=1) :: prec_wrt ! history buffer write precision flag + type (history_entry) :: tmp ! temporary used for swapping + character(len=*),parameter :: subname = 'htapes_fieldlist' +!----------------------------------------------------------------------- + + ! First ensure contents of fincl and fexcl are valid names + + do t = 1,max_tapes + f = 1 + do while (f < max_flds .and. fincl(f,t) /= ' ') + name = getname (fincl(f,t)) + do ff = 1,nfmaster + mastername = masterlist(ff)%field%name + if (name == mastername) exit + end do + if (name /= mastername) then + write(iulog,*) trim(subname),' ERROR: ', trim(name), ' in fincl(', f, ') ',& + 'for history tape ',t,' not found' + call endrun() + end if + f = f + 1 + end do + + f = 1 + do while (f < max_flds .and. fexcl(f,t) /= ' ') + do ff = 1,nfmaster + mastername = masterlist(ff)%field%name + if (fexcl(f,t) == mastername) exit + end do + if (fexcl(f,t) /= mastername) then + write(iulog,*) trim(subname),' ERROR: ', fexcl(f,t), ' in fexcl(', f, ') ', & + 'for history tape ',t,' not found' + call endrun() + end if + f = f + 1 + end do + end do + + tape(:)%nflds = 0 + do t = 1,max_tapes + + ! Loop through the masterlist set of field names and determine if any of those + ! are in the FINCL or FEXCL arrays + ! The call to list_index determines the index in the FINCL or FEXCL arrays + ! that the masterlist field corresponds to + ! Add the field to the tape if specified via namelist (FINCL[1-max_tapes]), + ! or if it is on by default and was not excluded via namelist (FEXCL[1-max_tapes]). + + do f = 1,nfmaster + mastername = masterlist(f)%field%name + call list_index (fincl(1,t), mastername, ff) + + if (ff > 0) then + + ! if field is in include list, ff > 0 and htape_addfld + ! will not be called for field + + avgflag = getflag (fincl(ff,t)) + call htape_addfld (t, f, avgflag) + + else if (.not. hist_empty_htapes) then + + ! find index of field in exclude list + + call list_index (fexcl(1,t), mastername, ff) + + ! if field is in exclude list, ff > 0 and htape_addfld + ! will not be called for field + ! if field is not in exclude list, ff =0 and htape_addfld + ! will be called for field (note that htape_addfld will be + ! called below only if field is not in exclude list OR in + ! include list + + if (ff == 0 .and. masterlist(f)%actflag(t)) then + call htape_addfld (t, f, ' ') + end if + + end if + end do + + ! Specification of tape contents now complete. + ! Sort each list of active entries + + do f = tape(t)%nflds-1,1,-1 + do ff = 1,f + if (tape(t)%hlist(ff)%field%name > tape(t)%hlist(ff+1)%field%name) then + + tmp = tape(t)%hlist(ff) + tape(t)%hlist(ff ) = tape(t)%hlist(ff+1) + tape(t)%hlist(ff+1) = tmp + + else if (tape(t)%hlist(ff)%field%name == tape(t)%hlist(ff+1)%field%name) then + + write(iulog,*) trim(subname),' ERROR: Duplicate field ', & + tape(t)%hlist(ff)%field%name, & + 't,ff,name=',t,ff,tape(t)%hlist(ff+1)%field%name + call endrun() + + end if + end do + end do + + if (masterproc) then + if (tape(t)%nflds > 0) then + write(iulog,*) trim(subname),' : Included fields tape ',t,'=',tape(t)%nflds + end if + do f = 1,tape(t)%nflds + write(iulog,*) f,' ',tape(t)%hlist(f)%field%name, & + tape(t)%hlist(f)%field%num2d,' ',tape(t)%hlist(f)%avgflag + end do + call shr_sys_flush(iulog) + end if + end do + + ! Determine total number of active history tapes + + ntapes = 0 + do t = max_tapes,1,-1 + if (tape(t)%nflds > 0) then + ntapes = t + exit + end if + end do + + ! Ensure there are no "holes" in tape specification, i.e. empty tapes. + ! Enabling holes should not be difficult if necessary. + + do t = 1,ntapes + if (tape(t)%nflds == 0) then + write(iulog,*) trim(subname),' ERROR: Tape ',t,' is empty' + call endrun() + end if + end do + + ! Check that the number of history files declared does not exceed + ! the maximum allowed. + + if (ntapes > max_tapes) then + write(iulog,*) trim(subname),' ERROR: Too many history files declared, max_tapes=',max_tapes + call endrun() + end if + + ! Change 1d output per tape output flag if requested - only for history + ! tapes where 2d xy averaging is not enabled + + do t = 1,ntapes + if (hist_type1d_pertape(t) /= ' ' .and. (.not. hist_dov2xy(t))) then + select case (trim(hist_type1d_pertape(t))) + case ('PFTS','COLS', 'LAND', 'GRID') + if ( masterproc ) & + write(iulog,*)'history tape ',t,' will have 1d output type of ',hist_type1d_pertape(t) + case default + write(iulog,*) trim(subname),' ERROR: unknown namelist type1d per tape=',hist_type1d_pertape(t) + call endrun() + end select + end if + end do + + if (masterproc) then + write(iulog,*) 'There will be a total of ',ntapes,' history tapes' + do t=1,ntapes + write(iulog,*) + if (hist_nhtfrq(t) == 0) then + write(iulog,*)'History tape ',t,' write frequency is MONTHLY' + else + write(iulog,*)'History tape ',t,' write frequency = ',hist_nhtfrq(t) + endif + if (hist_dov2xy(t)) then + write(iulog,*)'All fields on history tape ',t,' are grid averaged' + else + write(iulog,*)'All fields on history tape ',t,' are not grid averaged' + end if + write(iulog,*)'Number of time samples on history tape ',t,' is ',hist_mfilt(t) + write(iulog,*)'Output precision on history tape ',t,'=',hist_ndens(t) + write(iulog,*) + end do + call shr_sys_flush(iulog) + end if + + ! Set flag indicating h-tape contents are now defined (needed by masterlist_addfld) + + htapes_defined = .true. + + end subroutine htapes_fieldlist + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: htape_addfld +! +! !INTERFACE: + subroutine htape_addfld (t, f, avgflag) +! +! !DESCRIPTION: +! Add a field to the active list for a history tape. Copy the data from +! the master field list to the active list for the tape. +! +! !USES: +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! history tape index + integer, intent(in) :: f ! field index from master field list + character(len=1), intent(in) :: avgflag ! time averaging flag +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: n ! field index on defined tape + character(len=8) :: type1d ! clm pointer 1d type + character(len=8) :: type1d_out ! history buffer 1d type + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: numa ! total number of atm cells across all processors + integer :: numg ! total number of gridcells across all processors + integer :: numl ! total number of landunits across all processors + integer :: numc ! total number of columns across all processors + integer :: nump ! total number of pfts across all processors + integer :: num2d ! size of second dimension (e.g. .number of vertical levels) + integer :: beg1d_out,end1d_out ! history output per-proc 1d beginning and ending indices + integer :: num1d_out ! history output 1d size + character(len=*),parameter :: subname = 'htape_addfld' +!----------------------------------------------------------------------- + + ! Ensure that it is not to late to add a field to the history tape + + if (htapes_defined) then + write(iulog,*) trim(subname),' ERROR: attempt to add field ', & + masterlist(f)%field%name, ' after history files are set' + call endrun() + end if + + tape(t)%nflds = tape(t)%nflds + 1 + n = tape(t)%nflds + + ! Copy field information + + tape(t)%hlist(n)%field = masterlist(f)%field + + ! Determine bounds + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + call get_proc_global(numg, numl, numc, nump) + + ! Modify type1d_out if necessary + + if (hist_dov2xy(t)) then + + ! If xy output averaging is requested, set output 1d type to grlnd + ! ***NOTE- the following logic is what permits non lat/lon grids to + ! be written to clm history file + + type1d = tape(t)%hlist(n)%field%type1d + + if (type1d == nameg .or. & + type1d == namel .or. & + type1d == namec .or. & + type1d == namep) then + tape(t)%hlist(n)%field%type1d_out = grlnd + end if + if (type1d == grlnd) then + tape(t)%hlist(n)%field%type1d_out = grlnd + end if + + else if (hist_type1d_pertape(t) /= ' ') then + + ! Set output 1d type based on namelist setting of hist_type1d_pertape + ! Only applies to tapes when xy output is not required + + type1d = tape(t)%hlist(n)%field%type1d + + select case (trim(hist_type1d_pertape(t))) + case('GRID') + tape(t)%hlist(n)%field%type1d_out = nameg + case('LAND') + tape(t)%hlist(n)%field%type1d_out = namel + case('COLS') + tape(t)%hlist(n)%field%type1d_out = namec + case ('PFTS') + tape(t)%hlist(n)%field%type1d_out = namep + case default + write(iulog,*) trim(subname),' ERROR: unknown input hist_type1d_pertape= ', hist_type1d_pertape(t) + call endrun() + end select + + endif + + ! Determine output 1d dimensions + + type1d_out = tape(t)%hlist(n)%field%type1d_out + if (type1d_out == grlnd) then + beg1d_out = begg + end1d_out = endg + num1d_out = numg + else if (type1d_out == nameg) then + beg1d_out = begg + end1d_out = endg + num1d_out = numg + else if (type1d_out == namel) then + beg1d_out = begl + end1d_out = endl + num1d_out = numl + else if (type1d_out == namec) then + beg1d_out = begc + end1d_out = endc + num1d_out = numc + else if (type1d_out == namep) then + beg1d_out = begp + end1d_out = endp + num1d_out = nump + else + write(iulog,*) trim(subname),' ERROR: incorrect value of type1d_out= ',type1d_out + call endrun() + end if + + tape(t)%hlist(n)%field%beg1d_out = beg1d_out + tape(t)%hlist(n)%field%end1d_out = end1d_out + tape(t)%hlist(n)%field%num1d_out = num1d_out + + ! Alloccate and initialize history buffer and related info + + num2d = tape(t)%hlist(n)%field%num2d + allocate (tape(t)%hlist(n)%hbuf(beg1d_out:end1d_out,num2d)) + allocate (tape(t)%hlist(n)%nacs(beg1d_out:end1d_out,num2d)) + tape(t)%hlist(n)%hbuf(:,:) = 0._r8 + tape(t)%hlist(n)%nacs(:,:) = 0 + + ! Set time averaging flag based on masterlist setting or + ! override the default averaging flag with namelist setting + + select case (avgflag) + case (' ') + tape(t)%hlist(n)%avgflag = masterlist(f)%avgflag(t) + case ('A','I','X','M') + tape(t)%hlist(n)%avgflag = avgflag + case default + write(iulog,*) trim(subname),' ERROR: unknown avgflag=', avgflag + call endrun() + end select + + end subroutine htape_addfld + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_update_hbuf +! +! !INTERFACE: + subroutine hist_update_hbuf() +! +! !DESCRIPTION: +! Accumulate (or take min, max, etc. as appropriate) input field +! into its history buffer for appropriate tapes. +! +! !USES: +! +! !ARGUMENTS: + implicit none +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: t ! tape index + integer :: f ! field index + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: num2d ! size of second dimension (e.g. number of vertical levels) + character(len=*),parameter :: subname = 'hist_update_hbuf' +!----------------------------------------------------------------------- + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + do t = 1,ntapes +!$OMP PARALLEL DO PRIVATE (f, num2d) + do f = 1,tape(t)%nflds + num2d = tape(t)%hlist(f)%field%num2d + if ( num2d == 1) then + call hist_update_hbuf_field_1d (t, f, begp, endp, begc, endc, begl, endl, begg, endg) + else + call hist_update_hbuf_field_2d (t, f, begp, endp, begc, endc, begl, endl, begg, endg, num2d) + end if + end do +!$OMP END PARALLEL DO + end do + + end subroutine hist_update_hbuf + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_update_hbuf_field_1d +! +! !INTERFACE: + subroutine hist_update_hbuf_field_1d (t, f, begp, endp, begc, endc, begl, endl, begg, endg) +! +! !DESCRIPTION: +! Accumulate (or take min, max, etc. as appropriate) input field +! into its history buffer for appropriate tapes. +! +! !USES: + use clmtype + use subgridAveMod, only : p2g, c2g, l2g + use clm_varcon , only : istice_mec +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + integer, intent(in) :: f ! field index + integer, intent(in) :: begp, endp ! per-proc beginning and ending pft indices + integer, intent(in) :: begc, endc ! per-proc beginning and ending column indices + integer, intent(in) :: begl, endl ! per-proc beginning and ending landunit indices + integer, intent(in) :: begg, endg ! per-proc gridcell ending gridcell indices +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: hpindex ! history pointer index + integer :: k ! gridcell, landunit, column or pft index + integer :: l ! landunit index + integer :: beg1d,end1d ! beginning and ending indices + logical :: checkwt ! true => check weight of pft relative to gridcell + logical :: valid ! true => history operation is valid + logical :: map2gcell ! true => map clm pointer field to gridcell + character(len=8) :: type1d ! 1d clm pointerr type ["gridcell","landunit","column","pft"] + character(len=8) :: type1d_out ! 1d history buffer type ["gridcell","landunit","column","pft"] + character(len=1) :: avgflag ! time averaging flag + character(len=8) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column + character(len=8) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits + character(len=8) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells + real(r8), pointer :: hbuf(:,:) ! history buffer + integer , pointer :: nacs(:,:) ! accumulation counter + integer , pointer :: ltype(:) ! landunit type + integer , pointer :: plandunit(:) ! pft's landunit index + real(r8), pointer :: pwtgcell(:) ! weight of pft relative to corresponding gridcell + real(r8), pointer :: field(:) ! clm 1d pointer field + real(r8) :: field_gcell(begg:endg) ! gricell level field (used if mapping to gridcell is done) + integer j + character(len=*),parameter :: subname = 'hist_update_hbuf_field_1d' +!----------------------------------------------------------------------- + + avgflag = tape(t)%hlist(f)%avgflag + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + beg1d = tape(t)%hlist(f)%field%beg1d + end1d = tape(t)%hlist(f)%field%end1d + type1d = tape(t)%hlist(f)%field%type1d + type1d_out = tape(t)%hlist(f)%field%type1d_out + p2c_scale_type = tape(t)%hlist(f)%field%p2c_scale_type + c2l_scale_type = tape(t)%hlist(f)%field%c2l_scale_type + l2g_scale_type = tape(t)%hlist(f)%field%l2g_scale_type + hpindex = tape(t)%hlist(f)%field%hpindex + field => clmptr_rs(hpindex)%ptr + + ! set variables to check weights when allocate all pfts + + map2gcell = .false. + if (type1d_out == nameg .or. type1d_out == grlnd) then + if (type1d == namep) then + call p2g(begp, endp, begc, endc, begl, endl, begg, endg, field, field_gcell, & + p2c_scale_type, c2l_scale_type, l2g_scale_type) + map2gcell = .true. + else if (type1d == namec) then + call c2g(begc, endc, begl, endl, begg, endg, field, field_gcell, & + c2l_scale_type, l2g_scale_type) + map2gcell = .true. + else if (type1d == namel) then + call l2g(begl, endl, begg, endg, field, field_gcell, & + l2g_scale_type) + map2gcell = .true. + end if + end if + + if (map2gcell) then ! Map to gridcell + + ! note that in this case beg1d = begg and end1d=endg + select case (avgflag) + case ('I') ! Instantaneous + do k = begg,endg + if (field_gcell(k) /= spval) then + hbuf(k,1) = field_gcell(k) + else + hbuf(k,1) = spval + end if + nacs(k,1) = 1 + end do + case ('A') ! Time average + do k = begg,endg + if (field_gcell(k) /= spval) then + if (nacs(k,1) == 0) hbuf(k,1) = 0._r8 + hbuf(k,1) = hbuf(k,1) + field_gcell(k) + nacs(k,1) = nacs(k,1) + 1 + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + end do + case ('X') ! Maximum over time + do k = begg,endg + if (field_gcell(k) /= spval) then + if (nacs(k,1) == 0) hbuf(k,1) = -1.e50_r8 + hbuf(k,1) = max( hbuf(k,1), field_gcell(k) ) + else + hbuf(k,1) = spval + endif + nacs(k,1) = 1 + end do + case ('M') ! Minimum over time + do k = begg,endg + if (field_gcell(k) /= spval) then + if (nacs(k,1) == 0) hbuf(k,1) = +1.e50_r8 + hbuf(k,1) = min( hbuf(k,1), field_gcell(k) ) + else + hbuf(k,1) = spval + endif + nacs(k,1) = 1 + end do + case default + write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag + call endrun() + end select + + else ! Do not map to gridcell + + pwtgcell => clm3%g%l%c%p%wtgcell + plandunit => clm3%g%l%c%p%landunit + ltype => clm3%g%l%itype + + checkwt = .false. + if (type1d == namep) checkwt = .true. + + select case (avgflag) + case ('I') ! Instantaneous + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + ! Note: some glacier_mec pfts may have zero weight and still be considered valid + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k) /= spval) then + hbuf(k,1) = field(k) + else + hbuf(k,1) = spval + end if + else + hbuf(k,1) = spval + end if + nacs(k,1) = 1 + end do + case ('A') ! Time average + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k) /= spval) then + if (nacs(k,1) == 0) hbuf(k,1) = 0._r8 + hbuf(k,1) = hbuf(k,1) + field(k) + nacs(k,1) = nacs(k,1) + 1 + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + end do + case ('X') ! Maximum over time + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k) /= spval) then + if (nacs(k,1) == 0) hbuf(k,1) = -1.e50_r8 + hbuf(k,1) = max( hbuf(k,1), field(k) ) + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + nacs(k,1) = 1 + end do + case ('M') ! Minimum over time + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k) /= spval) then + if (nacs(k,1) == 0) hbuf(k,1) = +1.e50_r8 + hbuf(k,1) = min( hbuf(k,1), field(k) ) + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + nacs(k,1) = 1 + end do + case default + write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag + call endrun() + end select + end if + + end subroutine hist_update_hbuf_field_1d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_update_hbuf_field_2d +! +! !INTERFACE: + subroutine hist_update_hbuf_field_2d (t, f, begp, endp, begc, endc, begl, endl, begg, endg, num2d) +! +! !DESCRIPTION: +! Accumulate (or take min, max, etc. as appropriate) input field +! into its history buffer for appropriate tapes. +! +! !USES: + use clmtype + use subgridAveMod, only : p2g, c2g, l2g + use clm_varcon , only : istice_mec +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + integer, intent(in) :: f ! field index + integer, intent(in) :: begp, endp ! per-proc beginning and ending pft indices + integer, intent(in) :: begc, endc ! per-proc beginning and ending column indices + integer, intent(in) :: begl, endl ! per-proc beginning and ending landunit indices + integer, intent(in) :: begg, endg ! per-proc gridcell ending gridcell indices + integer, intent(in) :: num2d ! size of second dimension +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: hpindex ! history pointer index + integer :: k ! gridcell, landunit, column or pft index + integer :: l ! landunit index + integer :: j ! level index + integer :: beg1d,end1d ! beginning and ending indices + logical :: checkwt ! true => check weight of pft relative to gridcell + logical :: valid ! true => history operation is valid + logical :: map2gcell ! true => map clm pointer field to gridcell + character(len=8) :: type1d ! 1d clm pointerr type ["gridcell","landunit","column","pft"] + character(len=8) :: type1d_out ! 1d history buffer type ["gridcell","landunit","column","pft"] + character(len=1) :: avgflag ! time averaging flag + character(len=8) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column + character(len=8) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits + character(len=8) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells + real(r8), pointer :: hbuf(:,:) ! history buffer + integer , pointer :: nacs(:,:) ! accumulation counter + integer , pointer :: ltype(:) ! landunit type + integer , pointer :: plandunit(:) ! pft's landunit index + real(r8), pointer :: pwtgcell(:) ! weight of pft relative to corresponding gridcell + real(r8), pointer :: field(:,:) ! clm 2d pointer field + real(r8) :: field_gcell(begg:endg,num2d) ! gricell level field (used if mapping to gridcell is done) + character(len=*),parameter :: subname = 'hist_update_hbuf_field_2d' +!----------------------------------------------------------------------- + + avgflag = tape(t)%hlist(f)%avgflag + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + beg1d = tape(t)%hlist(f)%field%beg1d + end1d = tape(t)%hlist(f)%field%end1d + type1d = tape(t)%hlist(f)%field%type1d + type1d_out = tape(t)%hlist(f)%field%type1d_out + p2c_scale_type = tape(t)%hlist(f)%field%p2c_scale_type + c2l_scale_type = tape(t)%hlist(f)%field%c2l_scale_type + l2g_scale_type = tape(t)%hlist(f)%field%l2g_scale_type + hpindex = tape(t)%hlist(f)%field%hpindex + field => clmptr_ra(hpindex)%ptr(:,1:num2d) + + ! set variables to check weights when allocate all pfts + + map2gcell = .false. + if (type1d_out == nameg .or. type1d_out == grlnd) then + if (type1d == namep) then + call p2g(begp, endp, begc, endc, begl, endl, begg, endg, num2d, field, field_gcell, & + p2c_scale_type, c2l_scale_type, l2g_scale_type) + map2gcell = .true. + else if (type1d == namec) then + call c2g(begc, endc, begl, endl, begg, endg, num2d, field, field_gcell, & + c2l_scale_type, l2g_scale_type) + map2gcell = .true. + else if (type1d == namel) then + call l2g(begl, endl, begg, endg, num2d, field, field_gcell, & + l2g_scale_type) + map2gcell = .true. + end if + end if + + if (map2gcell) then ! Map to gridcell + + ! note that in this case beg1d = begg and end1d=endg + select case (avgflag) + case ('I') ! Instantaneous + do j = 1,num2d + do k = begg,endg + if (field_gcell(k,j) /= spval) then + hbuf(k,j) = field_gcell(k,j) + else + hbuf(k,j) = spval + end if + nacs(k,j) = 1 + end do + end do + case ('A') ! Time average + do j = 1,num2d + do k = begg,endg + if (field_gcell(k,j) /= spval) then + if (nacs(k,j) == 0) hbuf(k,j) = 0._r8 + hbuf(k,j) = hbuf(k,j) + field_gcell(k,j) + nacs(k,j) = nacs(k,j) + 1 + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + endif + end do + end do + case ('X') ! Maximum over time + do j = 1,num2d + do k = begg,endg + if (field_gcell(k,j) /= spval) then + if (nacs(k,j) == 0) hbuf(k,j) = -1.e50_r8 + hbuf(k,j) = max( hbuf(k,j), field_gcell(k,j) ) + else + hbuf(k,j) = spval + endif + nacs(k,j) = 1 + end do + end do + case ('M') ! Minimum over time + do j = 1,num2d + do k = begg,endg + if (field_gcell(k,j) /= spval) then + if (nacs(k,j) == 0) hbuf(k,j) = +1.e50_r8 + hbuf(k,j) = min( hbuf(k,j), field_gcell(k,j) ) + else + hbuf(k,j) = spval + endif + nacs(k,j) = 1 + end do + end do + case default + write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag + call endrun() + end select + + else ! Do not map to gridcell + + ! Note that since field points to an array section the + ! bounds are field(1:end1d-beg1d+1, num2d) - therefore + ! need to do the shifting below + + pwtgcell => clm3%g%l%c%p%wtgcell + plandunit => clm3%g%l%c%p%landunit + ltype => clm3%g%l%itype + + checkwt = .false. + if (type1d == namep) checkwt = .true. + + select case (avgflag) + case ('I') ! Instantaneous + do j = 1,num2d + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k-beg1d+1,j) /= spval) then + hbuf(k,j) = field(k-beg1d+1,j) + else + hbuf(k,j) = spval + end if + else + hbuf(k,j) = spval + end if + nacs(k,j) = 1 + end do + end do + case ('A') ! Time average + do j = 1,num2d + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k-beg1d+1,j) /= spval) then + if (nacs(k,j) == 0) hbuf(k,j) = 0._r8 + hbuf(k,j) = hbuf(k,j) + field(k-beg1d+1,j) + nacs(k,j) = nacs(k,j) + 1 + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + end if + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + end if + end do + end do + case ('X') ! Maximum over time + do j = 1,num2d + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k-beg1d+1,j) /= spval) then + if (nacs(k,j) == 0) hbuf(k,j) = -1.e50_r8 + hbuf(k,j) = max( hbuf(k,j), field(k-beg1d+1,j) ) + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + end if + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + end if + nacs(k,j) = 1 + end do + end do + case ('M') ! Minimum over time + do j = 1,num2d + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k-beg1d+1,j) /= spval) then + if (nacs(k,j) == 0) hbuf(k,j) = +1.e50_r8 + hbuf(k,j) = min( hbuf(k,j), field(k-beg1d+1,j)) + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + end if + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + end if + nacs(k,j) = 1 + end do + end do + case default + write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag + call endrun() + end select + end if + + end subroutine hist_update_hbuf_field_2d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hfields_normalize +! +! !INTERFACE: + subroutine hfields_normalize (t) +! +! !DESCRIPTION: +! Normalize fields on a history file by the number of accumulations. +! Loop over fields on the tape. Need averaging flag and number of +! accumulations to perform normalization. +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + integer :: k ! 1d index + integer :: j ! 2d index + logical :: aflag ! averaging flag + integer :: beg1d_out,end1d_out ! hbuf 1d beginning and ending indices + integer :: num2d ! hbuf size of second dimension (e.g. number of vertical levels) + character(len=1) :: avgflag ! averaging flag + real(r8), pointer :: hbuf(:,:) ! history buffer + integer , pointer :: nacs(:,:) ! accumulation counter + character(len=*),parameter :: subname = 'hfields_normalize' +!----------------------------------------------------------------------- +!dir$ inlinenever hfields_normalize + + ! Normalize by number of accumulations for time averaged case + + do f = 1,tape(t)%nflds + avgflag = tape(t)%hlist(f)%avgflag + beg1d_out = tape(t)%hlist(f)%field%beg1d_out + end1d_out = tape(t)%hlist(f)%field%end1d_out + num2d = tape(t)%hlist(f)%field%num2d + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + if (avgflag == 'A') then + aflag = .true. + else + aflag = .false. + end if + + do j = 1, num2d + do k = beg1d_out, end1d_out + if (aflag .and. nacs(k,j) /= 0) then + hbuf(k,j) = hbuf(k,j) / float(nacs(k,j)) + end if + end do + end do + end do + + end subroutine hfields_normalize + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hfields_zero +! +! !INTERFACE: + subroutine hfields_zero (t) +! +! !DESCRIPTION: +! Zero out accumulation and history buffers for a given history tape. +! Loop through fields on the tape. +! +! !USES: +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + character(len=*),parameter :: subname = 'hfields_zero' +!----------------------------------------------------------------------- + + do f = 1,tape(t)%nflds + tape(t)%hlist(f)%hbuf(:,:) = 0._r8 + tape(t)%hlist(f)%nacs(:,:) = 0 + end do + + end subroutine hfields_zero + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: htape_create +! +! !INTERFACE: + subroutine htape_create (t, histrest) +! +! !DESCRIPTION: +! Define contents of history file t. Issue the required netcdf +! wrapper calls to define the history file contents. +! +! !USES: + use clmtype + use clm_varpar , only : nlevgrnd, nlevlak, numrad + use clm_varctl , only : caseid, ctitle, fsurdat, finidat, fpftcon, & + version, hostname, username, conventions, source + use domainMod , only : ldomain + use fileutils , only : get_filename +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + logical, intent(in), optional :: histrest ! if creating the history restart file +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + integer :: p,c,l,n ! indices + integer :: ier ! error code + integer :: num2d ! size of second dimension (e.g. number of vertical levels) + integer :: dimid ! dimension id temporary + integer :: dim1id(1) ! netCDF dimension id + integer :: dim2id(2) ! netCDF dimension id + integer :: ndims ! dimension counter + integer :: omode ! returned mode from netCDF call + integer :: ncprec ! output netCDF write precision + integer :: ret ! netCDF error status + integer :: nump ! total number of pfts across all processors + integer :: numc ! total number of columns across all processors + integer :: numl ! total number of landunits across all processors + integer :: numg ! total number of gridcells across all processors + integer :: numa ! total number of atm cells across all processors + logical :: lhistrest ! local history restart flag + type(file_desc_t) :: lnfid ! local file id + character(len= 8) :: curdate ! current date + character(len= 8) :: curtime ! current time + character(len=256) :: name ! name of attribute + character(len=256) :: units ! units of attribute + character(len=256) :: str ! global attribute string + character(len= 1) :: avgflag ! time averaging flag + character(len=*),parameter :: subname = 'htape_create' +!----------------------------------------------------------------------- + + if ( present(histrest) )then + lhistrest = histrest + else + lhistrest = .false. + end if + + ! Determine necessary indices + + call get_proc_global(numg, numl, numc, nump) + + ! define output write precsion for tape + + ncprec = tape(t)%ncprec + + ! Create new netCDF file. It will be in define mode + + if ( .not. lhistrest )then + if (masterproc) then + write(iulog,*) trim(subname),' : Opening netcdf htape ', & + trim(locfnh(t)) + call shr_sys_flush(iulog) + end if + call ncd_pio_createfile(lnfid, trim(locfnh(t))) + call ncd_putatt(lnfid, ncd_global, 'title', 'CLM History file information' ) + call ncd_putatt(lnfid, ncd_global, 'comment', & + "NOTE: None of the variables are weighted by land fraction!" ) + else + if (masterproc) then + write(iulog,*) trim(subname),' : Opening netcdf rhtape ', & + trim(locfnhr(t)) + call shr_sys_flush(iulog) + end if + call ncd_pio_createfile(lnfid, trim(locfnhr(t))) + call ncd_putatt(lnfid, ncd_global, 'title', & + 'CLM Restart History information, required to continue a simulation' ) + call ncd_putatt(lnfid, ncd_global, 'comment', & + "This entire file NOT needed for startup or branch simulations") + end if + + ! Create global attributes. Attributes are used to store information + ! about the data set. Global attributes are information about the + ! data set as a whole, as opposed to a single variable + + call ncd_putatt(lnfid, ncd_global, 'Conventions', trim(conventions)) + call getdatetime(curdate, curtime) + str = 'created on ' // curdate // ' ' // curtime + call ncd_putatt(lnfid, ncd_global, 'history' , trim(str)) + call ncd_putatt(lnfid, ncd_global, 'source' , trim(source)) + call ncd_putatt(lnfid, ncd_global, 'hostname', trim(hostname)) + call ncd_putatt(lnfid, ncd_global, 'username', trim(username)) + call ncd_putatt(lnfid, ncd_global, 'version' , trim(version)) + + str = & + '$Id: histFileMod.F90 40539 2012-09-26 21:57:22Z muszala $' + call ncd_putatt(lnfid, ncd_global, 'revision_id', trim(str)) + call ncd_putatt(lnfid, ncd_global, 'case_title', trim(ctitle)) + call ncd_putatt(lnfid, ncd_global, 'case_id', trim(caseid)) + str = get_filename(fsurdat) + call ncd_putatt(lnfid, ncd_global, 'Surface_dataset', trim(str)) + if (finidat == ' ') then + str = 'arbitrary initialization' + else + str = get_filename(finidat) + endif + call ncd_putatt(lnfid, ncd_global, 'Initial_conditions_dataset', trim(str)) + str = get_filename(fpftcon) + call ncd_putatt(lnfid, ncd_global, 'PFT_physiological_constants_dataset', trim(str)) + + ! Define dimensions. + ! Time is an unlimited dimension. Character string is treated as an array of characters. + + ! Global uncompressed dimensions (including non-land points) + if (ldomain%isgrid2d) then + call ncd_defdim(lnfid, 'lon' , ldomain%ni, dimid) + call ncd_defdim(lnfid, 'lat' , ldomain%nj, dimid) + else + call ncd_defdim(lnfid, trim(grlnd), ldomain%ns, dimid) + end if + + ! Global compressed dimensions (not including non-land points) + call ncd_defdim(lnfid, trim(nameg), numg, dimid) + call ncd_defdim(lnfid, trim(namel), numl, dimid) + call ncd_defdim(lnfid, trim(namec), numc, dimid) + call ncd_defdim(lnfid, trim(namep), nump, dimid) + + ! "level" dimensions + call ncd_defdim(lnfid, 'levgrnd', nlevgrnd, dimid) + call ncd_defdim(lnfid, 'levlak' , nlevlak, dimid) + call ncd_defdim(lnfid, 'numrad' , numrad , dimid) + + do n = 1,num_subs + call ncd_defdim(lnfid, subs_name(n), subs_dim(n), dimid) + end do + call ncd_defdim(lnfid, 'string_length', 8, strlen_dimid) + + if ( .not. lhistrest )then + call ncd_defdim(lnfid, 'hist_interval', 2, hist_interval_dimid) + call ncd_defdim(lnfid, 'time', ncd_unlimited, time_dimid) + nfid(t) = lnfid + if (masterproc)then + write(iulog,*) trim(subname), & + ' : Successfully defined netcdf history file ',t + call shr_sys_flush(iulog) + end if + else + ncid_hist(t) = lnfid + if (masterproc)then + write(iulog,*) trim(subname), & + ' : Successfully defined netcdf restart history file ',t + call shr_sys_flush(iulog) + end if + end if + + end subroutine htape_create + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: htape_timeconst3D +! +! !INTERFACE: + subroutine htape_timeconst3D(t, mode) +! +! !DESCRIPTION: +! Write time constant 3D variables to history tapes. +! Only write out when this subroutine is called (normally only for +! primary history files at very first time-step, nstep=0). +! Issue the required netcdf wrapper calls to define the history file +! contents. +! +! !USES: + use clmtype + use subgridAveMod , only : c2g + use clm_varpar , only : nlevgrnd + use shr_string_mod, only : shr_string_listAppend + use domainMod , only : ldomain +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + character(len=*), intent(in) :: mode ! 'define' or 'write' +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: c,l,lev,ifld ! indices + integer :: ier ! error status + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + character(len=max_chars) :: long_name ! variable long name + character(len=max_namlen):: varname ! variable name + character(len=max_namlen):: units ! variable units + character(len=8) :: l2g_scale_type ! scale type for subgrid averaging of landunits to grid cells + real(r8), pointer :: histi(:,:) ! temporary + real(r8), pointer :: histo(:,:) ! temporary + type(landunit_type), pointer :: lptr ! pointer to landunit derived subtype + type(column_type) , pointer :: cptr ! pointer to column derived subtype + integer, parameter :: nflds = 6 ! Number of 3D time-constant fields + character(len=*),parameter :: subname = 'htape_timeconst3D' + character(len=*),parameter :: varnames(nflds) = (/ & + 'ZSOI ', & + 'DZSOI ', & + 'WATSAT', & + 'SUCSAT', & + 'BSW ', & + 'HKSAT ' & + /) +!----------------------------------------------------------------------- + +!------------------------------------------------------------------------------- +!*** Non-time varying 3D fields *** +!*** Only write out when this subroutine is called *** +!*** Normally only called once for primary tapes *** +!------------------------------------------------------------------------------- + + if (mode == 'define') then + + do ifld = 1,nflds + ! Field indices MUST match varnames array order above! + if (ifld == 1) then + long_name='soil depth'; units = 'm' + else if (ifld == 2) then + long_name='soil thickness'; units = 'm' + else if (ifld == 3) then + long_name='saturated soil water content (porosity)'; units = 'mm3/mm3' + else if (ifld == 4) then + long_name='saturated soil matric potential'; units = 'mm' + else if (ifld == 5) then + long_name='slope of soil water retention curve'; units = 'unitless' + else if (ifld == 6) then + long_name='saturated hydraulic conductivity'; units = 'unitless' + else + call endrun( subname//' ERROR: bad 3D time-constant field index' ) + end if + if (tape(t)%dov2xy) then + if (ldomain%isgrid2d) then + call ncd_defvar(ncid=nfid(t), varname=trim(varnames(ifld)), xtype=tape(t)%ncprec,& + dim1name='lon', dim2name='lat', dim3name='levgrnd', & + long_name=long_name, units=units, missing_value=spval, fill_value=spval) + else + call ncd_defvar(ncid=nfid(t), varname=trim(varnames(ifld)), xtype=tape(t)%ncprec, & + dim1name=grlnd, dim2name='levgrnd', & + long_name=long_name, units=units, missing_value=spval, fill_value=spval) + end if + else + call ncd_defvar(ncid=nfid(t), varname=trim(varnames(ifld)), xtype=tape(t)%ncprec, & + dim1name=namec, dim2name='levgrnd', & + long_name=long_name, units=units, missing_value=spval, fill_value=spval) + end if + call shr_string_listAppend(TimeConst3DVars,varnames(ifld)) + end do + + else if (mode == 'write') then + + ! Set pointers into derived type and get necessary bounds + + lptr => clm3%g%l + cptr => clm3%g%l%c + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + allocate(histi(begc:endc,nlevgrnd), stat=ier) + if (ier /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation error for histi'; call endrun() + end if + + ! Write time constant fields + + if (tape(t)%dov2xy) then + allocate(histo(begg:endg,nlevgrnd), stat=ier) + if (ier /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation error for histo'; call endrun() + end if + end if + + do ifld = 1,nflds + + ! WJS (10-25-11): Note about l2g_scale_type in the following: ZSOI & DZSOI are + ! currently constant in space, except for urban points, so their scale type + ! doesn't matter at the moment as long as it excludes urban points. I am using + ! 'nonurb' so that the values are output everywhere where the fields are + ! constant (i.e., everywhere except urban points). For the other fields, I am + ! using 'veg' to be consistent with the l2g_scale_type that is now used for many + ! of the 3-d time-variant fields; in theory, though, one might want versions of + ! these variables output for different landunits. + + ! Field indices MUST match varnames array order above! + if (ifld == 1) then ! ZSOI + l2g_scale_type = 'nonurb' + else if (ifld == 2) then ! DZSOI + l2g_scale_type = 'nonurb' + else if (ifld == 3) then ! WATSAT + l2g_scale_type = 'veg' + else if (ifld == 4) then ! SUCSAT + l2g_scale_type = 'veg' + else if (ifld == 5) then ! BSW + l2g_scale_type = 'veg' + else if (ifld == 6) then ! HKSAT + l2g_scale_type = 'veg' + end if + + histi(:,:) = spval + do lev = 1,nlevgrnd + do c = begc, endc + l = cptr%landunit(c) + if (.not. lptr%lakpoi(l)) then + ! Field indices MUST match varnames array order above! + if (ifld ==1) histi(c,lev) = cptr%cps%z(c,lev) + if (ifld ==2) histi(c,lev) = cptr%cps%dz(c,lev) + if (ifld ==3) histi(c,lev) = cptr%cps%watsat(c,lev) + if (ifld ==4) histi(c,lev) = cptr%cps%sucsat(c,lev) + if (ifld ==5) histi(c,lev) = cptr%cps%bsw(c,lev) + if (ifld ==6) histi(c,lev) = cptr%cps%hksat(c,lev) + end if + end do + end do + if (tape(t)%dov2xy) then + histo(:,:) = spval + call c2g(begc, endc, begl, endl, begg, endg, nlevgrnd, histi, histo, & + c2l_scale_type='unity', l2g_scale_type=l2g_scale_type) + + if (ldomain%isgrid2d) then + call ncd_io(varname=trim(varnames(ifld)), dim1name=grlnd, & + data=histo, ncid=nfid(t), flag='write') + else + call ncd_io(varname=trim(varnames(ifld)), dim1name=grlnd, & + data=histo, ncid=nfid(t), flag='write') + end if + else + call ncd_io(varname=trim(varnames(ifld)), dim1name=namec, & + data=histi, ncid=nfid(t), flag='write') + end if + end do + + if (tape(t)%dov2xy) deallocate(histo) + deallocate(histi) + + end if ! (define/write mode + + end subroutine htape_timeconst3D + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: htape_timeconst +! +! !INTERFACE: + subroutine htape_timeconst(t, mode) +! +! !DESCRIPTION: +! Write time constant values to primary history tape. +! Issue the required netcdf wrapper calls to define the history file +! contents. +! +! !USES: + use clmtype + use clm_varcon , only : zsoi, zlak, secspday + use domainMod , only : ldomain, lon1d, lat1d + use clm_time_manager, only : get_nstep, get_curr_date, get_curr_time + use clm_time_manager, only : get_ref_date +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + character(len=*), intent(in) :: mode ! 'define' or 'write' +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: vid,n,i,j,m ! indices + integer :: nstep ! current step + integer :: mcsec ! seconds of current date + integer :: mdcur ! current day + integer :: mscur ! seconds of current day + integer :: mcdate ! current date + integer :: yr,mon,day,nbsec ! year,month,day,seconds components of a date + integer :: hours,minutes,secs ! hours,minutes,seconds of hh:mm:ss + character(len= 10) :: basedate ! base date (yyyymmdd) + character(len= 8) :: basesec ! base seconds + character(len= 8) :: cdate ! system date + character(len= 8) :: ctime ! system time + real(r8):: time ! current time + real(r8):: timedata(2) ! time interval boundaries + integer :: dim1id(1) ! netCDF dimension id + integer :: dim2id(2) ! netCDF dimension id + integer :: varid ! netCDF variable id + type(Var_desc_t) :: vardesc ! netCDF variable description + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + character(len=max_chars) :: long_name ! variable long name + character(len=max_namlen):: varname ! variable name + character(len=max_namlen):: units ! variable units + character(len=256):: str ! global attribute string + real(r8), pointer :: histo(:,:) ! temporary + type(landunit_type), pointer :: lptr ! pointer to landunit derived subtype + type(column_type) , pointer :: cptr ! pointer to column derived subtype + integer :: status + + character(len=*),parameter :: subname = 'htape_timeconst' +!----------------------------------------------------------------------- + + !------------------------------------------------------------------------------- + !*** Time constant grid variables only on first time-sample of file *** + !------------------------------------------------------------------------------- + if (tape(t)%ntimes == 1) then + if (mode == 'define') then + call ncd_defvar(varname='levgrnd', xtype=tape(t)%ncprec, & + dim1name='levgrnd', & + long_name='coordinate soil levels', units='m', ncid=nfid(t)) + call ncd_defvar(varname='levlak', xtype=tape(t)%ncprec, & + dim1name='levlak', & + long_name='coordinate lake levels', units='m', ncid=nfid(t)) + elseif (mode == 'write') then + call ncd_io(varname='levgrnd', data=zsoi , ncid=nfid(t), flag='write') + call ncd_io(varname='levlak' , data=zlak , ncid=nfid(t), flag='write') + endif + endif + + !------------------------------------------------------------------------------- + !*** Time definition variables *** + !------------------------------------------------------------------------------- + + ! For define mode -- only do this for first time-sample + if (mode == 'define' .and. tape(t)%ntimes == 1) then + call get_ref_date(yr, mon, day, nbsec) + nstep = get_nstep() + hours = nbsec / 3600 + minutes = (nbsec - hours*3600) / 60 + secs = (nbsec - hours*3600 - minutes*60) + write(basedate,80) yr,mon,day +80 format(i4.4,'-',i2.2,'-',i2.2) + write(basesec ,90) hours, minutes, secs +90 format(i2.2,':',i2.2,':',i2.2) + + dim1id(1) = time_dimid + str = 'days since ' // basedate // " " // basesec + call ncd_defvar(nfid(t), 'time', tape(t)%ncprec, 1, dim1id, varid, & + long_name='time',units=str) + call ncd_putatt(nfid(t), varid, 'calendar', 'noleap') + call ncd_putatt(nfid(t), varid, 'bounds', 'time_bounds') + + dim1id(1) = time_dimid + call ncd_defvar(nfid(t) , 'mcdate', ncd_int, 1, dim1id , varid, & + long_name = 'current date (YYYYMMDD)') + call ncd_defvar(nfid(t) , 'mcsec' , ncd_int, 1, dim1id , varid, & + long_name = 'current seconds of current date', units='s') + call ncd_defvar(nfid(t) , 'mdcur' , ncd_int, 1, dim1id , varid, & + long_name = 'current day (from base day)') + call ncd_defvar(nfid(t) , 'mscur' , ncd_int, 1, dim1id , varid, & + long_name = 'current seconds of current day') + call ncd_defvar(nfid(t) , 'nstep' , ncd_int, 1, dim1id , varid, & + long_name = 'time step') + + dim2id(1) = hist_interval_dimid; dim2id(2) = time_dimid + call ncd_defvar(nfid(t), 'time_bounds', ncd_double, 2, dim2id, varid, & + long_name = 'history time interval endpoints') + + dim2id(1) = strlen_dimid; dim2id(2) = time_dimid + call ncd_defvar(nfid(t), 'date_written', ncd_char, 2, dim2id, varid) + call ncd_defvar(nfid(t), 'time_written', ncd_char, 2, dim2id, varid) + + if ( len_trim(TimeConst3DVars_Filename) > 0 )then + call ncd_putatt(nfid(t), ncd_global, 'Time_constant_3Dvars_filename', & + trim(TimeConst3DVars_Filename)) + end if + if ( len_trim(TimeConst3DVars) > 0 )then + call ncd_putatt(nfid(t), ncd_global, 'Time_constant_3Dvars', & + trim(TimeConst3DVars)) + end if + + elseif (mode == 'write') then + + call get_curr_time (mdcur, mscur) + call get_curr_date (yr, mon, day, mcsec) + mcdate = yr*10000 + mon*100 + day + nstep = get_nstep() + + call ncd_io('mcdate', mcdate, 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('mcsec' , mcsec , 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('mdcur' , mdcur , 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('mscur' , mscur , 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('nstep' , nstep , 'write', nfid(t), nt=tape(t)%ntimes) + + time = mdcur + mscur/secspday + call ncd_io('time' , time , 'write', nfid(t), nt=tape(t)%ntimes) + + timedata(1) = tape(t)%begtime + timedata(2) = time + call ncd_io('time_bounds', timedata, 'write', nfid(t), nt=tape(t)%ntimes) + + call getdatetime (cdate, ctime) + call ncd_io('date_written', cdate, 'write', nfid(t), nt=tape(t)%ntimes) + + call ncd_io('time_written', ctime, 'write', nfid(t), nt=tape(t)%ntimes) + + endif + + !------------------------------------------------------------------------------- + !*** Grid definition variables *** + !------------------------------------------------------------------------------- + ! For define mode -- only do this for first time-sample + if (mode == 'define' .and. tape(t)%ntimes == 1) then + + if (ldomain%isgrid2d) then + call ncd_defvar(varname='lon', xtype=tape(t)%ncprec, dim1name='lon', & + long_name='coordinate longitude', units='degrees_east', & + ncid=nfid(t), missing_value=spval, fill_value=spval) + else + call ncd_defvar(varname='lon', xtype=tape(t)%ncprec, & + dim1name=grlnd, & + long_name='coordinate longitude', units='degrees_east', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + end if + if (ldomain%isgrid2d) then + call ncd_defvar(varname='lat', xtype=tape(t)%ncprec, dim1name='lat', & + long_name='coordinate latitude', units='degrees_north', & + ncid=nfid(t), missing_value=spval, fill_value=spval) + else + call ncd_defvar(varname='lat', xtype=tape(t)%ncprec, & + dim1name=grlnd, & + long_name='coordinate latitude', units='degrees_north', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + end if + if (ldomain%isgrid2d) then + call ncd_defvar(varname='area', xtype=tape(t)%ncprec, & + dim1name='lon', dim2name='lat',& + long_name='grid cell areas', units='km^2', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + else + call ncd_defvar(varname='area', xtype=tape(t)%ncprec, & + dim1name=grlnd, & + long_name='grid cell areas', units='km^2', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + end if + if (ldomain%isgrid2d) then + call ncd_defvar(varname='topo', xtype=tape(t)%ncprec, & + dim1name='lon', dim2name='lat',& + long_name='grid cell topography', units='m', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + else + call ncd_defvar(varname='topo', xtype=tape(t)%ncprec, & + dim1name=grlnd, & + long_name='grid cell topography', units='m', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + end if + if (ldomain%isgrid2d) then + call ncd_defvar(varname='landfrac', xtype=tape(t)%ncprec, & + dim1name='lon', dim2name='lat', & + long_name='land fraction', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + else + call ncd_defvar(varname='landfrac', xtype=tape(t)%ncprec, & + dim1name=grlnd, & + long_name='land fraction', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + end if + if (ldomain%isgrid2d) then + call ncd_defvar(varname='landmask', xtype=ncd_int, & + dim1name='lon', dim2name='lat', & + long_name='land/ocean mask (0.=ocean and 1.=land)', ncid=nfid(t), & + imissing_value=ispval, ifill_value=ispval) + else + call ncd_defvar(varname='landmask', xtype=ncd_int, & + dim1name=grlnd, & + long_name='land/ocean mask (0.=ocean and 1.=land)', ncid=nfid(t), & + imissing_value=ispval, ifill_value=ispval) + end if + if (ldomain%isgrid2d) then + call ncd_defvar(varname='pftmask' , xtype=ncd_int, & + dim1name='lon', dim2name='lat', & + long_name='pft real/fake mask (0.=fake and 1.=real)', ncid=nfid(t), & + imissing_value=ispval, ifill_value=ispval) + else + call ncd_defvar(varname='pftmask' , xtype=ncd_int, & + dim1name=grlnd, & + long_name='pft real/fake mask (0.=fake and 1.=real)', ncid=nfid(t), & + imissing_value=ispval, ifill_value=ispval) + end if + + else if (mode == 'write') then + + ! Most of this is constant and only needs to be done on tape(t)%ntimes=1 + ! But, some may change for dynamic PFT mode for example + ! Set pointers into derived type and get necessary bounds + + lptr => clm3%g%l + cptr => clm3%g%l%c + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + if (ldomain%isgrid2d) then + call ncd_io(varname='lon', data=lon1d, ncid=nfid(t), flag='write') + call ncd_io(varname='lat', data=lat1d, ncid=nfid(t), flag='write') + else + call ncd_io(varname='lon', data=ldomain%lonc, dim1name=grlnd, ncid=nfid(t), flag='write') + call ncd_io(varname='lat', data=ldomain%latc, dim1name=grlnd, ncid=nfid(t), flag='write') + end if + call ncd_io(varname='area' , data=ldomain%area, dim1name=grlnd, ncid=nfid(t), flag='write') + call ncd_io(varname='landfrac', data=ldomain%frac, dim1name=grlnd, ncid=nfid(t), flag='write') + call ncd_io(varname='landmask', data=ldomain%mask, dim1name=grlnd, ncid=nfid(t), flag='write') + call ncd_io(varname='pftmask' , data=ldomain%pftm, dim1name=grlnd, ncid=nfid(t), flag='write') + + end if ! (define/write mode + + end subroutine htape_timeconst + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hfields_write +! +! !INTERFACE: + subroutine hfields_write(t, mode) +! +! !DESCRIPTION: +! Write history tape. Issue the call to write the variable. +! +! !USES: + use clmtype + use domainMod , only : ldomain +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + character(len=*), intent(in) :: mode ! 'define' or 'write' +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + integer :: k ! 1d index + integer :: c,l,p ! indices + integer :: beg1d_out ! on-node 1d hbuf pointer start index + integer :: end1d_out ! on-node 1d hbuf pointer end index + integer :: num1d_out ! size of hbuf first dimension (overall all nodes) + integer :: num2d ! hbuf second dimension size + integer :: nt ! time index + integer :: ier ! error status + character(len=1) :: avgflag ! time averaging flag + character(len=max_chars) :: long_name! long name + character(len=max_chars) :: units ! units + character(len=max_namlen):: varname ! variable name + character(len=32) :: avgstr ! time averaging type + character(len=8) :: type1d_out ! history output 1d type + character(len=8) :: type2d ! history output 2d type + character(len=32) :: dim1name ! temporary + character(len=32) :: dim2name ! temporary + real(r8), pointer :: histo(:,:) ! temporary + real(r8), pointer :: hist1do(:) ! temporary + character(len=*),parameter :: subname = 'hfields_write' +!----------------------------------------------------------------------- + + ! Write/define 1d topological info + + if (.not. tape(t)%dov2xy) then + if (mode == 'define') then + call hfields_1dinfo(t, mode='define') + else if (mode == 'write') then + call hfields_1dinfo(t, mode='write') + end if + end if + + ! Define time-dependent variables create variables and attributes for field list + + do f = 1,tape(t)%nflds + + ! Set history field variables + + varname = tape(t)%hlist(f)%field%name + long_name = tape(t)%hlist(f)%field%long_name + units = tape(t)%hlist(f)%field%units + avgflag = tape(t)%hlist(f)%avgflag + type1d_out = tape(t)%hlist(f)%field%type1d_out + beg1d_out = tape(t)%hlist(f)%field%beg1d_out + end1d_out = tape(t)%hlist(f)%field%end1d_out + num1d_out = tape(t)%hlist(f)%field%num1d_out + type2d = tape(t)%hlist(f)%field%type2d + num2d = tape(t)%hlist(f)%field%num2d + nt = tape(t)%ntimes + + if (mode == 'define') then + + select case (avgflag) + case ('A') + avgstr = 'mean' + case ('I') + avgstr = 'instantaneous' + case ('X') + avgstr = 'maximum' + case ('M') + avgstr = 'minimum' + case default + write(iulog,*) trim(subname),' ERROR: unknown time averaging flag (avgflag)=',avgflag; call endrun() + end select + + if (type1d_out == grlnd) then + if (ldomain%isgrid2d) then + dim1name = 'lon' ; dim2name = 'lat' + else + dim1name = trim(grlnd); dim2name = 'undefined' + end if + else + dim1name = type1d_out ; dim2name = 'undefined' + endif + + if (dim2name == 'undefined') then + if (num2d == 1) then + call ncd_defvar(ncid=nfid(t), varname=varname, xtype=tape(t)%ncprec, & + dim1name=dim1name, dim2name='time', & + long_name=long_name, units=units, cell_method=avgstr, & + missing_value=spval, fill_value=spval) + else + call ncd_defvar(ncid=nfid(t), varname=varname, xtype=tape(t)%ncprec, & + dim1name=dim1name, dim2name=type2d, dim3name='time', & + long_name=long_name, units=units, cell_method=avgstr, & + missing_value=spval, fill_value=spval) + end if + else + if (num2d == 1) then + call ncd_defvar(ncid=nfid(t), varname=varname, xtype=tape(t)%ncprec, & + dim1name=dim1name, dim2name=dim2name, dim3name='time', & + long_name=long_name, units=units, cell_method=avgstr, & + missing_value=spval, fill_value=spval) + else + call ncd_defvar(ncid=nfid(t), varname=varname, xtype=tape(t)%ncprec, & + dim1name=dim1name, dim2name=dim2name, dim3name=type2d, dim4name='time', & + long_name=long_name, units=units, cell_method=avgstr, & + missing_value=spval, fill_value=spval) + end if + endif + + else if (mode == 'write') then + + ! Determine output buffer + + histo => tape(t)%hlist(f)%hbuf + + ! Allocate dynamic memory + + if (num2d == 1) then + allocate(hist1do(beg1d_out:end1d_out), stat=ier) + if (ier /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation'; call endrun() + end if + hist1do(beg1d_out:end1d_out) = histo(beg1d_out:end1d_out,1) + end if + + ! Write history output. Always output land and ocean runoff on xy grid. + + if (num2d == 1) then + call ncd_io(flag='write', varname=varname, & + dim1name=type1d_out, data=hist1do, ncid=nfid(t), nt=nt) + else + call ncd_io(flag='write', varname=varname, & + dim1name=type1d_out, data=histo, ncid=nfid(t), nt=nt) + end if + + + ! Deallocate dynamic memory + + if (num2d == 1) then + deallocate(hist1do) + end if + + end if + + end do + + end subroutine hfields_write + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hfields_1dinfo +! +! !INTERFACE: + subroutine hfields_1dinfo(t, mode) +! +! !DESCRIPTION: +! Write/define 1d info for history tape. +! +! !USES: + use clmtype + use decompMod , only : ldecomp + use domainMod , only : ldomain, ldomain +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + character(len=*), intent(in) :: mode ! 'define' or 'write' +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + integer :: k ! 1d index + integer :: g,c,l,p ! indices + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: ier ! errir status + real(r8), pointer :: rgarr(:) ! temporary + real(r8), pointer :: rcarr(:) ! temporary + real(r8), pointer :: rlarr(:) ! temporary + real(r8), pointer :: rparr(:) ! temporary + integer , pointer :: igarr(:) ! temporary + integer , pointer :: icarr(:) ! temporary + integer , pointer :: ilarr(:) ! temporary + integer , pointer :: iparr(:) ! temporary + type(file_desc_t) :: ncid ! netcdf file + type(gridcell_type), pointer :: gptr ! pointer to gridcell derived subtype + type(landunit_type), pointer :: lptr ! pointer to landunit derived subtype + type(column_type) , pointer :: cptr ! pointer to column derived subtype + type(pft_type) , pointer :: pptr ! pointer to pft derived subtype + character(len=*),parameter :: subname = 'hfields_1dinfo' +!----------------------------------------------------------------------- + + ncid = nfid(t) + + if (mode == 'define') then + + ! Define gridcell info + + call ncd_defvar(varname='grid1d_lon', xtype=ncd_double, dim1name=nameg, & + long_name='gridcell longitude', units='degrees_east', ncid=ncid) + + call ncd_defvar(varname='grid1d_lat', xtype=ncd_double, dim1name=nameg, & + long_name='gridcell latitude', units='degrees_north', ncid=ncid) + + call ncd_defvar(varname='grid1d_ixy', xtype=ncd_int, dim1name=nameg, & + long_name='2d longitude index of corresponding gridcell', ncid=ncid) + + call ncd_defvar(varname='grid1d_jxy', xtype=ncd_int, dim1name=nameg, & + long_name='2d latitude index of corresponding gridcell', ncid=ncid) + + ! Define landunit info + + call ncd_defvar(varname='land1d_lon', xtype=ncd_double, dim1name=namel, & + long_name='landunit longitude', units='degrees_east', ncid=ncid) + + call ncd_defvar(varname='land1d_lat', xtype=ncd_double, dim1name=namel, & + long_name='landunit latitude', units='degrees_north', ncid=ncid) + + call ncd_defvar(varname='land1d_ixy', xtype=ncd_int, dim1name=namel, & + long_name='2d longitude index of corresponding landunit', ncid=ncid) + + call ncd_defvar(varname='land1d_jxy', xtype=ncd_int, dim1name=namel, & + long_name='2d latitude index of corresponding landunit', ncid=ncid) + + ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 --- Bug 1310 + !call ncd_defvar(varname='land1d_gi', xtype=ncd_int, dim1name='landunit', & + ! long_name='1d grid index of corresponding landunit', ncid=ncid) + ! ---------------------------------------------------------------- + + call ncd_defvar(varname='land1d_wtgcell', xtype=ncd_double, dim1name=namel, & + long_name='landunit weight relative to corresponding gridcell', ncid=ncid) + + call ncd_defvar(varname='land1d_ityplunit', xtype=ncd_int, dim1name=namel, & + long_name='landunit type (vegetated,urban,lake,wetland,glacier or glacier_mec)', & + ncid=ncid) + + ! Define column info + + call ncd_defvar(varname='cols1d_lon', xtype=ncd_double, dim1name=namec, & + long_name='column longitude', units='degrees_east', ncid=ncid) + + call ncd_defvar(varname='cols1d_lat', xtype=ncd_double, dim1name=namec, & + long_name='column latitude', units='degrees_north', ncid=ncid) + + call ncd_defvar(varname='cols1d_ixy', xtype=ncd_int, dim1name=namec, & + long_name='2d longitude index of corresponding column', ncid=ncid) + + call ncd_defvar(varname='cols1d_jxy', xtype=ncd_int, dim1name=namec, & + long_name='2d latitude index of corresponding column', ncid=ncid) + + ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 --- Bug 1310 + !call ncd_defvar(varname='cols1d_gi', xtype=ncd_int, dim1name='column', & + ! long_name='1d grid index of corresponding column', ncid=ncid) + + !call ncd_defvar(varname='cols1d_li', xtype=ncd_int, dim1name='column', & + ! long_name='1d landunit index of corresponding column', ncid=ncid) + ! ---------------------------------------------------------------- + + call ncd_defvar(varname='cols1d_wtgcell', xtype=ncd_double, dim1name=namec, & + long_name='column weight relative to corresponding gridcell', ncid=ncid) + + call ncd_defvar(varname='cols1d_wtlunit', xtype=ncd_double, dim1name=namec, & + long_name='column weight relative to corresponding landunit', ncid=ncid) + + call ncd_defvar(varname='cols1d_itype_lunit', xtype=ncd_int, dim1name=namec, & + long_name='column landunit type (vegetated,urban,lake,wetland,glacier or glacier_mec)', & + ncid=ncid) + + ! Define pft info + + call ncd_defvar(varname='pfts1d_lon', xtype=ncd_double, dim1name=namep, & + long_name='pft longitude', units='degrees_east', ncid=ncid) + + call ncd_defvar(varname='pfts1d_lat', xtype=ncd_double, dim1name=namep, & + long_name='pft latitude', units='degrees_north', ncid=ncid) + + call ncd_defvar(varname='pfts1d_ixy', xtype=ncd_int, dim1name=namep, & + long_name='2d longitude index of corresponding pft', ncid=ncid) + + call ncd_defvar(varname='pfts1d_jxy', xtype=ncd_int, dim1name=namep, & + long_name='2d latitude index of corresponding pft', ncid=ncid) + + ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 --- Bug 1310 + !call ncd_defvar(varname='pfts1d_gi', xtype=ncd_int, dim1name='pft', & + ! long_name='1d grid index of corresponding pft', ncid=ncid) + + !call ncd_defvar(varname='pfts1d_li', xtype=ncd_int, dim1name='pft', & + ! long_name='1d landunit index of corresponding pft', ncid=ncid) + + !call ncd_defvar(varname='pfts1d_ci', xtype=ncd_int, dim1name='pft', & + ! long_name='1d column index of corresponding pft', ncid=ncid) + ! ---------------------------------------------------------------- + + call ncd_defvar(varname='pfts1d_wtgcell', xtype=ncd_double, dim1name=namep, & + long_name='pft weight relative to corresponding gridcell', ncid=ncid) + + call ncd_defvar(varname='pfts1d_wtlunit', xtype=ncd_double, dim1name=namep, & + long_name='pft weight relative to corresponding landunit', ncid=ncid) + + call ncd_defvar(varname='pfts1d_wtcol', xtype=ncd_double, dim1name=namep, & + long_name='pft weight relative to corresponding column', ncid=ncid) + + call ncd_defvar(varname='pfts1d_itype_veg', xtype=ncd_int, dim1name=namep, & + long_name='pft vegetation type', ncid=ncid) + + call ncd_defvar(varname='pfts1d_itype_lunit', xtype=ncd_int, dim1name=namep, & + long_name='pft landunit type (vegetated,urban,lake,wetland,glacier or glacier_mec)', & + ncid=ncid) + + else if (mode == 'write') then + + ! Set pointers into derived type + + gptr => clm3%g + lptr => clm3%g%l + cptr => clm3%g%l%c + pptr => clm3%g%l%c%p + + ! Determine bounds + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + allocate(rgarr(begg:endg),rlarr(begl:endl),rcarr(begc:endc),rparr(begp:endp),stat=ier) + if (ier /= 0) call endrun('hfields_1dinfo allocation error of rarrs') + + allocate(igarr(begg:endg),ilarr(begl:endl),icarr(begc:endc),iparr(begp:endp),stat=ier) + if (ier /= 0) call endrun('hfields_1dinfo allocation error of iarrs') + + ! Write gridcell info + + call ncd_io(varname='grid1d_lon', data=gptr%londeg, dim1name=nameg, ncid=ncid, flag='write') + call ncd_io(varname='grid1d_lat', data=gptr%latdeg, dim1name=nameg, ncid=ncid, flag='write') + do g=begg,endg + igarr(g)= mod(ldecomp%gdc2glo(g)-1,ldomain%ni) + 1 + enddo + call ncd_io(varname='grid1d_ixy', data=igarr , dim1name=nameg, ncid=ncid, flag='write') + do g=begg,endg + igarr(g)= (ldecomp%gdc2glo(g) - 1)/ldomain%ni + 1 + enddo + call ncd_io(varname='grid1d_jxy', data=igarr , dim1name=nameg, ncid=ncid, flag='write') + + ! Write landunit info + + do l=begl,endl + rlarr(l) = gptr%londeg(lptr%gridcell(l)) + enddo + call ncd_io(varname='land1d_lon', data=rlarr, dim1name=namel, ncid=ncid, flag='write') + do l=begl,endl + rlarr(l) = gptr%latdeg(lptr%gridcell(l)) + enddo + call ncd_io(varname='land1d_lat', data=rlarr, dim1name=namel, ncid=ncid, flag='write') + do l=begl,endl + ilarr(l) = mod(ldecomp%gdc2glo(lptr%gridcell(l))-1,ldomain%ni) + 1 + enddo + call ncd_io(varname='land1d_ixy', data=ilarr, dim1name=namel, ncid=ncid, flag='write') + do l=begl,endl + ilarr(l) = (ldecomp%gdc2glo(lptr%gridcell(l))-1)/ldomain%ni + 1 + enddo + call ncd_io(varname='land1d_jxy' , data=ilarr , dim1name=namel, ncid=ncid, flag='write') + ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 Bug 1310 + !call ncd_io(varname='land1d_gi' , data=lptr%gridcell, dim1name=namel, ncid=ncid, flag='write') + ! ---------------------------------------------------------------- + call ncd_io(varname='land1d_wtgcell' , data=lptr%wtgcell , dim1name=namel, ncid=ncid, flag='write') + call ncd_io(varname='land1d_ityplunit', data=lptr%itype , dim1name=namel, ncid=ncid, flag='write') + + ! Write column info + + do c=begc,endc + rcarr(c) = gptr%londeg(cptr%gridcell(c)) + enddo + call ncd_io(varname='cols1d_lon', data=rcarr, dim1name=namec, ncid=ncid, flag='write') + do c=begc,endc + rcarr(c) = gptr%latdeg(cptr%gridcell(c)) + enddo + call ncd_io(varname='cols1d_lat', data=rcarr, dim1name=namec, ncid=ncid, flag='write') + do c=begc,endc + icarr(c) = mod(ldecomp%gdc2glo(cptr%gridcell(c))-1,ldomain%ni) + 1 + enddo + call ncd_io(varname='cols1d_ixy', data=icarr, dim1name=namec, ncid=ncid, flag='write') + do c=begc,endc + icarr(c) = (ldecomp%gdc2glo(cptr%gridcell(c))-1)/ldomain%ni + 1 + enddo + call ncd_io(varname='cols1d_jxy' , data=icarr ,dim1name=namec, ncid=ncid, flag='write') + ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 Bug 1310 + !call ncd_io(varname='cols1d_gi' , data=cptr%gridcell, dim1name=namec, ncid=ncid, flag='write') + !call ncd_io(varname='cols1d_li' , data=cptr%landunit, dim1name=namec, ncid=ncid, flag='write') + ! ---------------------------------------------------------------- + call ncd_io(varname='cols1d_wtgcell', data=cptr%wtgcell , dim1name=namec, ncid=ncid, flag='write') + call ncd_io(varname='cols1d_wtlunit', data=cptr%wtlunit , dim1name=namec, ncid=ncid, flag='write') + do c=begc,endc + icarr(c) = lptr%itype(cptr%landunit(c)) + enddo + call ncd_io(varname='cols1d_itype_lunit', data=icarr , dim1name=namec, ncid=ncid, flag='write') + + ! Write pft info + + do p=begp,endp + rparr(p) = gptr%londeg(pptr%gridcell(p)) + enddo + call ncd_io(varname='pfts1d_lon', data=rparr, dim1name=namep, ncid=ncid, flag='write') + do p=begp,endp + rparr(p) = gptr%latdeg(pptr%gridcell(p)) + enddo + call ncd_io(varname='pfts1d_lat', data=rparr, dim1name=namep, ncid=ncid, flag='write') + do p=begp,endp + iparr(p) = mod(ldecomp%gdc2glo(pptr%gridcell(p))-1,ldomain%ni) + 1 + enddo + call ncd_io(varname='pfts1d_ixy', data=iparr, dim1name=namep, ncid=ncid, flag='write') + do p=begp,endp + iparr(p) = (ldecomp%gdc2glo(pptr%gridcell(p))-1)/ldomain%ni + 1 + enddo + call ncd_io(varname='pfts1d_jxy' , data=iparr , dim1name=namep, ncid=ncid, flag='write') + ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 --- Bug 1310 + !call ncd_io(varname='pfts1d_gi' , data=pptr%gridcell, dim1name=namep, ncid=ncid, flag='write') + !call ncd_io(varname='pfts1d_li' , data=pptr%landunit, dim1name=namep, ncid=ncid, flag='write') + !call ncd_io(varname='pfts1d_ci' , data=pptr%column , dim1name=namep, ncid=ncid, flag='write') + ! ---------------------------------------------------------------- + call ncd_io(varname='pfts1d_wtgcell' , data=pptr%wtgcell , dim1name=namep, ncid=ncid, flag='write') + call ncd_io(varname='pfts1d_wtlunit' , data=pptr%wtlunit , dim1name=namep, ncid=ncid, flag='write') + call ncd_io(varname='pfts1d_wtcol' , data=pptr%wtcol , dim1name=namep, ncid=ncid, flag='write') + call ncd_io(varname='pfts1d_itype_veg', data=pptr%itype , dim1name=namep, ncid=ncid, flag='write') + + do p=begp,endp + iparr(p) = lptr%itype(pptr%landunit(p)) + enddo + call ncd_io(varname='pfts1d_itype_lunit', data=iparr , dim1name=namep, ncid=ncid, flag='write') + + deallocate(rgarr,rlarr,rcarr,rparr) + deallocate(igarr,ilarr,icarr,iparr) + + end if + + end subroutine hfields_1dinfo + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_htapes_wrapup +! +! !INTERFACE: + subroutine hist_htapes_wrapup( rstwr, nlend ) +! +! !DESCRIPTION: +! Write history tape(s) +! Determine if next time step is beginning of history interval and if so: +! increment the current time sample counter, open a new history file +! and if needed (i.e., when ntim = 1), write history data to current +! history file, reset field accumulation counters to zero. +! If primary history file is full or at the last time step of the simulation, +! write restart dataset and close all history fiels. +! If history file is full or at the last time step of the simulation: +! close history file +! and reset time sample counter to zero if file is full. +! Daily-averaged data for the first day in September are written on +! date = 00/09/02 with mscur = 0. +! Daily-averaged data for the first day in month mm are written on +! date = yyyy/mm/02 with mscur = 0. +! Daily-averaged data for the 30th day (last day in September) are written +! on date = 0000/10/01 mscur = 0. +! Daily-averaged data for the last day in month mm are written on +! date = yyyy/mm+1/01 with mscur = 0. +! +! !USES: + use clm_time_manager, only : get_nstep, get_curr_date, get_curr_time, get_prev_date + use clm_varcon , only : secspday + use clmtype +! +! !ARGUMENTS: + implicit none + logical, intent(in) :: rstwr ! true => write restart file this step + logical, intent(in) :: nlend ! true => end of run on this step +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: t ! tape index + integer :: f ! field index + integer :: ier ! error code + integer :: nstep ! current step + integer :: day ! current day (1 -> 31) + integer :: mon ! current month (1 -> 12) + integer :: yr ! current year (0 -> ...) + integer :: mdcur ! current day + integer :: mscur ! seconds of current day + integer :: mcsec ! current time of day [seconds] + integer :: daym1 ! nstep-1 day (1 -> 31) + integer :: monm1 ! nstep-1 month (1 -> 12) + integer :: yrm1 ! nstep-1 year (0 -> ...) + integer :: mcsecm1 ! nstep-1 time of day [seconds] + real(r8):: time ! current time + character(len=256) :: str ! global attribute string + logical :: if_stop ! true => last time step of run + logical, save :: do_3Dtconst = .true. ! true => write out 3D time-constant data + character(len=*),parameter :: subname = 'hist_htapes_wrapup' +!----------------------------------------------------------------------- + + ! get current step + + nstep = get_nstep() + + ! Set calendar for current time step + + call get_curr_date (yr, mon, day, mcsec) + call get_curr_time (mdcur, mscur) + time = mdcur + mscur/secspday + + ! Set calendar for current for previous time step + + call get_prev_date (yrm1, monm1, daym1, mcsecm1) + + ! Loop over active history tapes, create new history files if necessary + ! and write data to history files if end of history interval. + do t = 1, ntapes + + ! Skip nstep=0 if monthly average + + if (nstep==0 .and. tape(t)%nhtfrq==0) cycle + + ! Determine if end of history interval + tape(t)%is_endhist = .false. + if (tape(t)%nhtfrq==0) then !monthly average + if (mon /= monm1) tape(t)%is_endhist = .true. + else + if (mod(nstep,tape(t)%nhtfrq) == 0) tape(t)%is_endhist = .true. + end if + + ! If end of history interval + + if (tape(t)%is_endhist) then + + ! Normalize history buffer if time averaged + + call hfields_normalize(t) + + ! Increment current time sample counter. + + tape(t)%ntimes = tape(t)%ntimes + 1 + + ! Create history file if appropriate and build time comment + + ! If first time sample, generate unique history file name, open file, + ! define dims, vars, etc. + + if (tape(t)%ntimes == 1) then + locfnh(t) = set_hist_filename (hist_freq=tape(t)%nhtfrq, & + hist_mfilt=tape(t)%mfilt, hist_file=t) + if (masterproc) then + write(iulog,*) trim(subname),' : Creating history file ', trim(locfnh(t)), & + ' at nstep = ',get_nstep() + write(iulog,*)'calling htape_create for file t = ',t + endif + call htape_create (t) + + ! Define time-constant field variables + call htape_timeconst(t, mode='define') + + ! Define 3D time-constant field variables only to first primary tape + + if ( do_3Dtconst .and. t == 1 ) then + call htape_timeconst3D(t, mode='define') + TimeConst3DVars_Filename = trim(locfnh(t)) + end if + + ! Define model field variables + + call hfields_write(t, mode='define') + + ! Exit define model + call ncd_enddef(nfid(t)) + + endif + + ! Write time constant history variables + call htape_timeconst(t, mode='write') + + ! Write 3D time constant history variables only to first primary tape + if ( do_3Dtconst .and. t == 1 .and. tape(t)%ntimes == 1 )then + call htape_timeconst3D(t, mode='write') + do_3Dtconst = .false. + end if + + if (masterproc) then + write(iulog,*) + write(iulog,*) trim(subname),' : Writing current time sample to local history file ', & + trim(locfnh(t)),' at nstep = ',get_nstep(), & + ' for history time interval beginning at ', tape(t)%begtime, & + ' and ending at ',time + write(iulog,*) + call shr_sys_flush(iulog) + endif + + ! Update beginning time of next interval + + tape(t)%begtime = time + + ! Write history time samples + + call hfields_write(t, mode='write') + + ! Zero necessary history buffers + + call hfields_zero(t) + + end if + + end do ! end loop over history tapes + + ! Determine if file needs to be closed + + call hist_do_disp (ntapes, tape(:)%ntimes, tape(:)%mfilt, if_stop, if_disphist, rstwr, nlend) + + ! Close open history file + ! Auxilary files may have been closed and saved off without being full, + ! must reopen the files + + do t = 1, ntapes + if (if_disphist(t)) then + if (tape(t)%ntimes /= 0) then + if (masterproc) then + write(iulog,*) + write(iulog,*) trim(subname),' : Closing local history file ',& + trim(locfnh(t)),' at nstep = ', get_nstep() + write(iulog,*) + endif + call ncd_pio_closefile(nfid(t)) + if (.not.if_stop .and. (tape(t)%ntimes/=tape(t)%mfilt)) then + call ncd_pio_openfile (nfid(t), trim(locfnh(t)), ncd_write) + end if + else + if (masterproc) then + write(iulog,*) trim(subname),' : history tape ',t,': no open file to close' + end if + endif + endif + end do + + ! Reset number of time samples to zero if file is full + + do t = 1, ntapes + if (if_disphist(t) .and. tape(t)%ntimes==tape(t)%mfilt) then + tape(t)%ntimes = 0 + end if + end do + + end subroutine hist_htapes_wrapup + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_restart_ncd +! +! !INTERFACE: + subroutine hist_restart_ncd (ncid, flag, rdate) +! +! !DESCRIPTION: +! Read/write history file restart data. +! If the current history file(s) are not full, file(s) are opened +! so that subsequent time samples are added until the file is full. +! A new history file is used on a branch run. +! +! !USES: + use clm_varctl, only : nsrest, caseid, inst_suffix, nsrStartup, nsrBranch + use fileutils , only : getfil + use clmtype , only : grlnd, nameg, namel, namec, namep + use domainMod , only : ldomain + use clm_varpar, only : nlevgrnd, nlevlak, numrad +! +! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file + character(len=*) , intent(in) :: flag !'read' or 'write' + character(len=*) , intent(in), optional :: rdate ! restart file time stamp for name +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: max_nflds ! Max number of fields + integer :: num1d,beg1d,end1d ! 1d size, beginning and ending indices + integer :: num1d_out,beg1d_out,end1d_out ! 1d size, beginning and ending indices + integer :: num2d ! 2d size (e.g. number of vertical levels) + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: numa ! total number of atm cells across all processors + integer :: numg ! total number of gridcells across all processors + integer :: numl ! total number of landunits across all processors + integer :: numc ! total number of columns across all processors + integer :: nump ! total number of pfts across all processors + character(len=max_namlen) :: name ! variable name + character(len=max_namlen) :: name_acc ! accumulator variable name + character(len=max_namlen) :: long_name ! long name of variable + character(len=max_chars) :: long_name_acc ! long name for accumulator + character(len=max_chars) :: units ! units of variable + character(len=max_chars) :: units_acc ! accumulator units + character(len=max_chars) :: fname ! full name of history file + character(len=max_chars) :: locrest(max_tapes) ! local history restart file names + + character(len=max_namlen),allocatable :: tname(:) + character(len=max_chars), allocatable :: tunits(:),tlongname(:) + character(len=8), allocatable :: tmpstr(:,:) + character(len=1), allocatable :: tavgflag(:) + integer :: start(2) + + character(len=1) :: hnum ! history file index + character(len=8) :: type1d ! clm pointer 1d type + character(len=8) :: type1d_out ! history buffer 1d type + character(len=8) :: type2d ! history buffer 2d type + character(len=32) :: dim1name ! temporary + character(len=32) :: dim2name ! temporary + type(var_desc_t) :: name_desc ! variable descriptor for name + type(var_desc_t) :: longname_desc ! variable descriptor for long_name + type(var_desc_t) :: units_desc ! variable descriptor for units + type(var_desc_t) :: type1d_desc ! variable descriptor for type1d + type(var_desc_t) :: type1d_out_desc ! variable descriptor for type1d_out + type(var_desc_t) :: type2d_desc ! variable descriptor for type2d + type(var_desc_t) :: avgflag_desc ! variable descriptor for avgflag + type(var_desc_t) :: p2c_scale_type_desc ! variable descriptor for p2c_scale_type + type(var_desc_t) :: c2l_scale_type_desc ! variable descriptor for c2l_scale_type + type(var_desc_t) :: l2g_scale_type_desc ! variable descriptor for l2g_scale_type + integer :: status ! error status + integer :: dimid ! dimension ID + integer :: k ! 1d index + integer :: t ! tape index + integer :: f ! field index + integer :: varid ! variable id + integer, allocatable :: itemp2d(:,:) ! 2D temporary + real(r8), pointer :: hbuf(:,:) ! history buffer + real(r8), pointer :: hbuf1d(:) ! 1d history buffer + integer , pointer :: nacs(:,:) ! accumulation counter + integer , pointer :: nacs1d(:) ! 1d accumulation counter + character(len=*),parameter :: subname = 'hist_restart_ncd' +!------------------------------------------------------------------------ + + ! If branch run, initialize file times and return + + if (flag == 'read') then + if (nsrest == nsrBranch) then + do t = 1,ntapes + tape(t)%ntimes = 0 + end do + RETURN + end if + ! If startup run just return + if (nsrest == nsrStartup) then + RETURN + end if + endif + + ! Read history file data only for restart run (not for branch run) + + ! + ! First when writing out and in define mode, create files and define all variables + ! + !================================================ + if (flag == 'define') then + !================================================ + + if (.not. present(rdate)) then + call endrun('variable rdate must be present for writing restart files') + end if + + ! + ! On master restart file add ntapes/max_chars dimension + ! and then add the history and history restart filenames + ! + call ncd_defdim( ncid, 'ntapes' , ntapes , dimid) + call ncd_defdim( ncid, 'max_chars' , max_chars , dimid) + + call ncd_defvar(ncid=ncid, varname='locfnh', xtype=ncd_char, & + long_name="History filename", & + comment="This variable NOT needed for startup or branch simulations", & + dim1name='max_chars', dim2name="ntapes" ) + call ncd_defvar(ncid=ncid, varname='locfnhr', xtype=ncd_char, & + long_name="Restart history filename", & + comment="This variable NOT needed for startup or branch simulations", & + dim1name='max_chars', dim2name="ntapes" ) + + ! max_nflds is the maximum number of fields on any tape + ! max_flds is the maximum number possible number of fields + + max_nflds = max_nFields() + + call get_proc_global(numg, numl, numc, nump) + + ! Loop over tapes - write out namelist information to each restart-history tape + ! only read/write accumulators and counters if needed + + do t = 1,ntapes + + ! + ! Create the restart history filename and open it + ! + write(hnum,'(i1.1)') t-1 + locfnhr(t) = "./" // trim(caseid) //".clm2"// trim(inst_suffix) & + // ".rh" // hnum //"."// trim(rdate) //".nc" + + call htape_create( t, histrest=.true. ) + + ! + ! Add read/write accumultators and counters if needed + ! + if (.not. tape(t)%is_endhist) then + do f = 1,tape(t)%nflds + name = tape(t)%hlist(f)%field%name + long_name = tape(t)%hlist(f)%field%long_name + units = tape(t)%hlist(f)%field%units + name_acc = trim(name) // "_acc" + units_acc = "unitless positive integer" + long_name_acc = trim(long_name) // " accumulator number of samples" + type1d_out = tape(t)%hlist(f)%field%type1d_out + type2d = tape(t)%hlist(f)%field%type2d + num2d = tape(t)%hlist(f)%field%num2d + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + if (type1d_out == grlnd) then + if (ldomain%isgrid2d) then + dim1name = 'lon' ; dim2name = 'lat' + else + dim1name = trim(grlnd); dim2name = 'undefined' + end if + else + dim1name = type1d_out ; dim2name = 'undefined' + endif + + if (dim2name == 'undefined') then + if (num2d == 1) then + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & + dim1name=dim1name, & + long_name=trim(long_name), units=trim(units)) + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & + dim1name=dim1name, & + long_name=trim(long_name_acc), units=trim(units_acc)) + else + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & + dim1name=dim1name, dim2name=type2d, & + long_name=trim(long_name), units=trim(units)) + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & + dim1name=dim1name, dim2name=type2d, & + long_name=trim(long_name_acc), units=trim(units_acc)) + end if + else + if (num2d == 1) then + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & + dim1name=dim1name, dim2name=dim2name, & + long_name=trim(long_name), units=trim(units)) + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & + dim1name=dim1name, dim2name=dim2name, & + long_name=trim(long_name_acc), units=trim(units_acc)) + else + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & + dim1name=dim1name, dim2name=dim2name, dim3name=type2d, & + long_name=trim(long_name), units=trim(units)) + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & + dim1name=dim1name, dim2name=dim2name, dim3name=type2d, & + long_name=trim(long_name_acc), units=trim(units_acc)) + end if + endif + end do + endif + + ! + ! Add namelist information to each restart history tape + ! + call ncd_defdim( ncid_hist(t), 'fname_lenp2' , max_namlen+2, dimid) + call ncd_defdim( ncid_hist(t), 'fname_len' , max_namlen , dimid) + call ncd_defdim( ncid_hist(t), 'len1' , 1 , dimid) + call ncd_defdim( ncid_hist(t), 'scalar' , 1 , dimid) + call ncd_defdim( ncid_hist(t), 'max_chars' , max_chars , dimid) + call ncd_defdim( ncid_hist(t), 'max_nflds' , max_nflds , dimid) + call ncd_defdim( ncid_hist(t), 'max_flds' , max_flds , dimid) + + call ncd_defvar(ncid=ncid_hist(t), varname='nhtfrq', xtype=ncd_int, & + long_name="Frequency of history writes", & + comment="Namelist item", & + units="absolute value of negative is in hours, 0=monthly, positive is time-steps", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='mfilt', xtype=ncd_int, & + long_name="Number of history time samples on a file", units="unitless", & + comment="Namelist item", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='ncprec', xtype=ncd_int, & + long_name="Flag for data precision", flag_values=(/1,2/), & + comment="Namelist item", & + nvalid_range=(/1,2/), & + flag_meanings=(/"single-precision", "double-precision"/), & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='dov2xy', xtype=ncd_log, & + long_name="Output on 2D grid format (TRUE) or vector format (FALSE)", & + comment="Namelist item", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='fincl', xtype=ncd_char, & + comment="Namelist item", & + long_name="Fieldnames to include", & + dim1name='fname_lenp2', dim2name='max_flds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='fexcl', xtype=ncd_char, & + comment="Namelist item", & + long_name="Fieldnames to exclude", & + dim1name='fname_lenp2', dim2name='max_flds' ) + + call ncd_defvar(ncid=ncid_hist(t), varname='nflds', xtype=ncd_int, & + long_name="Number of fields on file", units="unitless", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='ntimes', xtype=ncd_int, & + long_name="Number of time steps on file", units="time-step", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='is_endhist', xtype=ncd_log, & + long_name="End of history file", dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='begtime', xtype=ncd_double, & + long_name="Beginning time", units="time units", & + dim1name='scalar') + + call ncd_defvar(ncid=ncid_hist(t), varname='num2d', xtype=ncd_int, & + long_name="Size of second dimension", units="unitless", & + dim1name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='hpindex', xtype=ncd_int, & + long_name="History pointer index", units="unitless", & + dim1name='max_nflds' ) + + call ncd_defvar(ncid=ncid_hist(t), varname='avgflag', xtype=ncd_char, & + long_name="Averaging flag", & + units="A=Average, X=Maximum, M=Minimum, I=Instantaneous", & + dim1name='len1', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='name', xtype=ncd_char, & + long_name="Fieldnames", & + dim1name='fname_len', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='long_name', xtype=ncd_char, & + long_name="Long descriptive names for fields", & + dim1name='max_chars', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='units', xtype=ncd_char, & + long_name="Units for each history field output", & + dim1name='max_chars', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='type1d', xtype=ncd_char, & + long_name="1st dimension type", & + dim1name='string_length', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='type1d_out', xtype=ncd_char, & + long_name="1st output dimension type", & + dim1name='string_length', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='type2d', xtype=ncd_char, & + long_name="2nd dimension type", & + dim1name='string_length', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='p2c_scale_type', xtype=ncd_char, & + long_name="PFT to column scale type", & + dim1name='string_length', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='c2l_scale_type', xtype=ncd_char, & + long_name="column to landunit scale type", & + dim1name='string_length', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='l2g_scale_type', xtype=ncd_char, & + long_name="landunit to gridpoint scale type", & + dim1name='string_length', dim2name='max_nflds' ) + + call ncd_enddef(ncid_hist(t)) + + end do ! end of ntapes loop + + RETURN + + ! + ! First write out namelist information to each restart history file + ! + !================================================ + else if (flag == 'write') then + !================================================ + + ! Add history filenames to master restart file + do t = 1,ntapes + call ncd_io('locfnh', locfnh(t), 'write', ncid, nt=t) + call ncd_io('locfnhr', locfnhr(t), 'write', ncid, nt=t) + end do + + fincl(:,1) = hist_fincl1(:) + fincl(:,2) = hist_fincl2(:) + fincl(:,3) = hist_fincl3(:) + fincl(:,4) = hist_fincl4(:) + fincl(:,5) = hist_fincl5(:) + fincl(:,6) = hist_fincl6(:) + + fexcl(:,1) = hist_fexcl1(:) + fexcl(:,2) = hist_fexcl2(:) + fexcl(:,3) = hist_fexcl3(:) + fexcl(:,4) = hist_fexcl4(:) + fexcl(:,5) = hist_fexcl5(:) + fexcl(:,6) = hist_fexcl6(:) + + max_nflds = max_nFields() + + start(1)=1 + + allocate(itemp2d(max_nflds,ntapes)) + + ! + ! Add history namelist data to each history restart tape + ! + do t = 1,ntapes + call ncd_io(varname='fincl', data=fincl(:,t), ncid=ncid_hist(t), flag='write') + + call ncd_io(varname='fexcl', data=fexcl(:,t), ncid=ncid_hist(t), flag='write') + + call ncd_io(varname='is_endhist', data=tape(t)%is_endhist, ncid=ncid_hist(t), flag='write') + + call ncd_io(varname='dov2xy', data=tape(t)%dov2xy, ncid=ncid_hist(t), flag='write') + + itemp2d(:,:) = 0 + do f=1,tape(t)%nflds + itemp2d(f,t) = tape(t)%hlist(f)%field%num2d + end do + call ncd_io(varname='num2d', data=itemp2d(:,t), ncid=ncid_hist(t), flag='write') + + itemp2d(:,:) = 0 + do f=1,tape(t)%nflds + itemp2d(f,t) = tape(t)%hlist(f)%field%hpindex + end do + call ncd_io(varname='hpindex', data=itemp2d(:,t), ncid=ncid_hist(t), flag='write') + + call ncd_io('nflds', tape(t)%nflds, 'write', ncid_hist(t) ) + call ncd_io('ntimes', tape(t)%ntimes, 'write', ncid_hist(t) ) + call ncd_io('nhtfrq', tape(t)%nhtfrq, 'write', ncid_hist(t) ) + call ncd_io('mfilt', tape(t)%mfilt, 'write', ncid_hist(t) ) + call ncd_io('ncprec', tape(t)%ncprec, 'write', ncid_hist(t) ) + call ncd_io('begtime', tape(t)%begtime, 'write', ncid_hist(t) ) + allocate(tmpstr(tape(t)%nflds,6 ),tname(tape(t)%nflds), & + tavgflag(tape(t)%nflds),tunits(tape(t)%nflds),tlongname(tape(t)%nflds)) + do f=1,tape(t)%nflds + tname(f) = tape(t)%hlist(f)%field%name + tunits(f) = tape(t)%hlist(f)%field%units + tlongname(f) = tape(t)%hlist(f)%field%long_name + tmpstr(f,1) = tape(t)%hlist(f)%field%type1d + tmpstr(f,2) = tape(t)%hlist(f)%field%type1d_out + tmpstr(f,3) = tape(t)%hlist(f)%field%type2d + tavgflag(f) = tape(t)%hlist(f)%avgflag + tmpstr(f,4) = tape(t)%hlist(f)%field%p2c_scale_type + tmpstr(f,5) = tape(t)%hlist(f)%field%c2l_scale_type + tmpstr(f,6) = tape(t)%hlist(f)%field%l2g_scale_type + end do + call ncd_io( 'name', tname, 'write',ncid_hist(t)) + call ncd_io('long_name', tlongname, 'write', ncid_hist(t)) + call ncd_io('units', tunits, 'write',ncid_hist(t)) + call ncd_io('type1d', tmpstr(:,1), 'write', ncid_hist(t)) + call ncd_io('type1d_out', tmpstr(:,2), 'write', ncid_hist(t)) + call ncd_io('type2d', tmpstr(:,3), 'write', ncid_hist(t)) + call ncd_io('avgflag',tavgflag , 'write', ncid_hist(t)) + call ncd_io('p2c_scale_type', tmpstr(:,4), 'write', ncid_hist(t)) + call ncd_io('c2l_scale_type', tmpstr(:,5), 'write', ncid_hist(t)) + call ncd_io('l2g_scale_type', tmpstr(:,6), 'write', ncid_hist(t)) + deallocate(tname,tlongname,tunits,tmpstr,tavgflag) + enddo + deallocate(itemp2d) + + ! + ! Read in namelist information + ! + !================================================ + else if (flag == 'read') then + !================================================ + + call ncd_inqdlen(ncid,dimid,ntapes, name='ntapes') + call ncd_io('locfnh', locfnh(1:ntapes), 'read', ncid ) + call ncd_io('locfnhr', locrest(1:ntapes), 'read', ncid ) + do t = 1,ntapes + call strip_null(locrest(t)) + call strip_null(locfnh(t)) + end do + + ! Determine necessary indices - the following is needed if model decomposition is different on restart + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + call get_proc_global(numg, numl, numc, nump) + + start(1)=1 + + do t = 1,ntapes + + call getfil( locrest(t), locfnhr(t), 0 ) + call ncd_pio_openfile (ncid_hist(t), trim(locfnhr(t)), ncd_nowrite) + + if ( t == 1 )then + + call ncd_inqdlen(ncid_hist(1),dimid,max_nflds,name='max_nflds') + + allocate(itemp2d(max_nflds,ntapes)) + end if + + call ncd_inqvid(ncid_hist(t), 'name', varid, name_desc) + call ncd_inqvid(ncid_hist(t), 'long_name', varid, longname_desc) + call ncd_inqvid(ncid_hist(t), 'units', varid, units_desc) + call ncd_inqvid(ncid_hist(t), 'type1d', varid, type1d_desc) + call ncd_inqvid(ncid_hist(t), 'type1d_out', varid, type1d_out_desc) + call ncd_inqvid(ncid_hist(t), 'type2d', varid, type2d_desc) + call ncd_inqvid(ncid_hist(t), 'avgflag', varid, avgflag_desc) + call ncd_inqvid(ncid_hist(t), 'p2c_scale_type', varid, p2c_scale_type_desc) + call ncd_inqvid(ncid_hist(t), 'c2l_scale_type', varid, c2l_scale_type_desc) + call ncd_inqvid(ncid_hist(t), 'l2g_scale_type', varid, l2g_scale_type_desc) + + call ncd_io(varname='fincl', data=fincl(:,t), ncid=ncid_hist(t), flag='read') + + call ncd_io(varname='fexcl', data=fexcl(:,t), ncid=ncid_hist(t), flag='read') + + call ncd_io('nflds', tape(t)%nflds, 'read', ncid_hist(t) ) + call ncd_io('ntimes', tape(t)%ntimes, 'read', ncid_hist(t) ) + call ncd_io('nhtfrq', tape(t)%nhtfrq, 'read', ncid_hist(t) ) + call ncd_io('mfilt', tape(t)%mfilt, 'read', ncid_hist(t) ) + call ncd_io('ncprec', tape(t)%ncprec, 'read', ncid_hist(t) ) + call ncd_io('begtime', tape(t)%begtime, 'read', ncid_hist(t) ) + + call ncd_io(varname='is_endhist', data=tape(t)%is_endhist, ncid=ncid_hist(t), flag='read') + call ncd_io(varname='dov2xy', data=tape(t)%dov2xy, ncid=ncid_hist(t), flag='read') + call ncd_io(varname='num2d', data=itemp2d(:,t), ncid=ncid_hist(t), flag='read') + do f=1,tape(t)%nflds + tape(t)%hlist(f)%field%num2d = itemp2d(f,t) + end do + + call ncd_io(varname='hpindex', data=itemp2d(:,t), ncid=ncid_hist(t), flag='read') + do f=1,tape(t)%nflds + tape(t)%hlist(f)%field%hpindex = itemp2d(f,t) + end do + + do f=1,tape(t)%nflds + start(2) = f + call ncd_io( name_desc, tape(t)%hlist(f)%field%name, & + 'read', ncid_hist(t), start ) + call ncd_io( longname_desc, tape(t)%hlist(f)%field%long_name, & + 'read', ncid_hist(t), start ) + call ncd_io( units_desc, tape(t)%hlist(f)%field%units, & + 'read', ncid_hist(t), start ) + call ncd_io( type1d_desc, tape(t)%hlist(f)%field%type1d, & + 'read', ncid_hist(t), start ) + call ncd_io( type1d_out_desc, tape(t)%hlist(f)%field%type1d_out, & + 'read', ncid_hist(t), start ) + call ncd_io( type2d_desc, tape(t)%hlist(f)%field%type2d, & + 'read', ncid_hist(t), start ) + call ncd_io( avgflag_desc, tape(t)%hlist(f)%avgflag, & + 'read', ncid_hist(t), start ) + call ncd_io( p2c_scale_type_desc, tape(t)%hlist(f)%field%p2c_scale_type, & + 'read', ncid_hist(t), start ) + call ncd_io( c2l_scale_type_desc, tape(t)%hlist(f)%field%c2l_scale_type, & + 'read', ncid_hist(t), start ) + call ncd_io( l2g_scale_type_desc, tape(t)%hlist(f)%field%l2g_scale_type, & + 'read', ncid_hist(t), start ) + call strip_null(tape(t)%hlist(f)%field%name) + call strip_null(tape(t)%hlist(f)%field%long_name) + call strip_null(tape(t)%hlist(f)%field%units) + call strip_null(tape(t)%hlist(f)%field%type1d) + call strip_null(tape(t)%hlist(f)%field%type1d_out) + call strip_null(tape(t)%hlist(f)%field%type2d) + call strip_null(tape(t)%hlist(f)%field%p2c_scale_type) + call strip_null(tape(t)%hlist(f)%field%c2l_scale_type) + call strip_null(tape(t)%hlist(f)%field%l2g_scale_type) + call strip_null(tape(t)%hlist(f)%avgflag) + + type1d_out = trim(tape(t)%hlist(f)%field%type1d_out) + select case (trim(type1d_out)) + case (grlnd) + num1d_out = numg + beg1d_out = begg + end1d_out = endg + case (nameg) + num1d_out = numg + beg1d_out = begg + end1d_out = endg + case (namel) + num1d_out = numl + beg1d_out = begl + end1d_out = endl + case (namec) + num1d_out = numc + beg1d_out = begc + end1d_out = endc + case (namep) + num1d_out = nump + beg1d_out = begp + end1d_out = endp + case default + write(iulog,*) trim(subname),' ERROR: read unknown 1d output type=',trim(type1d_out) + call endrun () + end select + + tape(t)%hlist(f)%field%num1d_out = num1d_out + tape(t)%hlist(f)%field%beg1d_out = beg1d_out + tape(t)%hlist(f)%field%end1d_out = end1d_out + + num2d = tape(t)%hlist(f)%field%num2d + allocate (tape(t)%hlist(f)%hbuf(beg1d_out:end1d_out,num2d), & + tape(t)%hlist(f)%nacs(beg1d_out:end1d_out,num2d), & + stat=status) + if (status /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation error for hbuf,nacs at t,f=',t,f + call endrun() + endif + tape(t)%hlist(f)%hbuf(:,:) = 0._r8 + tape(t)%hlist(f)%nacs(:,:) = 0 + + type1d = tape(t)%hlist(f)%field%type1d + select case (type1d) + case (grlnd) + num1d = numg + beg1d = begg + end1d = endg + case (nameg) + num1d = numg + beg1d = begg + end1d = endg + case (namel) + num1d = numl + beg1d = begl + end1d = endl + case (namec) + num1d = numc + beg1d = begc + end1d = endc + case (namep) + num1d = nump + beg1d = begp + end1d = endp + case default + write(iulog,*) trim(subname),' ERROR: read unknown 1d type=',type1d + call endrun () + end select + + tape(t)%hlist(f)%field%num1d = num1d + tape(t)%hlist(f)%field%beg1d = beg1d + tape(t)%hlist(f)%field%end1d = end1d + + end do ! end of flds loop + + ! If history file is not full, open it + + if (tape(t)%ntimes /= 0) then + call ncd_pio_openfile (nfid(t), trim(locfnh(t)), ncd_write) + end if + + end do ! end of tapes loop + + hist_fincl1(:) = fincl(:,1) + hist_fincl2(:) = fincl(:,2) + hist_fincl3(:) = fincl(:,3) + hist_fincl4(:) = fincl(:,4) + hist_fincl5(:) = fincl(:,5) + hist_fincl6(:) = fincl(:,6) + + hist_fexcl1(:) = fexcl(:,1) + hist_fexcl2(:) = fexcl(:,2) + hist_fexcl3(:) = fexcl(:,3) + hist_fexcl4(:) = fexcl(:,4) + hist_fexcl5(:) = fexcl(:,5) + hist_fexcl6(:) = fexcl(:,6) + + if ( allocated(itemp2d) ) deallocate(itemp2d) + + end if + + !====================================================================== + ! Read/write history file restart data. + ! If the current history file(s) are not full, file(s) are opened + ! so that subsequent time samples are added until the file is full. + ! A new history file is used on a branch run. + !====================================================================== + + if (flag == 'write') then + + do t = 1,ntapes + if (.not. tape(t)%is_endhist) then + + do f = 1,tape(t)%nflds + name = tape(t)%hlist(f)%field%name + name_acc = trim(name) // "_acc" + type1d_out = tape(t)%hlist(f)%field%type1d_out + type2d = tape(t)%hlist(f)%field%type2d + num2d = tape(t)%hlist(f)%field%num2d + beg1d_out = tape(t)%hlist(f)%field%beg1d_out + end1d_out = tape(t)%hlist(f)%field%end1d_out + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + if (num2d == 1) then + allocate(hbuf1d(beg1d_out:end1d_out), & + nacs1d(beg1d_out:end1d_out), stat=status) + if (status /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation'; call endrun() + end if + + hbuf1d(beg1d_out:end1d_out) = hbuf(beg1d_out:end1d_out,1) + nacs1d(beg1d_out:end1d_out) = nacs(beg1d_out:end1d_out,1) + + call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name), & + dim1name=type1d_out, data=hbuf1d) + call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name_acc), & + dim1name=type1d_out, data=nacs1d) + + deallocate(hbuf1d) + deallocate(nacs1d) + else + call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name), & + dim1name=type1d_out, data=hbuf) + call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name_acc), & + dim1name=type1d_out, data=nacs) + end if + + end do + + end if ! end of is_endhist block + + call ncd_pio_closefile(ncid_hist(t)) + + end do ! end of ntapes loop + + else if (flag == 'read') then + + ! Read history restart information if history files are not full + + do t = 1,ntapes + + if (.not. tape(t)%is_endhist) then + + do f = 1,tape(t)%nflds + name = tape(t)%hlist(f)%field%name + name_acc = trim(name) // "_acc" + type1d_out = tape(t)%hlist(f)%field%type1d_out + type2d = tape(t)%hlist(f)%field%type2d + num2d = tape(t)%hlist(f)%field%num2d + beg1d_out = tape(t)%hlist(f)%field%beg1d_out + end1d_out = tape(t)%hlist(f)%field%end1d_out + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + if (num2d == 1) then + allocate(hbuf1d(beg1d_out:end1d_out), & + nacs1d(beg1d_out:end1d_out), stat=status) + if (status /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation'; call endrun() + end if + + call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name), & + dim1name=type1d_out, data=hbuf1d) + call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name_acc), & + dim1name=type1d_out, data=nacs1d) + + hbuf(beg1d_out:end1d_out,1) = hbuf1d(beg1d_out:end1d_out) + nacs(beg1d_out:end1d_out,1) = nacs1d(beg1d_out:end1d_out) + + deallocate(hbuf1d) + deallocate(nacs1d) + else + call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name), & + dim1name=type1d_out, data=hbuf) + call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name_acc), & + dim1name=type1d_out, data=nacs) + end if + end do + + end if + + call ncd_pio_closefile(ncid_hist(t)) + + end do + + end if + + end subroutine hist_restart_ncd + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: max_nFields +! +! !INTERFACE: +integer function max_nFields() +! +! !DESCRIPTION: +! Get the maximum number of fields on all tapes. +! +! !ARGUMENTS: + implicit none +! +! !REVISION HISTORY: +! Created by Erik Kluzek +! +! +! !LOCAL VARIABLES: +!EOP + integer :: t ! index + character(len=*),parameter :: subname = 'max_nFields' +!----------------------------------------------------------------------- + max_nFields = 0 + do t = 1,ntapes + max_nFields = max(max_nFields, tape(t)%nflds) + end do + + return + +end function max_nFields + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: getname +! +! !INTERFACE: + character(len=max_namlen) function getname (inname) +! +! !DESCRIPTION: +! Retrieve name portion of inname. If an averaging flag separater character +! is present (:) in inname, lop it off. +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: inname +! +! !REVISION HISTORY: +! Created by Jim Rosinski +! +! +! !LOCAL VARIABLES: +!EOP + integer :: length + integer :: i + character(len=*),parameter :: subname = 'getname' +!----------------------------------------------------------------------- + + length = len (inname) + + if (length < max_namlen .or. length > max_namlen+2) then + write(iulog,*) trim(subname),' ERROR: bad length=',length + call endrun() + end if + + getname = ' ' + do i = 1,max_namlen + if (inname(i:i) == ':') exit + getname(i:i) = inname(i:i) + end do + + end function getname + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: getflag +! +! !INTERFACE: + character(len=1) function getflag (inname) +! +! !DESCRIPTION: +! Retrieve flag portion of inname. If an averaging flag separater character +! is present (:) in inname, return the character after it as the flag +! +! !ARGUMENTS: + implicit none + character(len=*) inname ! character string +! +! !REVISION HISTORY: +! Created by Jim Rosinski +! +! +! !LOCAL VARIABLES: +!EOP + integer :: length ! length of inname + integer :: i ! loop index + character(len=*),parameter :: subname = 'getflag' +!----------------------------------------------------------------------- + + length = len (inname) + + if (length < max_namlen .or. length > max_namlen+2) then + write(iulog,*) trim(subname),' ERROR: bad length=',length + call endrun() + end if + + getflag = ' ' + do i = 1,length + if (inname(i:i) == ':') then + getflag = inname(i+1:i+1) + exit + end if + end do + + end function getflag + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: list_index +! +! !INTERFACE: + subroutine list_index (list, name, index) +! +! !DESCRIPTION: +! +! !USES: +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: list(max_flds) ! input list of names, possibly ":" delimited + character(len=max_namlen), intent(in) :: name ! name to be searched for + integer, intent(out) :: index ! index of "name" in "list" +! +! !REVISION HISTORY: +! Created by Jim Rosinski +! +! +! !LOCAL VARIABLES: +!EOP + character(len=max_namlen) :: listname ! input name with ":" stripped off. + integer f ! field index + character(len=*),parameter :: subname = 'list_index' +!----------------------------------------------------------------------- + + ! Only list items + + index = 0 + do f=1,max_flds + listname = getname (list(f)) + if (listname == ' ') exit + if (listname == name) then + index = f + exit + end if + end do + + end subroutine list_index + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: set_hist_filename +! +! !INTERFACE: + character(len=256) function set_hist_filename (hist_freq, hist_mfilt, hist_file) +! +! !DESCRIPTION: +! Determine history dataset filenames. +! +! !USES: + use clm_varctl, only : caseid, inst_suffix + use clm_time_manager, only : get_curr_date, get_prev_date +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: hist_freq !history file frequency + integer, intent(in) :: hist_mfilt !history file number of time-samples + integer, intent(in) :: hist_file !history file index +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + character(len=256) :: cdate !date char string + character(len= 1) :: hist_index !p,1 or 2 (currently) + integer :: day !day (1 -> 31) + integer :: mon !month (1 -> 12) + integer :: yr !year (0 -> ...) + integer :: sec !seconds into current day + character(len=*),parameter :: subname = 'set_hist_filename' +!----------------------------------------------------------------------- + + if (hist_freq == 0 .and. hist_mfilt == 1) then !monthly + call get_prev_date (yr, mon, day, sec) + write(cdate,'(i4.4,"-",i2.2)') yr,mon + else !other + call get_curr_date (yr, mon, day, sec) + write(cdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr,mon,day,sec + endif + write(hist_index,'(i1.1)') hist_file - 1 + set_hist_filename = "./"//trim(caseid)//".clm2"//trim(inst_suffix)//& + ".h"//hist_index//"."//trim(cdate)//".nc" + + end function set_hist_filename + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_addfld1d +! +! !INTERFACE: + subroutine hist_addfld1d (fname, units, avgflag, long_name, type1d_out, & + ptr_gcell, ptr_lunit, ptr_col, ptr_pft, ptr_lnd, & + ptr_atm, p2c_scale_type, c2l_scale_type, & + l2g_scale_type, set_lake, set_urb, set_nourb, & + set_noglcmec, set_spec, default) +! +! !DESCRIPTION: +! Initialize a single level history field. The pointer, ptrhist, +! is a pointer to the clmtype array that the history buffer will use. +! The value of type1d passed to masterlist\_add\_fld determines which of the +! 1d type of the output and the beginning and ending indices the history +! buffer field). Default history contents for given field on all tapes +! are set by calling [masterlist\_make\_active] for the appropriate tape. +! After the masterlist is built, routine [htapes\_build] is called for an +! initial or branch run to initialize the actual history tapes. +! +! !USES: + use clmtype +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: fname ! field name + character(len=*), intent(in) :: units ! units of field + character(len=1), intent(in) :: avgflag ! time averaging flag + character(len=*), intent(in) :: long_name ! long name of field + character(len=*), optional, intent(in) :: type1d_out ! output type (from clmtype) + real(r8) , optional, pointer :: ptr_gcell(:) ! pointer to gridcell array + real(r8) , optional, pointer :: ptr_lunit(:) ! pointer to landunit array + real(r8) , optional, pointer :: ptr_col(:) ! pointer to column array + real(r8) , optional, pointer :: ptr_pft(:) ! pointer to pft array + real(r8) , optional, pointer :: ptr_lnd(:) ! pointer to lnd array + real(r8) , optional, pointer :: ptr_atm(:) ! pointer to atm array + real(r8) , optional, intent(in) :: set_lake ! value to set lakes to + real(r8) , optional, intent(in) :: set_urb ! value to set urban to + real(r8) , optional, intent(in) :: set_nourb ! value to set non-urban to + real(r8) , optional, intent(in) :: set_noglcmec ! value to set non-glacier_mec to + real(r8) , optional, intent(in) :: set_spec ! value to set special to + character(len=*), optional, intent(in) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column + character(len=*), optional, intent(in) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits + character(len=*), optional, intent(in) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells + character(len=*), optional, intent(in) :: default ! if set to 'inactive, field will not appear on primary tape +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: p,c,l,g ! indices + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: hpindex ! history buffer pointer index + character(len=8) :: l_type1d ! 1d data type + character(len=8) :: l_type1d_out ! 1d output type + character(len=8) :: scale_type_p2c ! scale type for subgrid averaging of pfts to column + character(len=8) :: scale_type_c2l ! scale type for subgrid averaging of columns to landunits + character(len=8) :: scale_type_l2g ! scale type for subgrid averaging of landunits to gridcells + character(len=*),parameter :: subname = 'hist_addfld1d' +!------------------------------------------------------------------------ + + ! Determine processor bounds + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + ! History buffer pointer + + hpindex = pointer_index() + + if (present(ptr_lnd)) then + l_type1d = grlnd + l_type1d_out = grlnd + clmptr_rs(hpindex)%ptr => ptr_lnd + + else if (present(ptr_gcell)) then + l_type1d = nameg + l_type1d_out = nameg + clmptr_rs(hpindex)%ptr => ptr_gcell + + else if (present(ptr_lunit)) then + l_type1d = namel + l_type1d_out = namel + clmptr_rs(hpindex)%ptr => ptr_lunit + if (present(set_lake)) then + do l = begl,endl + if (clm3%g%l%lakpoi(l)) ptr_lunit(l) = set_lake + end do + end if + if (present(set_urb)) then + do l = begl,endl + if (clm3%g%l%urbpoi(l)) ptr_lunit(l) = set_urb + end do + end if + if (present(set_nourb)) then + do l = begl,endl + if (.not.(clm3%g%l%urbpoi(l))) ptr_lunit(l) = set_nourb + end do + end if + if (present(set_spec)) then + do l = begl,endl + if (clm3%g%l%ifspecial(l)) ptr_lunit(l) = set_spec + end do + end if + + else if (present(ptr_col)) then + l_type1d = namec + l_type1d_out = namec + clmptr_rs(hpindex)%ptr => ptr_col + if (present(set_lake)) then + do c = begc,endc + l = clm3%g%l%c%landunit(c) + if (clm3%g%l%lakpoi(l)) ptr_col(c) = set_lake + end do + end if + if (present(set_urb)) then + do c = begc,endc + l = clm3%g%l%c%landunit(c) + if (clm3%g%l%urbpoi(l)) ptr_col(c) = set_urb + end do + end if + if (present(set_nourb)) then + do c = begc,endc + l = clm3%g%l%c%landunit(c) + if (.not.(clm3%g%l%urbpoi(l))) ptr_col(c) = set_nourb + end do + end if + if (present(set_spec)) then + do c = begc,endc + l = clm3%g%l%c%landunit(c) + if (clm3%g%l%ifspecial(l)) ptr_col(c) = set_spec + end do + end if + if (present(set_noglcmec)) then + do c = begc,endc + l = clm3%g%l%c%landunit(c) + if (.not.(clm3%g%l%glcmecpoi(l))) ptr_col(c) = set_noglcmec + end do + endif + + else if (present(ptr_pft)) then + l_type1d = namep + l_type1d_out = namep + clmptr_rs(hpindex)%ptr => ptr_pft + if (present(set_lake)) then + do p = begp,endp + l = clm3%g%l%c%p%landunit(p) + if (clm3%g%l%lakpoi(l)) ptr_pft(p) = set_lake + end do + end if + if (present(set_urb)) then + do p = begp,endp + l = clm3%g%l%c%p%landunit(p) + if (clm3%g%l%urbpoi(l)) ptr_pft(p) = set_urb + end do + end if + if (present(set_nourb)) then + do p = begp,endp + l = clm3%g%l%c%p%landunit(p) + if (.not.(clm3%g%l%urbpoi(l))) ptr_pft(p) = set_nourb + end do + end if + if (present(set_spec)) then + do p = begp,endp + l = clm3%g%l%c%p%landunit(p) + if (clm3%g%l%ifspecial(l)) ptr_pft(p) = set_spec + end do + end if + if (present(set_noglcmec)) then + do p = begp,endp + l = clm3%g%l%c%p%landunit(p) + if (.not.(clm3%g%l%glcmecpoi(l))) ptr_pft(p) = set_noglcmec + end do + end if + else + write(iulog,*) trim(subname),' ERROR: must specify a valid pointer index,', & + ' choices are [ptr_atm, ptr_lnd, ptr_gcell, ptr_lunit, ptr_col, ptr_pft] ' + call endrun() + + end if + + ! Set scaling factor + + scale_type_p2c = 'unity' + scale_type_c2l = 'unity' + scale_type_l2g = 'unity' + + if (present(p2c_scale_type)) scale_type_p2c = p2c_scale_type + if (present(c2l_scale_type)) scale_type_c2l = c2l_scale_type + if (present(l2g_scale_type)) scale_type_l2g = l2g_scale_type + if (present(type1d_out)) l_type1d_out = type1d_out + + ! Add field to masterlist + + call masterlist_addfld (fname=trim(fname), type1d=l_type1d, type1d_out=l_type1d_out, & + type2d='unset', num2d=1, & + units=units, avgflag=avgflag, long_name=long_name, hpindex=hpindex, & + p2c_scale_type=scale_type_p2c, c2l_scale_type=scale_type_c2l, l2g_scale_type=scale_type_l2g) + + if (present(default)) then + if (trim(default) == 'inactive') return + else + call masterlist_make_active (name=trim(fname), tape_index=1) + end if + + end subroutine hist_addfld1d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_addfld2d +! +! !INTERFACE: + subroutine hist_addfld2d (fname, type2d, units, avgflag, long_name, type1d_out, & + ptr_gcell, ptr_lunit, ptr_col, ptr_pft, ptr_lnd, ptr_atm, & + p2c_scale_type, c2l_scale_type, l2g_scale_type, & + set_lake, set_urb, set_nourb, set_spec, default) +! +! !DESCRIPTION: +! Initialize a single level history field. The pointer, ptrhist, +! is a pointer to the clmtype array that the history buffer will use. +! The value of type1d passed to masterlist\_add\_fld determines which of the +! 1d type of the output and the beginning and ending indices the history +! buffer field). Default history contents for given field on all tapes +! are set by calling [masterlist\_make\_active] for the appropriatae tape. +! After the masterlist is built, routine [htapes\_build] is called for an +! initial or branch run to initialize the actual history tapes. +! +! !USES: + use clmtype + use clm_varpar, only : nlevgrnd, nlevlak, numrad +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: fname ! field name + character(len=*), intent(in) :: type2d ! 2d output type + character(len=*), intent(in) :: units ! units of field + character(len=1), intent(in) :: avgflag ! time averaging flag + character(len=*), intent(in) :: long_name ! long name of field + character(len=*), optional, intent(in) :: type1d_out ! output type (from clmtype) + real(r8) , optional, pointer :: ptr_atm(:,:) ! pointer to atm array + real(r8) , optional, pointer :: ptr_lnd(:,:) ! pointer to lnd array + real(r8) , optional, pointer :: ptr_gcell(:,:) ! pointer to gridcell array + real(r8) , optional, pointer :: ptr_lunit(:,:) ! pointer to landunit array + real(r8) , optional, pointer :: ptr_col(:,:) ! pointer to column array + real(r8) , optional, pointer :: ptr_pft(:,:) ! pointer to pft array + real(r8) , optional, intent(in) :: set_lake ! value to set lakes to + real(r8) , optional, intent(in) :: set_urb ! value to set urban to + real(r8) , optional, intent(in) :: set_nourb ! value to set non-urban to + real(r8) , optional, intent(in) :: set_spec ! value to set special to + character(len=*), optional, intent(in) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column + character(len=*), optional, intent(in) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits + character(len=*), optional, intent(in) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells + character(len=*), optional, intent(in) :: default ! if set to 'inactive, field will not appear on primary tape +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: p,c,l,g ! indices + integer :: num2d ! size of second dimension (e.g. number of vertical levels) + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: hpindex ! history buffer index + character(len=8) :: l_type1d ! 1d data type + character(len=8) :: l_type1d_out ! 1d output type + character(len=8) :: scale_type_p2c ! scale type for subgrid averaging of pfts to column + character(len=8) :: scale_type_c2l ! scale type for subgrid averaging of columns to landunits + character(len=8) :: scale_type_l2g ! scale type for subgrid averaging of landunits to gridcells + character(len=*),parameter :: subname = 'hist_addfld2d' +!------------------------------------------------------------------------ + + ! Determine second dimension size + + select case (type2d) + case ('levgrnd') + num2d = nlevgrnd + case ('levlak') + num2d = nlevlak + case ('numrad') + num2d = numrad + case default + write(iulog,*) trim(subname),' ERROR: unsupported 2d type ',type2d, & + ' currently supported types for multi level fields are [levgrnd,levlak,numrad]' + call endrun() + end select + + ! Determine processor bounds + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + ! History buffer pointer + + hpindex = pointer_index() + + if (present(ptr_lnd)) then + l_type1d = grlnd + l_type1d_out = grlnd + clmptr_ra(hpindex)%ptr => ptr_lnd + + else if (present(ptr_gcell)) then + l_type1d = nameg + l_type1d_out = nameg + clmptr_ra(hpindex)%ptr => ptr_gcell + + else if (present(ptr_lunit)) then + l_type1d = namel + l_type1d_out = namel + clmptr_ra(hpindex)%ptr => ptr_lunit + if (present(set_lake)) then + do l = begl,endl + if (clm3%g%l%lakpoi(l)) ptr_lunit(l,:) = set_lake + end do + end if + if (present(set_urb)) then + do l = begl,endl + if (clm3%g%l%urbpoi(l)) ptr_lunit(l,:) = set_urb + end do + end if + if (present(set_nourb)) then + do l = begl,endl + if (.not.(clm3%g%l%urbpoi(l))) ptr_lunit(l,:) = set_nourb + end do + end if + if (present(set_spec)) then + do l = begl,endl + if (clm3%g%l%ifspecial(l)) ptr_lunit(l,:) = set_spec + end do + end if + + else if (present(ptr_col)) then + l_type1d = namec + l_type1d_out = namec + clmptr_ra(hpindex)%ptr => ptr_col + if (present(set_lake)) then + do c = begc,endc + l = clm3%g%l%c%landunit(c) + if (clm3%g%l%lakpoi(l)) ptr_col(c,:) = set_lake + end do + end if + if (present(set_urb)) then + do c = begc,endc + l = clm3%g%l%c%landunit(c) + if (clm3%g%l%urbpoi(l)) ptr_col(c,:) = set_urb + end do + end if + if (present(set_nourb)) then + do c = begc,endc + l = clm3%g%l%c%landunit(c) + if (.not.(clm3%g%l%urbpoi(l))) ptr_col(c,:) = set_nourb + end do + end if + if (present(set_spec)) then + do c = begc,endc + l = clm3%g%l%c%landunit(c) + if (clm3%g%l%ifspecial(l)) ptr_col(c,:) = set_spec + end do + end if + + else if (present(ptr_pft)) then + l_type1d = namep + l_type1d_out = namep + clmptr_ra(hpindex)%ptr => ptr_pft + if (present(set_lake)) then + do p = begp,endp + l = clm3%g%l%c%p%landunit(p) + if (clm3%g%l%lakpoi(l)) ptr_pft(p,:) = set_lake + end do + end if + if (present(set_urb)) then + do p = begp,endp + l = clm3%g%l%c%p%landunit(p) + if (clm3%g%l%urbpoi(l)) ptr_pft(p,:) = set_urb + end do + end if + if (present(set_nourb)) then + do p = begp,endp + l = clm3%g%l%c%p%landunit(p) + if (.not.(clm3%g%l%urbpoi(l))) ptr_pft(p,:) = set_nourb + end do + end if + if (present(set_spec)) then + do p = begp,endp + l = clm3%g%l%c%p%landunit(p) + if (clm3%g%l%ifspecial(l)) ptr_pft(p,:) = set_spec + end do + end if + + else + write(iulog,*) trim(subname),' ERROR: must specify a valid pointer index,', & + ' choices are ptr_atm, ptr_lnd, ptr_gcell, ptr_lunit, ptr_col, ptr_pft' + call endrun() + + end if + + ! Set scaling factor + + scale_type_p2c = 'unity' + scale_type_c2l = 'unity' + scale_type_l2g = 'unity' + + if (present(p2c_scale_type)) scale_type_p2c = p2c_scale_type + if (present(c2l_scale_type)) scale_type_c2l = c2l_scale_type + if (present(l2g_scale_type)) scale_type_l2g = l2g_scale_type + if (present(type1d_out)) l_type1d_out = type1d_out + + ! Add field to masterlist + + call masterlist_addfld (fname=trim(fname), type1d=l_type1d, type1d_out=l_type1d_out, & + type2d=type2d, num2d=num2d, & + units=units, avgflag=avgflag, long_name=long_name, hpindex=hpindex, & + p2c_scale_type=scale_type_p2c, c2l_scale_type=scale_type_c2l, l2g_scale_type=scale_type_l2g) + + if (present(default)) then + if (trim(default) == 'inactive') return + else + call masterlist_make_active (name=trim(fname), tape_index=1) + end if + + end subroutine hist_addfld2d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: pointer_index +! +! !INTERFACE: + integer function pointer_index () +! +! !DESCRIPTION: +! Set the current pointer index and increment the value of the index. +! +! !ARGUMENTS: + implicit none +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +!EOP + integer, save :: lastindex = 1 + character(len=*),parameter :: subname = 'pointer_index' +!----------------------------------------------------------------------- + + pointer_index = lastindex + lastindex = lastindex + 1 + if (lastindex > max_mapflds) then + write(iulog,*) trim(subname),' ERROR: ',& + ' lastindex = ',lastindex,' greater than max_mapflds= ',max_mapflds + call endrun() + endif + + end function pointer_index + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_add_subscript +! +! !INTERFACE: + subroutine hist_add_subscript(name, dim) +! +! !DESCRIPTION: +! Add a history variable to the output history tape. +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: name ! name of subscript + integer , intent(in) :: dim ! dimension of subscript +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + character(len=*),parameter :: subname = 'hist_add_subscript' +!----------------------------------------------------------------------- + + num_subs = num_subs + 1 + if (num_subs > max_subs) then + write(iulog,*) trim(subname),' ERROR: ',& + ' num_subs = ',num_subs,' greater than max_subs= ',max_subs + call endrun() + endif + subs_name(num_subs) = name + subs_dim(num_subs) = dim + + end subroutine hist_add_subscript + +!----------------------------------------------------------------------- + + subroutine strip_null(str) + character(len=*), intent(inout) :: str + integer :: i + do i=1,len(str) + if(ichar(str(i:i))==0) str(i:i)=' ' + end do + end subroutine strip_null + +!------------------------------------------------------------------------ +!BOP +! +! !ROUTINE: hist_do_disp +! +! !INTERFACE: + subroutine hist_do_disp (ntapes, hist_ntimes, hist_mfilt, if_stop, if_disphist, rstwr, nlend) +! +! !DESCRIPTION: +! Determine logic for closeing and/or disposing history file +! Sets values for if_disphist, if_stop (arguments) +! Remove history files unless this is end of run or +! history file is not full. +! +! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_sys_mod , only : shr_sys_abort + use clm_time_manager, only : is_last_step +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: ntapes !actual number of history tapes + integer, intent(in) :: hist_ntimes(ntapes) !current numbers of time samples on history tape + integer, intent(in) :: hist_mfilt(ntapes) !maximum number of time samples per tape + logical, intent(out) :: if_stop !true => last time step of run + logical, intent(out) :: if_disphist(ntapes) !true => save and dispose history file + logical, intent(in) :: rstwr + logical, intent(in) :: nlend + ! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: t ! history tape index + logical :: rest_now ! temporary + logical :: stop_now ! temporary +!------------------------------------------------------------------------ + + rest_now = .false. + stop_now = .false. + + if (nlend) stop_now = .true. + if (rstwr) rest_now = .true. + + if_stop = stop_now + + if (stop_now) then + ! End of run - dispose all history files + + if_disphist(1:ntapes) = .true. + + else if (rest_now) then + ! Restart - dispose all history files + + do t = 1,ntapes + if_disphist(t) = .true. + end do + else + ! Dispose + + if_disphist(1:ntapes) = .false. + do t = 1,ntapes + if (hist_ntimes(t) == hist_mfilt(t)) then + if_disphist(t) = .true. + endif + end do + endif + + end subroutine hist_do_disp + +end module histFileMod + diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.datm/datm_comp_mod.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.datm/datm_comp_mod.F90 new file mode 100644 index 0000000000..e787e7c298 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.datm/datm_comp_mod.F90 @@ -0,0 +1,1237 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1/models/atm/datm/datm_comp_mod.F90 + +#ifdef AIX +@PROCESS ALIAS_SIZE(805306368) +#endif +module datm_comp_mod + +! !USES: + + use shr_const_mod + use shr_sys_mod + use shr_kind_mod , only: IN=>SHR_KIND_IN, R8=>SHR_KIND_R8, & + CS=>SHR_KIND_CS, CL=>SHR_KIND_CL + use shr_file_mod , only: shr_file_getunit, shr_file_getlogunit, shr_file_getloglevel, & + shr_file_setlogunit, shr_file_setloglevel, shr_file_setio, & + shr_file_freeunit + use shr_cal_mod , only: shr_cal_date2julian + use shr_mpi_mod , only: shr_mpi_bcast + use mct_mod + use esmf + use perf_mod + + use shr_strdata_mod + use shr_dmodel_mod + use shr_pcdf_mod + use datm_shr_mod + + use seq_cdata_mod + use seq_infodata_mod + use seq_timemgr_mod + use seq_comm_mct , only: seq_comm_inst, seq_comm_name, seq_comm_suffix + use seq_flds_mod , only: seq_flds_a2x_fields, & + seq_flds_x2a_fields +! +! !PUBLIC TYPES: + implicit none + private ! except + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: datm_comp_init + public :: datm_comp_run + public :: datm_comp_final + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + + !--- other --- + character(CS) :: myModelName = 'atm' ! user defined model name + integer(IN) :: mpicom + integer(IN) :: COMPID ! mct comp id + integer(IN) :: my_task ! my task in mpi communicator mpicom + integer(IN) :: npes ! total number of tasks + integer(IN),parameter :: master_task=0 ! task number of master task + integer(IN) :: logunit ! logging unit number + integer :: inst_index ! number of current instance (ie. 1) + character(len=16) :: inst_name ! fullname of current instance (ie. "lnd_0001") + character(len=16) :: inst_suffix ! char string associated with instance + ! (ie. "_0001" or "") + character(CL) :: atm_mode ! mode + integer(IN) :: dbug = 0 ! debug level (higher is more) + logical :: firstcall = .true. ! first call logical + logical :: scmMode = .false. ! single column mode + real(R8) :: scmLat = shr_const_SPVAL ! single column lat + real(R8) :: scmLon = shr_const_SPVAL ! single column lon + integer :: phase ! phase of method + logical :: read_restart ! start from restart + real(R8) :: orbEccen ! orb eccentricity (unit-less) + real(R8) :: orbMvelpp ! orb moving vernal eq (radians) + real(R8) :: orbLambm0 ! orb mean long of perhelion (radians) + real(R8) :: orbObliqr ! orb obliquity (radians) + real(R8) :: tbotmax ! units detector + real(R8) :: tdewmax ! units detector + real(R8) :: anidrmax ! existance detector + integer(IN) :: iradsw ! radiation logical + character(CL) :: factorFn ! file containing correction factors + + character(len=*),parameter :: rpfile = 'rpointer.atm' + character(len=*),parameter :: nullstr = 'undefined' + + real(R8),parameter :: aerodep_spval = 1.e29_r8 ! special aerosol deposition + real(R8),parameter :: tKFrz = SHR_CONST_TKFRZ + real(R8),parameter :: degtorad = SHR_CONST_PI/180.0_R8 + real(R8),parameter :: pstd = SHR_CONST_PSTD ! standard pressure ~ Pa + real(R8),parameter :: stebol = SHR_CONST_STEBOL ! Stefan-Boltzmann constant ~ W/m^2/K^4 + real(R8),parameter :: rdair = SHR_CONST_RDAIR ! dry air gas constant ~ J/K/kg + real(R8),parameter :: avg_c0 = 61.846_R8 + real(R8),parameter :: avg_c1 = 1.107_R8 + real(R8),parameter :: amp_c0 = -21.841_R8 + real(R8),parameter :: amp_c1 = -0.447_R8 + real(R8),parameter :: phs_c0 = 0.298_R8 + real(R8),parameter :: dLWarc = -5.000_R8 + real(R8) ,save :: dTarc(12) + data dTarc / 0.49_R8, 0.06_R8,-0.73_R8, -0.89_R8,-0.77_R8,-1.02_R8, & + & -1.99_R8,-0.91_R8, 1.72_R8, 2.30_R8, 1.81_R8, 1.06_R8/ + + integer(IN) :: kz,ku,kv,ktbot,kptem,kshum,kdens,kpbot,kpslv,klwdn + integer(IN) :: krc,krl,ksc,ksl,kswndr,kswndf,kswvdr,kswvdf,kswnet,kco2p,kco2d + integer(IN) :: kbid,kbod,kbiw,koid,kood,koiw,kdw1,kdw2,kdw3,kdw4,kdd1,kdd2,kdd3,kdd4 + integer(IN) :: kanidr,kanidf,kavsdr,kavsdf + integer(IN) :: stbot,swind,sz,spbot,sshum,stdew,srh,slwdn,sswdn,sswdndf,sswdndr + integer(IN) :: sprecc,sprecl,sprecn,sco2p,sco2d,sswup,sprec,starcf + + type(shr_strdata_type) :: SDATM + type(mct_rearr) :: rearr + type(mct_avect) :: avstrm ! av of data from stream + integer(IN), pointer :: imask(:) + real(R8), pointer :: yc(:) + real(R8), pointer :: windFactor(:) + real(R8), pointer :: winddFactor(:) + real(R8), pointer :: qsatFactor(:) + + integer(IN),parameter :: ktrans = 56 + character(16),parameter :: avofld(1:ktrans) = & + (/"Sa_z ","Sa_u ","Sa_v ","Sa_tbot ", & + "Sa_ptem ","Sa_shum ","Sa_dens ","Sa_pbot ", & + "Sa_pslv ","Faxa_lwdn ","Faxa_rainc ","Faxa_rainl ", & + "Faxa_snowc ","Faxa_snowl ","Faxa_swndr ","Faxa_swvdr ", & + "Faxa_swndf ","Faxa_swvdf ","Faxa_swnet ","Sa_co2prog ", & + "Sa_co2diag ","Faxa_bcphidry ","Faxa_bcphodry ","Faxa_bcphiwet ", & + "Faxa_ocphidry ","Faxa_ocphodry ","Faxa_ocphiwet ","Faxa_dstwet1 ", & + "Faxa_dstwet2 ","Faxa_dstwet3 ","Faxa_dstwet4 ","Faxa_dstdry1 ", & + "Faxa_dstdry2 ","Faxa_dstdry3 ","Faxa_dstdry4 ", & + "Sx_tref ","Sx_qref ","Sx_avsdr ","Sx_anidr ", & + "Sx_avsdf ","Sx_anidf ","Sx_t ","So_t ", & + "Sl_snowh ","Sf_lfrac ","Sf_ifrac ","Sf_ofrac ", & + "Faxx_taux ","Faxx_tauy ","Faxx_lat ","Faxx_sen ", & + "Faxx_lwup ","Faxx_evap ","Fall_fco2_lnd ","Faoo_fco2_ocn ", & + "Faoo_fdms_ocn " /) + character(16),parameter :: avifld(1:ktrans) = & + (/"z ","u ","v ","tbot ", & + "ptem ","shum ","dens ","pbot ", & + "pslv ","lwdn ","rainc ","rainl ", & + "snowc ","snowl ","swndr ","swvdr ", & + "swndf ","swvdf ","swnet ","co2prog ", & + "co2diag ","bcphidry ","bcphodry ","bcphiwet ", & + "ocphidry ","ocphodry ","ocphiwet ","dstwet1 ", & + "dstwet2 ","dstwet3 ","dstwet4 ","dstdry1 ", & + "dstdry2 ","dstdry3 ","dstdry4 ", & + "tref ","qref ","avsdr ","anidr ", & + "avsdf ","anidf ","ts ","to ", & + "snowhl ","lfrac ","ifrac ","ofrac ", & + "taux ","tauy ","lat ","sen ", & + "lwup ","evap ","co2lnd ","co2ocn ", & + "dms " /) + + integer(IN),parameter :: ktranss = 19 + character(16),parameter :: stofld(1:ktranss) = & + (/"strm_tbot ","strm_wind ","strm_z ","strm_pbot ", & + "strm_shum ","strm_tdew ","strm_rh ","strm_lwdn ", & + "strm_swdn ","strm_swdndf ","strm_swdndr ","strm_precc ", & + "strm_precl ","strm_precn ","strm_co2prog ","strm_co2diag ", & + "strm_swup ","strm_prec ","strm_tarcf " /) + character(16),parameter :: stifld(1:ktranss) = & + (/"tbot ","wind ","z ","pbot ", & + "shum ","tdew ","rh ","lwdn ", & + "swdn ","swdndf ","swdndr ","precc ", & + "precl ","precn ","co2prog ","co2diag ", & + "swup ","prec ","tarcf " /) + + character(CL), pointer :: ilist_av(:) ! input list for translation + character(CL), pointer :: olist_av(:) ! output list for translation + character(CL), pointer :: ilist_st(:) ! input list for translation + character(CL), pointer :: olist_st(:) ! output list for translation + integer(IN) , pointer :: count_av(:) + integer(IN) , pointer :: count_st(:) + + save + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CONTAINS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: datm_comp_init +! +! !DESCRIPTION: +! initialize data atm model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine datm_comp_init( EClock, cdata, x2a, a2x, NLFilename ) + use shr_pio_mod, only : shr_pio_getiosys, shr_pio_getiotype + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) , intent(in) :: EClock + type(seq_cdata) , intent(inout) :: cdata + type(mct_aVect) , intent(inout) :: x2a, a2x + character(len=*), optional , intent(in) :: NLFilename ! Namelist filename + +!EOP + + !--- local variables --- + integer(IN) :: n,k ! generic counters + integer(IN) :: ierr ! error code + integer(IN) :: gsize ! global size + integer(IN) :: lsize ! local size + integer(IN) :: shrlogunit, shrloglev ! original log unit and level + integer(IN) :: nunit ! unit number + integer(IN) :: kmask ! field reference + integer(IN) :: klat ! field reference + integer(IN) :: kfld ! fld index + integer(IN) :: cnt ! counter + logical :: atm_present ! flag + logical :: atm_prognostic ! flag + + type(seq_infodata_type), pointer :: infodata + type(mct_gsMap) , pointer :: gsMap + type(mct_gGrid) , pointer :: ggrid + + character(CL) :: filePath ! generic file path + character(CL) :: fileName ! generic file name + character(CS) :: timeName ! domain file: time variable name + character(CS) :: lonName ! domain file: lon variable name + character(CS) :: latName ! domain file: lat variable name + character(CS) :: maskName ! domain file: mask variable name + character(CS) :: areaName ! domain file: area variable name + + integer(IN) :: yearFirst ! first year to use in data stream + integer(IN) :: yearLast ! last year to use in data stream + integer(IN) :: yearAlign ! data year that aligns with yearFirst + + character(CL) :: atm_in ! dshr atm namelist + character(CL) :: decomp ! decomp strategy + character(CL) :: rest_file ! restart filename + character(CL) :: rest_file_strm ! restart filename for streams + character(CL) :: restfilm ! model restart file namelist + character(CL) :: restfils ! stream restart file namelist + logical :: exists ! filename existance + integer(IN) :: nu ! unit number + integer(IN) :: idt ! integer timestep + integer(IN) :: CurrentYMD ! model date + integer(IN) :: CurrentTOD ! model sec into model date + integer(IN) :: stepno ! step number + real(R8) :: nextsw_cday ! calendar of next atm sw + character(CL) :: flds_strm + logical :: presaero ! true => send valid prescribe aero fields to coupler + character(CL) :: calendar ! calendar type + + !----- define namelist ----- + namelist / datm_nml / & + atm_in, decomp, iradsw, factorFn, restfilm, restfils, presaero + + !--- formats --- + character(*), parameter :: F00 = "('(datm_comp_init) ',8a)" + character(*), parameter :: F0L = "('(datm_comp_init) ',a, l2)" + character(*), parameter :: F01 = "('(datm_comp_init) ',a,5i8)" + character(*), parameter :: F02 = "('(datm_comp_init) ',a,4es13.6)" + character(*), parameter :: F03 = "('(datm_comp_init) ',a,i8,a)" + character(*), parameter :: F04 = "('(datm_comp_init) ',2a,2i8,'s')" + character(*), parameter :: F05 = "('(datm_comp_init) ',a,2f10.4)" + character(*), parameter :: F90 = "('(datm_comp_init) ',73('='))" + character(*), parameter :: F91 = "('(datm_comp_init) ',73('-'))" + character(*), parameter :: subName = "(datm_comp_init) " +!------------------------------------------------------------------------------- + + + call t_startf('DATM_INIT') + + ! Set cdata pointers + + call seq_cdata_setptrs(cdata, ID=COMPID, mpicom=mpicom, & + gsMap=gsmap, dom=ggrid, infodata=infodata) + call seq_infodata_getData(infodata,atm_phase=phase) + + inst_name = seq_comm_name(COMPID) + inst_index = seq_comm_inst(COMPID) + inst_suffix = seq_comm_suffix(COMPID) + + if (phase == 1) then + ! Determine communicator groups and sizes + call mpi_comm_rank(mpicom, my_task, ierr) + call mpi_comm_size(mpicom, npes, ierr) + + !--- open log file --- + if (my_task == master_task) then + logUnit = shr_file_getUnit() + call shr_file_setIO('atm_modelio.nml'//trim(inst_suffix),logUnit) + else + logUnit = 6 + endif + endif + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (logUnit) + + if (phase == 1) then + + !---------------------------------------------------------------------------- + ! Set a Few Defaults + !---------------------------------------------------------------------------- + + call seq_infodata_getData(infodata,single_column=scmMode, & + & scmlat=scmlat, scmlon=scmLon) + call seq_infodata_GetData(infodata,orb_eccen=orbEccen,orb_mvelpp=orbMvelpp, & + orb_lambm0=orbLambm0,orb_obliqr=orbObliqr ) + + atm_present = .false. + atm_prognostic = .false. + call seq_infodata_GetData(infodata,read_restart=read_restart) + + ! TJH this prevents the need to have a COUPLER restart file. + ! TJH From an email to Bill Sacks from Tony Craig dated 2011/8/12 + ! TJH one line change to models/atm/datm/datm_comp_mod.F90 + + read_restart = .false. + + !---------------------------------------------------------------------------- + ! Read datm_in + !---------------------------------------------------------------------------- + + call t_startf('datm_readnml') + + filename = "datm_in"//trim(inst_suffix) + atm_in = "unset" + decomp = "1d" + iradsw = 0 + factorFn = 'null' + restfilm = trim(nullstr) + restfils = trim(nullstr) + presaero = .false. + if (my_task == master_task) then + nunit = shr_file_getUnit() ! get unused unit number + open (nunit,file=trim(filename),status="old",action="read") + read (nunit,nml=datm_nml,iostat=ierr) + close(nunit) + call shr_file_freeUnit(nunit) + if (ierr > 0) then + write(logunit,F01) 'ERROR: reading input namelist, '//trim(filename)//' iostat=',ierr + call shr_sys_abort(subName//': namelist read error '//trim(filename)) + end if + write(logunit,F00)' atm_in = ',trim(atm_in) + write(logunit,F00)' decomp = ',trim(decomp) + write(logunit,F01)' iradsw = ',iradsw + write(logunit,F00)' factorFn = ',trim(factorFn) + write(logunit,F00)' restfilm = ',trim(restfilm) + write(logunit,F00)' restfils = ',trim(restfils) + write(logunit,F0L)' presaero = ',presaero + write(logunit,F01) 'inst_index = ',inst_index + write(logunit,F00) 'inst_name = ',trim(inst_name) + write(logunit,F00) 'inst_suffix = ',trim(inst_suffix) + call shr_sys_flush(logunit) + endif + call shr_mpi_bcast(atm_in,mpicom,'atm_in') + call shr_mpi_bcast(decomp,mpicom,'decomp') + call shr_mpi_bcast(iradsw,mpicom,'iradsw') + call shr_mpi_bcast(factorFn,mpicom,'factorFn') + call shr_mpi_bcast(restfilm,mpicom,'restfilm') + call shr_mpi_bcast(restfils,mpicom,'restfils') + call shr_mpi_bcast(presaero,mpicom,'presaero') + + rest_file = trim(restfilm) + rest_file_strm = trim(restfils) + + !---------------------------------------------------------------------------- + ! Read dshr namelist + !---------------------------------------------------------------------------- + + call shr_strdata_readnml(SDATM,trim(atm_in),mpicom=mpicom) + call shr_sys_flush(shrlogunit) + + !---------------------------------------------------------------------------- + ! Initialize PIO + !---------------------------------------------------------------------------- + + call shr_strdata_pioinit(SDATM, shr_pio_getiosys(trim(inst_name)), & + shr_pio_getiotype(trim(inst_name))) + + !---------------------------------------------------------------------------- + ! Validate mode + !---------------------------------------------------------------------------- + + atm_mode = trim(SDATM%dataMode) + + ! check that we know how to handle the mode + + if (trim(atm_mode) == 'NULL' .or. & + trim(atm_mode) == 'CORE2_NYF' .or. & + trim(atm_mode) == 'CORE2_IAF' .or. & + trim(atm_mode) == 'WRF' .or. & + trim(atm_mode) == 'CLMNCEP' .or. & + trim(atm_mode) == 'CPLHIST' .or. & + trim(atm_mode) == 'COPYALL' ) then + if (my_task == master_task) then + write(logunit,F00) ' atm mode = ',trim(atm_mode) + call shr_sys_flush(logunit) + end if + else + write(logunit,F00) ' ERROR illegal atm mode = ',trim(atm_mode) + call shr_sys_abort() + endif + + call t_stopf('datm_readnml') + + !---------------------------------------------------------------------------- + ! Initialize datasets + !---------------------------------------------------------------------------- + + call t_startf('datm_strdata_init') + + if (trim(atm_mode) /= 'NULL') then + atm_present = .true. + call seq_timemgr_EClockGetData( EClock, dtime=idt, calendar=calendar ) + if (scmmode) then + if (my_task == master_task) & + write(logunit,F05) ' scm lon lat = ',scmlon,scmlat + call shr_strdata_init(SDATM,mpicom,compid,name='atm', & + scmmode=scmmode,scmlon=scmlon,scmlat=scmlat, & + calendar=calendar) + else + call shr_strdata_init(SDATM,mpicom,compid,name='atm', & + calendar=calendar) + endif + if (my_task == master_task) call shr_sys_flush(shrlogunit) + !--- overwrite mask and frac --- + k = mct_aVect_indexRA(SDATM%grid%data,'mask') + SDATM%grid%data%rAttr(k,:) = 1.0_R8 + k = mct_aVect_indexRA(SDATM%grid%data,'frac') + SDATM%grid%data%rAttr(k,:) = 1.0_R8 + + !--- set data needed for cosz t-interp method --- + + call shr_strdata_setOrbs(SDATM,orbEccen,orbMvelpp,orbLambm0,orbObliqr,idt) + endif + + if (my_task == master_task) then + call shr_strdata_print(SDATM,'ATM data') + call shr_sys_flush(shrlogunit) + endif + + call t_stopf('datm_strdata_init') + + !---------------------------------------------------------------------------- + ! Set flag to specify data components + !---------------------------------------------------------------------------- + + call seq_infodata_PutData(infodata, & + atm_present=atm_present, atm_prognostic=atm_prognostic, & + atm_nx=SDATM%nxg, atm_ny=SDATM%nyg ) + call seq_infodata_PutData( infodata, atm_aero=presaero) + + !---------------------------------------------------------------------------- + ! Initialize MCT global seg map, 1d decomp + !---------------------------------------------------------------------------- + + call t_startf('datm_initgsmaps') + if (my_task == master_task) write(logunit,F00) ' initialize gsmaps' + call shr_sys_flush(logunit) + + call shr_dmodel_gsmapcreate(gsmap,SDATM%nxg*SDATM%nyg,compid,mpicom,decomp) + call shr_sys_flush(shrlogunit) + lsize = mct_gsmap_lsize(gsmap,mpicom) + + if (atm_present) then + call mct_rearr_init(SDATM%gsmap,gsmap,mpicom,rearr) + endif + + call t_stopf('datm_initgsmaps') + + !---------------------------------------------------------------------------- + ! Initialize MCT domain + !---------------------------------------------------------------------------- + + call t_startf('datm_initmctdom') + if (my_task == master_task) write(logunit,F00) 'copy domains' + call shr_sys_flush(logunit) + + if (atm_present)then + call shr_dmodel_rearrGGrid(SDATM%grid, ggrid, gsmap, rearr, mpicom) + call shr_sys_flush(shrlogunit) + end if + + call t_stopf('datm_initmctdom') + + !---------------------------------------------------------------------------- + ! Initialize MCT attribute vectors + !---------------------------------------------------------------------------- + + call t_startf('datm_initmctavs') + if (my_task == master_task) write(logunit,F00) 'allocate AVs' + call shr_sys_flush(logunit) + + call mct_aVect_init(a2x, rList=seq_flds_a2x_fields, lsize=lsize) + call mct_aVect_zero(a2x) + + kz = mct_aVect_indexRA(a2x,'Sa_z') + ku = mct_aVect_indexRA(a2x,'Sa_u') + kv = mct_aVect_indexRA(a2x,'Sa_v') + ktbot = mct_aVect_indexRA(a2x,'Sa_tbot') + kptem = mct_aVect_indexRA(a2x,'Sa_ptem') + kshum = mct_aVect_indexRA(a2x,'Sa_shum') + kdens = mct_aVect_indexRA(a2x,'Sa_dens') + kpbot = mct_aVect_indexRA(a2x,'Sa_pbot') + kpslv = mct_aVect_indexRA(a2x,'Sa_pslv') + klwdn = mct_aVect_indexRA(a2x,'Faxa_lwdn') + krc = mct_aVect_indexRA(a2x,'Faxa_rainc') + krl = mct_aVect_indexRA(a2x,'Faxa_rainl') + ksc = mct_aVect_indexRA(a2x,'Faxa_snowc') + ksl = mct_aVect_indexRA(a2x,'Faxa_snowl') + kswndr= mct_aVect_indexRA(a2x,'Faxa_swndr') + kswndf= mct_aVect_indexRA(a2x,'Faxa_swndf') + kswvdr= mct_aVect_indexRA(a2x,'Faxa_swvdr') + kswvdf= mct_aVect_indexRA(a2x,'Faxa_swvdf') + kswnet= mct_aVect_indexRA(a2x,'Faxa_swnet') + kco2p = mct_aVect_indexRA(a2x,'Sa_co2prog',perrWith='quiet') + kco2d = mct_aVect_indexRA(a2x,'Sa_co2diag',perrWith='quiet') + + kbid = mct_aVect_indexRA(a2x,'Faxa_bcphidry') + kbod = mct_aVect_indexRA(a2x,'Faxa_bcphodry') + kbiw = mct_aVect_indexRA(a2x,'Faxa_bcphiwet') + koid = mct_aVect_indexRA(a2x,'Faxa_ocphidry') + kood = mct_aVect_indexRA(a2x,'Faxa_ocphodry') + koiw = mct_aVect_indexRA(a2x,'Faxa_ocphiwet') + kdd1 = mct_aVect_indexRA(a2x,'Faxa_dstdry1') + kdd2 = mct_aVect_indexRA(a2x,'Faxa_dstdry2') + kdd3 = mct_aVect_indexRA(a2x,'Faxa_dstdry3') + kdd4 = mct_aVect_indexRA(a2x,'Faxa_dstdry4') + kdw1 = mct_aVect_indexRA(a2x,'Faxa_dstwet1') + kdw2 = mct_aVect_indexRA(a2x,'Faxa_dstwet2') + kdw3 = mct_aVect_indexRA(a2x,'Faxa_dstwet3') + kdw4 = mct_aVect_indexRA(a2x,'Faxa_dstwet4') + + call mct_aVect_init(x2a, rList=seq_flds_x2a_fields, lsize=lsize) + call mct_aVect_zero(x2a) + + kanidr = mct_aVect_indexRA(x2a,'Sx_anidr') + kanidf = mct_aVect_indexRA(x2a,'Sx_anidf') + kavsdr = mct_aVect_indexRA(x2a,'Sx_avsdr') + kavsdf = mct_aVect_indexRA(x2a,'Sx_avsdf') + + !--- figure out what's on the streams --- + cnt = 0 + flds_strm = '' + do n = 1,SDATM%nstreams + do k = 1,ktranss + kfld = mct_aVect_indexRA(SDATM%avs(n),trim(stifld(k)),perrWith='quiet') + if (kfld > 0) then + cnt = cnt + 1 + if (cnt == 1) then + flds_strm = trim(stofld(k)) + else + flds_strm = trim(flds_strm)//':'//trim(stofld(k)) + endif + endif + enddo + enddo + if (my_task == master_task) write(logunit,F00) ' flds_strm = ',trim(flds_strm) + call shr_sys_flush(logunit) + + call mct_aVect_init(avstrm, rList=flds_strm, lsize=lsize) + call mct_aVect_zero(avstrm) + + stbot = mct_aVect_indexRA(avstrm,'strm_tbot',perrWith='quiet') + swind = mct_aVect_indexRA(avstrm,'strm_wind',perrWith='quiet') + sz = mct_aVect_indexRA(avstrm,'strm_z',perrWith='quiet') + spbot = mct_aVect_indexRA(avstrm,'strm_pbot',perrWith='quiet') + sshum = mct_aVect_indexRA(avstrm,'strm_shum',perrWith='quiet') + stdew = mct_aVect_indexRA(avstrm,'strm_tdew',perrWith='quiet') + srh = mct_aVect_indexRA(avstrm,'strm_rh',perrWith='quiet') + slwdn = mct_aVect_indexRA(avstrm,'strm_lwdn',perrWith='quiet') + sswdn = mct_aVect_indexRA(avstrm,'strm_swdn',perrWith='quiet') + sswdndf= mct_aVect_indexRA(avstrm,'strm_swdndf',perrWith='quiet') + sswdndr= mct_aVect_indexRA(avstrm,'strm_swdndr',perrWith='quiet') + sprecc = mct_aVect_indexRA(avstrm,'strm_precc',perrWith='quiet') + sprecl = mct_aVect_indexRA(avstrm,'strm_precl',perrWith='quiet') + sprecn = mct_aVect_indexRA(avstrm,'strm_precn',perrWith='quiet') + sco2p = mct_aVect_indexRA(avstrm,'strm_co2p',perrWith='quiet') + sco2d = mct_aVect_indexRA(avstrm,'strm_co2d',perrWith='quiet') + sswup = mct_aVect_indexRA(avstrm,'strm_swup',perrWith='quiet') + sprec = mct_aVect_indexRA(avstrm,'strm_prec',perrWith='quiet') + starcf = mct_aVect_indexRA(avstrm,'strm_tarcf',perrWith='quiet') + + allocate(imask(lsize)) + allocate(yc(lsize)) + allocate(windFactor(lsize)) + allocate(winddFactor(lsize)) + allocate(qsatFactor(lsize)) + + kmask = mct_aVect_indexRA(ggrid%data,'mask') + imask(:) = nint(ggrid%data%rAttr(kmask,:)) + klat = mct_aVect_indexRA(ggrid%data,'lat') + yc(:) = ggrid%data%rAttr(klat,:) + + call t_stopf('datm_initmctavs') + + !---------------------------------------------------------------------------- + ! Read restart + !---------------------------------------------------------------------------- + + if (read_restart) then + if (trim(rest_file) == trim(nullstr) .and. & + trim(rest_file_strm) == trim(nullstr)) then + if (my_task == master_task) then + write(logunit,F00) ' restart filenames from rpointer' + call shr_sys_flush(logunit) + inquire(file=trim(rpfile)//trim(inst_suffix),exist=exists) + if (.not.exists) then + write(logunit,F00) ' ERROR: rpointer file does not exist' + call shr_sys_abort(trim(subname)//' ERROR: rpointer file missing') + endif + nu = shr_file_getUnit() + open(nu,file=trim(rpfile)//trim(inst_suffix),form='formatted') + read(nu,'(a)') rest_file + read(nu,'(a)') rest_file_strm + close(nu) + call shr_file_freeUnit(nu) + inquire(file=trim(rest_file_strm),exist=exists) + endif + call shr_mpi_bcast(rest_file,mpicom,'rest_file') + call shr_mpi_bcast(rest_file_strm,mpicom,'rest_file_strm') + else + ! use namelist already read + if (my_task == master_task) then + write(logunit,F00) ' restart filenames from namelist ' + call shr_sys_flush(logunit) + inquire(file=trim(rest_file_strm),exist=exists) + endif + endif + call shr_mpi_bcast(exists,mpicom,'exists') +! if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file) +! call shr_pcdf_readwrite('read',trim(rest_file),mpicom,gsmap,rf1=somtp,rf1n='somtp') + if (exists) then + if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file_strm) + call shr_strdata_restRead(trim(rest_file_strm),SDATM,mpicom) + else + if (my_task == master_task) write(logunit,F00) ' file not found, skipping ',trim(rest_file_strm) + endif + call shr_sys_flush(logunit) + endif + + if (read_restart) then + call seq_timemgr_EClockGetData( EClock, curr_ymd=CurrentYMD, curr_tod=CurrentTOD) + call seq_timemgr_EClockGetData( EClock, stepno=stepno, dtime=idt ) + call seq_timemgr_EClockGetData( EClock, calendar=calendar ) + nextsw_cday = datm_shr_getNextRadCDay( CurrentYMD, CurrentTOD, stepno, idt, iradsw, calendar ) + else + call seq_timemgr_EClockGetData( EClock, curr_cday=nextsw_cday, stepno=stepno ) + endif + call seq_infodata_PutData(infodata, nextsw_cday=nextsw_cday ) + + else + + call seq_timemgr_EClockGetData( EClock, curr_ymd=CurrentYMD, curr_tod=CurrentTOD) + call seq_timemgr_EClockGetData( EClock, stepno=stepno, dtime=idt) + call seq_timemgr_EClockGetData( EClock, calendar=calendar ) + nextsw_cday = datm_shr_getNextRadCDay( CurrentYMD, CurrentTOD, stepno, idt, iradsw, calendar ) + call seq_infodata_PutData(infodata, nextsw_cday=nextsw_cday ) + + endif + + !---------------------------------------------------------------------------- + ! Set initial atm state, needed for CCSM atm initialization + !---------------------------------------------------------------------------- + + call t_adj_detailf(+2) + call datm_comp_run( EClock, cdata, x2a, a2x) + call t_adj_detailf(-2) + + !---------------------------------------------------------------------------- + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + if (my_task == master_task) write(logunit,F00) 'datm_comp_init done' + call shr_sys_flush(logunit) + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + call shr_sys_flush(logunit) + + call t_stopf('DATM_INIT') + +end subroutine datm_comp_init + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: datm_comp_run +! +! !DESCRIPTION: +! run method for dead atm model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine datm_comp_run( EClock, cdata, x2a, a2x) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) ,intent(in) :: EClock + type(seq_cdata) ,intent(inout) :: cdata + type(mct_aVect) ,intent(inout) :: x2a ! driver -> dead + type(mct_aVect) ,intent(inout) :: a2x ! dead -> driver + +!EOP + + !--- local --- + type(mct_gsMap) , pointer :: gsMap + type(mct_gGrid) , pointer :: ggrid + + integer(IN) :: CurrentYMD ! model date + integer(IN) :: CurrentTOD ! model sec into model date + integer(IN) :: yy,mm,dd ! year month day + integer(IN) :: n ! indices + integer(IN) :: lsize ! size of attr vect + integer(IN) :: shrlogunit, shrloglev ! original log unit and level + logical :: mssrmlf ! remove old data + integer(IN) :: idt ! integer timestep + real(R8) :: dt ! timestep + logical :: write_restart ! restart now + character(CL) :: case_name ! case name + character(CL) :: rest_file ! restart_file + character(CL) :: rest_file_strm ! restart_file + integer(IN) :: nu ! unit number + integer(IN) :: stepno ! step number + real(R8) :: nextsw_cday ! calendar of next atm sw + integer(IN) :: eday ! elapsed day + real(R8) :: rday ! elapsed day + real(R8) :: cosFactor ! cosine factor + real(R8) :: factor ! generic/temporary correction factor + real(R8) :: avg_alb ! average albedo + real(R8) :: tMin ! minimum temperature + character(CL) :: calendar ! calendar type + + !--- temporaries + real(R8) :: uprime,vprime,swndr,swndf,swvdr,swvdf,ratio_rvrf + real(R8) :: tbot,pbot,rtmp,vp,ea,e,qsat,frac,qsatT + + type(seq_infodata_type), pointer :: infodata + + character(*), parameter :: F00 = "('(datm_comp_run) ',8a)" + character(*), parameter :: F04 = "('(datm_comp_run) ',2a,2i8,'s')" + character(*), parameter :: subName = "(datm_comp_run) " +!------------------------------------------------------------------------------- + + call t_startf('DATM_RUN') + + call t_startf('datm_run1') + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (logUnit) + + call seq_cdata_setptrs(cdata, gsMap=gsmap, dom=ggrid) + + call seq_cdata_setptrs(cdata, infodata=infodata) + + call seq_timemgr_EClockGetData( EClock, curr_ymd=CurrentYMD, curr_tod=CurrentTOD) + call seq_timemgr_EClockGetData( EClock, curr_yr=yy, curr_mon=mm, curr_day=dd) + call seq_timemgr_EClockGetData( EClock, stepno=stepno, dtime=idt) + call seq_timemgr_EClockGetData( EClock, calendar=calendar) + dt = idt * 1.0_r8 + write_restart = seq_timemgr_RestartAlarmIsOn(EClock) + + call t_stopf('datm_run1') + + !-------------------- + ! ADVANCE ATM + !-------------------- + + call t_barrierf('datm_BARRIER',mpicom) + call t_startf('datm') + + nextsw_cday = datm_shr_getNextRadCDay( CurrentYMD, CurrentTOD, stepno, idt, iradsw, calendar ) + call seq_infodata_PutData(infodata, nextsw_cday=nextsw_cday ) + + !--- copy all fields from streams to a2x as default --- + + if (trim(atm_mode) /= 'NULL') then + call t_startf('datm_strdata_advance') + call shr_strdata_advance(SDATM,currentYMD,currentTOD,mpicom,'datm') + call t_stopf('datm_strdata_advance') + call t_barrierf('datm_scatter_BARRIER',mpicom) + call t_startf('datm_scatter') + if (trim(atm_mode) /= 'COPYALL') then + lsize = mct_avect_lsize(a2x) + do n = 1,lsize + a2x%rAttr(kbid,n) = aerodep_spval + a2x%rAttr(kbod,n) = aerodep_spval + a2x%rAttr(kbiw,n) = aerodep_spval + a2x%rAttr(koid,n) = aerodep_spval + a2x%rAttr(kood,n) = aerodep_spval + a2x%rAttr(koiw,n) = aerodep_spval + a2x%rAttr(kdd1,n) = aerodep_spval + a2x%rAttr(kdd2,n) = aerodep_spval + a2x%rAttr(kdd3,n) = aerodep_spval + a2x%rAttr(kdd4,n) = aerodep_spval + a2x%rAttr(kdw1,n) = aerodep_spval + a2x%rAttr(kdw2,n) = aerodep_spval + a2x%rAttr(kdw3,n) = aerodep_spval + a2x%rAttr(kdw4,n) = aerodep_spval + enddo + endif + if (firstcall) then + allocate(ilist_av(SDATM%nstreams)) + allocate(olist_av(SDATM%nstreams)) + allocate(ilist_st(SDATM%nstreams)) + allocate(olist_st(SDATM%nstreams)) + allocate(count_av(SDATM%nstreams)) + allocate(count_st(SDATM%nstreams)) + end if + do n = 1,SDATM%nstreams + if (firstcall) then + call shr_dmodel_translate_list(SDATM%avs(n),a2x,& + avifld,avofld,ilist_av(n),olist_av(n),count_av(n)) + end if + if (count_av(n) > 0) then + call shr_dmodel_translateAV_list(SDATM%avs(n),a2x,& + ilist_av(n),olist_av(n),rearr) + end if + enddo + do n = 1,SDATM%nstreams + if (firstcall) then + call shr_dmodel_translate_list(SDATM%avs(n),avstrm,& + stifld,stofld,ilist_st(n),olist_st(n),count_st(n)) + end if + if (count_st(n) > 0) then + call shr_dmodel_translateAV_list(SDATM%avs(n),avstrm,& + ilist_st(n),olist_st(n),rearr) + end if + enddo + + call t_stopf('datm_scatter') + else + call mct_aVect_zero(a2x) + endif + + call t_startf('datm_mode') + + select case (trim(atm_mode)) + + case('COPYALL') + ! do nothing extra + + case('CPLHIST') + ! do nothing extra + + case ('WRF') + lsize = mct_avect_lsize(a2x) + do n = 1,lsize + + !--- fabricate required swdn components from total swdn --- + a2x%rAttr(kswvdr,n) = avstrm%rAttr(sswdn,n)*(0.28_R8) + a2x%rAttr(kswndr,n) = avstrm%rAttr(sswdn,n)*(0.31_R8) + a2x%rAttr(kswvdf,n) = avstrm%rAttr(sswdn,n)*(0.24_R8) + a2x%rAttr(kswndf,n) = avstrm%rAttr(sswdn,n)*(0.17_R8) + + !--- just a diagnostic, not really needed + a2x%rAttr(kswnet,n) = avstrm%rAttr(sswdn,n)-avstrm%rAttr(sswup,n) + + !--- convert from hPa + a2x%rAttr(kpslv,n) = a2x%rAttr(kpslv,n)*100._R8 + a2x%rAttr(kpbot,n) = a2x%rAttr(kpbot,n)*100._R8 + +! !--- fix dens problem in dataset, should be about "1" +! if (a2x%rAttr(kdens,n) < 0.01) & +! a2x%rAttr(kdens,n) = a2x%rAttr(kdens,n)*10000._R8 + +! !--- set z to at least 10m +! a2x%rAttr(kz,n) = max(10.0_R8,a2x%rAttr(kz,n)) + !--- tcraig, file has terrain height on it, set to 10m + a2x%rAttr(kz,n) = 10.0_R8 + +! !--- compute theta from tbot and pbot as in WRF +! !--- tcraig now from WRF input data +! a2x%rAttr(kptem,n) = a2x%rAttr(ktbot,n) / ((a2x%rAttr(kpbot)/1.0e6)**0.2854) + + !--- convert to degK from degC + a2x%rAttr(ktbot,n) = a2x%rAttr(ktbot,n) + tKFrz + + enddo + + case('CORE2_NYF','CORE2_IAF') + if (firstcall) then + if (sprec < 1 .or. sswdn < 1) then + write(logunit,F00) 'ERROR: prec and swdn must be in streams for CORE2' + call shr_sys_abort(trim(subname)//'ERROR: prec and swdn must be in streams for CORE2') + endif + if (trim(atm_mode) == 'CORE2_IAF' ) then + if (starcf < 1 ) then + write(logunit,F00) 'ERROR: tarcf must be in an input stream for CORE2_IAF' + call shr_sys_abort(trim(subname)//'tarcf must be in an input stream for CORE2_IAF') + endif + endif + call datm_shr_CORE2getFactors(factorFn,windFactor,winddFactor,qsatFactor, & + mpicom,compid,gsmap,ggrid,SDATM%nxg,SDATM%nyg) + endif + ! call shr_cal_date2eday(currentYMD,eday,calendar) + ! rday = mod(eday,365) + real(currentTOD)/SHR_CONST_CDAY + call shr_cal_date2julian(currentYMD,currentTOD,rday,calendar) + rday = mod((rday - 1.0_R8),365.0_R8) + cosfactor = cos((2.0_R8*SHR_CONST_PI*rday)/365 - phs_c0) + + lsize = mct_avect_lsize(a2x) + do n = 1,lsize + a2x%rAttr(kz,n) = 10.0_R8 + + !--- correction to NCEP winds based on QSCAT --- + uprime = a2x%rAttr(ku,n)*windFactor(n) + vprime = a2x%rAttr(kv,n)*windFactor(n) + a2x%rAttr(ku,n) = uprime*cos(winddFactor(n)*degtorad)- & + vprime*sin(winddFactor(n)*degtorad) + a2x%rAttr(kv,n) = uprime*sin(winddFactor(n)*degtorad)+ & + vprime*cos(winddFactor(n)*degtorad) + + !--- density, tbot, & pslv taken directly from input stream, set pbot --- + ! a2x%rAttr(kdens,n) = + ! a2x%rAttr(ktbot,n) = + ! a2x%rAttr(kpslv,n) = + a2x%rAttr(kpbot,n) = a2x%rAttr(kpslv,n) + + !--- correction to NCEP Arctic & Antarctic air T & potential T --- + if ( yc(n) < -60.0_R8 ) then + tMin = (avg_c0 + avg_c1*yc(n)) + (amp_c0 + amp_c1*yc(n))*cosFactor + tKFrz + a2x%rAttr(ktbot,n) = max(a2x%rAttr(ktbot,n), tMin) + else if ( yc(n) > 60.0_R8 ) then + factor = MIN(1.0_R8, 0.1_R8*(yc(n)-60.0_R8) ) + a2x%rAttr(ktbot,n) = a2x%rAttr(ktbot,n) + factor * dTarc(mm) + endif + a2x%rAttr(kptem,n) = a2x%rAttr(ktbot,n) + + !--- correction to NCEP relative humidity for heat budget balance --- + a2x%rAttr(kshum,n) = a2x%rAttr(kshum,n) + qsatFactor(n) + + !--- Dupont correction to NCEP Arctic air T --- + !--- don't correct during summer months (July-September) + !--- ONLY correct when forcing year is 1997->2004 + if (trim(atm_mode) == 'CORE2_IAF' ) then + a2x%rAttr(ktbot,n) = a2x%rAttr(ktbot,n) + avstrm%rAttr(starcf,n) + a2x%rAttr(kptem,n) = a2x%rAttr(ktbot,n) + end if + + !------------------------------------------------------------------------- + ! PRECIPITATION DATA + !------------------------------------------------------------------------- + + avstrm%rAttr(sprec,n) = avstrm%rAttr(sprec,n)/86400.0_R8 ! convert mm/day to kg/m^2/s + + ! only correct satellite products, do not correct Serreze Arctic data + if ( yc(n) < 58. ) then + avstrm%rAttr(sprec,n) = avstrm%rAttr(sprec,n)*1.14168_R8 + endif + if ( yc(n) >= 58. .and. yc(n) < 68. ) then + factor = MAX(0.0_R8, 1.0_R8 - 0.1_R8*(yc(n)-58.0_R8) ) + avstrm%rAttr(sprec,n) = avstrm%rAttr(sprec,n)*(factor*(1.14168_R8 - 1.0_R8) + 1.0_R8) + endif + + a2x%rAttr(krc,n) = 0.0_R8 ! default zero + a2x%rAttr(ksc,n) = 0.0_R8 + if (a2x%rAttr(ktbot,n) < tKFrz ) then ! assign precip to rain/snow components + a2x%rAttr(krl,n) = 0.0_R8 + a2x%rAttr(ksl,n) = avstrm%rAttr(sprec,n) + else + a2x%rAttr(krl,n) = avstrm%rAttr(sprec,n) + a2x%rAttr(ksl,n) = 0.0_R8 + endif + + !------------------------------------------------------------------------- + ! RADIATION DATA + !------------------------------------------------------------------------- + + !--- fabricate required swdn components from net swdn --- + a2x%rAttr(kswvdr,n) = avstrm%rAttr(sswdn,n)*(0.28_R8) + a2x%rAttr(kswndr,n) = avstrm%rAttr(sswdn,n)*(0.31_R8) + a2x%rAttr(kswvdf,n) = avstrm%rAttr(sswdn,n)*(0.24_R8) + a2x%rAttr(kswndf,n) = avstrm%rAttr(sswdn,n)*(0.17_R8) + + !--- compute net short-wave based on LY08 latitudinally-varying albedo --- + avg_alb = ( 0.069 - 0.011*cos(2.0_R8*yc(n)*degtorad ) ) + a2x%rAttr(kswnet,n) = avstrm%rAttr(sswdn,n)*(1.0_R8 - avg_alb) + + !--- corrections to GISS sswdn for heat budget balancing --- + factor = 1.0_R8 + if ( -60.0_R8 < yc(n) .and. yc(n) < -50.0_R8 ) then + factor = 1.0_R8 - (yc(n) + 60.0_R8)*(0.05_R8/10.0_R8) + else if ( -50.0_R8 < yc(n) .and. yc(n) < 30.0_R8 ) then + factor = 0.95_R8 + else if ( 30.0_R8 < yc(n) .and. yc(n) < 40._R8 ) then + factor = 1.0_R8 - (40.0_R8 - yc(n))*(0.05_R8/10.0_R8) + endif + a2x%rAttr(kswnet,n) = a2x%rAttr(kswnet,n)*factor + a2x%rAttr(kswvdr,n) = a2x%rAttr(kswvdr,n)*factor + a2x%rAttr(kswndr,n) = a2x%rAttr(kswndr,n)*factor + a2x%rAttr(kswvdf,n) = a2x%rAttr(kswvdf,n)*factor + a2x%rAttr(kswndf,n) = a2x%rAttr(kswndf,n)*factor + + !--- correction to GISS lwdn in Arctic --- + if ( yc(n) > 60._R8 ) then + factor = MIN(1.0_R8, 0.1_R8*(yc(n)-60.0_R8) ) + a2x%rAttr(klwdn,n) = a2x%rAttr(klwdn,n) + factor * dLWarc + endif + + enddo ! lsize + + case('CLMNCEP') + if (firstcall) then + if (swind < 1 .or. stbot < 1) then + write(logunit,F00) ' ERROR: wind and tbot must be in streams for CLMNCEP' + call shr_sys_abort(trim(subname)//' ERROR: wind and tbot must be in streams for CLMNCEP') + endif + rtmp = maxval(a2x%rAttr(ktbot,:)) + call shr_mpi_max(rtmp,tbotmax,mpicom,'datm_tbot',all=.true.) + rtmp = maxval(x2a%rAttr(kanidr,:)) + call shr_mpi_max(rtmp,anidrmax,mpicom,'datm_ani',all=.true.) + if (stdew > 0) then + rtmp = maxval(avstrm%rAttr(stdew,:)) + call shr_mpi_max(rtmp,tdewmax,mpicom,'datm_tdew',all=.true.) + endif + if (my_task == master_task) & + write(logunit,*) trim(subname),' max values = ',tbotmax,tdewmax,anidrmax + endif + lsize = mct_avect_lsize(a2x) + do n = 1,lsize + !--- bottom layer height --- + if (sz < 1) a2x%rAttr(kz,n) = 30.0_R8 + + !--- temperature --- + if (tbotmax < 50.0_R8) a2x%rAttr(ktbot,n) = a2x%rAttr(ktbot,n) + tkFrz + a2x%rAttr(kptem,n) = a2x%rAttr(ktbot,n) + + !--- pressure --- + if (spbot < 1) a2x%rAttr(kpbot,n) = pstd + a2x%rAttr(kpslv,n) = a2x%rAttr(kpbot,n) + + !--- u, v wind velocity --- + a2x%rAttr(ku,n) = avstrm%rAttr(swind,n)/sqrt(2.0_R8) + a2x%rAttr(kv,n) = a2x%rAttr(ku,n) + + !--- specific humidity --- + tbot = a2x%rAttr(ktbot,n) + pbot = a2x%rAttr(kpbot,n) + if (sshum > 0) then + e = datm_shr_esat(tbot,tbot) + qsat = (0.622_R8 * e)/(pbot - 0.378_R8 * e) + if (qsat < a2x%rAttr(kshum,n)) then + a2x%rAttr(kshum,n) = qsat + endif + else if (srh > 0) then + e = avstrm%rAttr(srh,n) * 0.01_R8 * datm_shr_esat(tbot,tbot) + qsat = (0.622_R8 * e)/(pbot - 0.378_R8 * e) + a2x%rAttr(kshum,n) = qsat + else if (stdew > 0) then + if (tdewmax < 50.0_R8) avstrm%rAttr(stdew,n) = avstrm%rAttr(stdew,n) + tkFrz + e = datm_shr_esat(avstrm%rAttr(stdew,n),tbot) + qsat = (0.622_R8 * e)/(pbot - 0.378_R8 * e) + a2x%rAttr(kshum,n) = qsat + else + call shr_sys_abort(subname//'ERROR: cannot compute shum') + endif + + !--- density --- + vp = (a2x%rAttr(kshum,n)*pbot) / (0.622_R8 + 0.378_R8 * a2x%rAttr(kshum,n)) + a2x%rAttr(kdens,n) = (pbot - 0.378_R8 * vp) / (tbot*rdair) + + !--- downward longwave --- + if (slwdn < 1) then + e = a2x%rAttr(kpslv,n) * a2x%rAttr(kshum,n) / (0.622_R8 + 0.378_R8 * a2x%rAttr(kshum,n)) + ea = 0.70_R8 + 5.95e-05_R8 * 0.01_R8 * e * exp(1500.0_R8/tbot) + a2x%rAttr(klwdn,n) = ea * stebol * tbot**4 + endif + + !--- shortwave radiation --- + if (sswdndf > 0 .and. sswdndr > 0) then + a2x%rAttr(kswndr,n) = avstrm%rAttr(sswdndr,n) * 0.50_R8 + a2x%rAttr(kswvdr,n) = avstrm%rAttr(sswdndr,n) * 0.50_R8 + a2x%rAttr(kswndf,n) = avstrm%rAttr(sswdndf,n) * 0.50_R8 + a2x%rAttr(kswvdf,n) = avstrm%rAttr(sswdndf,n) * 0.50_R8 + elseif (sswdn > 0) then + ! relationship between incoming NIR or VIS radiation and ratio of + ! direct to diffuse radiation calculated based on one year's worth of + ! hourly CAM output from CAM version cam3_5_55 + swndr = avstrm%rAttr(sswdn,n) * 0.50_R8 + ratio_rvrf = min(0.99_R8,max(0.29548_R8 + 0.00504_R8*swndr & + -1.4957e-05_R8*swndr**2 + 1.4881e-08_R8*swndr**3,0.01_R8)) + a2x%rAttr(kswndr,n) = ratio_rvrf*swndr + swndf = avstrm%rAttr(sswdn,n) * 0.50_R8 + a2x%rAttr(kswndf,n) = (1._R8 - ratio_rvrf)*swndf + + swvdr = avstrm%rAttr(sswdn,n) * 0.50_R8 + ratio_rvrf = min(0.99_R8,max(0.17639_R8 + 0.00380_R8*swvdr & + -9.0039e-06_R8*swvdr**2 + 8.1351e-09_R8*swvdr**3,0.01_R8)) + a2x%rAttr(kswvdr,n) = ratio_rvrf*swvdr + swvdf = avstrm%rAttr(sswdn,n) * 0.50_R8 + a2x%rAttr(kswvdf,n) = (1._R8 - ratio_rvrf)*swvdf + else + call shr_sys_abort(subName//'ERROR: cannot compute short-wave down') + endif + + !--- swnet: a diagnostic quantity --- + if (anidrmax < 1.0e-8 .or. anidrmax > SHR_CONST_SPVAL * 0.9_R8) then + a2x%rAttr(kswnet,n) = 0.0_R8 + else + a2x%rAttr(kswnet,n) = (1.0_R8-x2a%rAttr(kanidr,n))*a2x%rAttr(kswndr,n) + & + (1.0_R8-x2a%rAttr(kavsdr,n))*a2x%rAttr(kswvdr,n) + & + (1.0_R8-x2a%rAttr(kanidf,n))*a2x%rAttr(kswndf,n) + & + (1.0_R8-x2a%rAttr(kavsdf,n))*a2x%rAttr(kswvdf,n) + endif + + !--- rain and snow --- + if (sprecc > 0 .and. sprecl > 0) then + a2x%rAttr(krc,n) = avstrm%rAttr(sprecc,n) + a2x%rAttr(krl,n) = avstrm%rAttr(sprecl,n) + elseif (sprecn > 0) then + a2x%rAttr(krc,n) = avstrm%rAttr(sprecn,n)*0.1_R8 + a2x%rAttr(krl,n) = avstrm%rAttr(sprecn,n)*0.9_R8 + else + call shr_sys_abort(subName//'ERROR: cannot compute rain and snow') + endif + + !--- split precip between rain & snow --- + !--- note: aribitrarily small negative values cause CLM to crash --- + frac = (tbot - tkFrz)*0.5_R8 ! ramp near freezing + frac = min(1.0_R8,max(0.0_R8,frac)) ! bound in [0,1] + a2x%rAttr(ksc,n) = max(0.0_R8, a2x%rAttr(krc,n)*(1.0_R8 - frac) ) + a2x%rAttr(ksl,n) = max(0.0_R8, a2x%rAttr(krl,n)*(1.0_R8 - frac) ) + a2x%rAttr(krc,n) = max(0.0_R8, a2x%rAttr(krc,n)*( frac) ) + a2x%rAttr(krl,n) = max(0.0_R8, a2x%rAttr(krl,n)*( frac) ) + + enddo + + end select + + call t_stopf('datm_mode') + + if (write_restart) then + call t_startf('datm_restart') + call seq_infodata_GetData( infodata, case_name=case_name) + write(rest_file,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.datm'//trim(inst_suffix)//'.r.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.nc' + write(rest_file_strm,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.datm'//trim(inst_suffix)//'.rs1.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.bin' + if (my_task == master_task) then + nu = shr_file_getUnit() + open(nu,file=trim(rpfile)//trim(inst_suffix),form='formatted') + write(nu,'(a)') rest_file + write(nu,'(a)') rest_file_strm + close(nu) + call shr_file_freeUnit(nu) + endif +! if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file),currentYMD,currentTOD +! call shr_pcdf_readwrite('write',trim(rest_file),mpicom,gsmap,clobber=.true., & +! rf1=somtp,rf1n='somtp') + if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file_strm),currentYMD,currentTOD + call shr_strdata_restWrite(trim(rest_file_strm),SDATM,mpicom,trim(case_name),'SDATM strdata') + call shr_sys_flush(logunit) + call t_stopf('datm_restart') + endif + + call t_stopf('datm') + + !---------------------------------------------------------------------------- + ! Log output for model date + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + call t_startf('datm_run2') + if (my_task == master_task) then + write(logunit,F04) trim(myModelName),': model date ', CurrentYMD,CurrentTOD + call shr_sys_flush(logunit) + end if + + firstcall = .false. + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + call shr_sys_flush(logunit) + call t_stopf('datm_run2') + + call t_stopf('DATM_RUN') + +end subroutine datm_comp_run + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: datm_comp_final +! +! !DESCRIPTION: +! finalize method for dead atm model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ +! +subroutine datm_comp_final() + + implicit none + +!EOP + + !--- formats --- + character(*), parameter :: F00 = "('(datm_comp_final) ',8a)" + character(*), parameter :: F91 = "('(datm_comp_final) ',73('-'))" + character(*), parameter :: subName = "(datm_comp_final) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call t_startf('DATM_FINAL') + + if (my_task == master_task) then + write(logunit,F91) + write(logunit,F00) trim(myModelName),': end of main integration loop' + write(logunit,F91) + end if + + call t_stopf('DATM_FINAL') + +end subroutine datm_comp_final +!=============================================================================== +!=============================================================================== + + +end module datm_comp_mod diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.dice/dice_comp_mod.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.dice/dice_comp_mod.F90 new file mode 100644 index 0000000000..7fb6900d89 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.dice/dice_comp_mod.F90 @@ -0,0 +1,933 @@ +#ifdef AIX +@PROCESS ALIAS_SIZE(805306368) +#endif +module dice_comp_mod + +! !USES: + + use shr_const_mod + use shr_sys_mod + use shr_kind_mod , only: IN=>SHR_KIND_IN, R8=>SHR_KIND_R8, & + CS=>SHR_KIND_CS, CL=>SHR_KIND_CL + use shr_file_mod , only: shr_file_getunit, shr_file_getlogunit, shr_file_getloglevel, & + shr_file_setlogunit, shr_file_setloglevel, shr_file_setio, & + shr_file_freeunit + use shr_mpi_mod , only: shr_mpi_bcast + use shr_flux_mod , only: shr_flux_atmIce + use shr_cal_mod , only: shr_cal_ymd2julian + use mct_mod + use esmf + use perf_mod + + use shr_strdata_mod + use shr_dmodel_mod + use shr_pcdf_mod + + use seq_cdata_mod + use seq_infodata_mod + use seq_timemgr_mod + use seq_comm_mct , only: seq_comm_inst, seq_comm_name, seq_comm_suffix + use seq_flds_mod , only: seq_flds_i2x_fields, & + seq_flds_x2i_fields +! +! !PUBLIC TYPES: + implicit none + private ! except + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: dice_comp_init + public :: dice_comp_run + public :: dice_comp_final + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + + !--- other --- + character(CS) :: myModelName = 'ice' ! user defined model name + integer(IN) :: mpicom + integer(IN) :: my_task ! my task in mpi communicator mpicom + integer(IN) :: npes ! total number of tasks + integer(IN),parameter :: master_task=0 ! task number of master task + integer(IN) :: logunit ! logging unit number + integer :: inst_index ! number of current instance (ie. 1) + character(len=16) :: inst_name ! fullname of current instance (ie. "lnd_0001") + character(len=16) :: inst_suffix ! char string associated with instance + ! (ie. "_0001" or "") + character(CL) :: ice_mode ! mode + integer(IN) :: dbug = 0 ! debug level (higher is more) + logical :: firstcall ! first call logical + logical :: scmMode = .false. ! single column mode + real(R8) :: scmLat = shr_const_SPVAL ! single column lat + real(R8) :: scmLon = shr_const_SPVAL ! single column lon + logical :: read_restart ! start from restart + real(R8) :: flux_swpf ! short-wave penatration factor + real(R8) :: flux_Qmin ! bound on melt rate + logical :: flux_Qacc ! activates water accumulation/melt wrt Q + real(R8) :: flux_Qacc0 ! initial water accumulation value + + character(len=*),parameter :: rpfile = 'rpointer.ice' + character(len=*),parameter :: nullstr = 'undefined' + + real(R8),parameter :: pi = shr_const_pi ! pi + real(R8),parameter :: spval = shr_const_spval ! flags invalid data + real(R8),parameter :: tFrz = shr_const_tkfrzsw ! temp of freezing salt-water + real(R8),parameter :: latice = shr_const_latice ! latent heat of fusion + real(R8),parameter :: cDay = shr_const_cDay ! sec in calendar day + real(R8),parameter :: waterMax = 1000.0_R8 ! wrt iFrac comp & frazil ice (kg/m^2) + + !----- surface albedo constants ------ + real(R8),parameter :: snwfrac = 0.286_R8 ! snow cover fraction ~ [0,1] + real(R8),parameter :: as_nidf = 0.950_R8 ! albedo: snow,near-infr,diffuse + real(R8),parameter :: as_vsdf = 0.700_R8 ! albedo: snow,visible ,diffuse + real(R8),parameter :: as_nidr = 0.960_R8 ! albedo: snow,near-infr,direct + real(R8),parameter :: as_vsdr = 0.800_R8 ! albedo: snow,visible ,direct + real(R8),parameter :: ai_nidf = 0.700_R8 ! albedo: ice, near-infr,diffuse + real(R8),parameter :: ai_vsdf = 0.500_R8 ! albedo: ice, visible ,diffuse + real(R8),parameter :: ai_nidr = 0.700_R8 ! albedo: ice, near-infr,direct + real(R8),parameter :: ai_vsdr = 0.500_R8 ! albedo: ice, visible ,direct + real(R8),parameter :: ax_nidf = ai_nidf*(1.0_R8-snwfrac) + as_nidf*snwfrac + real(R8),parameter :: ax_vsdf = ai_vsdf*(1.0_R8-snwfrac) + as_vsdf*snwfrac + real(R8),parameter :: ax_nidr = ai_nidr*(1.0_R8-snwfrac) + as_nidr*snwfrac + real(R8),parameter :: ax_vsdr = ai_vsdr*(1.0_R8-snwfrac) + as_vsdr*snwfrac + + integer(IN) :: kswvdr,kswndr,kswvdf,kswndf,kq,kz,kua,kva,kptem,kshum,kdens,ktbot + integer(IN) :: kiFrac,kt,kavsdr,kanidr,kavsdf,kanidf,kswnet,kmelth,kmeltw + integer(IN) :: ksen,klat,klwup,kevap,ktauxa,ktauya,ktref,kqref,kswpen,ktauxo,ktauyo,ksalt + + type(shr_strdata_type) :: SDICE + type(mct_rearr) :: rearr +! type(mct_avect) :: avstrm ! av of data from stream + integer(IN) , pointer :: imask(:) + real(R8) , pointer :: yc(:) + real(R8) , pointer :: water(:) +! real(R8) , pointer :: ifrac0(:) + + integer(IN),parameter :: ktrans = 42 + character(16),parameter :: avofld(1:ktrans) = & + (/"So_t ","So_s ","So_u ","So_v ", & + "So_dhdx ","So_dhdy ","Fioo_q ","Sa_z ", & + "Sa_u ","Sa_v ","Sa_ptem ","Sa_tbot ", & + "Sa_shum ","Sa_dens ","Faxa_swndr ","Faxa_swvdr ", & + "Faxa_swndf ","Faxa_swvdf ","Faxa_lwdn ","Faxa_rain ", & + "Faxa_snow ","Si_t ","Si_tref ","Si_qref ", & + "Si_ifrac ","Si_avsdr ","Si_anidr ","Si_avsdf ", & + "Si_anidf ","Faii_taux ","Faii_tauy ","Faii_lat ", & + "Faii_sen ","Faii_lwup ","Faii_evap ","Faii_swnet ", & + "Fioi_swpen ","Fioi_melth ","Fioi_meltw ","Fioi_salt ", & + "Fioi_taux ","Fioi_tauy " /) + + character(16),parameter :: avifld(1:ktrans) = & + (/"to ","s ","uo ","vo ", & + "dhdx ","dhdy ","q ","z ", & + "ua ","va ","ptem ","tbot ", & + "shum ","dens ","swndr ","swvdr ", & + "swndf ","swvdf ","lwdn ","rain ", & + "snow ","t ","tref ","qref ", & + "ifrac ","avsdr ","anidr ","avsdf ", & + "anidf ","tauxa ","tauya ","lat ", & + "sen ","lwup ","evap ","swnet ", & + "swpen ","melth ","meltw ","salt ", & + "tauxo ","tauyo " /) + + save + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CONTAINS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: dice_comp_init +! +! !DESCRIPTION: +! initialize data ice model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine dice_comp_init( EClock, cdata, x2i, i2x, NLFilename ) + use pio, only : iosystem_desc_t + use shr_pio_mod, only : shr_pio_getiosys, shr_pio_getiotype + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) , intent(in) :: EClock + type(seq_cdata) , intent(inout) :: cdata + type(mct_aVect) , intent(inout) :: x2i, i2x + character(len=*), optional , intent(in) :: NLFilename ! Namelist filename + +!EOP + + !--- local variables --- + integer(IN) :: n,k ! generic counters + integer(IN) :: ierr ! error code + integer(IN) :: COMPID ! comp id + integer(IN) :: gsize ! global size + integer(IN) :: lsize ! local size + integer(IN) :: shrlogunit, shrloglev ! original log unit and level + integer(IN) :: nunit ! unit number + integer(IN) :: kfld ! field reference + logical :: ice_present ! flag + logical :: ice_prognostic ! flag + + type(seq_infodata_type), pointer :: infodata + type(mct_gsMap) , pointer :: gsmap + type(mct_gGrid) , pointer :: ggrid + + character(CL) :: filePath ! generic file path + character(CL) :: fileName ! generic file name + character(CS) :: timeName ! domain file: time variable name + character(CS) :: lonName ! domain file: lon variable name + character(CS) :: latName ! domain file: lat variable name + character(CS) :: maskName ! domain file: mask variable name + character(CS) :: areaName ! domain file: area variable name + + integer(IN) :: yearFirst ! first year to use in data stream + integer(IN) :: yearLast ! last year to use in data stream + integer(IN) :: yearAlign ! data year that aligns with yearFirst + character(CL) :: calendar ! calendar type + + character(CL) :: ice_in ! dshr ice namelist + character(CL) :: decomp ! decomp strategy + character(CL) :: rest_file ! restart filename + character(CL) :: rest_file_strm ! restart filename for stream + character(CL) :: restfilm ! model restart file namelist + character(CL) :: restfils ! stream restart file namelist + logical :: exists ! file existance logical + integer(IN) :: nu ! unit number + type(iosystem_desc_t), pointer :: ice_pio_subsystem + + + !----- define namelist ----- + namelist / dice_nml / & + ice_in, decomp, flux_swpf, flux_Qmin, flux_Qacc, flux_Qacc0, restfilm, restfils + + !--- formats --- + character(*), parameter :: F00 = "('(dice_comp_init) ',8a)" + character(*), parameter :: F01 = "('(dice_comp_init) ',a,5i8)" + character(*), parameter :: F02 = "('(dice_comp_init) ',a,4es13.6)" + character(*), parameter :: F03 = "('(dice_comp_init) ',a,i8,a)" + character(*), parameter :: F04 = "('(dice_comp_init) ',2a,2i8,'s')" + character(*), parameter :: F05 = "('(dice_comp_init) ',a,2f10.4)" + character(*), parameter :: F06 = "('(dice_comp_init) ',a,5l3)" + character(*), parameter :: F90 = "('(dice_comp_init) ',73('='))" + character(*), parameter :: F91 = "('(dice_comp_init) ',73('-'))" + character(*), parameter :: subName = "(dice_comp_init) " +!------------------------------------------------------------------------------- + + + call t_startf('DICE_INIT') + + firstcall = .true. + + ! Set cdata pointers + + call seq_cdata_setptrs(cdata, ID=COMPID, mpicom=mpicom, & + gsMap=gsmap, dom=ggrid, infodata=infodata) + + ! Determine communicator groups and sizes + + call mpi_comm_rank(mpicom, my_task, ierr) + call mpi_comm_size(mpicom, npes, ierr) + + inst_name = seq_comm_name(COMPID) + inst_index = seq_comm_inst(COMPID) + inst_suffix = seq_comm_suffix(COMPID) + + !--- open log file --- + if (my_task == master_task) then + logUnit = shr_file_getUnit() + call shr_file_setIO('ice_modelio.nml'//trim(inst_suffix),logUnit) + else + logUnit = 6 + endif + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (logUnit) + + !---------------------------------------------------------------------------- + ! Set a Few Defaults + !---------------------------------------------------------------------------- + + call seq_infodata_getData(infodata,single_column=scmMode, & + & scmlat=scmlat, scmlon=scmLon) + + ice_present = .false. + ice_prognostic = .false. + call seq_infodata_GetData(infodata,read_restart=read_restart) + + !---------------------------------------------------------------------------- + ! Read dice_in + !---------------------------------------------------------------------------- + + call t_startf('dice_readnml') + + filename = "dice_in"//trim(inst_suffix) + ice_in = "unset" + decomp = "1d" + flux_swpf = 0.0_R8 ! no penetration + flux_Qmin = -300.0_R8 ! kg/s/m^2 + flux_Qacc = .false. ! no accumulation + flux_Qacc0 = 0.0_R8 ! no water + restfilm = trim(nullstr) + restfils = trim(nullstr) + if (my_task == master_task) then + nunit = shr_file_getUnit() ! get unused unit number + open (nunit,file=trim(filename),status="old",action="read") + read (nunit,nml=dice_nml,iostat=ierr) + close(nunit) + call shr_file_freeUnit(nunit) + if (ierr > 0) then + write(logunit,F01) 'ERROR: reading input namelist, '//trim(filename)//' iostat=',ierr + call shr_sys_abort(subName//': namelist read error '//trim(filename)) + end if + write(logunit,F00)' ice_in = ',trim(ice_in) + write(logunit,F00)' decomp = ',trim(decomp) + write(logunit,F02)' flux_swpf = ',flux_swpf + write(logunit,F02)' flux_Qmin = ',flux_Qmin + write(logunit,F06)' flux_Qacc = ',flux_Qacc + write(logunit,F02)' flux_Qacc0 = ',flux_Qacc0 + write(logunit,F00)' restfilm = ',trim(restfilm) + write(logunit,F00)' restfils = ',trim(restfils) + endif + call shr_mpi_bcast(ice_in ,mpicom,'ice_in') + call shr_mpi_bcast(decomp ,mpicom,'decomp') + call shr_mpi_bcast(flux_swpf ,mpicom,'flux_swpf') + call shr_mpi_bcast(flux_Qmin ,mpicom,'flux_Qmin') + call shr_mpi_bcast(flux_Qacc ,mpicom,'flux_Qacc') + call shr_mpi_bcast(flux_Qacc0,mpicom,'flux_Qacc0') + call shr_mpi_bcast(restfilm,mpicom,'restfilm') + call shr_mpi_bcast(restfils,mpicom,'restfils') + + rest_file = trim(restfilm) + rest_file_strm = trim(restfils) + + !---------------------------------------------------------------------------- + ! Read dshr namelist + !---------------------------------------------------------------------------- + + call shr_strdata_readnml(SDICE,trim(ice_in),mpicom=mpicom) + + !---------------------------------------------------------------------------- + ! Initialize IO + !---------------------------------------------------------------------------- + + + ice_pio_subsystem=>shr_pio_getiosys(trim(inst_name)) + + call shr_strdata_pioinit(SDICE, ice_pio_subsystem, shr_pio_getiotype(trim(inst_name))) + + !---------------------------------------------------------------------------- + ! Validate mode + !---------------------------------------------------------------------------- + + + ice_mode = trim(SDICE%dataMode) + + ! check that we know how to handle the mode + + if (trim(ice_mode) == 'NULL' .or. & + trim(ice_mode) == 'SSTDATA' .or. & + trim(ice_mode) == 'COPYALL') then + if (my_task == master_task) & + write(logunit,F00) ' ice mode = ',trim(ice_mode) + else + write(logunit,F00) ' ERROR illegal ice mode = ',trim(ice_mode) + call shr_sys_abort() + endif + + call t_stopf('dice_readnml') + + !---------------------------------------------------------------------------- + ! Initialize datasets + !---------------------------------------------------------------------------- + + call t_startf('dice_strdata_init') + + ice_present = .true. + call seq_timemgr_EClockGetData( EClock, calendar=calendar ) + if (scmmode) then + if (my_task == master_task) & + write(logunit,F05) ' scm lon lat = ',scmlon,scmlat + call shr_strdata_init(SDICE,mpicom,compid,name='ice', & + scmmode=scmmode,scmlon=scmlon,scmlat=scmlat, & + calendar=calendar) + else + call shr_strdata_init(SDICE,mpicom,compid,name='ice', & + calendar=calendar) + endif + + if (trim(ice_mode) == 'SSTDATA' .or. & + trim(ice_mode) == 'COPYALL') then + ice_prognostic = .true. + endif + + if (my_task == master_task) then + call shr_strdata_print(SDICE,'SDICE data') + endif + + call t_stopf('dice_strdata_init') + + !---------------------------------------------------------------------------- + ! Set flag to specify data components + !---------------------------------------------------------------------------- + + call seq_infodata_PutData(infodata, & + ice_present=ice_present, ice_prognostic=ice_prognostic, & + ice_nx=SDICE%nxg, ice_ny=SDICE%nyg ) + + !---------------------------------------------------------------------------- + ! Initialize MCT global seg map, 1d decomp + !---------------------------------------------------------------------------- + + call t_startf('dice_initgsmaps') + if (my_task == master_task) write(logunit,F00) ' initialize gsmaps' + call shr_sys_flush(logunit) + + call shr_dmodel_gsmapcreate(gsmap,SDICE%nxg*SDICE%nyg,compid,mpicom,decomp) + lsize = mct_gsmap_lsize(gsmap,mpicom) + + if (ice_present) then + call mct_rearr_init(SDICE%gsmap,gsmap,mpicom,rearr) + endif + + call t_stopf('dice_initgsmaps') + + !---------------------------------------------------------------------------- + ! Initialize MCT domain + !---------------------------------------------------------------------------- + + call t_startf('dice_initmctdom') + if (my_task == master_task) write(logunit,F00) 'copy domains' + call shr_sys_flush(logunit) + + if (ice_present) call shr_dmodel_rearrGGrid(SDICE%grid, ggrid, gsmap, rearr, mpicom) + + call t_stopf('dice_initmctdom') + + !---------------------------------------------------------------------------- + ! Initialize MCT attribute vectors + !---------------------------------------------------------------------------- + + call t_startf('dice_initmctavs') + if (my_task == master_task) write(logunit,F00) 'allocate AVs' + call shr_sys_flush(logunit) + + call mct_aVect_init(i2x, rList=seq_flds_i2x_fields, lsize=lsize) + call mct_aVect_zero(i2x) + + kiFrac = mct_aVect_indexRA(i2x,'Si_ifrac') + kt = mct_aVect_indexRA(i2x,'Si_t') + ktref = mct_aVect_indexRA(i2x,'Si_tref') + kqref = mct_aVect_indexRA(i2x,'Si_qref') + kavsdr = mct_aVect_indexRA(i2x,'Si_avsdr') + kanidr = mct_aVect_indexRA(i2x,'Si_anidr') + kavsdf = mct_aVect_indexRA(i2x,'Si_avsdf') + kanidf = mct_aVect_indexRA(i2x,'Si_anidf') + kswnet = mct_aVect_indexRA(i2x,'Faii_swnet') + ksen = mct_aVect_indexRA(i2x,'Faii_sen') + klat = mct_aVect_indexRA(i2x,'Faii_lat') + klwup = mct_aVect_indexRA(i2x,'Faii_lwup') + kevap = mct_aVect_indexRA(i2x,'Faii_evap') + ktauxa = mct_aVect_indexRA(i2x,'Faii_taux') + ktauya = mct_aVect_indexRA(i2x,'Faii_tauy') + kmelth = mct_aVect_indexRA(i2x,'Fioi_melth') + kmeltw = mct_aVect_indexRA(i2x,'Fioi_meltw') + kswpen = mct_aVect_indexRA(i2x,'Fioi_swpen') + ktauxo = mct_aVect_indexRA(i2x,'Fioi_taux') + ktauyo = mct_aVect_indexRA(i2x,'Fioi_tauy') + ksalt = mct_aVect_indexRA(i2x,'Fioi_salt') + + call mct_aVect_init(x2i, rList=seq_flds_x2i_fields, lsize=lsize) + call mct_aVect_zero(x2i) + + kswvdr = mct_aVect_indexRA(x2i,'Faxa_swvdr') + kswndr = mct_aVect_indexRA(x2i,'Faxa_swndr') + kswvdf = mct_aVect_indexRA(x2i,'Faxa_swvdf') + kswndf = mct_aVect_indexRA(x2i,'Faxa_swndf') + kq = mct_aVect_indexRA(x2i,'Fioo_q') + kz = mct_aVect_indexRA(x2i,'Sa_z') + kua = mct_aVect_indexRA(x2i,'Sa_u') + kva = mct_aVect_indexRA(x2i,'Sa_v') + kptem = mct_aVect_indexRA(x2i,'Sa_ptem') + kshum = mct_aVect_indexRA(x2i,'Sa_shum') + kdens = mct_aVect_indexRA(x2i,'Sa_dens') + ktbot = mct_aVect_indexRA(x2i,'Sa_tbot') + + ! call mct_aVect_init(avstrm, rList=flds_strm, lsize=lsize) + ! call mct_aVect_zero(avstrm) + + allocate(imask(lsize)) + allocate(yc(lsize)) + allocate(water(lsize)) + ! allocate(iFrac0(lsize)) + + kfld = mct_aVect_indexRA(ggrid%data,'mask') + imask(:) = nint(ggrid%data%rAttr(kfld,:)) + kfld = mct_aVect_indexRA(ggrid%data,'lat') + yc(:) = ggrid%data%rAttr(kfld,:) + + call t_stopf('dice_initmctavs') + + !---------------------------------------------------------------------------- + ! Read restart + !---------------------------------------------------------------------------- + +!*****POPDART Sept 27,2012 AliciaK +!*****hardcode read_restart so that dice does not look for rpointers +!**** or restart files + +! read_restart = .false. + +!******************* + + + if (read_restart) then + if (trim(rest_file) == trim(nullstr) .and. & + trim(rest_file_strm) == trim(nullstr)) then + if (my_task == master_task) then + write(logunit,F00) ' restart filenames from rpointer' + call shr_sys_flush(logunit) + inquire(file=trim(rpfile)//trim(inst_suffix),exist=exists) + if (.not.exists) then + write(logunit,F00) ' ERROR: rpointer file does not exist' + call shr_sys_abort(trim(subname)//' ERROR: rpointer file missing') + endif + nu = shr_file_getUnit() + open(nu,file=trim(rpfile)//trim(inst_suffix),form='formatted') + read(nu,'(a)') rest_file + read(nu,'(a)') rest_file_strm + close(nu) + call shr_file_freeUnit(nu) + inquire(file=trim(rest_file_strm),exist=exists) + endif + call shr_mpi_bcast(rest_file,mpicom,'rest_file') + call shr_mpi_bcast(rest_file_strm,mpicom,'rest_file_strm') + else + ! use namelist already read + if (my_task == master_task) then + write(logunit,F00) ' restart filenames from namelist ' + call shr_sys_flush(logunit) + inquire(file=trim(rest_file_strm),exist=exists) + endif + endif + call shr_mpi_bcast(exists,mpicom,'exists') + if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file) + call shr_pcdf_readwrite('read',SDICE%pio_subsystem, SDICE%io_type, & + trim(rest_file),mpicom,gsmap,rf1=water,rf1n='water') + if (exists) then + if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file_strm) + call shr_strdata_restRead(trim(rest_file_strm),SDICE,mpicom) + else + if (my_task == master_task) write(logunit,F00) ' file not found, skipping ',trim(rest_file_strm) + endif + call shr_sys_flush(logunit) + endif + + !---------------------------------------------------------------------------- + ! On initial call, x2i is unset, so set for use in run method + ! These values should have no impact on the solution!! + !---------------------------------------------------------------------------- + x2i%rAttr(kz,:) = 10.0_R8 + x2i%rAttr(kua,:) = 5.0_R8 + x2i%rAttr(kva,:) = 5.0_R8 + x2i%rAttr(kptem,:) = 260.0_R8 + x2i%rAttr(ktbot,:) = 260.0_R8 + x2i%rAttr(kshum,:) = 0.0014_R8 + x2i%rAttr(kdens,:) = 1.3_R8 + + !---------------------------------------------------------------------------- + ! Set initial ice state, needed for CCSM atm initialization + !---------------------------------------------------------------------------- + + call t_adj_detailf(+2) + call dice_comp_run( EClock, cdata, x2i, i2x) + call t_adj_detailf(-2) + + !---------------------------------------------------------------------------- + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + if (my_task == master_task) write(logunit,F00) 'dice_comp_init done' + call shr_sys_flush(logunit) + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + call shr_sys_flush(logunit) + + call t_stopf('DICE_INIT') + +end subroutine dice_comp_init + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: dice_comp_run +! +! !DESCRIPTION: +! run method for dead ice model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine dice_comp_run( EClock, cdata, x2i, i2x) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) ,intent(in) :: EClock + type(seq_cdata) ,intent(inout) :: cdata + type(mct_aVect) ,intent(inout) :: x2i ! driver -> dead + type(mct_aVect) ,intent(inout) :: i2x ! dead -> driver + +!EOP + + !--- local --- + type(mct_gsMap) , pointer :: gsmap + type(mct_gGrid) , pointer :: ggrid + + integer(IN) :: CurrentYMD ! model date + integer(IN) :: CurrentTOD ! model sec into model date + integer(IN) :: yy,mm,dd ! year month day + integer(IN) :: n ! indices + integer(IN) :: nf ! fields loop index + integer(IN) :: nl ! ice frac index + integer(IN) :: lsize ! size of attr vect + integer(IN) :: shrlogunit, shrloglev ! original log unit and level + logical :: glcrun_alarm ! is glc going to run now + logical :: newdata ! has newdata been read + logical :: mssrmlf ! remove old data + integer(IN) :: idt ! integer timestep + real(R8) :: dt ! timestep + real(R8) :: hn ! h field + logical :: write_restart ! restart now + character(CL) :: case_name ! case name + character(CL) :: rest_file ! restart_file + character(CL) :: rest_file_strm ! restart_file for stream + integer(IN) :: nu ! unit number + real(R8) :: qmeltall ! q that would melt all accumulated water + real(R8) :: cosarg ! for setting ice temp pattern + real(R8) :: jday, jday0 ! elapsed day counters + character(CS) :: calendar ! calendar type + + type(seq_infodata_type), pointer :: infodata + + character(*), parameter :: F00 = "('(dice_comp_run) ',8a)" + character(*), parameter :: F04 = "('(dice_comp_run) ',2a,2i8,'s')" + character(*), parameter :: subName = "(dice_comp_run) " +!------------------------------------------------------------------------------- + + call t_startf('DICE_RUN') + + call t_startf('dice_run1') + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (logUnit) + + call seq_cdata_setptrs(cdata, gsMap=gsmap, dom=ggrid) + + call seq_cdata_setptrs(cdata, infodata=infodata) + + call seq_timemgr_EClockGetData( EClock, curr_ymd=CurrentYMD, curr_tod=CurrentTOD) + call seq_timemgr_EClockGetData( EClock, curr_yr=yy, curr_mon=mm, curr_day=dd) + call seq_timemgr_EClockGetData( EClock, dtime=idt, calendar=calendar) + dt = idt * 1.0_r8 + write_restart = seq_timemgr_RestartAlarmIsOn(EClock) + + call t_stopf('dice_run1') + + !-------------------- + ! UNPACK + !-------------------- + + call t_startf('dice_unpack') + +! lsize = mct_avect_lsize(x2i) + + call t_stopf('dice_unpack') + + !-------------------- + ! ADVANCE ICE + !-------------------- + + call t_barrierf('dice_BARRIER',mpicom) + call t_startf('dice') + + !--- copy all fields from streams to i2x as default --- + + if (trim(ice_mode) /= 'NULL') then + call t_startf('dice_strdata_advance') + call shr_strdata_advance(SDICE,currentYMD,currentTOD,mpicom,'dice') + call t_stopf('dice_strdata_advance') + call t_barrierf('dice_scatter_BARRIER',mpicom) + call t_startf('dice_scatter') + do n = 1,SDICE%nstreams + call shr_dmodel_translateAV(SDICE%avs(n),i2x,avifld,avofld,rearr) + enddo + call t_stopf('dice_scatter') + else + call mct_aVect_zero(i2x) + endif + + call t_startf('dice_mode') + + select case (trim(ice_mode)) + + case('COPYALL') + ! do nothing extra + + case('SSTDATA') + if (firstcall .and. .not. read_restart) then +! iFrac0 = iFrac ! previous step's ice fraction + water = 0.0_R8 ! previous step's water accumulation + where (i2x%rAttr(kiFrac,:) > 0.0_R8) water(:) = flux_Qacc0 + endif + +! tcraig, feb 10, 2012, ymd2eday no longer exists, use ymd2julian instead +! this could be improved for use in gregorian calendar +! call shr_cal_ymd2eday(0,mm,dd,eDay ,calendar) ! model date +! call shr_cal_ymd2eday(0,09,01,eDay0,calendar) ! sept 1st +! cosArg = 2.0_R8*pi*(real(eDay,R8) + real(currentTOD,R8)/cDay - real(eDay0,R8))/365.0_R8 + call shr_cal_ymd2julian(0,mm,dd,currentTOD,jDay ,calendar) ! julian day for model + call shr_cal_ymd2julian(0, 9, 1,0 ,jDay0,calendar) ! julian day for Sept 1 + cosArg = 2.0_R8*pi*(jday - jday0)/365.0_R8 + + lsize = mct_avect_lsize(i2x) + + do n = 1,lsize + + !--- fix erroneous iFrac --- + i2x%rAttr(kiFrac,n) = min(1.0_R8,max(0.0_R8,i2x%rAttr(kiFrac,n))) + + !--- fabricate ice surface T, fix erroneous iFrac --- + if ( yc(n) > 0.0_R8) then + i2x%rAttr(kt,n) = 260.0_R8 + 10.0_R8*cos(cosArg) + else + i2x%rAttr(kt,n) = 260.0_R8 - 10.0_R8*cos(cosArg) + end if + + !--- set albedos (constant) --- + i2x%rAttr(kavsdr,n) = ax_vsdr + i2x%rAttr(kanidr,n) = ax_nidr + i2x%rAttr(kavsdf,n) = ax_vsdf + i2x%rAttr(kanidf,n) = ax_nidf + + !--- swnet is sent to cpl as a diagnostic quantity only --- + !--- newly recv'd swdn goes with previously sent albedo --- + !--- but albedos are (currently) time invariant --- + i2x%rAttr(kswnet,n) = (1.0_R8 - i2x%rAttr(kavsdr,n))*x2i%rAttr(kswvdr,n) & + & + (1.0_R8 - i2x%rAttr(kanidr,n))*x2i%rAttr(kswndr,n) & + & + (1.0_R8 - i2x%rAttr(kavsdf,n))*x2i%rAttr(kswvdf,n) & + & + (1.0_R8 - i2x%rAttr(kanidf,n))*x2i%rAttr(kswndf,n) + + !--- compute melt/freeze water balance, adjust iFrac ------------- + if ( .not. flux_Qacc ) then ! Q accumulation option is OFF + i2x%rAttr(kmelth,n) = min(x2i%rAttr(kq,n),0.0_R8 ) ! q<0 => melt potential + i2x%rAttr(kmelth,n) = max(i2x%rAttr(kmelth,n),Flux_Qmin ) ! limit the melt rate + i2x%rAttr(kmeltw,n) = -i2x%rAttr(kmelth,n)/latice ! corresponding water flux + + else ! Q accumulation option is ON + !-------------------------------------------------------------- + ! 1a) Q<0 & iFrac > 0 => infinite supply of water to melt + ! 1b) Q<0 & iFrac = 0 => melt accumulated water only + ! 2a) Q>0 & iFrac > 0 => zero-out accumulated water + ! 2b) Q>0 & iFrac = 0 => accumulated water + !-------------------------------------------------------------- + if ( x2i%rAttr(kq,n) < 0.0_R8 ) then ! Q<0 => melt + if (i2x%rAttr(kiFrac,n) > 0.0_R8 ) then + i2x%rAttr(kmelth,n) = i2x%rAttr(kiFrac,n)*max(x2i%rAttr(kq,n),Flux_Qmin) + i2x%rAttr(kmeltw,n) = -i2x%rAttr(kmelth,n)/latice + ! water(n) = < don't change this value > + else + Qmeltall = -water(n)*latice/dt + i2x%rAttr(kmelth,n) = max(x2i%rAttr(kq,n), Qmeltall, Flux_Qmin ) + i2x%rAttr(kmeltw,n) = -i2x%rAttr(kmelth,n)/latice + water(n) = water(n) - i2x%rAttr(kmeltw,n)*dt + end if + else ! Q>0 => freeze + if (i2x%rAttr(kiFrac,n) > 0.0_R8 ) then + i2x%rAttr(kmelth,n) = 0.0_R8 + i2x%rAttr(kmeltw,n) = 0.0_R8 + water(n) = 0.0_R8 + else + i2x%rAttr(kmelth,n) = 0.0_R8 + i2x%rAttr(kmeltw,n) = 0.0_R8 + water(n) = water(n) + dt*x2i%rAttr(kq,n)/latice + end if + end if + + if (water(n) < 1.0e-16_R8 ) water(n) = 0.0_R8 + + !--- non-zero water => non-zero iFrac --- + if (i2x%rAttr(kiFrac,n) <= 0.0_R8 .and. water(n) > 0.0_R8) then + i2x%rAttr(kiFrac,n) = min(1.0_R8,water(n)/waterMax) + ! i2x%rAttr(kT,n) = Tfrz ! T can be above freezing?!? + end if + + !--- cpl multiplies melth & meltw by iFrac --- + !--- divide by iFrac here => fixed quantity flux (not per area) --- + if (i2x%rAttr(kiFrac,n) > 0.0_R8) then + i2x%rAttr(kiFrac,n) = max( 0.01_R8, i2x%rAttr(kiFrac,n)) ! min iFrac + i2x%rAttr(kmelth,n) = i2x%rAttr(kmelth,n)/i2x%rAttr(kiFrac,n) + i2x%rAttr(kmeltw,n) = i2x%rAttr(kmeltw,n)/i2x%rAttr(kiFrac,n) + else + i2x%rAttr(kmelth,n) = 0.0_R8 + i2x%rAttr(kmeltw,n) = 0.0_R8 + end if + end if + + !--- modify T wrt iFrac: (iFrac -> 0) => (T -> Tfrz) --- + i2x%rAttr(kt,n) = Tfrz + i2x%rAttr(kiFrac,n)*(i2x%rAttr(kt,n)-Tfrz) + + end do + + !---------------------------------------------------------------------------- + ! compute atm/ice surface fluxes + !---------------------------------------------------------------------------- + call shr_flux_atmIce(iMask ,x2i%rAttr(kz,:) ,x2i%rAttr(kua,:) ,x2i%rAttr(kva,:), & + x2i%rAttr(kptem,:) ,x2i%rAttr(kshum,:) ,x2i%rAttr(kdens,:) ,x2i%rAttr(ktbot,:), & + i2x%rAttr(kt,:) ,i2x%rAttr(ksen,:) ,i2x%rAttr(klat,:) ,i2x%rAttr(klwup,:), & + i2x%rAttr(kevap,:) ,i2x%rAttr(ktauxa,:) ,i2x%rAttr(ktauya,:) ,i2x%rAttr(ktref,:), & + i2x%rAttr(kqref,:) ) + + !---------------------------------------------------------------------------- + ! compute ice/oce surface fluxes (except melth & meltw, see above) + !---------------------------------------------------------------------------- + do n=1,lsize + if (iMask(n) == 0) then + i2x%rAttr(kswpen,n) = spval + i2x%rAttr(kmelth,n) = spval + i2x%rAttr(kmeltw,n) = spval + i2x%rAttr(ksalt ,n) = spval + i2x%rAttr(ktauxo,n) = spval + i2x%rAttr(ktauyo,n) = spval + i2x%rAttr(kiFrac,n) = 0.0_R8 + else + !--- penetrating short wave --- + i2x%rAttr(kswpen,n) = max(0.0_R8, flux_swpf*i2x%rAttr(kswnet,n) ) ! must be non-negative + + !--- i/o surface stress ( = atm/ice stress) --- + i2x%rAttr(ktauxo,n) = i2x%rAttr(ktauxa,n) + i2x%rAttr(ktauyo,n) = i2x%rAttr(ktauya,n) + + !--- salt flux --- + i2x%rAttr(ksalt ,n) = 0.0_R8 + end if + +! !--- save ifrac for next timestep +! iFrac0(n) = i2x%rAttr(kiFrac,n) + end do + + + end select + + call t_stopf('dice_mode') + + if (write_restart) then + call t_startf('dice_restart') + call seq_infodata_GetData( infodata, case_name=case_name) + write(rest_file,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.dice'//trim(inst_suffix)//'.r.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.nc' + write(rest_file_strm,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.dice'//trim(inst_suffix)//'.rs1.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.bin' + if (my_task == master_task) then + nu = shr_file_getUnit() + open(nu,file=trim(rpfile)//trim(inst_suffix),form='formatted') + write(nu,'(a)') rest_file + write(nu,'(a)') rest_file_strm + close(nu) + call shr_file_freeUnit(nu) + endif + if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file),currentYMD,currentTOD + call shr_pcdf_readwrite('write',SDICE%pio_subsystem, SDICE%io_type, & + trim(rest_file),mpicom,gsmap,clobber=.true.,rf1=water,rf1n='water') + if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file_strm),currentYMD,currentTOD + call shr_strdata_restWrite(trim(rest_file_strm),SDICE,mpicom,trim(case_name),'SDICE strdata') + call shr_sys_flush(logunit) + call t_stopf('dice_restart') + endif + + call t_stopf('dice') + + !---------------------------------------------------------------------------- + ! Log output for model date + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + call t_startf('dice_run2') + if (my_task == master_task) then + write(logunit,F04) trim(myModelName),': model date ', CurrentYMD,CurrentTOD + call shr_sys_flush(logunit) + end if + firstcall = .false. + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + call shr_sys_flush(logunit) + call t_stopf('dice_run2') + + call t_stopf('DICE_RUN') + +end subroutine dice_comp_run + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: dice_comp_final +! +! !DESCRIPTION: +! finalize method for dead ice model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ +! +subroutine dice_comp_final() + + implicit none + +!EOP + + !--- formats --- + character(*), parameter :: F00 = "('(dice_comp_final) ',8a)" + character(*), parameter :: F91 = "('(dice_comp_final) ',73('-'))" + character(*), parameter :: subName = "(dice_comp_final) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call t_startf('DICE_FINAL') + + if (my_task == master_task) then + write(logunit,F91) + write(logunit,F00) trim(myModelName),': end of main integration loop' + write(logunit,F91) + end if + + call t_stopf('DICE_FINAL') + +end subroutine dice_comp_final +!=============================================================================== +!=============================================================================== + +end module dice_comp_mod diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.dlnd/dlnd_comp_mod.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.dlnd/dlnd_comp_mod.F90 new file mode 100644 index 0000000000..9cbc00fd7c --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.dlnd/dlnd_comp_mod.F90 @@ -0,0 +1,782 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1/models/lnd/dlnd/dlnd_comp_mod.F90 + +#ifdef AIX +@PROCESS ALIAS_SIZE(805306368) +#endif +module dlnd_comp_mod + +! !USES: + + use shr_sys_mod + use shr_kind_mod , only: IN=>SHR_KIND_IN, R8=>SHR_KIND_R8, & + CS=>SHR_KIND_CS, CL=>SHR_KIND_CL + use shr_file_mod , only: shr_file_getunit, shr_file_getlogunit, shr_file_getloglevel, & + shr_file_setlogunit, shr_file_setloglevel, shr_file_setio, & + shr_file_freeunit + use shr_mpi_mod , only: shr_mpi_bcast + use mct_mod + use esmf + use perf_mod + + use shr_strdata_mod + use shr_dmodel_mod + + use seq_cdata_mod + use seq_infodata_mod + use seq_timemgr_mod + use seq_comm_mct , only: seq_comm_inst, seq_comm_name, seq_comm_suffix + use seq_flds_mod , only: seq_flds_l2x_fields, seq_flds_x2l_fields, & + seq_flds_x2s_fields, seq_flds_s2x_fields +! +! !PUBLIC TYPES: + implicit none + private ! except + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: dlnd_comp_init + public :: dlnd_comp_run + public :: dlnd_comp_final + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + + !--- other --- + character(CS) :: myModelName = 'lnd' ! user defined model name + integer(IN) :: mpicom + integer(IN) :: my_task ! my task in mpi communicator mpicom + integer(IN) :: npes ! total number of tasks + integer(IN),parameter :: master_task=0 ! task number of master task + integer(IN) :: logunit ! logging unit number + integer :: inst_index ! number of current instance (ie. 1) + character(len=16) :: inst_name ! fullname of current instance (ie. "lnd_0001") + character(len=16) :: inst_suffix ! char string associated with instance + ! (ie. "_0001" or "") + character(CL) :: lnd_mode + character(CL) :: sno_mode + integer(IN) :: dbug = 0 ! debug level (higher is more) + logical :: scmMode = .false. ! single column mode + real(R8) :: scmLat = shr_const_SPVAL ! single column lat + real(R8) :: scmLon = shr_const_SPVAL ! single column lon + logical :: read_restart ! start from restart + + character(len=*),parameter :: rpfile = 'rpointer.lnd' + character(len=*),parameter :: nullstr = 'undefined' + + type(shr_strdata_type),save :: SDLND + type(shr_strdata_type),save :: SDSNO + + type(mct_rearr) :: rearr_l + type(mct_rearr) :: rearr_s + + integer(IN),parameter :: ktrans = 52 + character(12),parameter :: avofld(1:ktrans) = & + (/ "Sl_t ","Sl_tref ","Sl_qref ","Sl_avsdr ","Sl_anidr ", & + "Sl_avsdf ","Sl_anidf ","Sl_snowh ","Fall_taux ","Fall_tauy ", & + "Fall_lat ","Fall_sen ","Fall_lwup ","Fall_evap ","Fall_swnet ", & + "Sl_landfrac ","Sl_fv ","Sl_ram1 ", & + "Fall_flxdst1","Fall_flxdst2","Fall_flxdst3","Fall_flxdst4", & + "Ss_tsrf01 ","Ss_topo01 ","Ss_tsrf02 ","Ss_topo02 ","Ss_tsrf03 ", & + "Ss_topo03 ","Ss_tsrf04 ","Ss_topo04 ","Ss_tsrf05 ","Ss_topo05 ", & + "Ss_tsrf06 ","Ss_topo06 ","Ss_tsrf07 ","Ss_topo07 ","Ss_tsrf08 ", & + "Ss_topo08 ","Ss_tsrf09 ","Ss_topo09 ","Ss_tsrf10 ","Ss_topo10 ", & + "Fgss_qice01 ","Fgss_qice02 ","Fgss_qice03 ","Fgss_qice04 ","Fgss_qice05 ", & + "Fgss_qice06 ","Fgss_qice07 ","Fgss_qice08 ","Fgss_qice09 ","Fgss_qice10 " /) + character(12),parameter :: avifld(1:ktrans) = & + (/ "t ","tref ","qref ","avsdr ","anidr ", & + "avsdf ","anidf ","snowh ","taux ","tauy ", & + "lat ","sen ","lwup ","evap ","swnet ", & + "lfrac ","fv ","ram1 ", & + "flddst1 ","flxdst2 ","flxdst3 ","flxdst4 ", & + "tsrf01 ","topo01 ","tsrf02 ","topo02 ","tsrf03 ", & + "topo03 ","tsrf04 ","topo04 ","tsrf05 ","topo05 ", & + "tsrf06 ","topo06 ","tsrf07 ","topo07 ","tsrf08 ", & + "topo08 ","tsrf09 ","topo09 ","tsrf10 ","topo10 ", & + "qice01 ","qice02 ","qice03 ","qice04 ","qice05 ", & + "qice06 ","qice07 ","qice08 ","qice09 ","qice10 " /) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CONTAINS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: dlnd_comp_init +! +! !DESCRIPTION: +! initialize data lnd model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine dlnd_comp_init( EClock, cdata_l, x2l, l2x, & + cdata_s, x2s, s2x, NLFilename ) + + use shr_pio_mod, only : shr_pio_getiosys, shr_pio_getiotype + use pio, only : iosystem_desc_t + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) , intent(in) :: EClock + type(seq_cdata) , intent(inout) :: cdata_l + type(mct_aVect) , intent(inout) :: x2l, l2x + type(seq_cdata) , intent(inout) :: cdata_s + type(mct_aVect) , intent(inout) :: x2s, s2x + character(len=*), optional , intent(in) :: NLFilename ! Namelist filename + +!EOP + + !--- local variables --- + integer(IN) :: n,k ! generic counters + integer(IN) :: ierr ! error code + integer(IN) :: COMPID ! comp id + integer(IN) :: gsize ! global size + integer(IN) :: lsize_l, lsize_s ! local size + integer(IN) :: shrlogunit, shrloglev ! original log unit and level + integer(IN) :: nunit ! unit number + logical :: lnd_present ! flag + logical :: lnd_prognostic ! flag + logical :: sno_present ! flag + logical :: sno_prognostic ! flag + character(CL) :: calendar ! model calendar + + type(seq_infodata_type), pointer :: infodata + type(mct_gsMap) , pointer :: gsMap_l + type(mct_gGrid) , pointer :: dom_l + type(mct_gsMap) , pointer :: gsMap_s + type(mct_gGrid) , pointer :: dom_s + + character(CL) :: filePath ! generic file path + character(CL) :: fileName ! generic file name + character(CS) :: timeName ! domain file: time variable name + character(CS) :: lonName ! domain file: lon variable name + character(CS) :: latName ! domain file: lat variable name + character(CS) :: maskName ! domain file: mask variable name + character(CS) :: areaName ! domain file: area variable name + + integer(IN) :: yearFirst ! first year to use in data stream + integer(IN) :: yearLast ! last year to use in data stream + integer(IN) :: yearAlign ! data year that aligns with yearFirst + + character(CL) :: lnd_in ! dshr lnd namelist + character(CL) :: sno_in ! dshr sno namelist + character(CL) :: decomp ! decomp strategy + character(CL) :: rest_file ! restart filename + character(CL) :: rest_file_strm_l ! restart filename for stream + character(CL) :: rest_file_strm_s ! restart filename for stream + character(CL) :: restfilm ! model restart file namelist + character(CL) :: restfilsl ! stream restart file namelist + character(CL) :: restfilsr ! stream restart file namelist + character(CL) :: restfilss ! stream restart file namelist + logical :: exists ! file existance logical + logical :: exists_l ! file existance logical + logical :: exists_s ! file existance logical + integer(IN) :: nu ! unit number + + type(iosystem_desc_t), pointer :: lnd_pio_subsys + integer(IN) :: lnd_pio_iotype + + !----- define namelist ----- + namelist / dlnd_nml / & + lnd_in, sno_in, decomp, restfilm, restfilsl, restfilss + + !--- formats --- + character(*), parameter :: F00 = "('(dlnd_comp_init) ',8a)" + character(*), parameter :: F01 = "('(dlnd_comp_init) ',a,5i8)" + character(*), parameter :: F02 = "('(dlnd_comp_init) ',a,4es13.6)" + character(*), parameter :: F03 = "('(dlnd_comp_init) ',a,i8,a)" + character(*), parameter :: F05 = "('(dlnd_comp_init) ',a,2f10.4)" + character(*), parameter :: F90 = "('(dlnd_comp_init) ',73('='))" + character(*), parameter :: F91 = "('(dlnd_comp_init) ',73('-'))" + character(*), parameter :: subName = "(dlnd_comp_init) " +!------------------------------------------------------------------------------- + + + call t_startf('DLND_INIT') + + ! Set cdata pointers + + call seq_cdata_setptrs(cdata_l, ID=COMPID, mpicom=mpicom, & + gsMap=gsMap_l, dom=dom_l, infodata=infodata) + + call seq_cdata_setptrs(cdata_s, & + gsMap=gsMap_s, dom=dom_s) + + ! Determine communicator groups and sizes + + call mpi_comm_rank(mpicom, my_task, ierr) + call mpi_comm_size(mpicom, npes, ierr) + + inst_name = seq_comm_name(COMPID) + inst_index = seq_comm_inst(COMPID) + inst_suffix = seq_comm_suffix(COMPID) + + !--- open log file --- + if (my_task == master_task) then + logUnit = shr_file_getUnit() + call shr_file_setIO('lnd_modelio.nml'//trim(inst_suffix),logUnit) + else + logUnit = 6 + endif + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (logUnit) + + !---------------------------------------------------------------------------- + ! Set a Few Defaults + !---------------------------------------------------------------------------- + + call seq_infodata_getData(infodata,single_column=scmMode, & + & scmlat=scmlat, scmlon=scmLon) + + lnd_present = .false. + lnd_prognostic = .false. + sno_present = .false. + sno_prognostic = .false. + call seq_infodata_GetData(infodata,read_restart=read_restart) + + !---------------------------------------------------------------------------- + ! Read dlnd_in + !---------------------------------------------------------------------------- + + call t_startf('dlnd_readnml') + + filename = "dlnd_in"//trim(inst_suffix) + lnd_in = "unset" + sno_in = "unset" + decomp = "1d" + restfilm = trim(nullstr) + restfilsl = trim(nullstr) + restfilsr = trim(nullstr) + restfilss = trim(nullstr) + if (my_task == master_task) then + nunit = shr_file_getUnit() ! get unused unit number + open (nunit,file=trim(filename),status="old",action="read") + read (nunit,nml=dlnd_nml,iostat=ierr) + close(nunit) + call shr_file_freeUnit(nunit) + if (ierr > 0) then + write(logunit,F01) 'ERROR: reading input namelist, '//trim(filename)//' iostat=',ierr + call shr_sys_abort(subName//': namelist read error '//trim(filename)) + end if + write(logunit,F00)' lnd_in = ',trim(lnd_in) + write(logunit,F00)' sno_in = ',trim(sno_in) + write(logunit,F00)' decomp = ',trim(decomp) + write(logunit,F00)' restfilm = ',trim(restfilm) + write(logunit,F00)' restfilsl = ',trim(restfilsl) + write(logunit,F00)' restfilsr = ',trim(restfilsr) + write(logunit,F00)' restfilss = ',trim(restfilss) + endif + call shr_mpi_bcast(lnd_in,mpicom,'lnd_in') + call shr_mpi_bcast(sno_in,mpicom,'sno_in') + call shr_mpi_bcast(decomp,mpicom,'decomp') + call shr_mpi_bcast(restfilm,mpicom,'restfilm') + call shr_mpi_bcast(restfilsl,mpicom,'restfilsl') + call shr_mpi_bcast(restfilsr,mpicom,'restfilsr') + call shr_mpi_bcast(restfilss,mpicom,'restfilss') + + rest_file = trim(restfilm) + rest_file_strm_l = trim(restfilsl) + rest_file_strm_s = trim(restfilss) + + !---------------------------------------------------------------------------- + ! Read dshr namelist + !---------------------------------------------------------------------------- + + call shr_strdata_readnml(SDLND,trim(lnd_in),mpicom=mpicom) + call shr_strdata_readnml(SDSNO,trim(sno_in),mpicom=mpicom) + + !---------------------------------------------------------------------------- + ! Validate mode + !---------------------------------------------------------------------------- + + lnd_mode = trim(SDLND%dataMode) + sno_mode = trim(SDSNO%dataMode) + + ! check that we know how to handle the mode + + if (trim(lnd_mode) == 'NULL' .or. & + trim(lnd_mode) == 'CPLHIST') then + if (my_task == master_task) & + write(logunit,F00) ' lnd mode = ',trim(lnd_mode) + else + write(logunit,F00) ' ERROR illegal lnd mode = ',trim(lnd_mode) + call shr_sys_abort() + endif + + if (trim(sno_mode) == 'NULL' .or. & + trim(sno_mode) == 'CPLHIST') then + if (my_task == master_task) & + write(logunit,F00) ' sno mode = ',trim(sno_mode) + else + write(logunit,F00) ' ERROR illegal sno mode = ',trim(sno_mode) + call shr_sys_abort() + endif + + call t_stopf('dlnd_readnml') + + !---------------------------------------------------------------------------- + ! Initialize datasets + !---------------------------------------------------------------------------- + + call t_startf('dlnd_strdata_init') + + lnd_pio_subsys => shr_pio_getiosys(trim(inst_name)) + lnd_pio_iotype = shr_pio_getiotype(trim(inst_name)) + + call seq_timemgr_EClockGetData( EClock, calendar=calendar ) + + if (trim(lnd_mode) /= 'NULL') then + lnd_present = .true. + call shr_strdata_pioinit(SDLND,lnd_pio_subsys,lnd_pio_iotype) + if (scmmode) then + if (my_task == master_task) & + write(logunit,F05) ' scm lon lat = ',scmlon,scmlat + call shr_strdata_init(SDLND,mpicom,compid,name='lnd', & + scmmode=scmmode,scmlon=scmlon,scmlat=scmlat, & + calendar=calendar) + else + call shr_strdata_init(SDLND,mpicom,compid,name='lnd', & + calendar=calendar) + endif + endif + + if (trim(sno_mode) /= 'NULL') then + sno_present = .true. + call shr_strdata_pioinit(SDSNO,lnd_pio_subsys,lnd_pio_iotype) + if (scmmode) then + call shr_strdata_init(SDSNO,mpicom,compid,name='sno', & + scmmode=scmmode,scmlon=scmlon,scmlat=scmlat, & + calendar=calendar) + else + call shr_strdata_init(SDSNO,mpicom,compid,name='sno', & + calendar=calendar) + endif + endif + + if (my_task == master_task) then + call shr_strdata_print(SDLND,'SDLND data') + call shr_strdata_print(SDSNO,'SDSNO data') + endif + + call t_stopf('dlnd_strdata_init') + + !---------------------------------------------------------------------------- + ! Set flag to specify data components + !---------------------------------------------------------------------------- + + call seq_infodata_PutData(infodata, & + lnd_present=lnd_present, lnd_prognostic=lnd_prognostic, & + sno_present=sno_present, sno_prognostic=sno_prognostic, & + lnd_nx=SDLND%nxg, lnd_ny=SDLND%nyg, & + sno_nx=SDSNO%nxg, sno_ny=SDSNO%nyg) + + if (.not. lnd_present .and. .not. sno_present) then + RETURN + end if + + !---------------------------------------------------------------------------- + ! Initialize MCT global seg map, 1d decomp + !---------------------------------------------------------------------------- + + call t_startf('dlnd_initgsmaps') + if (my_task == master_task) write(logunit,F00) ' initialize gsmaps' + call shr_sys_flush(logunit) + + call shr_dmodel_gsmapcreate(gsmap_l,SDLND%nxg*SDLND%nyg,compid,mpicom,decomp) + call shr_dmodel_gsmapcreate(gsmap_s,SDSNO%nxg*SDSNO%nyg,compid,mpicom,decomp) + lsize_l = mct_gsmap_lsize(gsmap_l,mpicom) + lsize_s = mct_gsmap_lsize(gsmap_s,mpicom) + + if (lnd_present) then + call mct_rearr_init(SDLND%gsmap,gsmap_l,mpicom,rearr_l) + endif + + if (sno_present) then + call mct_rearr_init(SDSNO%gsmap,gsmap_s,mpicom,rearr_s) + endif + + call t_stopf('dlnd_initgsmaps') + + !---------------------------------------------------------------------------- + ! Initialize MCT domain + !---------------------------------------------------------------------------- + + call t_startf('dlnd_initmctdom') + if (my_task == master_task) write(logunit,F00) 'copy domains' + call shr_sys_flush(logunit) + + if (lnd_present) call shr_dmodel_rearrGGrid(SDLND%grid, dom_l, gsmap_l, rearr_l, mpicom) + if (sno_present) call shr_dmodel_rearrGGrid(SDSNO%grid, dom_s, gsmap_s, rearr_s, mpicom) + + call t_stopf('dlnd_initmctdom') + + !---------------------------------------------------------------------------- + ! Initialize MCT attribute vectors + !---------------------------------------------------------------------------- + + call t_startf('dlnd_initmctavs') + if (my_task == master_task) write(logunit,F00) 'allocate AVs' + call shr_sys_flush(logunit) + + call mct_aVect_init(l2x, rList=seq_flds_l2x_fields, lsize=lsize_l) + call mct_aVect_zero(l2x) + + call mct_aVect_init(x2l, rList=seq_flds_x2l_fields, lsize=lsize_l) + call mct_aVect_zero(x2l) + + call mct_aVect_init(x2s, rList=seq_flds_x2s_fields, lsize=lsize_s) + call mct_aVect_zero(x2s) + + call mct_aVect_init(s2x, rList=seq_flds_s2x_fields, lsize=lsize_s) + call mct_aVect_zero(s2x) + call t_stopf('dlnd_initmctavs') + + !---------------------------------------------------------------------------- + ! Read restart + !---------------------------------------------------------------------------- + !*****POPDART Sept 27,2012 AliciaK + !*****hardcode read_restart so that dlnd does not look for rpointers + !**** or restart files + + write(6,*) "Setting read_restart to .false. in DLND" !ALICIAK + read_restart = .false. + + !******************* + + if (read_restart) then + if (trim(rest_file) == trim(nullstr) .and. & + trim(rest_file_strm_l) == trim(nullstr) .and. & + trim(rest_file_strm_s) == trim(nullstr)) then + if (my_task == master_task) then + write(logunit,F00) ' restart filenames from rpointer' + call shr_sys_flush(logunit) + inquire(file=trim(rpfile)//trim(inst_suffix),exist=exists) + if (.not.exists) then + write(logunit,F00) ' ERROR: rpointer file does not exist' + call shr_sys_abort(trim(subname)//' ERROR: rpointer file missing') + endif + nu = shr_file_getUnit() + open(nu,file=trim(rpfile)//trim(inst_suffix),form='formatted') + read(nu,'(a)') rest_file + read(nu,'(a)') rest_file_strm_l + read(nu,'(a)') rest_file_strm_s + close(nu) + call shr_file_freeUnit(nu) + inquire(file=trim(rest_file_strm_l),exist=exists_l) + inquire(file=trim(rest_file_strm_s),exist=exists_s) + endif + call shr_mpi_bcast(rest_file,mpicom,'rest_file') + call shr_mpi_bcast(rest_file_strm_l,mpicom,'rest_file_strm_l') + call shr_mpi_bcast(rest_file_strm_s,mpicom,'rest_file_strm_s') + else + ! use namelist already read + if (my_task == master_task) then + write(logunit,F00) ' restart filenames from namelist ' + call shr_sys_flush(logunit) + inquire(file=trim(rest_file_strm_l),exist=exists_l) + inquire(file=trim(rest_file_strm_s),exist=exists_s) + endif + endif + call shr_mpi_bcast(exists_l,mpicom,'exists_l') + call shr_mpi_bcast(exists_s,mpicom,'exists_s') + !if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file) + !call shr_pcdf_readwrite('read',trim(rest_file),mpicom,gsmap,rf1=somtp,rf1n='somtp') + if (exists_l) then + if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file_strm_l) + call shr_strdata_restRead(trim(rest_file_strm_l),SDLND,mpicom) + else + if (my_task == master_task) write(logunit,F00) ' file not found, skipping ',trim(rest_file_strm_l) + endif + if (exists_s) then + if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file_strm_s) + call shr_strdata_restRead(trim(rest_file_strm_s),SDSNO,mpicom) + else + if (my_task == master_task) write(logunit,F00) ' file not found, skipping ',trim(rest_file_strm_s) + endif + call shr_sys_flush(logunit) + endif + + !---------------------------------------------------------------------------- + ! Set initial lnd state, needed for CCSM atm initialization + !---------------------------------------------------------------------------- + + call t_adj_detailf(+2) + call dlnd_comp_run( EClock, cdata_l, x2l, l2x, cdata_s, x2s, s2x) + call t_adj_detailf(-2) + + !---------------------------------------------------------------------------- + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + if (my_task == master_task) write(logunit,F00) 'dlnd_comp_init done' + call shr_sys_flush(logunit) + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + call shr_sys_flush(logunit) + + call t_stopf('DLND_INIT') + +end subroutine dlnd_comp_init + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: dlnd_comp_run +! +! !DESCRIPTION: +! run method for dead lnd model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine dlnd_comp_run( EClock, cdata_l, x2l, l2x, cdata_s, x2s, s2x) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) ,intent(in) :: EClock + type(seq_cdata) ,intent(inout) :: cdata_l + type(mct_aVect) ,intent(inout) :: x2l + type(mct_aVect) ,intent(inout) :: l2x + type(seq_cdata) ,intent(inout) :: cdata_s + type(mct_aVect) ,intent(inout) :: x2s + type(mct_aVect) ,intent(inout) :: s2x + +!EOP + + !--- local --- + type(mct_gsMap) , pointer :: gsMap_l + type(mct_gGrid) , pointer :: dom_l + type(mct_gsMap) , pointer :: gsMap_s + type(mct_gGrid) , pointer :: dom_s + + integer(IN) :: CurrentYMD ! model date + integer(IN) :: CurrentTOD ! model sec into model date + integer(IN) :: yy,mm,dd ! year month day + integer(IN) :: n ! indices + integer(IN) :: nf ! fields loop index + integer(IN) :: nl ! land frac index + integer(IN) :: kl ! index of landfrac + integer(IN) :: lsize_l,lsize_s ! size of attr vect + integer(IN) :: shrlogunit, shrloglev ! original log unit and level + logical :: glcrun_alarm ! is glc going to run now + logical :: newdata ! has newdata been read + logical :: mssrmlf ! remove old data + logical :: write_restart ! restart now + character(CL) :: case_name ! case name + character(CL) :: rest_file ! restart_file + character(CL) :: rest_file_strm_l ! restart_file for stream + character(CL) :: rest_file_strm_s ! restart_file for stream + integer(IN) :: nu ! unit number + integer(IN) :: nflds_x2l + integer(IN) :: nflds_x2s + type(seq_infodata_type), pointer :: infodata + + character(*), parameter :: F00 = "('(dlnd_comp_run) ',8a)" + character(*), parameter :: F04 = "('(dlnd_comp_run) ',2a,2i8,'s')" + character(*), parameter :: subName = "(dlnd_comp_run) " +!------------------------------------------------------------------------------- + + call t_startf('DLND_RUN') + + call t_startf('dlnd_run1') + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (logUnit) + + call seq_cdata_setptrs(cdata_l, gsMap=gsMap_l, dom=dom_l) + call seq_cdata_setptrs(cdata_s, gsMap=gsMap_s, dom=dom_s) + + call seq_cdata_setptrs(cdata_l, infodata=infodata) + call seq_infodata_getData(infodata, glcrun_alarm=glcrun_alarm) + + call seq_timemgr_EClockGetData( EClock, curr_ymd=CurrentYMD, curr_tod=CurrentTOD) + call seq_timemgr_EClockGetData( EClock, curr_yr=yy, curr_mon=mm, curr_day=dd) + write_restart = seq_timemgr_RestartAlarmIsOn(EClock) + + lsize_l = mct_avect_lsize(x2l) + lsize_s = mct_avect_lsize(x2s) + nflds_x2l = mct_avect_nRattr(x2l) + nflds_x2s = mct_avect_nRattr(x2s) + + call t_stopf('dlnd_run1') + + !-------------------- + ! UNPACK + !-------------------- + + call t_startf('dlnd_unpack') + +! do nf=1,nflds_x2l +! do n=1,lsize_l +! ?? = x2l%rAttr(nf,n) +! enddo +! enddo + +! do nf=1,nflds_x2s +! do n=1,lsize_s +! ?? = x2s%rAttr(nf,n) +! enddo +! enddo + + call t_stopf('dlnd_unpack') + + !-------------------- + ! ADVANCE LAND + !-------------------- + + call t_barrierf('dlnd_l_BARRIER',mpicom) + call t_startf('dlnd_l') + + if (trim(lnd_mode) /= 'NULL') then + call t_startf('dlnd_l_strdata_advance') + call shr_strdata_advance(SDLND,currentYMD,currentTOD,mpicom,'dlnd_l') + call t_stopf('dlnd_l_strdata_advance') + call t_barrierf('dlnd_l_scatter_BARRIER',mpicom) + call t_startf('dlnd_l_scatter') + do n = 1,SDLND%nstreams + call shr_dmodel_translateAV(SDLND%avs(n),l2x,avifld,avofld,rearr_l) + enddo + call t_stopf('dlnd_l_scatter') + else + call mct_aVect_zero(l2x) + endif + + call t_stopf('dlnd_l') + + !-------------------- + ! ADVANCE SNO + !-------------------- + + call t_barrierf('dlnd_s_BARRIER',mpicom) + call t_startf('dlnd_s') + if (trim(sno_mode) /= 'NULL') then + call t_startf('dlnd_s_strdata_advance') + call shr_strdata_advance(SDSNO,currentYMD,currentTOD,mpicom,'dlnd_s') + call t_stopf('dlnd_s_strdata_advance') + call t_barrierf('dlnd_s_scatter_BARRIER',mpicom) + call t_startf('dlnd_s_scatter') + do n = 1,SDSNO%nstreams + call shr_dmodel_translateAV(SDSNO%avs(n),s2x,avifld,avofld,rearr_s) + enddo + call t_stopf('dlnd_s_scatter') + else + call mct_aVect_zero(s2x) + endif + call t_stopf('dlnd_s') + + if (write_restart) then + call t_startf('dlnd_restart') + call seq_infodata_GetData( infodata, case_name=case_name) + write(rest_file,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.dlnd'//trim(inst_suffix)//'.r.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.nc' + write(rest_file_strm_l,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.dlnd'//trim(inst_suffix)//'.rs1.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.bin' + write(rest_file_strm_s,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.dlnd'//trim(inst_suffix)//'.rs3.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.bin' + if (my_task == master_task) then + nu = shr_file_getUnit() + open(nu,file=trim(rpfile)//trim(inst_suffix),form='formatted') + write(nu,'(a)') rest_file + write(nu,'(a)') rest_file_strm_l + write(nu,'(a)') rest_file_strm_s + close(nu) + call shr_file_freeUnit(nu) + endif + !if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file),currentYMD,currentTOD + !call shr_pcdf_readwrite('write',trim(rest_file),mpicom,gsmap,clobber=.true., & + ! rf1=somtp,rf1n='somtp') + if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file_strm_l),currentYMD,currentTOD + call shr_strdata_restWrite(trim(rest_file_strm_l),SDLND,mpicom,trim(case_name),'SDLND strdata') + if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file_strm_s),currentYMD,currentTOD + call shr_strdata_restWrite(trim(rest_file_strm_s),SDSNO,mpicom,trim(case_name),'SDSNO strdata') + call shr_sys_flush(logunit) + call t_stopf('dlnd_restart') + endif + + !---------------------------------------------------------------------------- + ! Log output for model date + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + call t_startf('dlnd_run2') + if (my_task == master_task) then + write(logunit,F04) trim(myModelName),': model date ', CurrentYMD,CurrentTOD + call shr_sys_flush(logunit) + end if + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + call shr_sys_flush(logunit) + call t_stopf('dlnd_run2') + + call t_stopf('DLND_RUN') + +end subroutine dlnd_comp_run + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: dlnd_comp_final +! +! !DESCRIPTION: +! finalize method for dead lnd model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ +! +subroutine dlnd_comp_final() + + implicit none + +!EOP + + !--- formats --- + character(*), parameter :: F00 = "('(dlnd_comp_final) ',8a)" + character(*), parameter :: F91 = "('(dlnd_comp_final) ',73('-'))" + character(*), parameter :: subName = "(dlnd_comp_final) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call t_startf('DLND_FINAL') + + if (my_task == master_task) then + write(logunit,F91) + write(logunit,F00) trim(myModelName),': end of main integration loop' + write(logunit,F91) + end if + + call t_stopf('DLND_FINAL') + +end subroutine dlnd_comp_final +!=============================================================================== +!=============================================================================== + + +end module dlnd_comp_mod diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/build-namelist b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/build-namelist new file mode 100755 index 0000000000..039bfd65b2 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/build-namelist @@ -0,0 +1,2193 @@ +#!/usr/bin/env perl +#----------------------------------------------------------------------------------------------- +# DART comment block +# This file ( /glade/p/cesm/cseg/collections/cesm1_2_beta04/models/ocn/pop2/bld/build-namelist ) +# replaces /glade/p/cesm/cseg/collections/cesm1_1_1/models/ocn/pop2/bld/build-namelist +#----------------------------------------------------------------------------------------------- +# build-namelist +# +# This script builds the namelists for the POP2 configuration of CESM1. +# +# build-namelist uses a config_cache.xml file that current contains the ocean grid information. +# build-namelist reads this file to obtain information it needs to provide +# default values that are consistent with the POP2 library. For example, the grid resolution +# is obtained from the cache file and used to determine appropriate defaults for namelist input +# that is resolution dependent. +# +# The simplest use of build-namelist is to execute it from the build directory where configure +# was run. By default it will use the config_cache.xml file that was written by configure to +# determine the build time properties of the executable, and will write the files that contain +# the output namelists in that same directory. +# +# +# Date Contributor Modification +# ------------------------------------------------------------------------------------------- +# 2012-01-30 Vertenstein Original version +#-------------------------------------------------------------------------------------------- +use strict; +use Cwd; +use English; +use Getopt::Long; +use IO::File; + +#----------------------------------------------------------------------------------------------- + +sub usage { + die < 0, + test => 0, + verbose => 0, + preview => 0, + caseroot => undef, + casebuild => undef, + scriptsroot => undef, + inst_string => undef, + ocn_grid => undef, + cfg_dir => $cfgdir, + ); + +GetOptions( + "h|help" => \$opts{'help'}, + "infile=s" => \$opts{'infile'}, + "namelist=s" => \$opts{'namelist'}, + "v|verbose" => \$opts{'verbose'}, + "caseroot=s" => \$opts{'caseroot'}, + "casebuild=s" => \$opts{'casebuild'}, + "scriptsroot=s" => \$opts{'scriptsroot'}, + "inst_string=s" => \$opts{'inst_string'}, + "ocn_grid=s" => \$opts{'ocn_grid'}, + "cfg_dir=s" => \$opts{'cfg_dir'}, + "preview" => \$opts{'preview'}, +) or usage(); + +# Give usage message. +usage() if $opts{'help'}; + +# Check for unparsed arguments +if (@ARGV) { + print "ERROR: unrecognized arguments: @ARGV\n"; + usage(); +} + +# Define print levels: +# 0 - only issue fatal error messages +# 1 - only informs what files are created (currently not used) +# 2 - verbose +my $print = 0; +my $preview = 0; +if ($opts{'verbose'}) { $print = 2; } +if ($opts{'preview'}) { $preview = 1; } +my $eol = "\n"; + +if ($print>=2) { print "Setting POP2 configuration script directory to $cfgdir$eol"; } + +my $CASEROOT = $opts{'caseroot'}; +my $CASEBUILD = $opts{'casebuild'}; +my $SCRIPTSROOT = $opts{'scriptsroot'}; +my $inst_string = $opts{'inst_string'}; +my $OCN_GRID = $opts{'ocn_grid'}; +$cfgdir = $opts{'cfg_dir'}; + +# Validate some of the commandline option values. +validate_options("commandline", \%opts); + +# build config_cache.xml file (needed below) +my $config_cache = "${CASEBUILD}/pop2conf/config_cache.xml"; +my $fh = new IO::File; +$fh->open(">$config_cache") or die "** can't open file: $config_cache\n"; +print $fh <<"EOF"; + + + + +EOF +$fh->close; +if ($print>=2) { print "Wrote file $config_cache $eol"; } +(-f "config_cache.xml") or die <<"EOF"; +** $ProgName - Cannot find configuration cache file: config_cache.xml\" ** +EOF + +#----------------------------------------------------------------------------------------------- +# Make sure we can find required perl modules, definition, and defaults files. +# Look for them under the directory that contains the configure script. + +# The root directory for the perl5 required utilities +my $perl5lib_dir = "${SCRIPTSROOT}/ccsm_utils/Tools/perl5lib"; + +# The XML::Lite module is required to parse the XML files. +(-f "$perl5lib_dir/XML/Lite.pm") or die <<"EOF"; +** $ProgName - Cannot find perl module \"XML/Lite.pm\" in directory \"$perl5lib_dir\" ** +EOF + +# The Build::Config module provides utilities to access the configuration information +# in the config_cache.xml file (see below) +(-f "$perl5lib_dir/Build/Config.pm") or die <<"EOF"; +** $ProgName - Cannot find perl module \"Build/Config.pm\" in directory \"$perl5lib_dir\" ** +EOF + +# The Build::NamelistDefinition module provides utilities to validate that the output +# namelists are consistent with the namelist definition file +(-f "$perl5lib_dir/Build/NamelistDefinition.pm") or die <<"EOF"; +** $ProgName - Cannot find perl module \"Build/NamelistDefinition.pm\" in directory \"$perl5lib_dir\" ** +EOF + +# The Build::NamelistDefaults module provides a utility to obtain default values of namelist +# variables based on finding a best fit with the attributes specified in the defaults file. +(-f "$perl5lib_dir/Build/NamelistDefaults.pm") or die <<"EOF"; +** $ProgName - Cannot find perl module \"Build/NamelistDefaults.pm\" in directory \"$perl5lib_dir\" ** +EOF + +# The Build::Namelist module provides utilities to parse input namelists, to query and modify +# namelists, and to write output namelists. +(-f "$perl5lib_dir/Build/Namelist.pm") or die <<"EOF"; +** $ProgName - Cannot find perl module \"Build/Namelist.pm\" in directory \"$perl5lib_dir\" ** +EOF + +# The namelist definition file contains entries for all namelist variables that +# can be output by build-namelist. The version of the file that is associate with a +# fixed POP2 tag is $cfgdir/namelist_files/namelist_definition.xml. To aid developers +# who make use of the SourceMods/src.pop2 directory - we allow the definition file +# to come from that directory +my $nl_definition_file; +if (-f "${CASEROOT}/SourceMods/src.pop2/namelist_definition_pop2.xml") { + $nl_definition_file = "${CASEROOT}/SourceMods/src.pop2/namelist_definition_pop2.xml"; +} +if (! defined $nl_definition_file) { + # default location of namelist definition file + $nl_definition_file = "$cfgdir/namelist_files/namelist_definition_pop2.xml"; + (-f "$nl_definition_file") or die <<"EOF"; + ** $ProgName - ERROR: Cannot find namelist definition file \"$nl_definition_file\" ** +EOF +} +if ($print>=2) { print "Using namelist definition file $nl_definition_file$eol"; } + +# The namelist defaults file contains default values for all required namelist variables. +my $nl_defaults_file; +if (-f "${CASEROOT}/SourceMods/src.pop2/namelist_defaults_pop2.xml") { + $nl_defaults_file = "${CASEROOT}/SourceMods/src.pop2/namelist_defaults_pop2.xml"; +} +if (! defined $nl_defaults_file) { + $nl_defaults_file = "$cfgdir/namelist_files/namelist_defaults_pop2.xml"; + (-f "$nl_defaults_file") or die <<"EOF"; + ** $ProgName - Cannot find namelist defaults file \"$nl_defaults_file\" ** +EOF +} +if ($print>=2) { print "Using namelist defaults file $nl_defaults_file$eol"; } + +#----------------------------------------------------------------------------------------------- +# Add $perl5lib_dir to the list of paths that Perl searches for modules +unshift @INC, "$perl5lib_dir"; +require XML::Lite; +require Build::Config; +require Build::NamelistDefinition; +require Build::NamelistDefaults; +require Build::Namelist; + +#----------------------------------------------------------------------------------------------- +# Create a configuration object from the POP2 config_cache.xml file- created by +# pop2.cpl7.template in $CASEBUILD/pop2conf +my $cfg = Build::Config->new('config_cache.xml'); + +# Create a namelist definition object. This object provides a method for verifying that the +# output namelist variables are in the definition file, and are output in the correct +# namelist groups. +my $definition = Build::NamelistDefinition->new($nl_definition_file); + +# Create a namelist defaults object. This object provides default values for variables +# contained in the input defaults file. The configuration object provides attribute +# values that are relevent for the POP2 library for which the namelist is being produced. +my $defaults = Build::NamelistDefaults->new($nl_defaults_file, $cfg); + +# Create an empty namelist object. Add values to it in order of precedence. +my $nl = Build::Namelist->new(); + +#----------------------------------------------------------------------------------------------- +# Process the user input in order of precedence. At each point we'll only add new +# values to the namelist and not overwrite previously specified specified values which +# have higher precedence. + +# Process the commandline args that provide specific namelist values. + +# Process the -namelist arg. +if (defined $opts{'namelist'}) { + # Parse commandline namelist + my $nl_arg = Build::Namelist->new($opts{'namelist'}); + + # Validate input namelist -- trap exceptions + my $nl_arg_valid; + eval { $nl_arg_valid = $definition->validate($nl_arg); }; + if ($@) { + die "$ProgName - ERROR: Invalid namelist variable in commandline arg '-namelist'.\n $@"; + } + + # Merge input values into namelist. Previously specified values have higher precedence + # and are not overwritten. + $nl->merge_nl($nl_arg_valid); +} + +# Process the -infile arg. +if (defined $opts{'infile'}) { + # Parse namelist input from a file + my $nl_infile = Build::Namelist->new($opts{'infile'}); + my $nl_infile_valid = Build::Namelist->new(); + + # Validate namelist variables (going to do this one variable at a time) + for my $group ($nl_infile->get_group_names()) { + for my $var ($nl_infile->get_variable_names($group)) { + my $var_local; # Name of variable to write to infile + my $nl_check_var = Build::Namelist->new(); + my $nl_check_valid; + my $val = $nl_infile->get_variable_value($group, $var); + my @broken = split(/&/,$var); + my $check_grp = 0; # If 1, make sure group found in definitions file + # matches that specified in user_nl_pop2 + + # if variable has ampersand, truncate it unless it is type derived + if ($broken[1]) { + my $nl_check_amp = Build::Namelist->new(); + $nl_check_amp->set_variable_value($group, $var, $val); + eval { $definition->validate($nl_check_amp) }; + if (not $@) { + # & is required in variable name + $var_local = $var; + } else { + # & should not be in variable name + $var_local = $broken[0]; + $check_grp = 1; + } + } else { + $var_local = $var; + } + + # Make sure variable is defined in namelist_definition_pop2.xml + $nl_check_var->set_variable_value($group, $var_local,$val); + eval { $nl_check_valid = $definition->validate($nl_check_var); }; + (not $@) or die <<"EOF"; +** ERROR: either $var_local is not a valid POP2 namelist variable or $var_local = $val is not a valid value; please fix user_nl_pop2. Note that $var_local may appear in multiple namelists, in which case you need to specify the correct namelist in user_nl_pop2 using the format $var_local\&namelist_nml = $val, where \&namelist_nml is the pop2_in namelist containing $var_local.** +EOF + + # If group was specified in user_nl_pop2, make sure it matches + # the group in the definitions file. + my @group_valid = $nl_check_valid->get_group_names(); + ((not $check_grp) or ($broken[1] eq $group_valid[0])) or die <<"EOF"; +** ERROR: $broken[0] is in $group_valid[0], not $broken[1]! Please fix this in user_nl_pop2. ** +EOF + + # Add variable to validated namelist + $nl_infile_valid->set_variable_value($group_valid[0], $var_local, $val); + } + } + + # If preview is desired and something has been changed in $nl_infile_valid, + # output everything in $nl_infile_valid + if (($preview == 1) && ($nl_infile_valid->get_group_names)) { + print " - The following values have been set in user_nl_pop2:\n"; + print_nl_to_screen($nl_infile_valid); + } + # Merge input values into namelist. Previously specified values have higher + # precedence and are not overwritten. + $nl->merge_nl($nl_infile_valid); +} + +#----------------------------------------------------------------------------------------------- +# Determine xml variables + +my %xmlvars = (); +my @files = <${CASEROOT}/*xml>; +foreach my $file (@files) { + my $xml = XML::Lite->new( "$file" ); + my @e = $xml->elements_by_name('entry'); + while ( my $e = shift @e ) { + my %a = $e->get_attributes(); + $xmlvars{$a{'id'}} = $a{'value'}; + } +} +foreach my $attr (keys %xmlvars) { + if ( $xmlvars{$attr} =~ m/\$/ ) {$xmlvars{$attr} = expand_env_xml($xmlvars{$attr});} + if ( $xmlvars{$attr} =~ m/\$/ ) {$xmlvars{$attr} = expand_env_xml($xmlvars{$attr});} + if ( $xmlvars{$attr} =~ m/\$/ ) {$xmlvars{$attr} = expand_env_xml($xmlvars{$attr});} +} + +my $RUNDIR = "$xmlvars{'RUNDIR'}"; +my $CODEROOT = "$xmlvars{'CODEROOT'}"; +my $DIN_LOC_ROOT = "$xmlvars{'DIN_LOC_ROOT'}"; +my $CASE = "$xmlvars{'CASE'}"; +my $CALENDAR = "$xmlvars{'CALENDAR'}"; +my $CCSM_CO2_PPMV = "$xmlvars{'CCSM_CO2_PPMV'}"; +my $CCSM_BGC = "$xmlvars{'CCSM_BGC'}"; +my $NCPL_BASE_PERIOD = "$xmlvars{'NCPL_BASE_PERIOD'}"; +my $OCN_NCPL = "$xmlvars{'OCN_NCPL'}"; +my $OCN_COUPLING = "$xmlvars{'OCN_COUPLING'}"; +my $OCN_ICE_FORCING = "$xmlvars{'OCN_ICE_FORCING'}"; +my $OCN_CHL_TYPE = "$xmlvars{'OCN_CHL_TYPE'}"; +my $OCN_CO2_TYPE = "$xmlvars{'OCN_CO2_TYPE'}"; +my $OCN_TRANSIENT = "$xmlvars{'OCN_TRANSIENT'}"; +my $OCN_TRACER_MODULES = "$xmlvars{'OCN_TRACER_MODULES'}"; +my $OCN_TRACER_MODULES_OPT = "$xmlvars{'OCN_TRACER_MODULES_OPT'}"; +my $OCN_TAVG_TRACER_BUDGET = "$xmlvars{'OCN_TAVG_TRACER_BUDGET'}"; +my $OCN_TAVG_HIFREQ = "$xmlvars{'OCN_TAVG_HIFREQ'}"; +my $NTASKS_OCN = "$xmlvars{'NTASKS_OCN'}"; +my $NINST_OCN = "$xmlvars{'NINST_OCN'}"; +my $POP_DECOMPTYPE = "$xmlvars{'POP_DECOMPTYPE'}"; +my $INFO_DBUG = "$xmlvars{'INFO_DBUG'}"; +my $RUN_TYPE = "$xmlvars{'RUN_TYPE'}"; +my $RUN_STARTDATE = "$xmlvars{'RUN_STARTDATE'}"; +my $CONTINUE_RUN = "$xmlvars{'CONTINUE_RUN'}"; +my $OCN_CO2_FLUX_OCMIP_BUG_FIX = "$xmlvars{'OCN_CO2_FLUX_OCMIP_BUG_FIX'}"; + +my $output_r = "./${CASE}.pop.r"; +my $output_h = "./${CASE}.pop.h"; +my $output_d = "./${CASE}.pop.d"; +if ($inst_string) { + $output_r = "./${CASE}.pop${inst_string}.r"; + $output_h = "./${CASE}.pop${inst_string}.h"; + $output_d = "./${CASE}.pop${inst_string}.d"; +} + +# Environment variables set in pop2.buildnml.csh that are not xml variables +my $RESTART_INPUT_TS_FMT = "$ENV{'RESTART_INPUT_TS_FMT'}"; +my $LID = $ENV{'LID'}; + +my $ntasks = $NTASKS_OCN / $NINST_OCN; + +if ($CONTINUE_RUN eq 'TRUE') {$RUN_TYPE = "continue";} + +my $iyear0 = `echo $RUN_STARTDATE | cut -c1-4 | sed -e 's/^0*//'`; +$iyear0 =~ s/\n/ /g; # remove imbedded newline +$iyear0 = $iyear0+0; + +my $imonth0 = `echo $RUN_STARTDATE | cut -c6-7 | sed -e 's/^0*//'`; +$imonth0 =~ s/\n/ /g; # remove imbedded newline +$imonth0 = $imonth0+0; + +my $iday0 = `echo $RUN_STARTDATE | cut -c9-10 | sed -e 's/^0*//'`; +$iday0 =~ s/\n/ /g; # remove imbedded newline +$iday0 = $iday0+0; + +my $ihour0 = 0; +my $iminute0 = 0; +my $isecond0 = 0; + +# coupled_freq and coupled_freq_opts depend on +# environment variables NCPL_BASE_PERIOD and OCN_NCPL +# Note that env_run.xml couples OCN_NCPL times per NCPL_BASE_PERIOD +# while POP couples every coupled_freq [in units of coupled_freq_opts] +# Example: OCN_NCPL = 4, NCPL_BASE_PERIOD = day => couple 4 times a day +# coupled_freq = 4, coupled_freq_opts = nday => couple every 4 days +# +# Also need to know coupled_freq and coupled_freq_opts to set start time +# in time_manager_nml +my $coupled_freq; +my $coupled_freq_opt = 'nsecond'; +my $sec_per_base_period; +if ($NCPL_BASE_PERIOD eq 'hour') { + $sec_per_base_period = 3600; +} elsif ($NCPL_BASE_PERIOD eq 'day') { + $sec_per_base_period = 3600 * 24; +} elsif ($NCPL_BASE_PERIOD eq 'year') { + if ($CALENDAR eq 'NO_LEAP') { + $sec_per_base_period = 3600 * 24 * 365; + } else { + die "$ProgName: ERROR invalid CALENDAR for NCPL_BASE_PERIOD $NCPL_BASE_PERIOD"; + } +} elsif ($NCPL_BASE_PERIOD eq 'decade') { + if ($CALENDAR eq 'NO_LEAP') { + $sec_per_base_period = 3600 * 24 * 365 * 10; + } else { + die "$ProgName: ERROR invalid CALENDAR for NCPL_BASE_PERIOD $NCPL_BASE_PERIOD"; + } +} else { + die "$ProgName: ERROR invalid NCPL_BASE_PERIOD $NCPL_BASE_PERIOD"; +} + +if ($sec_per_base_period < 0) { + die "$ProgName: ERROR integer overflow $sec_per_base_period should be positive"; +} + +if ($sec_per_base_period % $OCN_NCPL == 0) { + $coupled_freq = $sec_per_base_period/$OCN_NCPL; +} else { + die "$ProgName: Coupling $OCN_NCPL times per $NCPL_BASE_PERIOD is not an integer number of seconds per coupling period"; +} +if ($coupled_freq % 3600 == 0) { + $coupled_freq = $coupled_freq / 3600; + $coupled_freq_opt = 'nhour'; +# print $sec_per_base_period/$OCN_NCPL," seconds = $coupled_freq hour(s)\n"; + if ($coupled_freq % 24 == 0) { + $coupled_freq = $coupled_freq / 24; + $coupled_freq_opt = 'nday'; +# print $sec_per_base_period/$OCN_NCPL," seconds = $coupled_freq day(s)\n"; + if ($coupled_freq % 365 == 0) { + $coupled_freq = $coupled_freq / 365; + $coupled_freq_opt = 'nyear'; +# print $sec_per_base_period/$OCN_NCPL," seconds = $coupled_freq year(s)\n"; + } + } +} + +# tmp starts with units of seconds, will cycle through minutes, hours, and days +# and increase isecond0, iminute0, ihour0, and iday0 as necessary. Note that at +# this point I don't know how to toggle months, so errors might occur with +# abnormally large coupling frequency. +my $tmp = $sec_per_base_period/$OCN_NCPL; +my $remainder; +# increase seconds +$remainder = $tmp%60; +$isecond0 += $remainder; +# increase minutes +$tmp = ($tmp - $remainder)/60; +$remainder = $tmp%60; +$iminute0 += $remainder; +# increase hours +$tmp = ($tmp - $remainder)/60; +$remainder = $tmp%24; +$ihour0 += $remainder; +# increase days +$tmp = ($tmp - $remainder)/24; +if ($tmp > 0) { + $iday0 += $tmp; + # check to see if need to roll into new month / year + while (not valid_date(\$iday0, \$imonth0, \$iyear0, $CALENDAR)) {} +} + +print "POP2 build-namelist: ocn_grid is $OCN_GRID \n"; +print "POP2 build-namelist: ocn_tracer_modules are $OCN_TRACER_MODULES \n"; + +(-d $DIN_LOC_ROOT) or die <<"EOF"; +** $ProgName - CCSM inputdata root is not a directory: \"$DIN_LOC_ROOT\" ** +EOF +if ($print>=2) { print "CESM inputdata root directory: $DIN_LOC_ROOT$eol"; } + +#----------------------------------------------------------------------------------------------- +# Determine namelist +#----------------------------------------------------------------------------------------------- + +################################## +# namelist group: domain_nml # +################################## + +add_default($nl, 'nprocs_clinic', 'val'=>"$ntasks"); +add_default($nl, 'nprocs_tropic', 'val'=>"$ntasks"); +add_default($nl, 'clinic_distribution_type', 'val'=>"$POP_DECOMPTYPE"); +add_default($nl, 'tropic_distribution_type', 'val'=>"$POP_DECOMPTYPE"); +add_default($nl, 'ew_boundary_type'); +add_default($nl, 'ns_boundary_type'); + +################################## +# namelist group: io_nml # +################################## + +add_default($nl, 'num_iotasks'); +add_default($nl, 'lredirect_stdout'); +add_default($nl, 'log_filename', 'val'=>"${RUNDIR}/ocn${inst_string}.log.$LID"); +add_default($nl, 'luse_pointer_files'); +add_default($nl, 'luse_nf_64bit_offset'); + +#################################### +# namelist group: time_manager_nml # +#################################### + +add_default($nl, 'accel_file', 'val'=>"${RUNDIR}/${OCN_GRID}_depth_accel"); +add_default($nl, 'runid', 'val'=>"$CASE"); +add_default($nl, 'time_mix_opt'); +add_default($nl, 'time_mix_freq'); +add_default($nl, 'dt_option'); +add_default($nl, 'dt_count','ocn_coupling'=>"$OCN_COUPLING"); +add_default($nl, 'impcor'); +add_default($nl, 'laccel'); +add_default($nl, 'dtuxcel'); +add_default($nl, 'allow_leapyear', 'calendar'=>"$CALENDAR"); +add_default($nl, 'iyear0' ,'val'=>$iyear0); +add_default($nl, 'imonth0' ,'val'=>$imonth0); +add_default($nl, 'iday0' ,'val'=>$iday0); +add_default($nl, 'ihour0' ,'val'=>$ihour0); +add_default($nl, 'iminute0','val'=>$iminute0); +add_default($nl, 'isecond0','val'=>$isecond0); +add_default($nl, 'date_separator'); +add_default($nl, 'stop_option'); +add_default($nl, 'stop_count'); +add_default($nl, 'fit_freq', 'val'=>"$OCN_NCPL"); + +#################################### +# namelist group: grid_nml # +#################################### + +# Note: topography_opt = bathymetry is a nonstandard option that +# requires the user to provide nonstandard files in the users' +# $CASEROOT/SourceMods/src.pop2 directory +# Currently this is hard-wired to 'file' + +my $topography_opt = 'file'; # hard-wired for now +my $bathymetry_file= 'unknown_bathymetry'; #hard-wired for now + +add_default($nl, 'vert_grid_file' , 'val'=>"${RUNDIR}/${OCN_GRID}_vert_grid"); +add_default($nl, 'region_info_file', 'val'=>"${RUNDIR}/${OCN_GRID}_region_ids"); +add_default($nl, 'topography_opt' , 'val'=>"$topography_opt"); +add_default($nl, 'bathymetry_file' , 'val'=>"$bathymetry_file"); +add_default($nl, 'lremove_points' , 'topograpahy_opt'=>"$topography_opt"); +add_default($nl, 'horiz_grid_opt'); +add_default($nl, 'horiz_grid_file'); +add_default($nl, 'vert_grid_opt' ); +add_default($nl, 'topography_file'); +add_default($nl, 'topography_outfile', 'val'=>"${output_h}.topography_bathymetry.ieeer8"); +add_default($nl, 'kmt_kmin'); +add_default($nl, 'partial_bottom_cells'); +add_default($nl, 'bottom_cell_file', 'nofail'=>1); +if (not $nl->get_value('bottom_cell_file')) { + add_default($nl, 'bottom_cell_file', 'val'=>'unknown_bottom_cell','noprepend'=>1); +} +add_default($nl, 'n_topo_smooth'); +add_default($nl, 'flat_bottom'); +add_default($nl, 'region_mask_file'); +add_default($nl, 'sfc_layer_opt'); + +#################################### +# namelist group: init_ts_nml # +#################################### + +if ($RUN_TYPE eq 'startup' && $topography_opt eq 'bathymetry') { + add_default($nl, 'init_ts_option' , 'val'=>'PHC'); + add_default($nl, 'init_ts_file' , 'val'=>'ts_PHC2_jan_ic_resindpt'); #TODO? + add_default($nl, 'init_ts_file_fmt', 'val'=>'nc'); +} else { + add_default($nl, 'init_ts_option' , 'val'=>"ccsm_${RUN_TYPE}"); + add_default($nl, 'init_ts_file'); + add_default($nl, 'init_ts_file_fmt', 'val'=>"$RESTART_INPUT_TS_FMT"); +} +add_default($nl, 'init_ts_outfile' , 'val'=>"${output_h}.ts_ic"); +add_default($nl, 'init_ts_outfile_fmt'); +add_default($nl, 'init_ts_suboption'); + +########################################## +# namelist group: diagnostics_nml # +########################################## + +add_default($nl, 'diag_transport_file', 'val'=>"${RUNDIR}/${OCN_GRID}_transport_contents"); +if ($INFO_DBUG > 1) { + add_default($nl, 'diag_global_freq_opt', 'val'=>'nstep'); + add_default($nl, 'diag_cfl_freq_opt' , 'val'=>'nstep'); + add_default($nl, 'diag_transp_freq_opt', 'val'=>'nstep'); +} else { + add_default($nl, 'diag_global_freq_opt'); + add_default($nl, 'diag_cfl_freq_opt'); + add_default($nl, 'diag_transp_freq_opt'); +} +add_default($nl, 'diag_global_freq'); +add_default($nl, 'diag_cfl_freq'); +add_default($nl, 'diag_transp_freq'); +add_default($nl, 'diag_outfile', 'val'=>"${RUNDIR}/${output_d}d"); +add_default($nl, 'diag_transport_outfile','val'=>"${RUNDIR}/${output_d}t"); +add_default($nl, 'diag_velocity_outfile', 'val'=>"${RUNDIR}/${output_d}v"); +add_default($nl, 'cfl_all_levels'); +add_default($nl, 'diag_all_levels'); +add_default($nl, 'ldiag_velocity'); + +########################################## +# namelist group: budget_diagnostics_nml # +########################################## + +if ($OCN_TAVG_HIFREQ eq "TRUE" ) { + add_default($nl, 'ldiag_global_tracer_budgets', 'val'=>'.false.'); +} else { + add_default($nl, 'ldiag_global_tracer_budgets'); +} + +########################################## +# namelist group: bsf_diagnostics_nml # +########################################## + +add_default($nl, 'ldiag_bsf'); + +########################################## +# namelist group: restart_nml # +########################################## + +add_default($nl, 'restart_freq_opt'); +add_default($nl, 'restart_freq'); +add_default($nl, 'restart_start_opt'); +add_default($nl, 'restart_start'); +add_default($nl, 'restart_outfile', 'val'=>"${output_r}"); +add_default($nl, 'restart_fmt'); +add_default($nl, 'leven_odd_on'); +add_default($nl, 'even_odd_freq'); +add_default($nl, 'pressure_correction'); + +########################################## +# namelist group: history_nml # +########################################## + +add_default($nl, 'history_contents', 'val'=>"${RUNDIR}/${OCN_GRID}_history_contents"); +add_default($nl, 'history_freq_opt'); +add_default($nl, 'history_freq'); +add_default($nl, 'history_outfile', 'val'=>"${output_h}s"); +add_default($nl, 'history_fmt'); + +########################################## +# namelist group: movie_nml # +########################################## + +add_default($nl, 'movie_contents', 'val'=>"${RUNDIR}/${OCN_GRID}_movie_contents"); +add_default($nl, 'movie_freq_opt'); +add_default($nl, 'movie_freq'); +add_default($nl, 'movie_outfile', 'val'=>"${output_h}m"); +add_default($nl, 'movie_fmt'); + +########################################## +# namelist group: solvers # +########################################## + +add_default($nl, 'solverChoice'); +add_default($nl, 'convergenceCriterion'); +add_default($nl, 'maxIterations'); +add_default($nl, 'convergenceCheckFreq'); +add_default($nl, 'preconditionerChoice'); +add_default($nl, 'preconditionerFile'); + +########################################## +# namelist group: vertical_mix_nml # +########################################## + +add_default($nl, 'vmix_choice'); +add_default($nl, 'aidif'); +add_default($nl, 'implicit_vertical_mix'); +add_default($nl, 'convection_type'); +add_default($nl, 'nconvad'); +add_default($nl, 'convect_diff'); +add_default($nl, 'convect_visc'); +add_default($nl, 'bottom_drag'); +add_default($nl, 'bottom_heat_flx'); +add_default($nl, 'bottom_heat_flx_depth'); + +########################################## +# namelist group: vmix_const_nml # +########################################## + +add_default($nl, 'const_vvc'); +add_default($nl, 'const_vdc'); + +########################################## +# namelist group: vmix_rich_nml # +########################################## + +add_default($nl, 'bckgrnd_vvc'); +add_default($nl, 'bckgrnd_vdc'); +add_default($nl, 'rich_mix&vmix_rich_nml'); + +########################################## +# namelist group: tidal_nml # +########################################## + +add_default($nl, 'ltidal_mixing'); +add_default($nl, 'tidal_energy_file', 'nofail'=>1); +if (not $nl->get_value('tidal_energy_file')) { + add_default($nl, 'tidal_energy_file', 'val'=>'unknown_tidal_mixing','noprepend'=>1); +} +add_default($nl, 'local_mixing_fraction'); +add_default($nl, 'mixing_efficiency'); +add_default($nl, 'vertical_decay_scale'); +add_default($nl, 'tidal_mix_max'); +add_default($nl, 'tidal_energy_file_fmt'); + +########################################## +# namelist group: vmix_kpp_nml # +########################################## + +add_default($nl, 'rich_mix&vmix_kpp_nml'); + +# grid dependent value of lhoriz_varying_background set in +# namelist_defaults_pop2.xml and value of ltidal-mixing is +# obtained from default value already set + +my $ltidal_mixing = $nl->get_value('ltidal_mixing'); +$ltidal_mixing =~ s/ //g; + +add_default($nl, 'lhoriz_varying_bckgrnd'); +my $lhoriz_varying_bckgrnd= $nl->get_value('lhoriz_varying_bckgrnd'); +$lhoriz_varying_bckgrnd =~ s/ //g; + +add_default($nl, 'llangmuir'); +add_default($nl, 'linertial'); +add_default($nl, 'Prandtl'); +add_default($nl, 'lrich'); +add_default($nl, 'ldbl_diff'); +add_default($nl, 'lshort_wave'); +add_default($nl, 'lcheckekmo'); +add_default($nl, 'num_v_smooth_Ri'); + +add_default($nl, 'bckgrnd_vdc1', 'lhoriz_varying_bckgrnd'=>"$lhoriz_varying_bckgrnd", 'ltidal_mixing'=>"$ltidal_mixing"); +add_default($nl, 'bckgrnd_vdc2', 'lhoriz_varying_bckgrnd'=>"$lhoriz_varying_bckgrnd", 'ltidal_mixing'=>"$ltidal_mixing"); +add_default($nl, 'bckgrnd_vdc_dpth', 'lhoriz_varying_bckgrnd'=>"$lhoriz_varying_bckgrnd", 'ltidal_mixing'=>"$ltidal_mixing"); +add_default($nl, 'bckgrnd_vdc_eq', 'lhoriz_varying_bckgrnd'=>"$lhoriz_varying_bckgrnd", 'ltidal_mixing'=>"$ltidal_mixing"); +add_default($nl, 'bckgrnd_vdc_psim', 'lhoriz_varying_bckgrnd'=>"$lhoriz_varying_bckgrnd", 'ltidal_mixing'=>"$ltidal_mixing"); +add_default($nl, 'bckgrnd_vdc_ban', 'lhoriz_varying_bckgrnd'=>"$lhoriz_varying_bckgrnd", 'ltidal_mixing'=>"$ltidal_mixing"); +add_default($nl, 'bckgrnd_vdc_linv'); + +########################################## +# namelist group: advect_nml # +########################################## + +add_default($nl, 'tadvect_ctype'); + +########################################## +# namelist group: hmix_nml # +########################################## + +add_default($nl, 'hmix_momentum_choice'); +add_default($nl, 'hmix_tracer_choice'); +add_default($nl, 'lsubmesoscale_mixing'); + +########################################## +# namelist group: hmix_del2u_nml # +########################################## + +add_default($nl, 'lauto_hmix&hmix_del2u_nml'); + +add_default($nl, 'lvariable_hmix&hmix_del2u_nml'); + +add_default($nl, 'am&hmix_del2u_nml'); + +########################################## +# namelist group: hmix_del2t_nml # +########################################## + +add_default($nl, 'lauto_hmix&hmix_del2t_nml'); + +add_default($nl, 'lvariable_hmix&hmix_del2t_nml'); + +add_default($nl, 'ah&hmix_del2t_nml'); + +########################################## +# namelist group: hmix_del4u_nml # +########################################## + +add_default($nl, 'lauto_hmix&hmix_del4u_nml'); + +add_default($nl, 'lvariable_hmix&hmix_del4u_nml'); + +add_default($nl, 'am&hmix_del4u_nml'); + +########################################## +# namelist group: hmix_del4t_nml # +########################################## + +add_default($nl, 'lauto_hmix&hmix_del4t_nml'); + +add_default($nl, 'lvariable_hmix&hmix_del4t_nml'); + +add_default($nl, 'ah&hmix_del4t_nml'); + +########################################## +# namelist group: hmix_gm_nml # +########################################## + +add_default($nl, 'kappa_isop_choice'); +add_default($nl, 'kappa_thic_choice'); + +# All namelist values are stored in exactly the format +# that is required in a valid namelist. So if that value +# is a string, then the quotes are stored as part of the value. + +my $kappa_isop_choice = $nl->get_value('kappa_isop_choice'); +my $kappa_thic_choice = $nl->get_value('kappa_thic_choice'); +$kappa_isop_choice =~ s/[\'\"]//g; +$kappa_thic_choice =~ s/[\'\"]//g; + +# note that ah_gm_value is explicitly put below since ah is +# contained in several namelist variables + +add_default($nl, 'ah_bolus' , + 'kappa_isop_choice'=>"$kappa_isop_choice", + 'kappa_thic_choice'=>"$kappa_thic_choice"); +add_default($nl, 'ah_bkg_srfbl', + 'kappa_isop_choice'=>"$kappa_isop_choice", + 'kappa_thic_choice'=>"$kappa_thic_choice"); +add_default($nl, 'use_const_ah_bkg_srfbl', + 'kappa_isop_choice'=>"$kappa_isop_choice", + 'kappa_thic_choice'=>"$kappa_thic_choice"); +add_default($nl, 'ah&hmix_gm_nml', + 'kappa_isop_choice'=>"$kappa_isop_choice", + 'kappa_thic_choice'=>"$kappa_thic_choice"); + +# note that ocn_grid dependence for ah_bolus, ah_bkg_srfbl +# is obtained from config_cache.xml + +add_default($nl, 'buoyancy_freq_filename', 'val'=>"${RUNDIR}/buoyancy_freq"); +add_default($nl, 'diag_gm_bolus'); +add_default($nl, 'kappa_freq_choice'); +add_default($nl, 'slope_control_choice'); +add_default($nl, 'kappa_depth_1'); +add_default($nl, 'kappa_depth_2'); +add_default($nl, 'kappa_depth_scale'); +add_default($nl, 'ah_bkg_bottom'); +add_default($nl, 'slm_r'); +add_default($nl, 'slm_b'); +add_default($nl, 'transition_layer_on'); +add_default($nl, 'read_n2_data'); +add_default($nl, 'buoyancy_freq_fmt'); +add_default($nl, 'const_eg'); +add_default($nl, 'gamma_eg'); +add_default($nl, 'kappa_min_eg'); +add_default($nl, 'kappa_max_eg'); + +########################################## +# namelist group: mix_submeso_nml # +########################################## + +add_default($nl, 'efficiency_factor'); +add_default($nl, 'time_scale_constant'); +add_default($nl, 'luse_const_horiz_len_scale'); +add_default($nl, 'hor_length_scale'); + +########################################## +# namelist group: hmix_aniso_nml # +########################################## + +add_default($nl, 'hmix_alignment_choice'); +add_default($nl, 'lvariable_hmix_aniso'); +add_default($nl, 'lsmag_aniso'); +add_default($nl, 'visc_para'); +add_default($nl, 'visc_perp'); +add_default($nl, 'c_para'); +add_default($nl, 'c_perp'); +add_default($nl, 'u_para'); +add_default($nl, 'u_perp'); +add_default($nl, 'vconst_1'); +add_default($nl, 'vconst_2'); +add_default($nl, 'vconst_3'); +add_default($nl, 'vconst_4'); +add_default($nl, 'vconst_5'); +add_default($nl, 'vconst_6'); +add_default($nl, 'vconst_7'); +add_default($nl, 'smag_lat'); +add_default($nl, 'smag_lat_fact'); +add_default($nl, 'smag_lat_gauss'); +add_default($nl, 'var_viscosity_infile'); +add_default($nl, 'var_viscosity_infile_fmt'); +add_default($nl, 'var_viscosity_outfile', 'val'=>"${output_h}v"); +add_default($nl, 'var_viscosity_outfile_fmt'); + +########################################## +# namelist group: state_nml # +########################################## + +add_default($nl, 'state_choice'); +add_default($nl, 'state_file'); +add_default($nl, 'state_range_opt'); +add_default($nl, 'state_range_freq'); + +########################################## +# namelist group: baroclinic_nml # +########################################## + +add_default($nl, 'reset_to_freezing'); + +########################################## +# namelist group: ice_nml # +########################################## + +add_default($nl,'lactive_ice', 'ocn_ice_forcing'=>"$OCN_ICE_FORCING"); +add_default($nl,'ice_freq_opt'); +add_default($nl,'ice_freq'); +add_default($nl,'kmxice'); + +########################################## +# namelist group: pressure_grad_nml # +########################################## + +add_default($nl,'lpressure_avg'); +add_default($nl,'lbouss_correct'); + +########################################## +# namelist group: topostress_nml # +########################################## + +add_default($nl,'ltopostress'); +add_default($nl,'nsmooth_topo'); + +########################################## +# namelist group: forcing_ws_nml # +########################################## + +add_default($nl,'ws_data_renorm'); +add_default($nl,'ws_data_type'); +add_default($nl,'ws_data_inc'); +add_default($nl,'ws_interp_freq'); +add_default($nl,'ws_interp_type'); +add_default($nl,'ws_interp_inc'); +add_default($nl,'ws_filename'); +add_default($nl,'ws_file_fmt'); + +########################################## +# namelist group: forcing_shf_nml # +########################################## + +add_default($nl,'shf_formulation','ocn_coupling'=>"$OCN_COUPLING"); +add_default($nl,'shf_data_type' ,'ocn_coupling'=>"$OCN_COUPLING"); +add_default($nl,'luse_cpl_ifrac' ,'ocn_coupling'=>"$OCN_COUPLING"); +add_default($nl,'shf_data_inc'); +add_default($nl,'shf_interp_freq'); +add_default($nl,'shf_interp_type'); +add_default($nl,'shf_interp_inc'); +add_default($nl,'shf_restore_tau'); +add_default($nl,'shf_filename'); +add_default($nl,'shf_file_fmt'); +add_default($nl,'shf_data_renorm(3)'); +add_default($nl,'shf_weak_restore'); +add_default($nl,'shf_strong_restore'); +add_default($nl,'shf_strong_restore_ms'); + +########################################## +# namelist_group: forcing_sfwf_nml # +########################################## + +add_default($nl,'sfwf_formulation' , 'ocn_coupling'=>"$OCN_COUPLING"); +add_default($nl,'sfwf_data_type' , 'ocn_coupling'=>"$OCN_COUPLING"); +add_default($nl,'ladjust_precip' , 'ocn_coupling'=>"$OCN_COUPLING"); +add_default($nl,'lms_balance' , 'ocn_coupling'=>"$OCN_COUPLING"); +add_default($nl,'lsend_precip_fact', 'ocn_coupling'=>"$OCN_COUPLING"); +add_default($nl,'sfwf_data_inc'); +add_default($nl,'sfwf_interp_freq'); +add_default($nl,'sfwf_interp_type'); +add_default($nl,'sfwf_interp_inc'); +add_default($nl,'sfwf_restore_tau'); +add_default($nl,'sfwf_filename'); +add_default($nl,'sfwf_file_fmt'); +add_default($nl,'sfwf_data_renorm'); +add_default($nl,'sfwf_strong_restore'); +add_default($nl,'sfwf_strong_restore_ms'); +add_default($nl,'sfwf_weak_restore'); +add_default($nl,'lfw_as_salt_flx'); + +########################################## +# namelist group: forcing_pt_interior_nml# +########################################## + +add_default($nl,'pt_interior_data_type'); +add_default($nl,'pt_interior_data_inc'); +add_default($nl,'pt_interior_interp_freq'); +add_default($nl,'pt_interior_interp_type'); +add_default($nl,'pt_interior_interp_inc'); +add_default($nl,'pt_interior_restore_tau'); +add_default($nl,'pt_interior_filename'); +add_default($nl,'pt_interior_file_fmt'); +add_default($nl,'pt_interior_restore_max_level'); +add_default($nl,'pt_interior_formulation'); +add_default($nl,'pt_interior_data_renorm'); +add_default($nl,'pt_interior_variable_restore'); +add_default($nl,'pt_interior_restore_filename'); +add_default($nl,'pt_interior_restore_file_fmt'); + + +########################################## +# namelist group: forcing_s_interior_nml # +########################################## + +add_default($nl,'s_interior_data_type'); +add_default($nl,'s_interior_data_inc'); +add_default($nl,'s_interior_interp_freq'); +add_default($nl,'s_interior_interp_type'); +add_default($nl,'s_interior_interp_inc'); +add_default($nl,'s_interior_restore_tau'); +add_default($nl,'s_interior_filename'); +add_default($nl,'s_interior_file_fmt'); +add_default($nl,'s_interior_restore_max_level'); +add_default($nl,'s_interior_formulation'); +add_default($nl,'s_interior_data_renorm'); +add_default($nl,'s_interior_variable_restore'); +add_default($nl,'s_interior_restore_filename'); +add_default($nl,'s_interior_restore_file_fmt'); + +########################################## +# namelist group: forcing_ap_interior_nml# +########################################## + +add_default($nl,'ap_data_type'); +add_default($nl,'ap_data_inc'); +add_default($nl,'ap_interp_freq'); +add_default($nl,'ap_interp_type'); +add_default($nl,'ap_interp_inc'); +add_default($nl,'ap_filename'); +add_default($nl,'ap_file_fmt'); +add_default($nl,'ap_data_renorm'); + +########################################## +# namelist group: coupled_nml # +########################################## + +# $coupled_freq and $coupled_freq_opts are computed after reading XML vars +add_default($nl,'coupled_freq',val=>"$coupled_freq"); +add_default($nl,'coupled_freq_opt', val=>"$coupled_freq_opt"); +add_default($nl,'qsw_distrb_opt', 'ocn_coupling'=>"$OCN_COUPLING"); + +########################################## +# namelist group: sw_absorption_nml # +########################################## + +add_default($nl,'sw_absorption_type'); +add_default($nl,'chl_option', 'ocn_chl_type'=>"$OCN_CHL_TYPE"); +add_default($nl,'chl_filename'); +add_default($nl,'chl_file_fmt'); +add_default($nl,'jerlov_water_type'); + +########################################## +# namelist group: transports_nml # +########################################## + +my @transport_reg2_names = ("'Atlantic Ocean'",',', + "'Mediterranean Sea'",',', + "'Labrador Sea'",',', + "'GIN Sea'",',', + "'Arctic Ocean'",',', + "'Hudson Bay'"); + +add_default($nl,'lat_aux_grid_type'); +add_default($nl,'lat_aux_begin'); +add_default($nl,'lat_aux_end'); +add_default($nl,'n_lat_aux_grid'); +add_default($nl,'moc_requested'); +add_default($nl,'n_heat_trans_requested'); +add_default($nl,'n_salt_trans_requested'); +add_default($nl,'transport_reg2_names', 'val'=>"@transport_reg2_names"); +add_default($nl,'n_transport_reg'); + +########################################## +# namelist group: context_nml # +########################################## + +add_default($nl,'lcoupled'); +add_default($nl,'lccsm'); +add_default($nl,'b4b_flag'); +add_default($nl,'lccsm_control_compatible'); + +########################################## +# namelist group: overflows_nml # +########################################## + +if ($OCN_GRID =~ /^gx*/) { + add_default($nl,'overflows_infile', 'val'=>"${RUNDIR}/${OCN_GRID}_overflow"); +} else { + add_default($nl, 'overflows_infile', 'val'=>'unknown_overflow','noprepend'=>1); +} + +add_default($nl,'overflows_on'); +add_default($nl,'overflows_interactive'); +add_default($nl,'overflows_diag_outfile', 'val'=>"${RUNDIR}/${output_d}o"); +add_default($nl,'overflows_restart_type', 'val'=>"ccsm_${RUN_TYPE}"); +add_default($nl,'overflows_restfile' , 'val'=>"${output_r}o"); + +########################################## +# namelist group: niw_nml # +########################################## + +add_default($nl,'lniw_mixing'); +add_default($nl,'niw_local_mixing_fraction'); +add_default($nl,'niw_mixing_efficiency'); +add_default($nl,'niw_obs2model_ratio'); +add_default($nl,'niw_boundary_layer_absorption'); +add_default($nl,'niw_vert_decay_scale'); +add_default($nl,'niw_mix_max'); +add_default($nl,'niw_energy_type'); +add_default($nl,'niw_energy_file_fmt'); +add_default($nl,'niw_energy_file', 'nofail'=>1); +if (not $nl->get_value('niw_energy_file')) { + add_default($nl, 'niw_energy_file', 'val'=>'unknown_niw_energy','noprepend'=>1); +} + +########################################## +# namelist group: passive_tracers_on_nml # +########################################## + +if ($OCN_TRACER_MODULES =~ /iage/) { + add_default($nl, 'iage_on', 'val'=>".true."); +} else { + add_default($nl, 'iage_on', 'val'=>".false."); +} +if ($OCN_TRACER_MODULES =~ /cfc/) { + add_default($nl, 'cfc_on', 'val'=>".true."); +} else { + add_default($nl, 'cfc_on', 'val'=>".false."); +} +if ($OCN_TRACER_MODULES =~ /ecosys/) { + add_default($nl, 'ecosys_on', 'val'=>".true."); +} else { + add_default($nl, 'ecosys_on', 'val'=>".false."); +} +if ($OCN_TRACER_MODULES =~ /moby/) { + add_default($nl, 'moby_on', 'val'=>".true."); +} else { + add_default($nl, 'moby_on', 'val'=>".false."); +} + + +########################################## +# namelist group: iage_nml # +########################################## + +if ($OCN_TRACER_MODULES =~ /iage/) { + add_default($nl, 'init_iage_option', 'val'=>"ccsm_${RUN_TYPE}"); + add_default($nl, 'init_iage_init_file', 'val'=>'same_as_TS', 'noprepend'=>1); +} + +########################################## +# namelist group: cfc_nml # +########################################## + +if ($OCN_TRACER_MODULES =~ /cfc/) { + +#=============================================================================== +# values of init_cfc_option for OCN_TRANSIENT == 1850-2000 are from following table +# runtype is set in $CASEROOT/env_run.xml +# +# CONTINUE_RUN RUN_STARTDATE RUN_TYPE runtype init_cfc_option +# TRUE any any continue ccsm_continue +# FALSE <= 1930 any $RUN_TYPE zero +# FALSE > 1930 hybrid,branch $RUN_TYPE ccsm_$RUN_TYPE +# FALSE > 1930 startup $RUN_TYPE abort +#=============================================================================== + + my $init_cfc_option; + $init_cfc_option = "ccsm_${RUN_TYPE}"; + if ($OCN_TRANSIENT eq "1850-2000") { + if ($RUN_TYPE ne "continue") { + my @START_ARRAY = split('-',$RUN_STARTDATE); + my $START_YEAR = @START_ARRAY[0]; + if ($START_YEAR le 1930) { + $init_cfc_option = "zero"; + } else { + if ($RUN_TYPE eq "startup") { + # Check to see if init_cfc_option was set in user_nl_pop2 + $init_cfc_option = $nl->get_variable_value("cfc_nml", "init_cfc_option"); + if ($init_cfc_option eq "") { + # If not, error out with message saying value must be specified + print "ERROR: CFCs cannot be automatically initializd post 1930 in a startup run! Set init_cfc_option in user_nl_pop2 before building pop2_in.\n"; + die; + } + } + } + } + } + add_default($nl, 'init_cfc_option', 'val'=>"$init_cfc_option"); + + add_default($nl, 'model_year', 'ocn_transient'=>"$OCN_TRANSIENT"); + add_default($nl, 'data_year' , 'ocn_transient'=>"$OCN_TRANSIENT"); + + add_default($nl, 'cfc_formulation'); + add_default($nl, 'pcfc_file'); + add_default($nl, 'init_cfc_init_file', 'noprepend'=>1); +} + + +########################################## +# namelist group: ecosys_nml # +########################################## + +if ($OCN_TRACER_MODULES =~ /ecosys/) { + + my $temp; + + if (($OCN_TRANSIENT ne "unset") && ($OCN_TRANSIENT ne "1850-2000")) { + print " OCN_TRANSIENT=$OCN_TRANSIENT not supported by ecosystem module \n"; + die; + } + + my $atm_co2_opt; + if ($OCN_CO2_TYPE eq "constant") { + $atm_co2_opt = "const"; + } elsif ($OCN_CO2_TYPE eq "prognostic") { + $atm_co2_opt = "drv_prog"; + } elsif ($OCN_CO2_TYPE eq "diagnostic") { + $atm_co2_opt = "drv_diag"; + } else { + print "error specifying atm_co2_opt \n"; + print "unknown OCN_CO2_TYPE: $OCN_CO2_TYPE \n"; + die; + } + + my $locmip_k1_k2_bug_fix; + if ($OCN_CO2_FLUX_OCMIP_BUG_FIX eq "TRUE") { + $locmip_k1_k2_bug_fix = ".true."; + } else { + $locmip_k1_k2_bug_fix = ".false."; + } + + add_default($nl, 'init_ecosys_option', 'val'=>"ccsm_${RUN_TYPE}"); + if ($RUN_TYPE eq "startup") { + add_default($nl, 'init_ecosys_init_file'); + } else { + add_default($nl, 'init_ecosys_init_file', 'val'=>"same_as_TS", 'noprepend'=>1); + } + add_default($nl, 'init_ecosys_init_file_fmt'); + add_default($nl, 'tracer_init_ext(1)%mod_varname&ecosys_nml'); + add_default($nl, 'tracer_init_ext(1)%scale_factor&ecosys_nml'); + add_default($nl, 'tracer_init_ext(2)%mod_varname&ecosys_nml'); + add_default($nl, 'tracer_init_ext(2)%scale_factor&ecosys_nml'); + + add_default($nl, 'tracer_init_ext(3)%mod_varname&ecosys_nml'); + add_default($nl, 'tracer_init_ext(3)%scale_factor&ecosys_nml'); + add_default($nl, 'lflux_gas_o2'); + add_default($nl, 'lflux_gas_co2'); + + add_default($nl, 'locmip_k1_k2_bug_fix', 'val'=>"$locmip_k1_k2_bug_fix"); + add_default($nl, 'atm_co2_opt', 'val'=>"$atm_co2_opt"); + add_default($nl, 'atm_co2_const', 'val'=>"$CCSM_CO2_PPMV"); + add_default($nl, 'ecosys_tadvect_ctype'); + add_default($nl, 'gas_flux_forcing_opt'); + add_default($nl, 'lmarginal_seas'); + + add_default($nl, 'lsource_sink'); + add_default($nl, 'comp_surf_avg_freq_opt'); + add_default($nl, 'comp_surf_avg_freq'); + + add_default($nl, 'use_nml_surf_vals', 'runtype'=>"$RUN_TYPE"); + + add_default($nl, 'surf_avg_dic_const'); + + add_default($nl, 'surf_avg_alk_const'); + + add_default($nl, 'ecosys_qsw_distrb_const'); + #add_default($nl, 'iron_dust_flx_data_type'); + add_default($nl, 'dust_flux_input%filename'); + add_default($nl, 'dust_flux_input%file_fmt'); + add_default($nl, 'dust_flux_input%file_varname'); + add_default($nl, 'dust_flux_input%scale_factor'); # kg/m^2/sec -> g/cm^2/sec + add_default($nl, 'iron_flux_input%filename'); + add_default($nl, 'iron_flux_input%file_fmt'); + add_default($nl, 'iron_flux_input%file_varname'); + add_default($nl, 'iron_flux_input%scale_factor'); # kg/m^2/sec -> nmol/cm^2/sec, 3.5% iron by weight + add_default($nl, 'fesedflux_input%filename'); + add_default($nl, 'fesedflux_input%file_varname'); + add_default($nl, 'fesedflux_input%file_fmt'); + add_default($nl, 'fesedflux_input%scale_factor'); # umolFe/m2/day -> nmolFe/cm2/s + if ($OCN_TRANSIENT eq "unset") { + add_default($nl, 'ndep_data_type', 'ocn_transient'=>"$OCN_TRANSIENT"); + add_default($nl, 'nox_flux_monthly_input%filename'); + add_default($nl, 'nox_flux_monthly_input%file_fmt'); + add_default($nl, 'nox_flux_monthly_input%file_varname'); + add_default($nl, 'nhy_flux_monthly_input%filename'); + add_default($nl, 'nox_flux_monthly_input%scale_factor'); # kgN/m^2/sec -> nmolN/cm^2/sec + add_default($nl, 'nhy_flux_monthly_input%file_fmt'); + add_default($nl, 'nhy_flux_monthly_input%file_varname'); + add_default($nl, 'nhy_flux_monthly_input%scale_factor'); # kgN/m^2/sec -> nmolN/cm^2/sec + } + if ($OCN_TRANSIENT eq "1850-2000") { + add_default($nl, 'ndep_data_type', 'ocn_transient'=>"$OCN_TRANSIENT"); + add_default($nl, 'ndep_shr_stream_year_first'); + add_default($nl, 'ndep_shr_stream_year_last'); + add_default($nl, 'ndep_shr_stream_year_align'); + add_default($nl, 'ndep_shr_stream_scale_factor'); # kgN/m^2/sec -> nmolN/cm^2/sec + add_default($nl, 'ndep_shr_stream_file'); + } + add_default($nl, 'lecovars_full_depth_tavg'); +} + +########################################## +# namelist group: moby_nml # +########################################## + +if ($OCN_TRACER_MODULES =~ /moby/) { + + my $temp; + + add_default($nl, 'moby_log_filename', 'val'=>"${RUNDIR}/moby${inst_string}.log.$LID"); + add_default($nl, "lmoby"); + add_default($nl, "ldarwin"); + add_default($nl, 'init_moby_option', 'val'=>"ccsm_${RUN_TYPE}"); + if ($RUN_TYPE eq "startup") { + add_default($nl, 'init_moby_init_file', 'val'=>"unknown", 'noprepend'=>"1"); + } else { + add_default($nl, 'init_moby_init_file', 'val'=>"same_as_TS", 'noprepend'=>"1"); + } + add_default($nl, 'init_moby_init_file_fmt', 'val'=>'nc'); + + add_default($nl, 'moby_comp_surf_avg_freq'); + add_default($nl, 'moby_comp_surf_avg_freq_opt'); + + add_default($nl, 'moby_iron_flux_input%filename'); + add_default($nl, 'moby_iron_flux_input%file_fmt'); + add_default($nl, 'moby_iron_flux_input%file_varname'); + add_default($nl, 'moby_iron_flux_input%scale_factor'); + + add_default($nl, 'moby_lecovars_full_depth_tavg'); + my $lflux_gas_co2; + if ($CCSM_BGC eq "CO2C") { + $lflux_gas_co2 = ".true."; + } else { + $lflux_gas_co2 = ".false."; + } + add_default($nl, 'moby_lflux_gas_co2','val'=>"$lflux_gas_co2"); + + add_default($nl, 'moby_lmarginal_seas'); + add_default($nl, 'moby_lrest_no3'); + add_default($nl, 'moby_lrest_po4'); + add_default($nl, 'moby_lrest_sio3'); + add_default($nl, 'moby_nutr_rest_file'); + + add_default($nl, 'moby_qsw_distrb_const'); + add_default($nl, 'moby_surf_avg_alk_const'); + add_default($nl, 'moby_surf_avg_dic_const'); + add_default($nl, 'moby_tadvect_ctype'); + + add_default($nl, 'moby_tracer_init_ext(1)%mod_varname'); + add_default($nl, 'moby_tracer_init_ext(1)%scale_factor'); + add_default($nl, 'moby_tracer_init_ext(2)%mod_varname'); + add_default($nl, 'moby_tracer_init_ext(2)%scale_factor'); + + add_default($nl, 'moby_use_nml_surf_vals', 'runtype'=>"${RUN_TYPE}"); + + # Build moby namelist- ${RUNDIR}/moby_in + + my $fh_in = new IO::File; + my $fh_out = new IO::File; + $fh_out->open(">${RUNDIR}/moby_in") or die "** can't open file: ${RUNDIR}/moby_in\n"; + foreach my $file ( "${OCN_GRID}_data", + "${OCN_GRID}_data.ptracers", + "${OCN_GRID}_data.gchem" , + "${OCN_GRID}_data.$OCN_TRACER_MODULES_OPT" , + "${OCN_GRID}_data.misc", + "${OCN_GRID}_data.pkg" ) + { + my $datafile; + if (-e "$CASEROOT/SourceMods/src.pop2/src.moby/$file") { + $datafile = "${CASEROOT}/SourceMods/src.pop2/src.moby/$file"; + } elsif ( -e "$CODEROOT/ocn/pop2/aux/moby/${OCN_TRACER_MODULES_OPT}/input/$file") { + $datafile = "$CODEROOT/ocn/pop2/aux/moby/${OCN_TRACER_MODULES_OPT}/input/$file"; + } else { + die "MOBY error for input file $file \n"; + } + $fh_in->open("<$datafile") or die "** can't open file: $datafile\n"; + while (my $line = <$fh_in>) { + if ($line =~ m/\#/) { + # do nothing + } else { + $line =~ s/POPVERTGRID/using_POP_grid_through_interface_layer/g; + my $path = "${DIN_LOC_ROOT}/ocn/moby"; + $line =~ s/INPUTDATA/$path/g; + $line =~ s/OCN_GRID/$OCN_GRID/g; + print $fh_out "$line"; + } + } + $fh_in->close; + } + $fh_out->close; +} + +########################################## +# namelist group: tavg_nml # +# AND # +# tavg contents file # +########################################## + +my $ltavg_streams_index_present; +my $ltavg_has_offset_date_values; +my $ltavg_one_time_header; +my $ltavg_nino_diags_requested; +my %tavg_nml = (tavg_freq_opt => [], + tavg_freq => [], + tavg_stream_filestrings => [], + tavg_file_freq_opt => [], + tavg_file_freq => [], + tavg_start_opt => [], + tavg_start => [], + tavg_fmt_in => [], + tavg_fmt_out => [], + ltavg_has_offset_date => [], + tavg_offset_year => [], + tavg_offset_month => [], + tavg_offset_day => [], + ltavg_one_time_header => [], + ); + +if ($OCN_GRID =~ /^gx*/) { + $ltavg_streams_index_present = ".true."; + $ltavg_nino_diags_requested = ".true."; +} elsif ($OCN_GRID =~ /^tx*/) { + $ltavg_streams_index_present = ".true."; + $ltavg_nino_diags_requested = ".false."; +} + +########################################## +# copy files to $RUNDIR # +########################################## + +my $my_path = "${CASEROOT}/SourceMods/src.pop2"; + +my @copy_files_to_input = (); +push @copy_files_to_input,"${OCN_GRID}_vert_grid"; +push @copy_files_to_input,"${OCN_GRID}_region_ids"; +push @copy_files_to_input,"${OCN_GRID}_history_contents"; +push @copy_files_to_input,"${OCN_GRID}_movie_contents"; +push @copy_files_to_input,"${OCN_GRID}_transport_contents"; +push @copy_files_to_input,"${OCN_GRID}_depth_accel"; +if ($OCN_GRID =~ /^gx*/) { push @copy_files_to_input,"${OCN_GRID}_overflow"; } + +foreach my $file (@copy_files_to_input ) { + if (-f "${my_path}/$file") { + my $sysmod = "cp -fp ${my_path}/$file ${RUNDIR}/$file"; + system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; + } else { + my $sysmod = "cp -fp ${CODEROOT}/ocn/pop2/input_templates/$file ${RUNDIR}/$file"; + system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; + } +} + +########################################## +# tavg contents file # +########################################## + +# Create tavg contents file + +my $pop2_tavg_file = "${CASEBUILD}/pop2conf/${OCN_GRID}_tavg_contents"; +my $sysmod; +my $file; + +#------------------------- +# 1. base tavg contents +#------------------------- + +# 1.a. create $CASEBUILD/pop2conf/base.tavg.nml file +$sysmod; +$file = "ocn.base.tavg.csh"; +if (-f "${my_path}/$file"){ + $sysmod = "${my_path}/${file}"; +} else { + $sysmod = "${CODEROOT}/ocn/pop2/input_templates/${file}"; +} +system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; + +# 1.b. read in pop2conf/base.tavg.nml file and fill in %tavg_nml entries +my $fh_in = new IO::File; +$fh_in->open("<$CASEBUILD/pop2conf/base.tavg.nml") or die "** can't open filepath file: $\n"; +my $line; +my $numcols; +while ($line = <$fh_in> ) { + chomp($line); + $line =~ /(.+)=(.+)/; + my $key = $1; + my $val = $2; + $key =~ s/^\s+//; + $key =~ s/\s+$//; + $val =~ s/^\s+//; + $val =~ s/\s+$//; + my @val = split (' ',$val); + push @{ $tavg_nml{$key} }, @val; + my @cols = @{$tavg_nml{$key}}; + $numcols = $#cols + 1; +} +$fh_in->close(); + +# 1.d create base tavg contents file - in pop2conf/ +# either from $my_path (first) or from +my $base_tavg_file = "${CASEBUILD}/pop2conf/${OCN_GRID}_tavg_contents"; +if ($OCN_TAVG_HIFREQ eq "TRUE") { + # High-frequency tavg contents + $file = "${OCN_GRID}_tavg_contents_high_freq"; +} else { + # Default resolution dependent tavg contents + $file = "${OCN_GRID}_tavg_contents"; +} +if (-f "$my_path/$file") { + $sysmod = "cp -fp ${my_path}/$file $base_tavg_file"; + system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; +} else { + if (-f "${CODEROOT}/ocn/pop2/input_templates/$file") { + $sysmod = "cp -fp ${CODEROOT}/ocn/pop2/input_templates/$file $base_tavg_file"; + system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; + } +} + +# 1.e add niw-specific fields to tavg_contents file +my $lniw_mixing = $nl->get_value('lniw_mixing'); +if ($lniw_mixing =~ /true/) { + $file = "niw_tavg_contents"; + my $niw_tavg_file = "${CASEBUILD}/pop2conf/$file"; + if (-f "$my_path/${OCN_GRID}_$file") { + $sysmod = "cp -fp ${my_path}/${OCN_GRID}_$file $niw_tavg_file"; + system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; + } else { + if (-f "${CODEROOT}/ocn/pop2/input_templates/${OCN_GRID}_$file") { + $sysmod = "cp -fp ${CODEROOT}/ocn/pop2/input_templates/${OCN_GRID}_$file $niw_tavg_file"; + system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; + } + } + if (-f "$niw_tavg_file") { + $sysmod = "cat $niw_tavg_file >> $pop2_tavg_file"; + system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; + } +} + +#------------------------- +# 2. budget tavg contents +#------------------------- +my $budget_tavg_file = "${CASEBUILD}/pop2conf/budget_tavg_contents"; +$file = "tavg_contents_tracer_budget_terms"; +if ($OCN_TAVG_TRACER_BUDGET eq "TRUE") { + # tracer budget tavg contents + if (-f "${my_path}/$file") { + $sysmod = "cp -fp ${my_path}/$file $budget_tavg_file"; + system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; + } else { + $sysmod = "cp -fp ${CODEROOT}/ocn/pop2/input_templates/$file $budget_tavg_file"; + system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; + } + $sysmod = "cat $budget_tavg_file >> $pop2_tavg_file"; + system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; +} + +#------------------------- +# 3. tracer tavg contents +#------------------------- +my @modules = split( ' ', $OCN_TRACER_MODULES); +for my $module (@modules) { + my $file = "ocn.${module}.tavg.csh"; + my $my_stream = $numcols+1; + if (-f "${my_path}/$file"){ + $sysmod = "${my_path}/${file} $my_stream"; + system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; + } else { + $sysmod = "${CODEROOT}/ocn/pop2/input_templates/${file} $my_stream"; + system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; + } + + # Create new tracer stream namelists - if appropriate + if (-f "${CASEBUILD}/pop2conf/${module}.tavg.nml") { + my $fh_in = new IO::File; + $fh_in->open("<${CASEBUILD}/pop2conf/$module.tavg.nml") or die "** can't open filepath file: $\n"; + my $line; + while ($line = <$fh_in> ) { + chomp($line); + $line =~ /(.+)=(.+)/; + my $key = $1; + my $val = $2; + $key =~ s/^\s+//; + $key =~ s/\s+$//; + $val =~ s/^\s+//; + $val =~ s/\s+$//; + my @val = split (' ',$val); + push @{ $tavg_nml{$key} }, @val; + my @cols = @{$tavg_nml{$key}}; + $numcols = $#cols + 1; + } + $fh_in->close(); + } + $sysmod = "cat ${CASEBUILD}/pop2conf/${module}_tavg_contents >> $pop2_tavg_file"; + system($sysmod) == 0 or die "ERROR: $sysmod failed: $?\n"; +} + +add_default($nl, 'n_tavg_streams', 'val'=>"$numcols"); +add_default($nl, 'ltavg_streams_index_present', 'val'=>"$ltavg_streams_index_present"); +add_default($nl, 'tavg_freq_opt', 'val'=>"@{$tavg_nml{'tavg_freq_opt'}}"); +add_default($nl, 'tavg_freq', 'val'=>"@{$tavg_nml{'tavg_freq'}}"); +add_default($nl, 'tavg_file_freq_opt', 'val'=>"@{$tavg_nml{'tavg_file_freq_opt'}}"); +add_default($nl, 'tavg_file_freq', 'val'=>"@{$tavg_nml{'tavg_file_freq'}}"); +add_default($nl, 'tavg_stream_filestrings', 'val'=>"@{$tavg_nml{'tavg_stream_filestrings'}}"); +add_default($nl, 'tavg_start_opt', 'val'=>"@{$tavg_nml{'tavg_start_opt'}}"); +add_default($nl, 'tavg_start', 'val'=>"@{$tavg_nml{'tavg_start'}}"); +add_default($nl, 'tavg_fmt_in', 'val'=>"@{$tavg_nml{'tavg_fmt_in'}}"); +add_default($nl, 'tavg_fmt_out', 'val'=>"@{$tavg_nml{'tavg_fmt_out'}}"); +add_default($nl, 'ltavg_has_offset_date', 'val'=>"@{$tavg_nml{'ltavg_has_offset_date'}}"); +add_default($nl, 'tavg_offset_years', 'val'=>"@{$tavg_nml{'tavg_offset_years'}}"); +add_default($nl, 'tavg_offset_months', 'val'=>"@{$tavg_nml{'tavg_offset_months'}}"); +add_default($nl, 'tavg_offset_days', 'val'=>"@{$tavg_nml{'tavg_offset_days'}}"); +add_default($nl, 'ltavg_one_time_header', 'val'=>"@{$tavg_nml{'ltavg_one_time_header'}}"); +add_default($nl, 'ltavg_nino_diags_requested', 'val'=>"$ltavg_nino_diags_requested"); +add_default($nl, 'tavg_contents', 'val'=>"${RUNDIR}/${OCN_GRID}_tavg_contents"); +add_default($nl, 'tavg_infile', 'val'=>"${output_h}restart.end"); +add_default($nl, 'tavg_outfile', 'val'=>"$output_h"); +add_default($nl, 'ltavg_ignore_extra_streams', 'val'=>".false."); + +#----------------------------------------------------------------------------------------------- +# *** Write output namelist file (pop2_in) and input dataset list (pop2.input_data_list) *** +#----------------------------------------------------------------------------------------------- +# Set namelist groups to be written out + +my @groups = qw(domain_nml + io_nml + time_manager_nml + grid_nml + init_ts_nml + diagnostics_nml + budget_diagnostics_nml + bsf_diagnostic_nml + restart_nml + tavg_nml + history_nml + movie_nml + solvers + vertical_mix_nml + vmix_const_nml + vmix_rich_nml + tidal_nml + vmix_kpp_nml + advect_nml + hmix_nml + hmix_del2u_nml + hmix_del2t_nml + hmix_del4u_nml + hmix_del4t_nml + hmix_gm_nml + mix_submeso_nml + hmix_aniso_nml + state_nml + baroclinic_nml + ice_nml + pressure_grad_nml + topostress_nml + forcing_ws_nml + forcing_shf_nml + forcing_sfwf_nml + forcing_pt_interior_nml + forcing_s_interior_nml + forcing_ap_nml + coupled_nml + sw_absorption_nml + transports_nml + context_nml + overflows_nml + niw_nml + passive_tracers_on_nml); + +if ($OCN_TRACER_MODULES =~ /iage/) { + push @groups, qw(iage_nml); +} +if ($OCN_TRACER_MODULES =~ /cfc/) { + push @groups, qw(cfc_nml); +} +if ($OCN_TRACER_MODULES =~ /ecosys/) { + push @groups, qw(ecosys_nml ecosys_parms_nml); +} +if ($OCN_TRACER_MODULES =~ /moby/) { + push @groups, qw(moby_nml moby_parms_nml ); +} + +# Check for variables in the "derived" group, add them to appropriate group +for my $var ($nl->get_variable_names('derived')) { + my @broken = split(/&/,$var); + my $val = $nl->get_variable_value('derived', $var); + $nl->set_variable_value($broken[1], $broken[0], $val); +} + +# Write out all groups to pop2_in +my $outfile = "./pop2_in"; +$nl->write($outfile, 'groups'=>\@groups); +if ($print>=2) { print "Writing pop2 ocean component namelist to $outfile $eol"; } + +# Write input dataset list. +check_input_files($nl, $DIN_LOC_ROOT, "../pop2.input_data_list"); + +#----------------------------------------------------------------------------------------------- +# END OF MAIN SCRIPT +#=============================================================================================== + +#=============================================================================================== +sub add_default { + +# Add a value for the specified variable to the specified namelist object. The variables +# already in the object have the higher precedence, so if the specified variable is already +# defined in the object then don't overwrite it, just return. +# +# This method checks the definition file and adds the variable to the correct +# namelist group. +# +# The value can be provided by using the optional argument key 'val' in the +# calling list. Otherwise a default value is obtained from the namelist +# defaults object. If no default value is found this method throws an exception +# unless the 'nofail' option is set true. +# +# Additional optional keyword=>value pairs may be specified. If the keyword 'val' is +# not present, then any other keyword=>value pairs that are specified will be used to +# match attributes in the defaults file. +# +# Example 1: Specify the default value $val for the namelist variable $var in namelist +# object $nl: +# +# add_default($nl, $var, 'val'=>$val) +# +# Example 2: Add a default for variable $var if an appropriate value is found. Otherwise +# don't add the variable +# +# add_default($nl, $var, 'nofail'=>1) +# +# +# ***** N.B. ***** This routine assumes the following variables are in package main:: +# $definition -- the namelist definition object +# $DIN_LOC_ROOT -- CCSM inputdata root directory + + my $nl = shift; # namelist object + my $var = shift; # name of namelist variable + my %opts = @_; # options + + my $val = undef; + + # Query the definition to find which group the variable belongs to. Exit if not found. + my $group = $definition->get_group_name($var); + unless ($group) { + my $fname = $definition->get_file_name(); + die "$ProgName - ERROR: variable \"$var\" not found in namelist definition file $fname.\n"; + } + + # check whether the variable has a value in the namelist object -- if so then return + $val = $nl->get_variable_value($group, $var); + if (defined $val) { return; } + + # Look for a specified value in the options hash + if (defined $opts{'val'}) { + $val = $opts{'val'}; + } + # or else get a value from namelist defaults object. + # Note that if the 'val' key isn't in the hash, then just pass anything else + # in %opts to the get_value method to be used as attributes that are matched + # when looking for default values. + else { + $val = get_default_value($var, \%opts); + } + + # if no value is found then exit w/ error (unless 'nofail' option set) + unless (defined $val) { + unless ($opts{'nofail'}) { + print "$ProgName - ERROR: No default value found for $var\n". + "user defined attributes:\n"; + foreach my $key (keys(%opts)) { + if ($key ne 'nofail' and $key ne 'val') { + print "key=$key val=$opts{$key}\n"; + } + } + die; + } else { + return; + } + } + + # query the definition to find out if the variable is an input pathname + my $is_input_pathname = $definition->is_input_pathname($var); + + # The default values for input pathnames are relative. If the namelist + # variable is defined to be an absolute pathname, then prepend + # the CCSM inputdata root directory. + # TODO: unless ignore_abs is passed as argument + if ($is_input_pathname eq 'abs') { + unless ($opts{'noprepend'}){ + $val = set_abs_filepath($val, $DIN_LOC_ROOT); + } + } + + # query the definition to find out if the variable takes a string value. + # The returned string length will be >0 if $var is a string, and 0 if not. + my $str_len = $definition->get_str_len($var); + + # If the variable is a string, then add quotes if they're missing + if ($str_len > 0) { + $val = quote_string($val); + } + + # set the value in the namelist + $nl->set_variable_value($group, $var, $val); +} + +#----------------------------------------------------------------------------------------------- + +sub get_default_value { + +# Return a default value for the requested variable. +# Return undef if no default found. +# +# ***** N.B. ***** This routine assumes the following variables are in package main:: +# $defaults -- the namelist defaults object +# $uc_defaults -- the use CASE defaults object + + my $var_name = lc(shift); # name of namelist variable (CASE insensitive interface) + my $usr_att_ref = shift; # reference to hash containing user supplied attributes + + # Check in the namelist defaults + return $defaults->get_value($var_name, $usr_att_ref); + +} + +#----------------------------------------------------------------------------------------------- + +sub check_input_files { + +# For each variable in the namelist which is an input dataset, check to see if it +# exists locally. +# +# ***** N.B. ***** This routine assumes the following variables are in package main:: +# $definition -- the namelist definition object + + my $nl = shift; # namelist object + my $inputdata_rootdir = shift; # if false prints test, else creates inputdata file + my $outfile = shift; + open(OUTFILE, ">$outfile") if defined $inputdata_rootdir; + + # Look through all namelist groups + my @groups = $nl->get_group_names(); + foreach my $group (@groups) { + + # Look through all variables in each group + my @vars = $nl->get_variable_names($group); + foreach my $var (@vars) { + + # Is the variable an input dataset? + my $input_pathname_type = $definition->is_input_pathname($var); + + # If it is, check to see if variable contains non-file + # For example, init_iage_init_file = "same_as_TS" + my $is_a_file = 1; + if ($input_pathname_type) { + + # Get pathname of input dataset + my $pathname = $nl->get_variable_value($group, $var); + # Need to strip the quotes + $pathname =~ s/['"]//g; + + # bottom_cell_file could be 'unknown_bottom_cell' + if (($var eq 'bottom_cell_file') and + ($pathname eq 'unknown_bottom_cell')) { + $is_a_file = 0; + } + + # tidal_energy_file could be 'unknown_tidal_mixing' + if (($var eq 'tidal_energy_file') and + ($pathname eq 'unknown_tidal_mixing')) { + $is_a_file = 0; + } + + # niw_energy_file could be 'unknown_niw_energy' + if (($var eq 'niw_energy_file') and + ($pathname eq 'unknown_niw_energy')) { + $is_a_file = 0; + } + + # init_iage_file could be 'same_as_TS' + if (($var eq 'init_iage_init_file') and + ($pathname eq 'same_as_TS')) { + $is_a_file = 0; + } + + # init_ecosys_init_file could be 'same_as_TS' + if (($var eq 'init_ecosys_init_file') and + ($pathname eq 'same_as_TS')) { + $is_a_file = 0; + } + } + + # If it is, check whether it exists locally and print status + if ($input_pathname_type and $is_a_file) { + + # Get pathname of input dataset + my $pathname = $nl->get_variable_value($group, $var); + # Need to strip the quotes + $pathname =~ s/['"]//g; + + if ($input_pathname_type eq 'abs') { + if ($inputdata_rootdir) { + print OUTFILE "$var = $pathname\n"; + } else { + if (-e $pathname) { # use -e rather than -f since the absolute pathname + # might be a directory + print "OK -- found $var = $pathname\n"; + } else { + print "NOT FOUND: $var = $pathname\n"; + } + } + } elsif ($input_pathname_type =~ m/rel:(.+)/o) { + # The match provides the namelist variable that contains the + # root directory for a relative filename + my $rootdir_var = $1; + my $rootdir = $nl->get_variable_value($group, $rootdir_var); + $rootdir =~ s/['"]//g; + if ($inputdata_rootdir) { + $pathname = "$rootdir/$pathname"; + print OUTFILE "$var = $pathname\n"; + } else { + if (-f "$rootdir/$pathname") { + print "OK -- found $var = $rootdir/$pathname\n"; + } else { + print "NOT FOUND: $var = $rootdir/$pathname\n"; + } + } + } + } + } +} + close OUTFILE if defined $inputdata_rootdir; + return 0 if defined $inputdata_rootdir; +} + +#----------------------------------------------------------------------------------------------- + +sub set_abs_filepath { + +# check whether the input filepath is an absolute path, and if it isn't then +# prepend a root directory + + my ($filepath, $rootdir) = @_; + + # strip any leading/trailing whitespace + $filepath =~ s/^\s+//; + $filepath =~ s/\s+$//; + $rootdir =~ s/^\s+//; + $rootdir =~ s/\s+$//; + + # strip any leading/trailing quotes + $filepath =~ s/^['"]+//; + $filepath =~ s/["']+$//; + $rootdir =~ s/^['"]+//; + $rootdir =~ s/["']+$//; + + my $out = $filepath; + unless ( $filepath =~ /^\// ) { # unless $filepath starts with a / + $out = "$rootdir/$filepath"; # prepend the root directory + } + return $out; +} + +#----------------------------------------------------------------------------------------------- + + +sub absolute_path { +# +# Convert a pathname into an absolute pathname, expanding any . or .. characters. +# Assumes pathnames refer to a local filesystem. +# Assumes the directory separator is "/". +# + my $path = shift; + my $cwd = getcwd(); # current working directory + my $abspath; # resulting absolute pathname + +# Strip off any leading or trailing whitespace. (This pattern won't match if +# there's embedded whitespace. + $path =~ s!^\s*(\S*)\s*$!$1!; + +# Convert relative to absolute path. + + if ($path =~ m!^\.$!) { # path is "." + return $cwd; + } elsif ($path =~ m!^\./!) { # path starts with "./" + $path =~ s!^\.!$cwd!; + } elsif ($path =~ m!^\.\.$!) { # path is ".." + $path = "$cwd/.."; + } elsif ($path =~ m!^\.\./!) { # path starts with "../" + $path = "$cwd/$path"; + } elsif ($path =~ m!^[^/]!) { # path starts with non-slash character + $path = "$cwd/$path"; + } + + my ($dir, @dirs2); + my @dirs = split "/", $path, -1; # The -1 prevents split from stripping trailing nulls + # This enables correct processing of the input "/". + + # Remove any "" that are not leading. + for (my $i=0; $i<=$#dirs; ++$i) { + if ($i == 0 or $dirs[$i] ne "") { + push @dirs2, $dirs[$i]; + } + } + @dirs = (); + + # Remove any "." + foreach $dir (@dirs2) { + unless ($dir eq ".") { + push @dirs, $dir; + } + } + @dirs2 = (); + + # Remove the "subdir/.." parts. + foreach $dir (@dirs) { + if ( $dir !~ /\.\./ ) { + push @dirs2, $dir; + } else { + pop @dirs2; # remove previous dir when current dir is .. + } + } + if ($#dirs2 == 0 and $dirs2[0] eq "") { return "/"; } + $abspath = join '/', @dirs2; + return( $abspath ); +} + +#------------------------------------------------------------------------------- + +sub valid_option { + + my ($val, @expect) = @_; + my ($expect); + + $val =~ s/^\s+//; + $val =~ s/\s+$//; + foreach $expect (@expect) { + if ($val =~ /^$expect$/i) { return $expect; } + } + return undef; +} + +#------------------------------------------------------------------------------- + +sub validate_options { + + my $source = shift; # text string declaring the source of the options being validated + my $opts = shift; # reference to hash that contains the options + + my ($opt, $old, @expect); + +} + +#------------------------------------------------------------------------------- + +sub quote_string { + my $str = shift; + $str =~ s/^\s+//; + $str =~ s/\s+$//; + unless ($str =~ /^['"]/) { #"' + $str = "\'$str\'"; + } + return $str; +} + +#------------------------------------------------------------------------------- + +sub expand_env_xml { + + my $value = shift; + + if ($value =~ /\$([\w_]+)(.*)$/) { + my $subst = $xmlvars{$1}; + $value =~ s/\$${1}/$subst/g; + } + return $value; +} + +#------------------------------------------------------------------------------- + +sub print_nl_to_screen { + + my $namelist = $_[0]; + # Loop through every group in the namelist + for my $group ($namelist->get_group_names()) { + # Loop through every variable in group + for my $var ($namelist->get_variable_names($group)) { + my $val = $namelist->get_variable_value($group, $var); + # For derived type, $var contains variable name and group name + if ($group eq "derived") { + my @broken = split(/&/,$var); + print " * ", $broken[0], " = ", $val, " in \&", $broken[1], "\n"; + } + else { + print " * ", $var, " = ", $val, " in \&", $group, "\n"; + } + } + } +} + +#------------------------------------------------------------------------------- + +sub valid_date { +# return 1 if given date ($$month/$$day/$$year) exists in calendar $cal +# otherwise subtract number of days in $$month from $$day, and increment +# $$month by 1 (also incrementing $$year if going from Dec to Jan) and +# then return 0. + + use Switch; + + my $day = shift; + my $month = shift; + my $year = shift; + my $cal = shift; + + my $maxday = -1; + switch ($$month) { + case 1 { $maxday = 31; } + case 2 { + if (($cal eq 'NO_LEAP') || (not leap($$year))) { + $maxday = 28; + } else { + $maxday = 29; + } + } + case 3 { $maxday = 31; } + case 4 { $maxday = 30; } + case 5 { $maxday = 31; } + case 6 { $maxday = 30; } + case 7 { $maxday = 31; } + case 8 { $maxday = 31; } + case 9 { $maxday = 30; } + case 10 { $maxday = 31; } + case 11 { $maxday = 30; } + case 12 { $maxday = 31; } + } + if ($maxday == -1) { + die "ERROR: can not figure out what month $$month is"; + } + if ($$day > $maxday) { + $$month++; + if ($$month == 13) { + $$year++; + $$month = 1; + } + $$day = $$day - $maxday; + return 0; + } + return 1; +} + +#------------------------------------------------------------------------------- + +sub leap() { +# return 1 if given year is a leap year, 0 otherwise + + my $year = shift; + + if (($year%4 == 0) && (($year%400 == 0) || ($year%100 != 0))) { + return 1; + } + return 0; +} + + diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/forcing.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/forcing.F90 new file mode 100644 index 0000000000..b15b6d07d5 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/forcing.F90 @@ -0,0 +1,646 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1/models/ocn/pop2/source/forcing.F90 + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + + module forcing + +!BOP +! !MODULE: forcing +! +! !DESCRIPTION: +! This is the main driver module for all surface and interior +! forcing. It contains necessary forcing fields as well as +! necessary routines for call proper initialization and +! update routines for those fields. +! +! !REVISION HISTORY: +! SVN:$Id: forcing.F90 38321 2012-06-29 23:22:21Z mlevy@ucar.edu $ +! +! !USES: + + use constants + use blocks + use distribution + use domain + use grid + use ice, only: salice, tfreez, FW_FREEZE + use forcing_ws + use forcing_shf + use forcing_sfwf + use forcing_pt_interior + use forcing_s_interior + use forcing_ap + use forcing_coupled, only: set_combined_forcing, tavg_coupled_forcing, & + liceform, qsw_12hr_factor, qsw_distrb_iopt, qsw_distrb_iopt_cosz, & + tday00_interval_beg, interval_cum_dayfrac, QSW_COSZ_WGHT_NORM, & + QSW_COSZ_WGHT, compute_cosz + use forcing_tools + use passive_tracers, only: set_sflux_passive_tracers + use prognostic + use tavg + use movie, only: define_movie_field, movie_requested, update_movie_field + use time_management + use exit_mod +#ifdef CCSMCOUPLED + use shr_sys_mod, only: shr_sys_abort +#endif + + !*** ccsm + use sw_absorption, only: set_chl + use registry + use forcing_fields + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + + public :: init_forcing, & + set_surface_forcing, & + tavg_forcing, & + movie_forcing + +!EOP +!BOC + + integer (int_kind) :: & + tavg_SHF, &! tavg_id for surface heat flux + tavg_SHF_QSW, &! tavg_id for short-wave solar heat flux + tavg_SFWF, &! tavg_id for surface freshwater flux + tavg_SFWF_WRST, &! tavg_id for weak restoring freshwater flux + tavg_TAUX, &! tavg_id for wind stress in X direction + tavg_TAUX2, &! tavg_id for wind stress**2 in X direction + tavg_TAUY, &! tavg_id for wind stress in Y direction + tavg_TAUY2, &! tavg_id for wind stress**2 in Y direction + tavg_FW, &! tavg_id for freshwater flux + tavg_TFW_T, &! tavg_id for T flux due to freshwater flux + tavg_TFW_S, &! tavg_id for S flux due to freshwater flux + tavg_U10_SQR ! tavg_id for U10_SQR 10m wind speed squared from cpl + +!----------------------------------------------------------------------- +! +! movie ids +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + movie_SHF, &! movie id for surface heat flux + movie_SFWF, &! movie id for surface freshwater flux + movie_TAUX, &! movie id for wind stress in X direction + movie_TAUY ! movie id for wind stress in Y direction + +!EOC +!*********************************************************************** + + contains + +!*********************************************************************** +!BOP +! !IROUTINE: init_forcing +! !INTERFACE: + + subroutine init_forcing + +! !DESCRIPTION: +! Initializes forcing by calling a separate routines for +! wind stress, heat flux, fresh water flux, passive tracer flux, +! interior restoring, and atmospheric pressure. +! +! !REVISION HISTORY: +! same as module + +!----------------------------------------------------------------------- +! +! write out header for forcing options to stdout. +! +!----------------------------------------------------------------------- + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,'(a15)') 'Forcing options' + write(stdout,blank_fmt) + write(stdout,delim_fmt) + endif + +!----------------------------------------------------------------------- +! +! initialize forcing arrays +! +!----------------------------------------------------------------------- + + ATM_PRESS = c0 + FW = c0 + FW_OLD = c0 + SMF = c0 + SMFT = c0 + STF = c0 + TFW = c0 + +!----------------------------------------------------------------------- +! +! call individual initialization routines +! +!----------------------------------------------------------------------- + + call init_ws(SMF,SMFT,lsmft_avail) + + !*** NOTE: with bulk NCEP forcing init_shf must be called before + !*** init_sfwf + + call init_shf (STF) + call init_sfwf(STF) + call init_pt_interior + call init_s_interior + call init_ap(ATM_PRESS) + +!----------------------------------------------------------------------- +! +! define tavg diagnostic fields +! +!----------------------------------------------------------------------- + + call define_tavg_field(tavg_SHF, 'SHF', 2, & + long_name='Total Surface Heat Flux, Including SW', & + units='watt/m^2', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_SHF_QSW, 'SHF_QSW', 2, & + long_name='Solar Short-Wave Heat Flux', & + units='watt/m^2', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_SFWF,'SFWF',2, & + long_name='Virtual Salt Flux in FW Flux formulation', & + units='kg/m^2/s', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_SFWF_WRST,'SFWF_WRST',2, & + long_name='Virtual Salt Flux due to weak restoring', & + units='kg/m^2/s', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_TAUX,'TAUX',2, & + long_name='Windstress in grid-x direction', & + units='dyne/centimeter^2', grid_loc='2220', & + coordinates='ULONG ULAT time') + + call define_tavg_field(tavg_TAUX2,'TAUX2',2, & + long_name='Windstress**2 in grid-x direction', & + units='dyne^2/centimeter^4', grid_loc='2220', & + coordinates='ULONG ULAT time') + + call define_tavg_field(tavg_TAUY,'TAUY',2, & + long_name='Windstress in grid-y direction', & + units='dyne/centimeter^2', grid_loc='2220', & + coordinates='ULONG ULAT time') + + call define_tavg_field(tavg_TAUY2,'TAUY2',2, & + long_name='Windstress**2 in grid-y direction', & + units='dyne^2/centimeter^4', grid_loc='2220', & + coordinates='ULONG ULAT time') + + call define_tavg_field(tavg_FW,'FW',2, & + long_name='Freshwater Flux', & + units='centimeter/s', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_TFW_T,'TFW_T',2, & + long_name='T flux due to freshwater flux', & + units='watt/m^2', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_TFW_S,'TFW_S',2, & + long_name='S flux due to freshwater flux (kg of salt/m^2/s)', & + units='kg/m^2/s', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_U10_SQR,'U10_SQR',2, & + long_name='10m wind speed squared', & + units='cm^2/^s', grid_loc='2110', & + coordinates='TLONG TLAT time') + +!----------------------------------------------------------------------- +! +! define movie diagnostic fields +! +!----------------------------------------------------------------------- + + call define_movie_field(movie_SHF,'SHF',0, & + long_name='Total Surface Heat Flux, Including SW', & + units='watt/m^2', grid_loc='2110') + + call define_movie_field(movie_SFWF,'SFWF',0, & + long_name='Virtual Salt Flux in FW Flux formulation', & + units='kg/m^2/s', grid_loc='2110') + + call define_movie_field(movie_TAUX,'TAUX',0, & + long_name='Windstress in grid-x direction', & + units='dyne/centimeter^2', grid_loc='2220') + + call define_movie_field(movie_TAUY,'TAUY',0, & + long_name='Windstress in grid-y direction', & + units='dyne/centimeter^2', grid_loc='2220') + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_forcing + + +!*********************************************************************** +!BOP +! !IROUTINE: set_surface_forcing +! !INTERFACE: + + subroutine set_surface_forcing + +! !DESCRIPTION: +! Calls surface forcing routines if necessary. +! If forcing does not depend on the ocean state, then update +! forcing if current time is greater than the appropriate +! interpolation time or if it is the first step. +! If forcing DOES depend on the ocean state, then call every +! timestep. interpolation check will be done within the set\_* +! routine. +! Interior restoring is assumed to take place every +! timestep and is set in subroutine tracer\_update, but +! updating the data fields must occur here outside +! any block loops. +! +! !REVISION HISTORY: +! same as module + + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + real (r8), dimension(nx_block,ny_block,max_blocks_clinic) :: & + TFRZ + integer (int_kind) :: index_qsw, iblock + real (r8) :: & + cosz_day, & + qsw_eps + + +#ifdef _HIRES + qsw_eps = -1.e-8_r8 +#else + qsw_eps = c0 +#endif + +!******POPDART AK ALICIAK... hardcoding the qsw crit to + +qsw_eps = -0.5e-1_r8 !ALICIAK + +!POPDART, this was done because negative sw values were in the +!the CPLHIST files from CAMDART and were crashing POP +!relaxing the critical value allowed the integration to continue. + +if (my_task == master_task) then +write(stdout,*) "THE QSW_CRIT HAS BEEN CHANGED FOR ASSIMILATION" !ALICIAK +endif +!************************************************ + +!----------------------------------------------------------------------- +! +! Get any interior restoring data and interpolate if necessary. +! +!----------------------------------------------------------------------- + + call get_pt_interior_data + call get_s_interior_data + +!----------------------------------------------------------------------- +! +! Call individual forcing update routines. +! +!----------------------------------------------------------------------- + + if (lsmft_avail) then + call set_ws(SMF,SMFT=SMFT) + else + call set_ws(SMF) + endif + + !*** NOTE: with bulk NCEP and partially-coupled forcing + !*** set_shf must be called before set_sfwf + + call set_shf(STF) + call set_sfwf(STF,FW,TFW) + + if ( shf_formulation == 'partially-coupled' .or. & + sfwf_formulation == 'partially-coupled' ) then + call set_combined_forcing(STF,FW,TFW) + endif + + +!----------------------------------------------------------------------- +! +! apply qsw 12hr if chosen +! +!----------------------------------------------------------------------- + + index_qsw = mod(nsteps_this_interval,nsteps_per_interval) + 1 + + if ( qsw_distrb_iopt == qsw_distrb_iopt_cosz ) then + cosz_day = tday00_interval_beg + interval_cum_dayfrac(index_qsw-1) & + - interval_cum_dayfrac(nsteps_per_interval) + + !$OMP PARALLEL DO PRIVATE(iblock) + do iblock = 1, nblocks_clinic + + call compute_cosz(cosz_day, iblock, QSW_COSZ_WGHT(:,:,iblock)) + + where (QSW_COSZ_WGHT_NORM(:,:,iblock) > c0) + QSW_COSZ_WGHT(:,:,iblock) = QSW_COSZ_WGHT(:,:,iblock) & + * QSW_COSZ_WGHT_NORM(:,:,iblock) + elsewhere + QSW_COSZ_WGHT(:,:,iblock) = c1 + endwhere + + SHF_QSW(:,:,iblock) = QSW_COSZ_WGHT(:,:,iblock) & + * SHF_COMP(:,:,iblock,shf_comp_qsw) + + enddo + !$OMP END PARALLEL DO + + else + + if (registry_match('lcoupled')) then + SHF_QSW = qsw_12hr_factor(index_qsw)*SHF_COMP(:,:,:,shf_comp_qsw) + endif + + endif + + if ( registry_match('lcoupled') & + .and. sfwf_formulation /= 'partially-coupled' & + .and. sfc_layer_type == sfc_layer_varthick .and. & + .not. lfw_as_salt_flx .and. liceform ) then + FW = SFWF_COMP(:,:,:, sfwf_comp_cpl) + TFW = TFW_COMP(:,:,:,:, tfw_comp_cpl) + endif + + if ( sfc_layer_type == sfc_layer_varthick .and. & + .not. lfw_as_salt_flx .and. liceform ) then + FW = FW + FW_FREEZE + + call tfreez(TFRZ,TRACER(:,:,1,2,curtime,:)) + + TFW(:,:,1,:) = TFW(:,:,1,:) + FW_FREEZE(:,:,:)*TFRZ(:,:,:) + TFW(:,:,2,:) = TFW(:,:,2,:) + FW_FREEZE(:,:,:)*salice + endif + + + call set_ap(ATM_PRESS) + + if (nt > 2) & + call set_sflux_passive_tracers(U10_SQR,IFRAC,ATM_PRESS,STF) + + call set_chl + +#ifdef CCSMCOUPLED + if (ANY(SHF_QSW < qsw_eps)) then + write(6,*) "AK AT END OF set_surface forcing" !ALICIAK POPDART AK + write(6,*) "AK THE minval is: ", MINVAL(SHF_QSW) !ALICIAK POPDART AK + write(6,*) "AK THE minloc is: ", MINLOC(SHF_QSW) !ALICIAK POPDART AK + call shr_sys_abort('(set_surface_forcing) ERROR: SHF_QSW < qsw_eps in set_surface_forcing') + endif +#endif + + +!----------------------------------------------------------------------- +!EOC + + end subroutine set_surface_forcing + +!*********************************************************************** +!BOP +! !IROUTINE: tavg_forcing +! !INTERFACE: + + subroutine tavg_forcing + +! !DESCRIPTION: +! This routine accumulates tavg diagnostics related to surface +! forcing. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + iblock ! block loop index + + type (block) :: & + this_block ! block information for current block + + real (r8), dimension(nx_block,ny_block) :: & + WORK ! local temp space for tavg diagnostics + +!----------------------------------------------------------------------- +! +! compute and accumulate tavg forcing diagnostics +! +!----------------------------------------------------------------------- + + !$OMP PARALLEL DO PRIVATE(iblock,this_block,WORK) + + do iblock = 1,nblocks_clinic + + this_block = get_block(blocks_clinic(iblock),iblock) + + if (accumulate_tavg_now(tavg_SHF)) then + where (KMT(:,:,iblock) > 0) + WORK = (STF(:,:,1,iblock)+SHF_QSW(:,:,iblock))/ & + hflux_factor ! W/m^2 + elsewhere + WORK = c0 + end where + + call accumulate_tavg_field(WORK,tavg_SHF,iblock,1) + endif + + if (accumulate_tavg_now(tavg_SHF_QSW)) then + where (KMT(:,:,iblock) > 0) + WORK = SHF_QSW(:,:,iblock)/hflux_factor ! W/m^2 + elsewhere + WORK = c0 + end where + + call accumulate_tavg_field(WORK,tavg_SHF_QSW,iblock,1) + endif + + if (accumulate_tavg_now(tavg_SFWF)) then + if (sfc_layer_type == sfc_layer_varthick .and. & + .not. lfw_as_salt_flx) then + where (KMT(:,:,iblock) > 0) + WORK = FW(:,:,iblock)*seconds_in_year*mpercm ! m/yr + elsewhere + WORK = c0 + end where + else + where (KMT(:,:,iblock) > 0) ! convert to kg(freshwater)/m^2/s + WORK = STF(:,:,2,iblock)/salinity_factor + elsewhere + WORK = c0 + end where + endif + + call accumulate_tavg_field(WORK,tavg_SFWF,iblock,1) + endif + + if (accumulate_tavg_now(tavg_SFWF_WRST)) then + if ( sfwf_formulation == 'partially-coupled' ) then + where (KMT(:,:,iblock) > 0) ! convert to kg(freshwater)/m^2/s + WORK = SFWF_COMP(:,:,iblock,sfwf_comp_wrest)/salinity_factor + elsewhere + WORK = c0 + end where + else + WORK = c0 + endif + call accumulate_tavg_field(WORK,tavg_SFWF_WRST,iblock,1) + endif + + call accumulate_tavg_field(SMF(:,:,1,iblock), tavg_TAUX,iblock,1) + call accumulate_tavg_field(SMF(:,:,1,iblock)**2, tavg_TAUX2,iblock,1) + call accumulate_tavg_field(SMF(:,:,2,iblock), tavg_TAUY,iblock,1) + call accumulate_tavg_field(SMF(:,:,2,iblock)**2, tavg_TAUY2,iblock,1) + call accumulate_tavg_field(FW (:,:,iblock), tavg_FW,iblock,1) + call accumulate_tavg_field(TFW(:,:,1,iblock)/hflux_factor, tavg_TFW_T,iblock,1) + call accumulate_tavg_field(TFW(:,:,2,iblock)*rho_sw*c10, tavg_TFW_S,iblock,1) + call accumulate_tavg_field(U10_SQR(:,:,iblock), tavg_U10_SQR,iblock,1) + + + end do + + !$OMP END PARALLEL DO + + if (registry_match('lcoupled')) call tavg_coupled_forcing + +!----------------------------------------------------------------------- +!EOC + + end subroutine tavg_forcing + + +!*********************************************************************** +!BOP +! !IROUTINE: movie_forcing +! !INTERFACE: + + subroutine movie_forcing + +! !DESCRIPTION: +! This routine accumulates movie diagnostics related to surface +! forcing. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + iblock ! block loop index + + type (block) :: & + this_block ! block information for current block + + real (r8), dimension(nx_block,ny_block) :: & + WORK ! local temp space for movie diagnostics + +!----------------------------------------------------------------------- +! +! compute and dump movie forcing diagnostics +! +!----------------------------------------------------------------------- + + !$OMP PARALLEL DO PRIVATE(iblock,this_block,WORK) + + do iblock = 1,nblocks_clinic + + this_block = get_block(blocks_clinic(iblock),iblock) + +!----------------------------------------------------------------------- +! +! dump movie diagnostics if requested +! +!----------------------------------------------------------------------- + + if (movie_requested(movie_SHF) ) then + where (KMT(:,:,iblock) > 0) + WORK = (STF(:,:,1,iblock)+SHF_QSW(:,:,iblock))/ & + hflux_factor ! W/m^2 + elsewhere + WORK = c0 + end where + call update_movie_field(WORK, movie_SHF, iblock, 1) + endif + + if (movie_requested(movie_SFWF) ) then + if (sfc_layer_type == sfc_layer_varthick .and. & + .not. lfw_as_salt_flx) then + where (KMT(:,:,iblock) > 0) + WORK = FW(:,:,iblock)*seconds_in_year*mpercm ! m/yr + elsewhere + WORK = c0 + end where + else + where (KMT(:,:,iblock) > 0) ! convert to kg(freshwater)/m^2/s + WORK = STF(:,:,2,iblock)/salinity_factor + elsewhere + WORK = c0 + end where + endif + call update_movie_field(WORK, movie_SFWF, iblock, 1) + endif + + if (movie_requested(movie_TAUX) ) then + call update_movie_field(SMF(:,:,1,iblock), & + movie_TAUX,iblock,1) + endif + + if (movie_requested(movie_TAUY) ) then + call update_movie_field(SMF(:,:,2,iblock), & + movie_TAUY,iblock,1) + endif + + + end do + + !$OMP END PARALLEL DO + +!----------------------------------------------------------------------- +!EOC + + end subroutine movie_forcing + + +!*********************************************************************** + + end module forcing + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/initial.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/initial.F90 new file mode 100644 index 0000000000..1bb7bc243f --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/initial.F90 @@ -0,0 +1,2232 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1/models/ocn/pop2/source/initial.F90 + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + + module initial + +!BOP +! !MODULE: initial +! !DESCRIPTION: +! This module contains routines for initializing a POP simulation, +! mostly by calling individual initialization routines for each +! POP module. +! +! !REVISION HISTORY: +! SVN:$Id: initial.F90 39674 2012-08-24 18:14:03Z mlevy@ucar.edu $ +! +! !USES: + + use POP_KindsMod + use POP_ErrorMod + use POP_IOUnitsMod + use POP_SolversMod + use POP_ReductionsMod + + use kinds_mod, only: i4, i8, r8, int_kind, log_kind, char_len + use blocks, only: block, nx_block, ny_block, get_block + use domain_size + use domain, only: nblocks_clinic, blocks_clinic, init_domain_blocks, & + init_domain_distribution, distrb_clinic + use constants, only: radian, delim_fmt, blank_fmt, field_loc_center, blank_fmt, & + c0, ppt_to_salt, mpercm, c1, field_type_scalar, init_constants, & + stefan_boltzmann, latent_heat_vapor_mks, vonkar, emissivity, & + latent_heat_fusion, t0_kelvin, pi, ocn_ref_salinity, & + sea_ice_salinity, radius, cp_sw, grav, omega,cp_air, & + rho_fw, sound, rho_air, rho_sw, ndelim_fmt + use communicate, only: my_task, master_task, init_communicate + use budget_diagnostics, only: init_budget_diagnostics + use broadcast, only: broadcast_array, broadcast_scalar + use prognostic, only: init_prognostic, max_blocks_clinic, nx_global, & + ny_global, km, nt, TRACER, curtime, RHO, newtime, oldtime + use grid, only: init_grid1, init_grid2, kmt, kmt_g, n_topo_smooth, zt, & + fill_points, sfc_layer_varthick, sfc_layer_type, TLON, TLAT, partial_bottom_cells + use io + use io_tools + use baroclinic, only: init_baroclinic + use barotropic, only: init_barotropic + use pressure_grad, only: init_pressure_grad + use surface_hgt, only: init_surface_hgt + use vertical_mix, only: init_vertical_mix, vmix_itype, vmix_type_kpp + use vmix_kpp, only: bckgrnd_vdc2, linertial + use horizontal_mix, only: init_horizontal_mix + use advection, only: init_advection + use diagnostics, only: init_diagnostics + use state_mod, only: init_state, state, state_itype, state_type_mwjf, state_range_iopt, & + state_range_enforce + use time_management, only: first_step, init_time1, init_time2, & + dttxcel, dtuxcel, check_time_flag_int, & + get_time_flag_id, freq_opt_nhour + use topostress, only: init_topostress + use ice + use output, only: init_output + use tavg, only: ltavg_restart, tavg_id, set_in_tavg_contents,n_tavg_streams, tavg_streams + !use hydro_sections + !use current_meters + !use drifters + use forcing, only: init_forcing + use forcing_sfwf, only: sfwf_formulation, lms_balance, sfwf_data_type, lfw_as_salt_flx + use forcing_shf, only: luse_cpl_ifrac, OCN_WGT, shf_formulation, shf_data_type + use forcing_ws, only: ws_data_type + use sw_absorption, only: init_sw_absorption + use passive_tracers, only: init_passive_tracers, ecosys_on + use ecosys_mod, only: ecosys_qsw_distrb_const + use exit_mod, only: sigAbort, exit_pop, flushm + use restart, only: read_restart, restart_fmt, read_restart_filename + use ms_balance, only: init_ms_balance + use forcing_coupled, only: pop_init_coupled, pop_init_partially_coupled, & + qsw_distrb_iopt, qsw_distrb_iopt_const, ncouple_per_day, coupled_freq_iopt + use global_reductions, only: init_global_reductions, global_sum + use timers, only: init_timers + use registry + use qflux_mod, only: init_qflux + use niw_mixing + use tidal_mixing + use step_mod, only: init_step + use gather_scatter +#ifdef CCSMCOUPLED + use shr_ncread_mod + use shr_map_mod +#endif + use overflows + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + + public :: pop_init_phase1, pop_init_phase2 + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- + + character (char_len) :: & + init_ts_file_fmt, &! format (bin or nc) for input file + exit_string ! exit_POP message string + + logical (log_kind), public :: &! context variables + lcoupled, &! T ==> pop is coupled to another system + lccsm, &! T ==> pop is being run in the ccsm context + b4b_flag, &! T ==> pop is being run in the "bit-for-bit" mode + ldata_assim, &! T ==> pop is being run in data assimilation mode !POPDART added by AK Sept 21,2012 + lccsm_control_compatible ! T ==> pop is being run with code that is b4b with the ccsm4 control run + ! this is a temporary flag that will be removed in ccsm4_0_1 + +!EOC +!*********************************************************************** + + contains +!*********************************************************************** +!BOP +! !IROUTINE: pop_init_phase1 +! !INTERFACE: + + subroutine pop_init_phase1(errorCode) + +! !DESCRIPTION: +! This routine is the first of a two-phase initialization process for +! a POP run. It calls various module initialization routines and sets up +! the initial temperature and salinity +! +! !REVISION HISTORY: +! same as module +! +! !OUTPUT PARAMETERS: + + integer (POP_i4), intent(out) :: & + errorCode ! returned error code + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + k, &! dummy vertical level index + ier ! error flag + +!----------------------------------------------------------------------- +! +! initialize message-passing or other communication protocol +! +!----------------------------------------------------------------------- + + errorCode = POP_Success + + call init_communicate + +!----------------------------------------------------------------------- +! +! initialize registry, which keeps track of which initialization +! routines have been called. This feature is used for error checking +! in routines whose calling order is important +! +!----------------------------------------------------------------------- + + call init_registry + +!----------------------------------------------------------------------- +! +! initialize constants and i/o stuff +! +!----------------------------------------------------------------------- + + call init_io + +#ifdef CCSMCOUPLED +!----------------------------------------------------------------------- +! +! temporary synching of old and new pop2 infrastructure for CCSM +! +!----------------------------------------------------------------------- + POP_stdout = stdout + POP_stderr = stderr + POP_stdin = stdin +#endif + +!----------------------------------------------------------------------- +! +! initialize context in which pop is being run +! +!----------------------------------------------------------------------- + + call init_context + +!----------------------------------------------------------------------- +! +! write version information to output log after output redirection +! +!----------------------------------------------------------------------- + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,'(a)') ' Parallel Ocean Program (POP) ' + write(stdout,'(a)') ' Based on Version 2.1alpha Jan 2005' + write(stdout,'(a)') ' Modified for CESM 2005-2010' + write(stdout,blank_fmt) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + call init_constants + +!----------------------------------------------------------------------- +! +! initialize timers +! +!----------------------------------------------------------------------- + + call init_timers + +!----------------------------------------------------------------------- +! +! initialize additional communication routines +! +!----------------------------------------------------------------------- + + call init_global_reductions + call POP_initReductions + +!----------------------------------------------------------------------- +! +! initialize overflows, part I +! +!----------------------------------------------------------------------- + + call init_overflows1 + +!----------------------------------------------------------------------- +! +! initialize domain and grid +! +!----------------------------------------------------------------------- + + call init_domain_blocks + call init_grid1 + call init_domain_distribution(KMT_G) + +!----------------------------------------------------------------------- +! +! initialize overflows, part II. placed here so KMT_G scatter to +! KMT can be done (and NOT in init_grid2) for possible KMT mods; then +! finish with domain and grid initialization +! +!----------------------------------------------------------------------- + + call init_overflows2 + + call init_grid2(errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_phase1: error initializing grid 2') + return + endif + +!----------------------------------------------------------------------- +! +! compute time step and initialize time-related quantities +! +!----------------------------------------------------------------------- + + call init_time1 + +!----------------------------------------------------------------------- +! +! initialize equation of state +! +!----------------------------------------------------------------------- + + call init_state + +!----------------------------------------------------------------------- +! +! calculate topographic stress (maximum entropy) velocities +! +!----------------------------------------------------------------------- + + call init_topostress(errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_phase1: error in init_topostress') + return + endif + +!----------------------------------------------------------------------- +! +! initialize niw driven mixing +! +!----------------------------------------------------------------------- + + call init_niw_mixing + +!----------------------------------------------------------------------- +! +! initialize tidally driven mixing +! +!----------------------------------------------------------------------- + + call init_tidal_mixing + + if ( overflows_interactive .and. .not.ltidal_mixing ) then + exit_string = 'FATAL ERROR: overflow code is validated only with tidal mixing' + call document ('pop_init_phase1', exit_string) + call exit_POP (sigAbort,exit_string,out_unit=stdout) + endif + +!----------------------------------------------------------------------- +! +! initialize barotropic elliptic solver +! +!----------------------------------------------------------------------- + + call POP_SolversInit(errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'POP_Init: error initializing solvers') + return + endif + +!----------------------------------------------------------------------- +! +! modify 9pt coefficients for barotropic solver for overflow use +! +!----------------------------------------------------------------------- + + call init_overflows3 + +!----------------------------------------------------------------------- +! +! initialize pressure gradient (pressure averaging) +! initialize baroclinic (reset to freezing) +! initialize barotropic (barotropic-related diagnostics) +! initialize surface_hgt (ssh-related diagnostics) +! +!----------------------------------------------------------------------- + + call init_pressure_grad + call init_baroclinic + call init_barotropic + call init_surface_hgt + +!----------------------------------------------------------------------- +! +! initialize prognostic fields +! +!----------------------------------------------------------------------- + + call init_prognostic + +!----------------------------------------------------------------------- +! +! initialize ice module +! +!----------------------------------------------------------------------- + + call init_ice + +!----------------------------------------------------------------------- +! +! set initial temperature and salinity profiles (includes read of +! restart file +! +!----------------------------------------------------------------------- + + call init_ts(errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_phase1: error in init_ts') + return + endif + +!----------------------------------------------------------------------- +! +! finish computing time-related quantities after restart info +! available +! +!----------------------------------------------------------------------- + + call init_time2 + + +!----------------------------------------------------------------------- +! +! initialize fields for surface forcing +! o init_ws +! o init_shf +! o init_sfwf +! o init_pt_interior +! o init_s_interior +! o init_ap +! +!----------------------------------------------------------------------- + + call init_forcing + +!----------------------------------------------------------------------- +! +! initialize generic aspects of coupled forcing (no coupling-specific +! references) +! +!----------------------------------------------------------------------- + + call pop_init_coupled + +!----------------------------------------------------------------------- +!EOC + + end subroutine pop_init_phase1 + + +!*********************************************************************** +!BOP +! !IROUTINE: pop_init_phase2 +! !INTERFACE: + + subroutine pop_init_phase2(errorCode) + +! !DESCRIPTION: +! This routine completes the two-phase initialization process for +! a POP run. +! +! !REVISION HISTORY: +! same as module +! +! !OUTPUT PARAMETERS: + + integer (POP_i4), intent(out) :: & + errorCode ! returned error code + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + k, &! dummy vertical level index + ier ! error flag + + +!----------------------------------------------------------------------- +! +! initialize passive tracer modules -- after call init_forcing_coupled +! do this independently of nt so that +! 1) consistency of nt and selected passive tracer modules +! can always be checked +! 2) passive_tavg_nonstd_vars gets allocated +! +!----------------------------------------------------------------------- + + errorCode = POP_Success + + call init_passive_tracers(init_ts_file_fmt, read_restart_filename, & + errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_phase2: error in init_passive_tracers') + return + endif + +!----------------------------------------------------------------------- +! +! initialize vertical mixing variables +! initialize horizontal mixing variables +! +!----------------------------------------------------------------------- + + call init_vertical_mix + + call init_horizontal_mix(errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_phase1: error in init_horizontal_mix') + return + endif + +!----------------------------------------------------------------------- +! +! initialize overflow regional values +! +!----------------------------------------------------------------------- + + call init_overflows5 + +!----------------------------------------------------------------------- +! +! initialize advection variables +! +!----------------------------------------------------------------------- + + call init_advection + +!----------------------------------------------------------------------- +! +! initialize shortwave absorption +! +!----------------------------------------------------------------------- + + call init_sw_absorption + +!----------------------------------------------------------------------- +! +! partial coupling forcing initialization +! +!----------------------------------------------------------------------- + + call pop_init_partially_coupled + +!----------------------------------------------------------------------- +! +! initialize time-averaged qflux information +! +!----------------------------------------------------------------------- + + call init_qflux + +!----------------------------------------------------------------------- +! +! initialize ms_balance +! +!----------------------------------------------------------------------- + + if (lcoupled .and. lms_balance) call init_ms_balance + +!----------------------------------------------------------------------- +! +! initialize diagnostics +! +!----------------------------------------------------------------------- + + call init_diagnostics + +!----------------------------------------------------------------------- +! +! initialize overflows output diagnostics filename +! +!----------------------------------------------------------------------- + + call init_overflows4 + +!----------------------------------------------------------------------- +! +! initialize output; subroutine init_output calls +! o init_restart +! o init_history +! o init_movie +! o init_tavg +! +!----------------------------------------------------------------------- + + call init_output + +!----------------------------------------------------------------------- +! +! initialize drifters, hydrographic sections and current meters +! +!----------------------------------------------------------------------- + + !call init_drifters + !call init_hydro_sections + !call init_current_meters + +!----------------------------------------------------------------------- +! +! initialize global budget diagnostics +! +!----------------------------------------------------------------------- + + call init_budget_diagnostics + +!----------------------------------------------------------------------- +! +! initialize step timers +! +!----------------------------------------------------------------------- + + call init_step + +!----------------------------------------------------------------------- +! +! check registry -- have any errors occured? +! +!----------------------------------------------------------------------- + + call trap_registry_failure + +!----------------------------------------------------------------------- +! +! check consistency of model options +! +!----------------------------------------------------------------------- + + call POP_check + +!----------------------------------------------------------------------- +! +! write model information into log file +! +!----------------------------------------------------------------------- + + call document_constants + + +!----------------------------------------------------------------------- +!EOC + + end subroutine pop_init_phase2 + + + +!*********************************************************************** +!BOP +! !IROUTINE: init_context +! !INTERFACE: + + subroutine init_context + +! !DESCRIPTION: +! This routine initializes the context in which POP is being run, +! including information about coupling and CCSM +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + + integer (int_kind) :: & + nml_error, &! namelist i/o error flag + number_of_fatal_errors + + namelist /context_nml/ lcoupled, lccsm, b4b_flag, lccsm_control_compatible + +!----------------------------------------------------------------------- +! +! read context_nml namelist to determine the context in which pop +! being run. check for errors and broadcast info to all processors +! +!----------------------------------------------------------------------- + + lcoupled = .false. + lccsm = .false. + b4b_flag = .false. + lccsm_control_compatible = .true. + + if (my_task == master_task) then + open (nml_in, file=nml_filename, status='old',iostat=nml_error) + if (nml_error /= 0) then + nml_error = -1 + else + nml_error = 1 + endif + do while (nml_error > 0) + read(nml_in, nml=context_nml,iostat=nml_error) + end do + if (nml_error == 0) close(nml_in) + endif + + call broadcast_scalar(nml_error, master_task) + if (nml_error /= 0) then + exit_string = 'FATAL ERROR: reading context_nml' + call document ('init_context', exit_string) + call exit_POP (sigAbort,exit_string,out_unit=stdout) + endif + + call broadcast_scalar(lcoupled, master_task) + call broadcast_scalar(lccsm, master_task) + call broadcast_scalar(b4b_flag, master_task) + call broadcast_scalar(lccsm_control_compatible, master_task) + +!----------------------------------------------------------------------- +! +! register information with the registry function, allowing other +! modules to access this information (avoids circular dependencies) +! +!----------------------------------------------------------------------- + if (lcoupled) call register_string('lcoupled') + if (lccsm) call register_string('lccsm') + if (b4b_flag) call register_string('b4b_flag') + if (lccsm_control_compatible) call register_string('lccsm_control_compatible') + +!----------------------------------------------------------------------- +! +! document the namelist information +! +!----------------------------------------------------------------------- + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,*) ' Context:' + write(stdout,blank_fmt) + write(stdout,*) ' context_nml namelist settings:' + write(stdout,blank_fmt) + write(stdout, context_nml) + write(stdout,blank_fmt) + endif + +!----------------------------------------------------------------------- +! +! error checking +! +!----------------------------------------------------------------------- + + number_of_fatal_errors = 0 + + if (.not. (lcoupled .eqv. lccsm)) then + exit_string = 'FATAL ERROR: presently, lcoupled and lccsm must have the same value' + call document ('init_context', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +#ifdef CCSMCOUPLED + if (.not. lcoupled) then + exit_string = 'FATAL ERROR: inconsistent options.' & + // ' Cpp option coupled is defined, but lcoupled = .false.' + call document ('init_context', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif +#else + if (lcoupled) then + exit_string = 'FATAL ERROR: inconsistent options.' & + // ' Cpp option coupled is not defined, but lcoupled = .true.' + call document ('init_context', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif +#endif + + if (number_of_fatal_errors > 0) & + call exit_POP(sigAbort,'ERROR: subroutine init_context -- see preceeding message') + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_context + +!*********************************************************************** +!BOP +! !IROUTINE: init_ts +! !INTERFACE: + + subroutine init_ts(errorCode) + +! !DESCRIPTION: +! Initializes temperature and salinity and +! initializes prognostic variables from restart if required +! +! !REVISION HISTORY: +! same as module +! +! !OUTPUT PARAMETERS: + + integer (POP_i4), intent(out) :: & + errorCode ! returned error code + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! namelist input +! +!----------------------------------------------------------------------- + + integer (int_kind) :: nml_error ! namelist i/o error flag + + character (char_len) :: & + init_ts_option, &! option for initializing t,s + init_ts_suboption, &! suboption for initializing t,s (rest or spunup) + init_ts_file, &! filename for input T,S file + init_ts_outfile, &! filename for output T,S file + init_ts_outfile_fmt ! format for output T,S file (bin or nc) + + namelist /init_ts_nml/ init_ts_option, init_ts_file, init_ts_file_fmt, & + init_ts_suboption, init_ts_outfile, & + init_ts_outfile_fmt + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + i,j,k,icnt, &! vertical level index + n, &! tracer index + kk, &! indices for interpolating levitus data + nu, &! i/o unit for mean profile file + iblock ! local block address + + integer (int_kind) :: & + m, &! overflows dummy loop index + ib,ie,jb,je ! local domain index boundaries + + integer (i4) :: & + PHCnx,PHCny,PHCnz + + integer (i4), dimension(:,:), allocatable :: & + PHC_msk,MASK_G + + logical (log_kind) :: & + lccsm_branch ,&! flag for ccsm 'ccsm_branch' restart + lccsm_hybrid ! flag for ccsm 'ccsm_hybrid' restart + + type (block) :: & + this_block ! block information for current block + + real (r8) :: & + sinterp, &! factor for interpolating levitus data + dpth_meters ! depth of level in meters + + real (r8), dimension(km) :: & + tinit, sinit ! mean initial state as function of depth + + type (datafile) :: & + in_file ! data file type for init ts file + + type (io_field_desc) :: & + io_temp, io_salt ! io field descriptors for input T,S + + type (io_dim) :: & + i_dim, j_dim, k_dim ! dimension descriptors + + real (r8), dimension(:,:,:,:), allocatable :: & + TEMP_DATA ! temp array for reading T,S data + + real (r8), dimension(:,:,:,:), allocatable :: & + PHC_ktop,PHC_kbot ! temp array for ncreading 3D PHC T,S data + + real (r8), dimension(:,:), allocatable :: & + dataSrc,dataDst, &! temp arrays for remapping PHC T,S data + PHC_x, &! lon array for PHC data + PHC_y, &! lat array for PHC data + PHC_kmod_T, &! PHC data on model zgrid + PHC_kmod_S, &! PHC data on model zgrid + MOD_T,MOD_S, &! 2D model init T,S data on model zgrid + tmpkt,tmpkb, &! 2D model init T,S data on model zgrid + TLON_G, &! global tlon array + TLAT_G ! global tlat array + + real (r8), dimension(:), allocatable :: & + tmp1,tmp2,PHC_z ! temp arrays + +#ifdef CCSMCOUPLED + type(shr_map_mapType) :: PHC_map ! used to map PHC data +#endif + + + !*** + !*** 1992 Levitus mean climatology for internal generation of t,s + !*** + + real (r8), dimension(33) :: & + depth_levitus = (/ & + 0.0_r8, 10.0_r8, 20.0_r8, & + 30.0_r8, 50.0_r8, 75.0_r8, & + 100.0_r8, 125.0_r8, 150.0_r8, & + 200.0_r8, 250.0_r8, 300.0_r8, & + 400.0_r8, 500.0_r8, 600.0_r8, & + 700.0_r8, 800.0_r8, 900.0_r8, & + 1000.0_r8, 1100.0_r8, 1200.0_r8, & + 1300.0_r8, 1400.0_r8, 1500.0_r8, & + 1750.0_r8, 2000.0_r8, 2500.0_r8, & + 3000.0_r8, 3500.0_r8, 4000.0_r8, & + 4500.0_r8, 5000.0_r8, 5500.0_r8 /) + + real (r8), dimension(33) :: & + tmean_levitus = (/ & + 18.27_r8, 18.22_r8, 18.09_r8, & + 17.87_r8, 17.17_r8, 16.11_r8, & + 15.07_r8, 14.12_r8, 13.29_r8, & + 11.87_r8, 10.78_r8, 9.94_r8, & + 8.53_r8, 7.35_r8, 6.38_r8, & + 5.65_r8, 5.06_r8, 4.57_r8, & + 4.13_r8, 3.80_r8, 3.51_r8, & + 3.26_r8, 3.05_r8, 2.86_r8, & + 2.47_r8, 2.19_r8, 1.78_r8, & + 1.49_r8, 1.26_r8, 1.05_r8, & + 0.91_r8, 0.87_r8, 1.00_r8 /) + + real (r8), dimension(33) :: & + smean_levitus = (/ & + 34.57_r8, 34.67_r8, 34.73_r8, & + 34.79_r8, 34.89_r8, 34.97_r8, & + 35.01_r8, 35.03_r8, 35.03_r8, & + 34.98_r8, 34.92_r8, 34.86_r8, & + 34.76_r8, 34.68_r8, 34.63_r8, & + 34.60_r8, 34.59_r8, 34.60_r8, & + 34.61_r8, 34.63_r8, 34.65_r8, & + 34.66_r8, 34.68_r8, 34.70_r8, & + 34.72_r8, 34.74_r8, 34.75_r8, & + 34.74_r8, 34.74_r8, 34.73_r8, & + 34.73_r8, 34.72_r8, 34.72_r8 /) + +!----------------------------------------------------------------------- +! +! read input namelist and broadcast +! +!----------------------------------------------------------------------- + + errorCode = POP_Success + + init_ts_suboption = 'rest' + init_ts_outfile = 'unknown_init_ts_outfile' + init_ts_outfile_fmt = 'bin' + ldata_assim = .false. !POPDART added by AK Sept 21,2012 + + if (my_task == master_task) then + open (nml_in, file=nml_filename, status='old',iostat=nml_error) + if (nml_error /= 0) then + nml_error = -1 + else + nml_error = 1 + endif + do while (nml_error > 0) + read(nml_in, nml=init_ts_nml,iostat=nml_error) + end do + if (nml_error == 0) close(nml_in) + endif + + call broadcast_scalar(nml_error, master_task) + if (nml_error /= 0) then + call exit_POP(sigAbort,'ERROR reading init_ts_nml') + endif + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,*) ' Initial T,S:' + write(stdout,blank_fmt) + write(stdout,*) ' init_ts_nml namelist settings:' + write(stdout,blank_fmt) + write(stdout,init_ts_nml) + write(stdout,blank_fmt) + if (trim(init_ts_option) == 'ccsm_startup' .and. & + trim(init_ts_suboption) == 'spunup') then + init_ts_option = 'ccsm_startup_spunup' + luse_pointer_files = .false. + endif + + select case (init_ts_option) + case ('ccsm_continue','restart', 'ccsm_branch', 'ccsm_hybrid') + !*****POPDART added by AK Sept 21,2012********* + if (trim(init_ts_suboption) == 'data_assim' ) then + ldata_assim = .true. + write(stdout,*) "AK: POPDART: Assume restarts followed an assimilation" + endif + !********************** + if (luse_pointer_files) then + write(stdout,*) ' In this case, the init_ts_file' /& + &/ ' name will be read from the pointer file.' + write(stdout,*) ' ' + endif + end select + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + call broadcast_scalar(init_ts_option , master_task) + call broadcast_scalar(ldata_assim , master_task) !POPDART added by AK sept 21,2012 + call broadcast_scalar(init_ts_suboption , master_task) + call broadcast_scalar(luse_pointer_files , master_task) + call broadcast_scalar(init_ts_file , master_task) + call broadcast_scalar(init_ts_file_fmt , master_task) + call broadcast_scalar(init_ts_outfile , master_task) + call broadcast_scalar(init_ts_outfile_fmt , master_task) + +!----------------------------------------------------------------------- +! +! initialize t,s or call restart based on init_ts_option +! +!----------------------------------------------------------------------- + + if (my_task == master_task) then ! TJH DEBUG on top of AK Sept 21 2012 + write(stdout,*) "DARTmessage: The init_ts_option is ", trim(init_ts_option) + write(stdout,*) "DARTmessage: The init_ts_suboption is ", trim(init_ts_suboption) + write(stdout,*) "DARTmessage: The ldata_assim value is ", ldata_assim + endif + + select case (init_ts_option) + +!----------------------------------------------------------------------- +! +! set initial state from restart file +! +!----------------------------------------------------------------------- + + case ('ccsm_continue', 'restart') + first_step = .false. + lccsm_branch = .false. + lccsm_hybrid = .false. + if (my_task == master_task .and. .not. luse_pointer_files) then + write(stdout,'(a35,a)') 'Initial T,S read from restart file:',& + trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout); call POP_IOUnitsFlush(stdout) + endif + + !******POPDART added by AK Sept 11,2013******************************* + !! If ldata_assim is true then the two time slices of POP states have + !! been modified by restart.F90:DART_modify_restart() to be identical. + !! Therefore, we must force the first step after data assimilation to + !! be forward euler. This happens when first_step = .true. + + if (ldata_assim) then + first_step = .true. + if (my_task == master_task) & + write(stdout,*) 'DART modification ... forward euler timestep.' + else + if (my_task == master_task) & + write(stdout,*) 'DART report ... standard timestep.' + endif + + !******POPDART added by AK Sept 21,2012******************************* + !! added the ldata_assim flag that changes read_restart + call read_restart(init_ts_file,lccsm_branch,lccsm_hybrid, & + init_ts_file_fmt, errorCode, ldata_assim=ldata_assim) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_ts: error in read_restart') + return + endif + + ltavg_restart = .true. + +!----------------------------------------------------------------------- +! +! set initial state from restart file +! +!----------------------------------------------------------------------- + + case ('ccsm_branch') + first_step = .false. + lccsm_branch = .true. + lccsm_hybrid = .false. + if (my_task == master_task .and. .not. luse_pointer_files) then + write(stdout,'(a40,a)') & + 'Initial T,S is a ccsm branch starting from the restart file:', & + trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + !******POPDART added by AK Sept 11,2013******************************* + !! If ldata_assim is true then the two time slices of POP states have + !! been modified by restart.F90:DART_modify_restart() to be identical. + !! Therefore, we must force the first step after data assimilation to + !! be forward euler. This happens when first_step = .true. + + if (ldata_assim) then + first_step = .true. + if (my_task == master_task) & + write(stdout,*) 'DART modification ... forward euler timestep.' + else + if (my_task == master_task) & + write(stdout,*) 'DART report ... standard timestep.' + endif + + call read_restart(init_ts_file,lccsm_branch,lccsm_hybrid, & + init_ts_file_fmt, errorCode, ldata_assim=ldata_assim) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_ts: error in read_restart') + return + endif + + ltavg_restart = .false. + + case ('ccsm_hybrid', 'branch') ! ccsm hybrid start or LANL branch start + first_step = .false. + lccsm_branch = .false. + lccsm_hybrid = .true. + if (my_task == master_task .and. .not. luse_pointer_files) then + write(stdout,'(a80,a)') & + 'Initial T,S ccsm_hybrid start from restart file:', & + trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + !******POPDART added by AK Sept 11,2013******************************* + !! If ldata_assim is true then the two time slices of POP states have + !! been modified by restart.F90:DART_modify_restart() to be identical. + !! Therefore, we must force the first step after data assimilation to + !! be forward euler. This happens when first_step = .true. + + if (ldata_assim) then + first_step = .true. + if (my_task == master_task) & + write(stdout,*) 'DART modification ... forward euler timestep.' + else + if (my_task == master_task) & + write(stdout,*) 'DART report ... standard timestep.' + endif + + call read_restart(init_ts_file,lccsm_branch,lccsm_hybrid, & + init_ts_file_fmt, errorCode, ldata_assim=ldata_assim) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_ts: error in read_restart') + return + endif + + ltavg_restart = .false. + + case ('ccsm_startup_spunup') + if(my_task == master_task ) then + write(stdout,*) ' ccsm_startup_spunup option' + write(stdout,*) ' init_ts_option = ', init_ts_option + endif + first_step = .false. + lccsm_branch = .false. + lccsm_hybrid = .true. + if (my_task == master_task .and. .not. luse_pointer_files) then + write(stdout,'(a80,a)') & + 'Initial T,S ccsm_startup run from spun-up restart file:', & + trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + call read_restart(init_ts_file,lccsm_branch,lccsm_hybrid, & + init_ts_file_fmt, errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_ts: error in read_restart') + return + endif + + ltavg_restart = .false. + !*** turn pointer file-creation back on + luse_pointer_files = .true. + +!----------------------------------------------------------------------- +! +! read full 3-d t,s from input file +! +!----------------------------------------------------------------------- + + case ('ccsm_startup', 'file') + first_step = .true. + + if (my_task == master_task) then + write(stdout,'(a31,a)') 'Initial 3-d T,S read from file:', & + trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + allocate(TEMP_DATA(nx_block,ny_block,km,max_blocks_clinic)) + + in_file = construct_file(init_ts_file_fmt, & + full_name=trim(init_ts_file), & + record_length = rec_type_dbl, & + recl_words=nx_global*ny_global) + call data_set(in_file,'open_read') + + i_dim = construct_io_dim('i',nx_global) + j_dim = construct_io_dim('j',ny_global) + k_dim = construct_io_dim('k',km) + + io_temp = construct_io_field('TEMPERATURE', & + dim1=i_dim, dim2=j_dim, dim3=k_dim, & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d3d_array=TEMP_DATA) + io_salt = construct_io_field('SALINITY', & + dim1=i_dim, dim2=j_dim, dim3=k_dim, & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d3d_array=TEMP_DATA) + + call data_set(in_file,'define',io_temp) + call data_set(in_file,'define',io_salt) + + call data_set(in_file,'read' ,io_temp) + do iblock=1,nblocks_clinic + TRACER(:,:,:,1,curtime,iblock) = TEMP_DATA(:,:,:,iblock) + end do + call data_set(in_file,'read' ,io_salt) + do iblock=1,nblocks_clinic + TRACER(:,:,:,2,curtime,iblock) = TEMP_DATA(:,:,:,iblock) + end do + + call destroy_io_field(io_temp) + call destroy_io_field(io_salt) + + deallocate(TEMP_DATA) + + call data_set(in_file,'close') + call destroy_file(in_file) + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,'(a12,a)') ' file read: ', trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + +!#################### temporary kludge for overflows #################### +!----------------------------------------------------------------------- +! fill any overflow-deepened points with T,S values from above +!----------------------------------------------------------------------- + + + if (overflows_on) then + ! fill any overflow-deepened points with T,S values from above + ! fill entire TRACER array for ghost (or halo) points + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + do j=1,ny_block + do i=1,nx_block + do n=1,num_ovf + do m=1,ovf(n)%num_kmt + if( ovf(n)%loc_kmt(m)%i.eq.this_block%i_glob(i).and.& + ovf(n)%loc_kmt(m)%j.eq.this_block%j_glob(j) ) then + if(ovf(n)%loc_kmt(m)%knew .gt. ovf(n)%loc_kmt(m)%korg) then + do k=ovf(n)%loc_kmt(m)%korg+1,ovf(n)%loc_kmt(m)%knew + ! use T,S from level above with slight increase in S + TRACER(i,j,k,1,curtime,iblock) = & + TRACER(i,j,k-1,1,curtime,iblock) + TRACER(i,j,k,2,curtime,iblock) = & + TRACER(i,j,k-1,2,curtime,iblock) * 1.001 + write(stdout,100) ovf(n)%loc_kmt(m)%i, & + ovf(n)%loc_kmt(m)%j,ovf(n)%loc_kmt(m)%korg, & + k,ovf(n)%loc_kmt(m)%knew + 100 format(' init_ts: T,S extended from ijKMT = ', & + 3(i4,1x),' to k=',i3,' until KMT_new=',i3) + enddo + endif + endif + end do + end do + enddo + enddo + enddo + endif + + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) +!################ end temporary kludge for overflows #################### + + + !$OMP PARALLEL DO PRIVATE(iblock, k, n) + do iblock = 1,nblocks_clinic + do n=1,nt + do k=1,km + where (k > KMT(:,:,iblock)) & + TRACER(:,:,k,n,curtime,iblock) = c0 + end do + end do + + !*** convert salinity to model units + TRACER(:,:,:,2,curtime,iblock) = & + TRACER(:,:,:,2,curtime,iblock)*ppt_to_salt + end do + !$OMP END PARALLEL DO + + if (n_topo_smooth > 0) then + do k=1,km + call fill_points(k,TRACER(:,:,k,1,curtime,:),errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_ts: error in fill_points for temp') + return + endif + + call fill_points(k,TRACER(:,:,k,2,curtime,:),errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_ts: error in fill_points for salt') + return + endif + + enddo + endif + + do iblock=1,nblocks_clinic + TRACER(:,:,:,:,newtime,iblock) = TRACER(:,:,:,:,curtime,iblock) + TRACER(:,:,:,:,oldtime,iblock) = TRACER(:,:,:,:,curtime,iblock) + end do + +!----------------------------------------------------------------------- +! +! set up t,s from input mean state as function of depth +! +!----------------------------------------------------------------------- + + case ('mean') + first_step = .true. + + !*** + !*** open input file and read t,s profile + !*** + + call get_unit(nu) + if (my_task == master_task) then + write(stdout,'(a40,a)') & + 'Initial mean T,S profile read from file:', & + trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + open(nu, file=init_ts_file, status='old') + do k = 1,km + read(nu,*) tinit(k),sinit(k) + enddo + close (nu) + endif + call release_unit(nu) + + call broadcast_array(tinit, master_task) + call broadcast_array(sinit, master_task) + + !*** + !*** fill tracer array with appropriate values + !*** + + !$OMP PARALLEL DO PRIVATE(iblock, k) + do iblock = 1,nblocks_clinic + do k=1,km + where (k <= KMT(:,:,iblock)) + TRACER(:,:,k,1,curtime,iblock) = tinit(k) + TRACER(:,:,k,2,curtime,iblock) = sinit(k)*ppt_to_salt + endwhere + enddo + + TRACER(:,:,:,:,newtime,iblock)=TRACER(:,:,:,:,curtime,iblock) + TRACER(:,:,:,:,oldtime,iblock)=TRACER(:,:,:,:,curtime,iblock) + end do + !$OMP END PARALLEL DO + +!----------------------------------------------------------------------- +! +! set up initial profile from 1992 Levitus mean ocean data +! +!----------------------------------------------------------------------- + + case ('internal') + first_step = .true. + if (my_task == master_task) then + write(stdout,'(a63)') & + 'Initial T,S profile computed internally from 1992 Levitus data' + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + !$OMP PARALLEL DO PRIVATE(iblock, k, kk, & + !$OMP dpth_meters, sinterp, tinit, sinit) + + do iblock = 1,nblocks_clinic + do k=1,km + + dpth_meters = zt(k)*mpercm + + intrp_loop: do kk=1,32 + if (dpth_meters >= depth_levitus(kk) .and. & + dpth_meters < depth_levitus(kk+1)) exit intrp_loop + end do intrp_loop + + sinterp = (dpth_meters - depth_levitus(kk))/ & + (depth_levitus(kk+1) - depth_levitus(kk)) + + tinit(k) = (c1 - sinterp)*tmean_levitus(kk) + & + sinterp *tmean_levitus(kk+1) + sinit(k) = (c1 - sinterp)*smean_levitus(kk) + & + sinterp *smean_levitus(kk+1) + + where (k <= KMT(:,:,iblock)) + TRACER(:,:,k,1,curtime,iblock) = tinit(k) + TRACER(:,:,k,2,curtime,iblock) = sinit(k)*ppt_to_salt + endwhere + + enddo + + TRACER(:,:,:,:,newtime,iblock)=TRACER(:,:,:,:,curtime,iblock) + TRACER(:,:,:,:,oldtime,iblock)=TRACER(:,:,:,:,curtime,iblock) + enddo + !$OMP END PARALLEL DO + +!----------------------------------------------------------------------- +! +! remap PHC Levitus data to POP grid +! +!----------------------------------------------------------------------- + +#ifdef CCSMCOUPLED + case ('PHC') + first_step = .true. + + if (my_task == master_task) then + write(stdout,'(a63)') & + 'Initial T,S profile generated by 3D remapping of filled Levitus-PHC data' + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + + write(stdout,*) ' init_ts_option = PHC' + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + + allocate (TLON_G(nx_global,ny_global),TLAT_G(nx_global,ny_global)) + call gather_global(TLON_G, TLON, master_task,distrb_clinic) + call gather_global(TLAT_G, TLAT, master_task,distrb_clinic) + + if (my_task == master_task) then + + call shr_ncread_varDimSizes(trim(init_ts_file),'TEMP',PHCnx,PHCny,PHCnz) + + allocate(MOD_T(nx_global,ny_global),MOD_S(nx_global,ny_global)) + allocate(PHC_kmod_T(PHCnx,PHCny),PHC_kmod_S(PHCnx,PHCny)) + allocate(PHC_ktop(PHCnx,PHCny,1,1),PHC_kbot(PHCnx,PHCny,1,1)) + allocate(tmpkt(PHCnx,PHCny),tmpkb(PHCnx,PHCny)) + allocate(PHC_x(PHCnx,PHCny),PHC_y(PHCnx,PHCny),PHC_msk(PHCnx,PHCny)) + allocate(tmp1(PHCnx),tmp2(PHCny),PHC_z(PHCnz)) + allocate (MASK_G(nx_global,ny_global)) + allocate(dataSrc(2,PHCnx*PHCny)) + allocate(dataDst(2,nx_global*ny_global)) + + PHC_msk(:,:) = 1 + MASK_G(:,:) = 1 + + call shr_ncread_tField(trim(init_ts_file),1,'lon',tmp1) + call shr_ncread_tField(trim(init_ts_file),1,'lat',tmp2) + call shr_ncread_tField(trim(init_ts_file),1,'depth',PHC_z) + + do j=1,PHCny + PHC_x(:,j) = tmp1/radian + enddo + do i=1,PHCnx + PHC_y(i,:) = tmp2/radian + enddo + + call shr_map_mapSet(PHC_map, PHC_x, PHC_y, PHC_msk, & + & TLON_G, TLAT_G, MASK_G, & + & name='phc_map',type='remap',algo='bilinear', & + & mask='dstmask',vect='scalar') + + !------------------------------------------------- + ! copy input data to arrays ordered for mapping + !------------------------------------------------- + + endif + + do k=1,km + if (my_task == master_task) then + dpth_meters = zt(k)*mpercm + + PHC_z_loop: do kk=1,PHCnz-1 + if (dpth_meters >= PHC_z(kk) .and. & + dpth_meters < PHC_z(kk+1)) exit PHC_z_loop + end do PHC_z_loop + + sinterp = (dpth_meters - depth_levitus(kk))/ & + (depth_levitus(kk+1) - depth_levitus(kk)) + + !------------------------------------------------- + ! do vertical remap of T + !------------------------------------------------- + call shr_ncread_field4dG(trim(init_ts_file),'TEMP', & + rfld=PHC_ktop, dim3='depth',dim3i=kk) + call shr_ncread_field4dG(trim(init_ts_file),'TEMP', & + rfld=PHC_kbot, dim3='depth',dim3i=kk+1) + tmpkt = reshape(PHC_ktop,(/PHCnx,PHCny/)) + tmpkb = reshape(PHC_kbot,(/PHCnx,PHCny/)) + PHC_kmod_T(:,:) = (c1 - sinterp)*tmpkt(:,:) + & + sinterp *tmpkb(:,:) + + !------------------------------------------------- + ! do vertical remap of S + !------------------------------------------------- + call shr_ncread_field4dG(trim(init_ts_file),'SALT', & + rfld=PHC_ktop, dim3='depth',dim3i=kk) + call shr_ncread_field4dG(trim(init_ts_file),'SALT', & + rfld=PHC_kbot, dim3='depth',dim3i=kk+1) + tmpkt = reshape(PHC_ktop,(/PHCnx,PHCny/)) + tmpkb = reshape(PHC_kbot,(/PHCnx,PHCny/)) + + PHC_kmod_S(:,:) = (c1 - sinterp)*tmpkt(:,:) + & + sinterp *tmpkb(:,:) + + !------------------------------------------------- + ! do horizontal remap of T & S + !------------------------------------------------- + icnt = 0 + do j=1,PHCny + do i=1,PHCnx + icnt = icnt + 1 + dataSrc(1,icnt) = PHC_kmod_T(i,j) + dataSrc(2,icnt) = PHC_kmod_S(i,j) + enddo + enddo + + call shr_map_mapData(dataSrc, dataDst, PHC_map) + + icnt = 0 + do j=1,ny_global + do i=1,nx_global + icnt = icnt + 1 + MOD_T(i,j) = dataDst(1,icnt) + MOD_S(i,j) = dataDst(2,icnt) + enddo + enddo + + endif + + call scatter_global(TRACER(:,:,k,1,curtime,:), MOD_T, & + master_task, distrb_clinic, field_loc_center, field_type_scalar) + call scatter_global(TRACER(:,:,k,2,curtime,:), MOD_S, & + master_task, distrb_clinic, field_loc_center, field_type_scalar) + + enddo + + deallocate(TLON_G,TLAT_G) + if (my_task == master_task) then + deallocate(MOD_T, MOD_S) + deallocate(PHC_kmod_T,PHC_kmod_S) + deallocate(PHC_ktop,PHC_kbot) + deallocate(tmpkt,tmpkb,PHC_z) + deallocate(PHC_x, PHC_y, PHC_msk, tmp1, tmp2) + deallocate(MASK_G, dataSrc, dataDst) + endif + + !$OMP PARALLEL DO PRIVATE(iblock, k, n) + do iblock = 1,nblocks_clinic + do n=1,nt + do k=1,km + where (k > KMT(:,:,iblock)) & + TRACER(:,:,k,n,curtime,iblock) = c0 + end do + end do + + !*** convert salinity to model units + TRACER(:,:,:,2,curtime,iblock) = & + TRACER(:,:,:,2,curtime,iblock)*ppt_to_salt + end do + !$OMP END PARALLEL DO + + do iblock=1,nblocks_clinic + TRACER(:,:,:,:,newtime,iblock) = TRACER(:,:,:,:,curtime,iblock) + TRACER(:,:,:,:,oldtime,iblock) = TRACER(:,:,:,:,curtime,iblock) + end do + + if (trim(init_ts_outfile) /= 'unknown_init_ts_outfile') then + if (my_task == master_task) then + write(stdout,*) 'remapped initial T & S written to',trim(init_ts_outfile) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + call write_init_ts(trim(init_ts_outfile),trim(init_ts_outfile_fmt)) + endif + +#endif +!----------------------------------------------------------------------- +! +! bad initialization option +! +!----------------------------------------------------------------------- + + case default + call exit_POP(sigAbort,'Unknown t,s initialization option') + end select + +!----------------------------------------------------------------------- +! +! check for appropriate initialization when overflows on and interactive +! +!----------------------------------------------------------------------- + + select case (init_ts_option) + case ('mean', 'internal', 'PHC') + if( overflows_on .and. overflows_interactive ) then + write(stdout,*) & + 'init_ts: ERROR initializing for interactive overflows' + write(stdout,*) & + 'initialization must be either ccsm_startup or file' + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + call exit_POP(sigAbort,'ERROR wrong initialization with overflows') + endif + end select + + +!----------------------------------------------------------------------- +! +! calculate RHO from TRACER at time levels curtime and oldtime +! +!----------------------------------------------------------------------- + + !$OMP PARALLEL DO PRIVATE(iblock, k, this_block) + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + + do k=1,km + call state(k,k,TRACER(:,:,k,1,curtime,iblock), & + TRACER(:,:,k,2,curtime,iblock), & + this_block, & + RHOOUT=RHO(:,:,k,curtime,iblock)) + call state(k,k,TRACER(:,:,k,1,oldtime,iblock), & + TRACER(:,:,k,2,oldtime,iblock), & + this_block, & + RHOOUT=RHO(:,:,k,oldtime,iblock)) + enddo + + enddo ! block loop + !$OMP END PARALLEL DO + +!----------------------------------------------------------------------- +! +! register init_ts +! +!----------------------------------------------------------------------- + call register_string('init_ts') + + call flushm (stdout) +!----------------------------------------------------------------------- +!EOC + + + end subroutine init_ts + +!*********************************************************************** +!BOP +! !IROUTINE: document_constants +! !INTERFACE: + + subroutine document_constants + +! !DESCRIPTION: +! This routine writes the values of POP model constants to the output log file + +! !REVISION HISTORY: +! same as module + +!EOP +!BOC + + if (my_task == master_task) then + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,*) ' Constants used in this run:' + write(stdout,blank_fmt) + + write(stdout,1020) 'grav', grav, 'cm/s^2' + write(stdout,1020) 'omega', omega, 'rad/s' + write(stdout,1020) 'radius', radius, 'cm' + write(stdout,1020) 'cp_sw', cp_sw, 'erg/g/K' + write(stdout,1020) 'cp_air', cp_air, 'J/kg/K' + write(stdout,1020) 'rho_air', rho_air, 'kg/m^3' + write(stdout,1020) 'rho_sw', rho_sw, 'g/cm^3' + write(stdout,1020) 'rho_fw', rho_fw, 'g/cm^3' + write(stdout,1020) 'sound', sound, 'cm/s' + write(stdout,1020) 'vonkar', vonkar, ' ' + write(stdout,1020) 'emissivity',emissivity, ' ' + write(stdout,1020) 'stefan_boltzmann', stefan_boltzmann, & + 'W/m^2/K^4' + write(stdout,1020) 'latent_heat_vapor_mks',latent_heat_vapor_mks, & + 'J/kg' + write(stdout,1020) 'latent_heat_fusion',latent_heat_fusion, & + 'erg/g' + write(stdout,1020) 'ocn_ref_salinity', ocn_ref_salinity, 'psu' + write(stdout,1020) 'sea_ice_salinity', sea_ice_salinity, 'psu' + write(stdout,1020) 'T0_Kelvin', T0_Kelvin, 'K' + write(stdout,1020) 'pi', pi, ' ' + + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + + endif + +1020 format (5x, a20, ' = ', 1pe25.15, 2x, a) + +!----------------------------------------------------------------------- +!EOC + + end subroutine document_constants + + +!*********************************************************************** +!BOP +! !IROUTINE: POP_check +! !INTERFACE: + + subroutine POP_check + +! !DESCRIPTION: +! This routine tests for consistency between model options, usually involving +! two or more modules, then writes warning and error messages to the output log file. +! If one or more error conditions are detected, the pop model will be shut down +! after all warning and error messages are printed. + +! !REVISION HISTORY: +! same as module + + +!EOP +!BOC + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character (char_len) :: & + string ! temporary string + + integer (int_kind) :: & + number_of_fatal_errors, &! counter for fatal error conditions + number_of_warnings, &! counter for warning messages + n, &! loop index + ns, &! streams loop index + temp_tavg_id, &! temporary tavg_id holder + coupled_flag ! flag for coupled_ts + + logical (log_kind) :: & + test_condition, &! logical test condition + lref_val, &! are any tracers specifying a non-zero ref_val + ISOP_test, &! temporary logical associated with ISOP + ISOP_on ! are any ISOP tavg fields selected? + + character (char_len), dimension(7) :: &! var names for diag_gm_bolus test + strings = (/'UISOP ' , 'VISOP ' , & + 'WISOP ' , & + 'ADVT_ISOP' , 'ADVS_ISOP' , & + 'VNT_ISOP ' , 'VNS_ISOP ' /) + + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,*)' POP_check: Check for Option Inconsistencies' + write(stdout,blank_fmt) + endif + + + !====================! + ! warning conditions ! + !====================! + + number_of_warnings = 0 + +!----------------------------------------------------------------------- +! +! 'varthick' and dtuxcel /= dttxcel(1) +! +!----------------------------------------------------------------------- + + if (my_task == master_task) then + if (sfc_layer_type == sfc_layer_varthick .and. & + dtuxcel /= dttxcel(1) ) then + exit_string = 'WARNING: Surface tracer and momentum timesteps are unequal; ' /& + &/'may cause instability when using variable-thickness surface layer.' + call document ('POP_check', exit_string) + number_of_warnings = number_of_warnings + 1 + endif + endif + +!----------------------------------------------------------------------- +! +! bulk-NCEP and marginal-seas balancing +! +!----------------------------------------------------------------------- + + if (my_task == master_task) then + if (sfwf_formulation == 'bulk-NCEP' .and. lms_balance) then + exit_string = 'WARNING: runoff and marginal seas balancing cannot ' /& + &/ 'be used with the bulk-NCEP option' + call document ('POP_check', exit_string) + number_of_warnings = number_of_warnings + 1 + endif + endif + +!----------------------------------------------------------------------- +! +! are time-averaging and coupling frequencies compatible? +! +!----------------------------------------------------------------------- + + coupled_flag = get_time_flag_id('coupled_ts') + + if (my_task == master_task) then + do ns=1,n_tavg_streams + if (check_time_flag_int(tavg_streams(ns)%field_flag, freq_opt=.true.) > 0 .and. & + check_time_flag_int(coupled_flag,freq_opt=.true.) > 0) then + + if (check_time_flag_int(tavg_streams(ns)%field_flag, freq_opt=.true.) /= & + check_time_flag_int(coupled_flag,freq_opt=.true.)) then + exit_string = 'WARNING: time-averaging and coupling frequency ' /& + &/ 'may be incompatible; tavg must be integer multiple of coupling freq' + call document ('POP_check', exit_string) + number_of_warnings = number_of_warnings + 1 + else + if ( mod(check_time_flag_int(tavg_streams(ns)%field_flag, freq=.true.), & + check_time_flag_int(coupled_flag,freq=.true.)) .ne. 0) then + exit_string = 'WARNING: time-averaging frequency is incompatible with ' /& + &/ ' the coupling frequency' + call document ('POP_check', exit_string) + number_of_warnings = number_of_warnings + 1 + endif + endif + endif + enddo ! ns + endif + + +!----------------------------------------------------------------------- +! +! Wrap up warning section with message +! +!----------------------------------------------------------------------- + + call broadcast_scalar(number_of_warnings, master_task) + + if (number_of_warnings == 0 ) then + if (my_task == master_task) then + exit_string = 'No warning messages generated' + call document ('POP_check', exit_string) + endif + endif + + + !========================! + ! fatal error conditions ! + !========================! + + + number_of_fatal_errors = 0 + +!----------------------------------------------------------------------- +! +! tidal mixing without KPP mixing +! +!----------------------------------------------------------------------- + + if (check_all(ltidal_mixing .and. vmix_itype /= vmix_type_kpp)) then + exit_string = & + 'FATAL ERROR: Tidally driven mixing is only allowed when KPP mixing is enabled' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! tidal mixing without bckgrnd_vdc2 = 0.0 +! +!----------------------------------------------------------------------- + + if (check_all(ltidal_mixing .and. bckgrnd_vdc2 /= c0)) then + exit_string = & + 'FATAL ERROR: bckgrnd_vdc2 must be zero when tidal_mixing option is enabled' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! diag_gm_bolus = .true., but ISOP variables not activated in tavg_contents file +! +!----------------------------------------------------------------------- + + if (registry_match('diag_gm_bolus') .and. my_task == master_task) then + ISOP_on = .true. + exit_string = 'FATAL ERROR: ' + + do n=1,7 + ISOP_test = .false. + string = trim(strings(n)) + ISOP_test = set_in_tavg_contents (tavg_id(trim(string),quiet=.true.)) + if (.not. ISOP_test) then + exit_string = trim(exit_string) // ' ' // trim(string) + ISOP_on = .false. + endif + enddo + + if (.not. ISOP_on) then + exit_string = trim(exit_string) /& + &/' must be activated in tavg_contents file when diag_gm_bolus = .T.' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + endif ! diag_gm_bolus + +!----------------------------------------------------------------------- +! +! luse_cpl_ifrac is true, but OCN_WGT is not allocated +! +!----------------------------------------------------------------------- + + if (check_all(luse_cpl_ifrac .and. .not. allocated(OCN_WGT))) then + exit_string = & + 'FATAL ERROR: cannot set luse_cpl_ifrac .true. without allocating OCN_WGT' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! ecosystem requests diurnal cycle, but base model is not using it +! +!----------------------------------------------------------------------- + + if (ecosys_on) then + + if ((.not. ecosys_qsw_distrb_const) .and. & + (qsw_distrb_iopt == qsw_distrb_iopt_const)) then + exit_string = & + 'FATAL ERROR: cannot set ecosys_qsw_distrb_const=.false. unless qsw_distrb_opt/=const' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + + endif + +!----------------------------------------------------------------------- +! +! untested forcing_coupled option +! +!----------------------------------------------------------------------- + + if (sfc_layer_type == sfc_layer_varthick .and. .not. lfw_as_salt_flx) then + exit_string = 'FATAL ERROR: untested/unsupported combination of options' + exit_string = trim(exit_string) /& + &/' (sfc_layer_type == sfc_layer_varthick .and. .not. lfw_as_salt_flx)' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! inertial mixing on +! +!----------------------------------------------------------------------- + + if (linertial) then + exit_string = 'FATAL ERROR: inertial mixing option. ' + exit_string = trim(exit_string) /& + &/' This option is untested. DO NOT USE!' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! inertial mixing inconsistencies +! +!----------------------------------------------------------------------- + + if (linertial .and. (.not. registry_match('diag_gm_bolus') .or. partial_bottom_cells)) then + exit_string = 'FATAL ERROR: inertial mixing option inconsistency. ' + exit_string = trim(exit_string) /& + &/' diag_gm_bolus must be on and partial_bottom_cells must not be on' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! overflow check: if overflow active, horiz_grid_opt must be 'file' +! +!----------------------------------------------------------------------- + + if ( overflows_on ) then + if ( overflows_interactive .and. .not. registry_match('topography_opt_file') ) then + exit_string = 'FATAL ERROR: interactive overflows without topography option = file' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + endif + +!----------------------------------------------------------------------- +! +! overflow check: if overflow active, must set state_range_iopt = state_range_enforce +! and state_itype = state_type_mwjf for consistency +! +!----------------------------------------------------------------------- + + if ( overflows_on ) then + if ( .not. (state_range_iopt == state_range_enforce .and. state_itype == state_type_mwjf) ) then + exit_string = 'FATAL ERROR: if overflows are active, must have state_range_opt = enforce '/& + &/' and state_choice = mwjf for consistency. You can uncomment this and procede at your own risk.' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + endif + +!----------------------------------------------------------------------- +! +! near-inertial wave mixing without KPP mixing +! +!----------------------------------------------------------------------- + + if (check_all(lniw_mixing .and. vmix_itype /= vmix_type_kpp)) then + exit_string = & + 'FATAL ERROR: Near-inertial wave mixing is only allowed when KPP mixing is enabled' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! near-inertial wave mixing and not 2-hour coupling +! +!----------------------------------------------------------------------- + + test_condition = (coupled_freq_iopt == freq_opt_nhour .and. ncouple_per_day == 12) + if (check_all(lniw_mixing .and. .not. test_condition) ) then + call document ('POP_check', 'coupled_freq_iopt ', coupled_freq_iopt ) + call document ('POP_check', 'freq_opt_nhour ', freq_opt_nhour ) + call document ('POP_check', 'ncouple_per_day ', ncouple_per_day ) + call document ('POP_check', '(coupled_freq_iopt == freq_opt_nhour .and. ncouple_per_day == 2) ', & + (coupled_freq_iopt == freq_opt_nhour .and. ncouple_per_day == 2) ) + exit_string = & + 'FATAL ERROR: Near-inertial wave mixing is only allowed when coupling every two hours' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! Now that error messages have been written, stop if there are fatal errors +! +!----------------------------------------------------------------------- + + call broadcast_scalar(number_of_fatal_errors, master_task) + + if (number_of_fatal_errors > 0 ) then + call exit_POP (sigAbort, & + 'correct the error condition(s) listed above before continuing') + else + if (my_task == master_task) then + exit_string = 'No fatal error conditions detected' + call document ('POP_check', exit_string) + endif + endif + + +!----------------------------------------------------------------------- +!EOC + + end subroutine POP_check + + +!*********************************************************************** +!BOP +! !IROUTINE: write_init_ts +! !INTERFACE: + + subroutine write_init_ts(outfile, outfile_fmt) + +! !DESCRIPTION: +! This routine writes out initial TEMP and SALT mapped to +! POP grid for topography_opt='bathymetry' +! +! !REVISION HISTORY: +! same as module + +! !INPUT PARAMETERS: + + character (*), intent(in) :: & + outfile, &! input file name (with path) + outfile_fmt ! input file format (bin or nc) + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + type (datafile) :: & + ts_file ! io file type for viscosity file + + type (io_field_desc) :: & + TEMP_d, SALT_d ! descriptors for temp and salt fields + + type (io_dim) :: & + i_dim, j_dim, &! dimension descriptors for horiz dims + k_dim ! dimension descriptor for vertical levels + +!----------------------------------------------------------------------- +! +! construct io file type and open for writing +! +!----------------------------------------------------------------------- + + ts_file = construct_file(outfile_fmt, root_name=outfile, & + record_length=rec_type_dbl, & + recl_words=nx_global*ny_global) + + call data_set(ts_file, 'open') + +!----------------------------------------------------------------------- +! +! define variables to be written +! +!----------------------------------------------------------------------- + + !*** define dimensions + + i_dim = construct_io_dim('i', nx_global) + j_dim = construct_io_dim('j', ny_global) + k_dim = construct_io_dim('k', km) + + TEMP_d = construct_io_field('TEMP', dim1=i_dim, dim2=j_dim, dim3=k_dim, & + long_name='Potential Temperature', & + units ='degC', & + grid_loc ='3111', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d3d_array = TRACER(:,:,:,1,curtime,:)) + + SALT_d = construct_io_field('SALT', dim1=i_dim, dim2=j_dim, dim3=k_dim, & + long_name='Salinity', & + units ='gram/kilogram', & + grid_loc ='3111', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d3d_array = TRACER(:,:,:,2,curtime,:)) + + call data_set (ts_file, 'define', TEMP_d) + call data_set (ts_file, 'define', SALT_d) + +!----------------------------------------------------------------------- +! +! write arrays then clean up +! +!----------------------------------------------------------------------- + + call data_set (ts_file, 'write', TEMP_d) + call data_set (ts_file, 'write', SALT_d) + + call destroy_io_field (TEMP_d) + call destroy_io_field (SALT_d) + + call data_set (ts_file, 'close') + call destroy_file(ts_file) + +!----------------------------------------------------------------------- +!EOC + + end subroutine write_init_ts + + +!*********************************************************************** +!BOP +! !IROUTINE: check_all +! !INTERFACE: + + function check_all(condition) + +! !DESCRIPTION: +! Tests input logical condition on all processors; if any element is +! .true., check_all is set to .true. +! +! +! !REVISION HISTORY: +! same as module + +! !INPUT PARAMETERS: + + logical (log_kind), intent(in) :: & + condition ! logical condition to be checked + +! !OUTPUT PARAMETERS: + + logical (log_kind) :: & + check_all ! true if condition is true on any processor + + +!EOP +!BOC + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + int_condition ! integer form of logical input condition + + + if (condition) then + int_condition = 1 + else + int_condition = 0 + endif + + check_all = (global_sum(int_condition,distrb_clinic) > 0) + +!----------------------------------------------------------------------- +!EOC + + end function check_all + +!*********************************************************************** + + end module initial + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/io_netcdf.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/io_netcdf.F90 new file mode 100644 index 0000000000..0d18551874 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/io_netcdf.F90 @@ -0,0 +1,2247 @@ +! DART note: this file started life as: +! /glade/p/cesmdata/cseg/collections/cesm1_1_1/models/ocn/pop2/source/io_netcdf.F90 + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + + module io_netcdf + +!BOP +! !MODULE: io_netcdf +! !DESCRIPTION: +! This module provides a generic input/output interface +! for writing arrays in netCDF format using pio. +! +! !REVISION HISTORY: +! SVN:$Id: io_netcdf.F90 45958 2013-04-12 23:10:42Z mlevy@ucar.edu $ + +! !USES: + + use POP_KindsMod + use POP_IOUnitsMod + use POP_ErrorMod + use kinds_mod + use domain_size + use domain + use constants + use communicate + use broadcast + use gather_scatter + use exit_mod + use io_types + use io_tools + use io_pio + use pio + use shr_sys_mod + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + + public :: open_read_netcdf, & + open_netcdf, & + close_netcdf, & + sync_netcdf, & + define_field_netcdf, & + read_field_netcdf, & + write_field_netcdf, & + define_nstd_netcdf, & + write_nstd_netcdf, & + write_time_bounds + +!EOP +!BOC + +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- + +!EOC +!*********************************************************************** + + contains + +!*********************************************************************** +!BOP +! !IROUTINE: open_read_netcdf +! !INTERFACE: + + subroutine open_read_netcdf(data_file) + +! !INPUT/OUTPUT PARAMETERS: + + type (datafile), target, intent (inout) :: data_file + +! !DESCRIPTION: +! This routine opens a netcdf data file and extracts global file +! attributes. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + + character (char_len) :: & + path ! filename to read + + character (80) :: & + work_line, &! temporary to use for parsing file lines + att_name ! temporary to use for attribute names + + + integer (i4) :: & + iostat, &! status flag + nsize, &! size parameter returned by inquire function + n, &! loop index + itype, &! netCDF data type + att_ival, &! netCDF data type + num_atts, &! number of global attributes + xtype + + logical (log_kind) :: & + att_lval ! temp space for logical attribute + + real (r4) :: & + att_rval ! temp space for real attribute + + real (r8) :: & + att_dval ! temp space for double attribute + + logical (log_kind) :: & + attrib_error ! error flag for reading attributes + +!----------------------------------------------------------------------- +! +! set the readonly flag in the data file descriptor +! +!----------------------------------------------------------------------- + + data_file%readonly = .true. + +!----------------------------------------------------------------------- +! +! open the netCDF file +! +!----------------------------------------------------------------------- + + path = trim(data_file%full_name) + + call io_pio_init('read', path, data_file%File) + +!----------------------------------------------------------------------- +! +! determine number of global file attributes +! +!----------------------------------------------------------------------- + + iostat = pio_inquire(data_file%File, nAttributes = num_atts) + +!----------------------------------------------------------------------- +! +! now read each attribute and set attribute values +! +!----------------------------------------------------------------------- + + do n=1,num_atts + + !*** + !*** get attribute name + !*** + + att_name = char_blank + iostat = pio_inq_attname(data_file%File, PIO_GLOBAL, n, att_name) + !*** + !*** check to see if name matches any of the standard file + !*** attributes + !*** + + select case(trim(att_name)) + + case('title') + + data_file%title = char_blank + + iostat = pio_inq_att(data_file%File, PIO_GLOBAL, 'title', & + xtype, nsize) + + if (iostat == pio_noerr) then + if (nsize <= len(data_file%title)) then + iostat = pio_get_att(data_file%File, PIO_GLOBAL, 'title', & + data_file%title(1:nsize)) + else + if (my_task == master_task) then + call document('open_read_netcdf', 'nsize', nsize) + call document('open_read_netcdf', 'len(data_file%title)', & + len(data_file%title)) + write(stdout,*) 'string too short; not enough room to read title from ' /& + &/ trim(path) + endif + endif + endif + + case('history') + + data_file%history = char_blank + iostat = pio_inq_attlen(data_file%File, PIO_GLOBAL, 'history', nsize) + + if (iostat == pio_noerr) then + if (nsize <= len(data_file%history)) then + iostat = pio_get_att(data_file%File, PIO_GLOBAL, 'history', & + data_file%history(1:nsize)) + else + if (my_task == master_task) then + call document('open_read_netcdf', 'nsize', nsize) + call document('open_read_netcdf', 'len(data_file%history)', & + len(data_file%history)) + write(stdout,*) 'string too short; not enough room to read history attribute from ' /& + &/ trim(path) + endif + endif + endif + + case('conventions','Conventions','CONVENTIONS') + + data_file%conventions = char_blank + iostat = pio_inq_att(data_file%File, PIO_GLOBAL, trim(att_name), & + xtype, nsize) + if (iostat == pio_noerr) then + if (nsize <= len(data_file%conventions)) then + iostat = pio_get_att(data_file%File, PIO_GLOBAL, trim(att_name), & + data_file%conventions(1:nsize)) + else + if (my_task == master_task) then + call document('open_read_netcdf', 'nsize', nsize) + call document('open_read_netcdf', 'len(data_file%conventions)', & + len(data_file%conventions)) + write(stdout,*) 'string too short; not enough room to read conventions from ' /& + &/ trim(path) + endif + endif + endif + + case default + + !*** + !*** if does not match any of the standard file attributes + !*** add the attribute to the datafile + !*** + + iostat = pio_inq_att(data_file%File, PIO_GLOBAL, trim(att_name), & + itype, nsize) + + select case (itype) + + case (PIO_CHAR) + work_line = char_blank + if (nsize <= len(work_line)) then + iostat = pio_get_att(data_file%File, PIO_GLOBAL, trim(att_name), & + work_line(1:nsize)) + else + if (my_task == master_task) then + call document('open_read_netcdf', 'nsize', nsize) + call document('open_read_netcdf', 'len(work_line)', & + len(work_line)) + write(stdout,*) 'string too short; not enough room to read ' /& + &/ trim(att_name) /& + &/ ' from ' /& + &/ trim(path) + endif + endif + call add_attrib_file(data_file, trim(att_name), trim(work_line)) + + case (PIO_INT) + iostat = pio_get_att(data_file%File, PIO_GLOBAL, trim(att_name), & + att_ival) + + if (att_name(1:4) == 'LOG_') then !*** attribute logical + work_line = att_name + work_line(1:4) = ' ' + att_name = adjustl(work_line) + + if (att_ival == 1) then + att_lval = .true. + else + att_lval = .false. + endif + call add_attrib_file(data_file, trim(att_name), att_lval) + else + call add_attrib_file(data_file, trim(att_name), att_ival) + endif + + case (PIO_REAL) + iostat = pio_get_att(data_file%File, PIO_GLOBAL, trim(att_name), & + att_rval) + call add_attrib_file(data_file, trim(att_name), att_rval) + + case (PIO_DOUBLE) + iostat = pio_get_att(data_file%File, PIO_GLOBAL, trim(att_name), & + att_dval) + call add_attrib_file(data_file, trim(att_name), att_dval) + + end select + + end select + + end do ! num_atts + +!----------------------------------------------------------------------- +!EOC + + end subroutine open_read_netcdf + +!*********************************************************************** +!BOP +! !IROUTINE: open_netcdf +! !INTERFACE: + + subroutine open_netcdf(data_file) + +! !INPUT/OUTPUT PARAMETERS: + + type (datafile), target, intent (inout) :: data_file + +! !DESCRIPTION: +! This routine opens a data file for writing and +! writes global file attributes. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character (char_len) :: & + path ! temp to use for filename + + character (255) :: & + work_line ! temp to use for character manipulation + + integer (i4) :: & + iostat, &! status flag for netCDF function calls + itmp, &! integer temp for equivalent logical attribute + n, &! loop index + ncvals, &! counter for number of character attributes + nlvals, &! counter for number of logical attributes + nivals, &! counter for number of integer attributes + nrvals, &! counter for number of real attributes + ndvals ! counter for number of double attributes + + logical (log_kind) :: & + attrib_error ! error flag for reading attributes + +!----------------------------------------------------------------------- +! +! open the netCDF file +! +!----------------------------------------------------------------------- + + path = trim(data_file%full_name) + + call io_pio_init(mode='write', filename=path, File=data_file%File, & + clobber=.true., cdf64=luse_nf_64bit_offset) + + data_file%ldefine = .true. ! file in netCDF define mode + +!----------------------------------------------------------------------- +! +! define global file attributes +! +!----------------------------------------------------------------------- + + attrib_error = .false. + + !*** standard attributes + + + iostat = pio_put_att(data_file%File, PIO_GLOBAL, 'title', & + trim(data_file%title)) + + iostat = pio_put_att(data_file%File, PIO_GLOBAL, 'history', & + trim(data_file%history)) + + iostat = pio_put_att(data_file%File, PIO_GLOBAL, 'Conventions', & + trim(data_file%conventions)) + + !*** additional attributes + + if (associated(data_file%add_attrib_cval)) then + ncvals = size(data_file%add_attrib_cval) + else + ncvals = 0 + endif + if (associated(data_file%add_attrib_lval)) then + nlvals = size(data_file%add_attrib_lval) + else + nlvals = 0 + endif + if (associated(data_file%add_attrib_ival)) then + nivals = size(data_file%add_attrib_ival) + else + nivals = 0 + endif + if (associated(data_file%add_attrib_rval)) then + nrvals = size(data_file%add_attrib_rval) + else + nrvals = 0 + endif + if (associated(data_file%add_attrib_dval)) then + ndvals = size(data_file%add_attrib_dval) + else + ndvals = 0 + endif + + do n=1,ncvals + work_line = data_file%add_attrib_cname(n) + iostat = pio_put_att(data_file%File, PIO_GLOBAL, trim(work_line), & + trim(data_file%add_attrib_cval(n))) + end do + + do n=1,nlvals + work_line = 'LOG_'/& + &/data_file%add_attrib_lname(n) + if (data_file%add_attrib_lval(n)) then + itmp = 1 + else + itmp = 0 + endif + iostat = pio_put_att(data_file%File, PIO_GLOBAL, trim(work_line), & + itmp) + end do + + do n=1,nivals + work_line = data_file%add_attrib_iname(n) + + iostat = pio_put_att(data_file%File, PIO_GLOBAL, trim(work_line), & + data_file%add_attrib_ival(n)) + end do + + do n=1,nrvals + work_line = data_file%add_attrib_rname(n) + + iostat = pio_put_att(data_file%File, PIO_GLOBAL, trim(work_line), & + data_file%add_attrib_rval(n)) + end do + + do n=1,ndvals + work_line = data_file%add_attrib_dname(n) + iostat = pio_put_att(data_file%File, PIO_GLOBAL, trim(work_line), & + data_file%add_attrib_dval(n)) + end do + + if (attrib_error) call exit_POP(sigAbort, & + 'Error writing file attributes') + +!----------------------------------------------------------------------- +!EOC + + end subroutine open_netcdf + +!*********************************************************************** +!BOP +! !IROUTINE: close_netcdf +! !INTERFACE: + + subroutine close_netcdf(data_file) + +! !INPUT/OUTPUT PARAMETERS: + + type (datafile), intent (inout) :: data_file + integer :: iostat +! !DESCRIPTION: +! This routine closes an open netcdf data file. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! close a data file +! +!----------------------------------------------------------------------- + + call pio_closefile(data_file%File) + +!----------------------------------------------------------------------- +!EOC + + end subroutine close_netcdf + +!*********************************************************************** +!BOP +! !IROUTINE: sync_netcdf +! !INTERFACE: + + subroutine sync_netcdf(data_file) + +! !INPUT/OUTPUT PARAMETERS: + + type (datafile), intent (inout) :: data_file + +! !DESCRIPTION: +! This routine uses pio_syncfile to flush an open netcdf data file. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! close a data file +! +!----------------------------------------------------------------------- + + call pio_syncfile(data_file%File) + +!----------------------------------------------------------------------- +!EOC + + end subroutine sync_netcdf + +!*********************************************************************** +!BOP +! !IROUTINE: define_field_netcdf +! !INTERFACE: + + subroutine define_field_netcdf(data_file, io_field) + +! !DESCRIPTION: +! This routine defines an io field for a netCDF file. +! When reading a file, the define routine will attempt to fill an +! io field structure with meta-data information from the netCDF file. +! When writing a file, it calls the appropriate netCDF routines +! to define all the field attributes and assign a field id. +! +! !REVISION HISTORY: +! same as module + +! !INPUT/OUTPUT PARAMETERS: + + type (datafile), target, intent (inout) :: & + data_file ! data file in which field contained + + type (io_field_desc), intent (inout) :: & + io_field ! field descriptor for this field + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character (80) :: & + work_line, &! workspace for manipulating input string + comp_line, &! comparison string + att_name ! attribute name + + integer (i4) :: & + iostat, &! status flag for netCDF calls + varid, &! variable id for field + ndims, &! number of dimensions + dimid, &! dimension id + n, &! loop index + ncount, &! num additional attributes + nsize, &! length of character strings + itype, &! netCDF data type + num_atts, &! number of variable attributes + att_ival, &! temp for integer attribute + ncvals, &! counter for number of character attributes + nlvals, &! counter for number of logical attributes + nivals, &! counter for number of integer attributes + nrvals, &! counter for number of real attributes + ndvals ! counter for number of double attributes + + logical (log_kind) :: & + att_lval ! temp for logical attribute + + real (r4) :: & + att_rval ! temp for real attribute + + real (r8) :: & + att_dval ! temp for double attribute + + logical (log_kind) :: & + define_error ! error flag + + integer (i4) :: xtype + + define_error = .false. + + data_file%ldefine = .true. ! file in netCDF define mode + +!----------------------------------------------------------------------- +! +! for input files, get the variable id and determine number of field +! attributes +! +!----------------------------------------------------------------------- + + call pio_seterrorhandling(data_file%File, PIO_BCAST_ERROR) + + if (data_file%readonly) then + + ! Note that currently a lot of pio inquire functions need a + ! netcdf varid and not a pio vardesc. Currently pio_inq_varnatts + ! can only be accessed through a pio vardesc. + + iostat = pio_inq_varid(data_file%File, io_field%short_name, io_field%id) + if (iostat /= pio_noerr) & + call exit_POP(sigAbort,'Error in getting varid for netCDF field') + + iostat = pio_inq_varid(data_file%File, io_field%short_name, io_field%varDesc) + if (iostat /= pio_noerr) & + call exit_POP(sigAbort,'Error in getting varDesc for netCDF field') + + iostat = pio_inq_varnatts(data_file%File, io_field%varDesc, nAtts=num_atts) + if (iostat /= pio_noerr) & + call exit_POP(sigAbort,'Error getting attrib count for netCDF field') + + !*** + !*** for each attribute, define standard attributes or add + !*** attribute to io_field + !*** + + do n=1,num_atts + + !*** + !*** get attribute name + !*** + + att_name = char_blank + iostat = pio_inq_attname(data_file%File, io_field%id, n, att_name) + if (iostat /= pio_noerr) & + call exit_POP(sigAbort,'Error getting netCDF field attribute name') + + !*** + !*** check to see if name matches any of the standard field + !*** attributes + !*** + + select case(trim(att_name)) + + case('long_name') + + io_field%long_name = char_blank + + iostat = pio_inq_att(data_file%File, io_field%id, 'long_name', & + xtype, nsize) + if (iostat == pio_noerr) then + if (nsize <= len(io_field%long_name)) then + iostat = pio_get_att(data_file%File, io_field%id, 'long_name', & + io_field%long_name(1:nsize)) + else + if (my_task == master_task) then + call document('define_field_netcdf', 'nsize', nsize) + call document('define_field_netcdf', 'len(io_field%long_name)', & + len(io_field%long_name)) + write(stdout,*) 'string too short; not enough room to read long_name of ' /& + &/ trim(io_field%short_name) /& + &/ ' from ' /& + &/ trim(data_file%full_name) + end if + endif + endif + if (iostat /= pio_noerr) then + call exit_POP(sigAbort, & + 'Error reading long_name from netCDF file') + endif + + case('units') + + io_field%units = char_blank + + iostat = pio_inq_att(data_file%File, io_field%id, 'units', & + xtype, nsize) + + if (iostat == pio_noerr) then + if (nsize <= len(io_field%units)) then + iostat = pio_get_att(data_file%File, io_field%id, 'units', & + io_field%units(1:nsize)) + else + if (my_task == master_task) then + call document('define_field_netcdf', 'nsize', nsize) + call document('define_field_netcdf', 'len(io_field%units)', & + len(io_field%units)) + write(stdout,*) 'string too short; not enough room to read units of ' /& + &/ trim(io_field%short_name) /& + &/ ' from ' /& + &/ trim(data_file%full_name) + end if + endif + endif + + case('coordinates') + + io_field%coordinates = char_blank + + iostat = pio_inq_att(data_file%File, io_field%id, 'coordinates', & + xtype, nsize) + + if (iostat == pio_noerr) then + if (nsize <= len(io_field%coordinates)) then + iostat = pio_get_att(data_file%File, io_field%id, 'coordinates', & + io_field%coordinates(1:nsize)) + if (iostat /= pio_noerr) then + call exit_POP(sigAbort, & + 'Error reading coordinates from netCDF file') + endif + else + if (my_task == master_task) then + call document('define_field_netcdf', 'nsize', nsize) + call document('define_field_netcdf', 'len(io_field%coordinates)', & + len(io_field%coordinates)) + write(stdout,*) 'string too short; not enough room to read coordinates of ' /& + &/ trim(io_field%short_name) /& + &/ ' from ' /& + &/ trim(data_file%full_name) + endif + endif + endif + + + case('grid_loc') + + io_field%grid_loc = ' ' + + iostat = pio_inq_att(data_file%File, io_field%id, 'grid_loc', & + xtype, nsize) + + if (iostat == pio_noerr) then + if (nsize <= len(io_field%grid_loc)) then + iostat = pio_get_att(data_file%File, io_field%id, 'grid_loc', & + io_field%grid_loc(1:nsize)) + else + call document('define_field_netcdf', 'nsize', nsize) + call document('define_field_netcdf', 'len(io_field%grid_loc)', & + len(io_field%grid_loc)) + write(stdout,*) 'string too short; not enough room to read grid_loc of ' /& + &/ trim(io_field%short_name) /& + &/ ' from ' /& + &/ trim(data_file%full_name) + endif + endif + + if (iostat /= pio_noerr) then + call exit_POP(sigAbort, & + 'Error reading grid_loc from netCDF file') + endif + + case('valid_range') + + iostat = pio_get_att(data_file%File, io_field%id, & + 'valid_range', & + io_field%valid_range) + if (iostat /= pio_noerr) then + call exit_POP(sigAbort, & + 'Error reading valid_range from netCDF file') + endif + + case default + + !*** + !*** if does not match any of the standard file attributes + !*** add the attribute to the datafile + !*** + + iostat = pio_inq_att(data_file%File, io_field%id, trim(att_name), & + itype, nsize) + + if (iostat /= pio_noerr) then + call exit_POP(sigAbort, & + 'Error reading netCDF file attribute') + endif + + select case (itype) + + case (PIO_CHAR) + work_line = char_blank + if (nsize <= len(work_line)) then + iostat = pio_get_att(data_file%File, io_field%id, trim(att_name), & + work_line(1:nsize)) + else + if (my_task == master_task) then + call document('define_field_netcdf', 'nsize', nsize) + call document('define_field_netcdf', 'len(work_line)', & + len(work_line)) + write(stdout,*) 'string too short; not enough room to read ' /& + &/ trim(att_name) /& + &/ ' of ' /& + &/ trim(io_field%short_name) /& + &/ ' from ' /& + &/ trim(data_file%full_name) + endif + endif + if (iostat /= pio_noerr) then + call exit_POP(sigAbort, & + 'Error reading netCDF file attribute') + endif + + call add_attrib_io_field(io_field, trim(att_name), & + trim(work_line)) + + case (PIO_INT) !*** both integer and logical attributes + iostat = pio_get_att(data_file%File, io_field%id, & + trim(att_name), att_ival) + if (iostat /= pio_noerr) then + call exit_POP(sigAbort, & + 'Error reading netCDF file attribute') + endif + + if (att_name(1:4) == 'LOG_') then !*** attribute logical + work_line = att_name + work_line(1:4) = ' ' + att_name = adjustl(work_line) + + if (att_ival == 1) then + att_lval = .true. + else + att_lval = .false. + endif + call add_attrib_file(data_file, trim(att_name), & + att_lval) + + else + call add_attrib_file(data_file, trim(att_name), & + att_ival) + endif + + case (PIO_REAL) + iostat = pio_get_att(data_file%File, io_field%id, & + trim(att_name), att_rval) + if (iostat /= pio_noerr) then + call exit_POP(sigAbort, & + 'Error reading netCDF file attribute') + endif + + call add_attrib_io_field(io_field, trim(att_name), & + att_rval) + + case (PIO_DOUBLE) + iostat = pio_get_att(data_file%File, io_field%id, & + trim(att_name), att_dval) + if (iostat /= pio_noerr) then + call exit_POP(sigAbort, & + 'Error reading netCDF file attribute') + endif + + call add_attrib_io_field(io_field, trim(att_name), & + att_dval) + + end select + + end select + + end do ! num_atts + +!----------------------------------------------------------------------- +! +! for output files, need to define everything +! make sure file is in define mode +! +!----------------------------------------------------------------------- + + else ! output file + + if (.not. data_file%ldefine) & + call exit_POP(sigAbort, & + 'attempt to define field but not in define mode') + +!----------------------------------------------------------------------- +! +! define the dimensions +! +!----------------------------------------------------------------------- + + ndims = io_field%nfield_dims + + do n = 1,ndims + dimid = 0 + + !*** check to see whether already defined + + iostat = pio_inq_dimid(data_file%file, & + name=trim(io_field%field_dim(n)%name),& + dimid=dimid) + + if (iostat /= PIO_NOERR) then ! dimension not yet defined + iostat = pio_def_dim (data_file%File, & + name=trim(io_field%field_dim(n)%name), & + len=io_field%field_dim(n)%length, & + dimid=io_field%field_dim(n)%id) + else + io_field%field_dim(n)%id = dimid + end if + end do + +!----------------------------------------------------------------------- +! +! now define the field +! +!----------------------------------------------------------------------- + + !*** check to see whether field of this name already defined. + + iostat = pio_inq_varid(data_file%File, trim(io_field%short_name), varid) + + if (iostat /= PIO_NOERR) then ! variable was not yet defined + + if (associated (io_field%field_r_1d).or. & + associated (io_field%field_r_2d).or. & + associated (io_field%field_r_3d)) then + iostat = pio_def_var (data_file%File, & + name=trim(io_field%short_name), & + type=PIO_REAL, & + dimids=(/ (io_field%field_dim(n)%id, n=1,ndims) /),& + varDesc=io_field%varDesc) + + else if ( io_field%nfield_dims == c0) then + ! do not supply optional dimids for scalars + iostat = pio_def_var (data_file%File, & + name=trim(io_field%short_name), & + type=PIO_DOUBLE, & + varDesc=io_field%varDesc) + else if (associated (io_field%field_d_1d).or. & + associated (io_field%field_d_2d).or. & + associated (io_field%field_d_3d)) then + iostat = pio_def_var (data_file%File, & + name=trim(io_field%short_name), & + type=PIO_DOUBLE, & + dimids=(/ (io_field%field_dim(n)%id, n=1,ndims) /),& + varDesc=io_field%varDesc) + else if (associated (io_field%field_i_1d).or. & + associated (io_field%field_i_2d).or. & + associated (io_field%field_i_3d)) then + iostat = pio_def_var (data_file%File, & + name=trim(io_field%short_name), & + type=PIO_INT, & + dimids=(/ (io_field%field_dim(n)%id, n=1,ndims) /),& + varDesc=io_field%varDesc) + else + define_error = .true. + end if + if (iostat /= pio_noerr) define_error = .true. + + end if + + ! Now get a valid netcdf varid for the variable and fill in + ! the io_field%id setting + + iostat = pio_inq_varid(data_file%File, trim(io_field%short_name), varid) + io_field%id = varid + if (iostat /= PIO_NOERR) define_error = .true. + + iostat = pio_inq_varid(data_file%File, trim(io_field%short_name), io_field%vardesc) + if (iostat /= pio_noerr) define_error = .true. + + if (define_error) then + write(stdout,*) '(define_field_netcdf) ', trim(io_field%short_name) + call exit_POP(sigAbort, 'Error defining netCDF field') + endif + +!----------------------------------------------------------------------- +! +! Now define the field attributes +! +!----------------------------------------------------------------------- + + !*** long_name + + if (io_field%long_name /= char_blank) then + iostat = pio_inq_att(data_file%File, varid, 'long_name', & + xtype, nsize) + if (iostat /= PIO_NOERR) then ! attrib probably not defined + iostat = pio_put_att(data_file%File, varid=varid, & + name='long_name', & + value=trim(io_field%long_name)) + if (iostat /= PIO_NOERR) define_error = .true. + end if + endif + + !*** units + + if (io_field%units /= char_blank) then + iostat = pio_inq_att(data_file%File, varid, 'units', & + xtype, nsize) + if (iostat /= PIO_NOERR) then ! attrib probably not defined + iostat = pio_put_att(data_file%File, varid=varid, & + name='units', & + value=trim(io_field%units)) + if (iostat /= PIO_NOERR) define_error = .true. + end if + endif + + !*** coordinates + + if (io_field%coordinates /= char_blank) then + iostat = pio_inq_att(data_file%File, varid, 'coordinates', & + xtype, nsize) + if (iostat /= PIO_NOERR) then ! attrib probably not defined + iostat = pio_put_att(data_file%File, varid=varid, & + name='coordinates', & + value=trim(io_field%coordinates)) + if (iostat /= PIO_NOERR) define_error = .true. + end if + endif + + !*** grid_loc + + if (io_field%grid_loc /= ' ') then + iostat = pio_inq_att(data_file%File, varid, 'grid_loc', & + xtype, nsize) + if (iostat /= PIO_NOERR) then ! attrib probably not defined + iostat = pio_put_att(data_file%File, varid=varid, & + name='grid_loc', & + value=io_field%grid_loc) + if (iostat /= PIO_NOERR) define_error = .true. + end if + endif + + + !*** valid_range(1:2) + + if (any(io_field%valid_range /= undefined)) then + iostat = pio_inq_att(data_file%File, varid, 'valid_range', & + xtype, nsize) + if (iostat /= PIO_NOERR) then ! attrib probably not yet defined + iostat = pio_put_att(data_file%File, varid=varid, & + name='valid_range', & + value=io_field%valid_range(:)) + if (iostat /= PIO_NOERR) define_error = .true. + end if + endif + + !*** additional attributes if defined + + ncvals = 0 + nlvals = 0 + nivals = 0 + nrvals = 0 + ndvals = 0 + if (associated(io_field%add_attrib_cval)) & + ncvals = size(io_field%add_attrib_cval) + if (associated(io_field%add_attrib_lval)) & + nlvals = size(io_field%add_attrib_lval) + if (associated(io_field%add_attrib_ival)) & + nivals = size(io_field%add_attrib_ival) + if (associated(io_field%add_attrib_rval)) & + nrvals = size(io_field%add_attrib_rval) + if (associated(io_field%add_attrib_dval)) & + ndvals = size(io_field%add_attrib_dval) + + do n=1,ncvals + iostat = pio_put_att(data_file%File, varid=varid, & + name=trim(io_field%add_attrib_cname(n)), & + value=trim(io_field%add_attrib_cval(n))) + if (iostat /= PIO_NOERR) define_error = .true. + end do + + do n=1,nlvals + work_line = 'LOG_'/& + &/trim(io_field%add_attrib_lname(n)) + iostat = pio_put_att(data_file%File, varid=varid, & + name=trim(work_line), & + value=io_field%add_attrib_ival(n)) + if (iostat /= PIO_NOERR) define_error = .true. + end do + + do n=1,nivals + iostat = pio_put_att(data_file%File, varid=varid, & + name=trim(io_field%add_attrib_iname(n)), & + value=io_field%add_attrib_ival(n)) + if (iostat /= PIO_NOERR) define_error = .true. + end do + + do n=1,nrvals + iostat = pio_put_att(data_file%file, varid=varid, & + name=trim(io_field%add_attrib_rname(n)), & + value=io_field%add_attrib_rval(n)) + if (iostat /= PIO_NOERR) define_error = .true. + end do + + do n=1,ndvals + iostat = pio_put_att(data_file%File, varid=varid, & + name=trim(io_field%add_attrib_dname(n)), & + value=io_field%add_attrib_dval(n)) + if (iostat /= PIO_NOERR) define_error = .true. + end do + + if (define_error) call exit_POP(sigAbort, & + 'Error adding attributes to field') + + endif ! input/output file + + call pio_seterrorhandling(data_file%File, PIO_INTERNAL_ERROR) + +!----------------------------------------------------------------------- +!EOC + + end subroutine define_field_netcdf + +!*********************************************************************** +!BOP +! !IROUTINE: write_field_netcdf +! !INTERFACE: + + subroutine write_field_netcdf(data_file, io_field) + +! !DESCRIPTION: +! This routine writes a field to a netCDF data file. +! +! !REVISION HISTORY: +! same as module + +! !INPUT/OUTPUT PARAMETERS: + + type (datafile), target, intent (inout) :: & + data_file ! file to which field will be written + + type (io_field_desc), intent (inout) :: & + io_field ! field to write to file + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (i4) :: & + iostat, &! netCDF status flag + ndims, &! dimension index + k,n ! loop counters + + logical (log_kind) :: & + write_error ! error flag + + integer (i4), dimension(1) :: & + start,count ! dimension quantities for netCDF + +!----------------------------------------------------------------------- +! +! exit define mode if necessary +! +!----------------------------------------------------------------------- + + write_error = .false. + + + if (data_file%ldefine) then + iostat = pio_enddef(data_file%File) + data_file%ldefine = .false. + endif + +!----------------------------------------------------------------------- +! +! make sure field has been defined +! +!----------------------------------------------------------------------- + + if (io_field%id == 0) then + call exit_POP(sigAbort,'Attempt to write undefined field in netCDF write') + end if + +!----------------------------------------------------------------------- +! +! write data based on type +! +!----------------------------------------------------------------------- + + if (trim(io_field%short_name) == 'time') then + ndims = io_field%nfield_dims + start(1) = io_field%field_dim(ndims)%start + count(1) = 1 + iostat = pio_put_var(data_file%File, varid=io_field%id, start=start(:), count=count(:), & + ival=io_field%field_d_1d) + if (iostat /= pio_noerr) then + call document('write_field_netcdf', 'short_name', io_field%short_name) + call exit_POP(sigAbort,'Error writing field time to netCDF file') + end if + RETURN + end if + + ! Set the unlimited dimension pointer for the variable + + if (io_field%set_iodesc) then + if (associated(io_field%field_r_3d)) then + call io_pio_initdecomp(PIO_REAL, ndim3=io_field%field_dim(3)%length, & + kdim3=size(io_field%field_r_3d,3), iodesc=io_field%ioDesc) + else if (associated(io_field%field_d_3d)) then + call io_pio_initdecomp(PIO_DOUBLE, ndim3=io_field%field_dim(3)%length, & + kdim3=size(io_field%field_d_3d,3), iodesc=io_field%ioDesc) + else if (associated(io_field%field_i_3d)) then + call io_pio_initdecomp(PIO_INT, ndim3=io_field%field_dim(3)%length, & + kdim3=size(io_field%field_i_3d,3), iodesc=io_field%ioDesc) + else if (associated(io_field%field_r_2d)) then + call io_pio_initdecomp(PIO_REAL, ndim3=0, kdim3=0, iodesc=io_field%ioDesc) + else if (associated(io_field%field_d_2d)) then + call io_pio_initdecomp(PIO_DOUBLE, ndim3=0, kdim3=0, iodesc=io_field%ioDesc) + else if (associated(io_field%field_i_2d)) then + call io_pio_initdecomp(PIO_INT, ndim3=0, kdim3=0, iodesc=io_field%ioDesc) + end if + io_field%set_iodesc = .false. + end if + + if (io_field%set_ioFrame) then + ndims = io_field%nfield_dims + call pio_setframe(io_field%vardesc, int(io_field%field_dim(ndims)%start,kind=PIO_OFFSET)) + end if + + if (associated(io_field%field_r_3d)) then + + call pio_write_darray(data_file%File, io_field%vardesc, io_field%iodesc, & + io_field%field_r_3d, iostat) + + else if (associated(io_field%field_r_2d)) then + + call pio_write_darray(data_file%File, io_field%vardesc, io_field%iodesc, & + io_field%field_r_2d, iostat) + + else if (associated(io_field%field_r_1d)) then + + ! 1d vectors are not distributed to blocks + iostat = pio_put_var(data_file%File, io_field%vardesc, io_field%field_r_1d) + + else if (associated(io_field%field_d_3d)) then + + call pio_write_darray(data_file%File, io_field%vardesc, io_field%iodesc, & + io_field%field_d_3d, iostat) + + else if (associated(io_field%field_d_2d)) then + + call pio_write_darray(data_file%File, io_field%vardesc, io_field%iodesc, & + io_field%field_d_2d, iostat) + + else if (associated(io_field%field_d_1d)) then + + ! 1d vectors are not distributed to blocks; no need for gather_global + iostat = pio_put_var(data_file%File, io_field%vardesc, io_field%field_d_1d) + + else if (io_field%nfield_dims == c0) then + + ! scalars are not distributed to blocks; no need for gather_global + ! for now, all scalars are r8 and are not pointers or targets + iostat = pio_put_var(data_file%File, io_field%vardesc, io_field%field_d_0d) + + else if (associated(io_field%field_i_3d)) then + + call pio_write_darray(data_file%File, io_field%vardesc, io_field%iodesc, & + io_field%field_i_3d, iostat) + + else if (associated(io_field%field_i_2d)) then + + call pio_write_darray(data_file%File, io_field%vardesc, io_field%iodesc, & + io_field%field_i_2d, iostat) + + else if (associated(io_field%field_i_1d)) then + + ! 1d vectors are not distributed to blocks; no need for gather_global + iostat = pio_put_var(data_file%File, io_field%vardesc, io_field%field_i_1d) + + else + call exit_POP(sigAbort, & + 'No field associated for writing to netCDF') + end if + + if (iostat /= pio_noerr) then + write_error = .true. + endif + + if (write_error) then + call document('write_field_netcdf', 'short_name', io_field%short_name) + call exit_POP(sigAbort, & + 'Error writing field to netCDF file') + endif + +!----------------------------------------------------------------------- +!EOC + + end subroutine write_field_netcdf + +!*********************************************************************** +!BOP +! !IROUTINE: read_field_netcdf +! !INTERFACE: + + subroutine read_field_netcdf(data_file, io_field) + +! !DESCRIPTION: +! This routine reads a field from a netcdf input file. +! +! !REVISION HISTORY: +! same as module +! +! !USES + + use POP_FieldMod + use POP_GridHorzMod + use Pop_HaloMod + +! !INPUT/OUTPUT PARAMETERS: + + type (datafile), target, intent (inout) :: & + data_file ! file from which to read field + + type (io_field_desc), intent (inout) :: & + io_field ! field to be read + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (i4) :: & + iostat, &! netCDF status flag + k,n ! loop counters + + character(len=8) :: fieldtype, fieldloc + + integer (POP_i4) :: errorCode ! returned error code + + logical (log_kind) :: lhalo_update + +!----------------------------------------------------------------------- +! +! make sure field has been defined +! +!----------------------------------------------------------------------- + + + iostat = pio_inq_varid(data_file%File, trim(io_field%short_name), io_field%varDesc) + +!----------------------------------------------------------------------- +! +! if no boundary update type defined, assume center location scalar +! +!----------------------------------------------------------------------- + + if (io_field%field_loc == field_loc_unknown) then + io_field%field_loc = field_loc_center + io_field%field_type = field_type_scalar + endif + +!----------------------------------------------------------------------- +! +! read data based on type +! +!----------------------------------------------------------------------- + + if (io_field%set_iodesc) then + call pio_setframe(io_field%vardesc, int(1,kind=PIO_OFFSET)) + if (associated(io_field%field_r_3d)) then + call io_pio_initdecomp(PIO_REAL, ndim3=io_field%field_dim(3)%length, & + kdim3=io_field%field_dim(3)%length, iodesc=io_field%ioDesc) + else if (associated(io_field%field_d_3d)) then + call io_pio_initdecomp(PIO_DOUBLE, ndim3=io_field%field_dim(3)%length, & + kdim3=io_field%field_dim(3)%length, iodesc=io_field%ioDesc) + else if (associated(io_field%field_i_3d)) then + call io_pio_initdecomp(PIO_INT, ndim3=io_field%field_dim(3)%length, & + kdim3=io_field%field_dim(3)%length, iodesc=io_field%ioDesc) + else if (associated(io_field%field_r_2d)) then + call io_pio_initdecomp(PIO_REAL, ndim3=0, kdim3=0, iodesc=io_field%ioDesc) + else if (associated(io_field%field_d_2d)) then + call io_pio_initdecomp(PIO_DOUBLE, ndim3=0, kdim3=0, iodesc=io_field%ioDesc) + else if (associated(io_field%field_i_2d)) then + call io_pio_initdecomp(PIO_INT, ndim3=0, kdim3=0, iodesc=io_field%ioDesc) + end if + io_field%set_iodesc = .false. + end if + + ! Set values for halo updates if needed + if (io_field%field_loc == field_loc_center) then + fieldLoc = POP_gridHorzLocCenter + else if (io_field%field_loc == field_loc_NEcorner) then + fieldLoc = POP_gridHorzLocNECorner + else if (io_field%field_loc == field_loc_Nface) then + fieldLoc = POP_gridHorzLocNface + else if (io_field%field_loc == field_loc_Eface) then + fieldLoc = POP_gridHorzLocEface + end if + + if (io_field%field_type == field_type_vector) then + fieldType = POP_fieldKindVector + else if (io_field%field_type == field_type_scalar) then + fieldType = POP_fieldKindScalar + else if (io_field%field_type == field_type_angle) then + fieldType = POP_fieldKindAngle + else if (io_field%field_type == field_type_noupdate) then + fieldType = POP_fieldKindNoUpdate + else + call exit_POP(sigAbort, 'read_field_netcdf field_type is not supported') + end if + + ! Currently halo update is not supported for tripole grid + if (ltripole_grid) then + if (io_field%field_type == field_type_noupdate .or. & + io_field%field_loc == field_loc_noupdate) then + lhalo_update = .false. + else + lhalo_update = .true. + end if + else + if (io_field%field_loc == field_loc_noupdate .or. & + io_field%field_loc == field_loc_unknown) then + lhalo_update = .false. + else + lhalo_update = .true. + end if + end if + + if (associated(io_field%field_r_3d)) then + + call pio_read_darray(data_file%File, io_field%varDesc, io_field%iodesc, & + io_field%field_r_3d(:,:,:,:), iostat) + + if (lhalo_update) then + call POP_HaloUpdate(array=io_field%field_r_3d(:,:,:,:), & + halo=POP_haloClinic, & + fieldLoc=FieldLoc, & + fieldKind=FieldType, errorCode=errorCode, & + fillValue=0.0_POP_r4) + if (errorCode /= POP_Success) then + call exit_POP(sigAbort, & + 'read_field_netcdf: error updating halo for field_r_3d') + endif + end if + + else if (associated(io_field%field_r_2d)) then + + call pio_read_darray(data_file%File, io_field%varDesc, io_field%iodesc, & + io_field%field_r_2d, iostat) + + if (lhalo_update) then + call POP_HaloUpdate(array=io_field%field_r_2d(:,:,:), & + halo=POP_haloClinic, & + fieldLoc=FieldLoc, & + fieldKind=FieldType, errorCode=errorCode, & + fillValue=0.0_POP_r4) + if (errorCode /= POP_Success) then + call exit_POP(sigAbort, & + 'read_field_netcdf: error updating halo for field_r_2d') + endif + end if + + else if (associated(io_field%field_r_1d)) then + + ! 1d vectors are not distributed to blocks; therefore, no scatter_global needed + iostat = pio_get_var (data_file%File,io_field%varDesc,& + io_field%field_r_1d) + + else if (associated(io_field%field_r_1d)) then + + ! scalars are not distributed to blocks; therefore, no scatter_global needed + iostat = pio_get_var (data_file%File,io_field%varDesc, & + io_field%field_r_0d) + + else if (associated(io_field%field_d_3d)) then + + call pio_read_darray(data_file%File, io_field%varDesc, io_field%ioDesc, & + io_field%field_d_3d, iostat) + + if (lhalo_update) then + call POP_HaloUpdate(array=io_field%field_d_3d(:,:,:,:), & + halo=POP_haloClinic, & + fieldLoc=FieldLoc, & + fieldKind=FieldType, errorCode=errorCode, & + fillValue=0.0_POP_r8) + if (errorCode /= POP_Success) then + call exit_POP(sigAbort, & + 'read_field_netcdf: error updating halo for field_d_3d') + endif + end if + + else if (associated(io_field%field_d_2d)) then + + call pio_read_darray(data_file%File, io_field%varDesc, io_field%ioDesc, & + io_field%field_d_2d, iostat) + + if (lhalo_update) then + call POP_HaloUpdate(array=io_field%field_d_2d(:,:,:), & + halo=POP_haloClinic, & + fieldLoc=FieldLoc, & + fieldKind=FieldType, errorCode=errorCode, & + fillValue=0.0_POP_r8) + if (errorCode /= POP_Success) then + call exit_POP(sigAbort, & + 'read_field_netcdf: error updating halo for field_d_2d') + endif + end if + + else if (associated(io_field%field_d_1d)) then + + ! 1d vectors are not distributed to blocks; therefore, no scatter_global needed + iostat = pio_get_var (data_file%File,io_field%varDesc, & + io_field%field_d_1d) + + else if (associated(io_field%field_d_1d)) then + + ! scalars are not distributed to blocks; therefore, no scatter_global needed + iostat = pio_get_var (data_file%File, io_field%varDesc, & + io_field%field_d_0d) + + else if (associated(io_field%field_i_3d)) then + + call pio_read_darray(data_file%File, io_field%varDesc, io_field%ioDesc, & + io_field%field_i_3d, iostat) + + if (lhalo_update) then + call POP_HaloUpdate(array=io_field%field_i_3d(:,:,:,:), & + halo=POP_haloClinic, & + fieldLoc=FieldLoc, & + fieldKind=FieldType, errorCode=errorCode, & + fillValue=0_POP_i4) + if (errorCode /= POP_Success) then + call exit_POP(sigAbort, & + 'read_field_netcdf: error updating halo for field_i_3d') + endif + end if + + else if (associated(io_field%field_i_2d)) then + + call pio_read_darray(data_file%File, io_field%varDesc, io_field%ioDesc, & + io_field%field_i_2d, iostat) + + if (lhalo_update) then + call POP_HaloUpdate(array=io_field%field_i_2d(:,:,:), & + halo=POP_haloClinic, & + fieldLoc=FieldLoc, & + fieldKind=FieldType, errorCode=errorCode, & + fillValue=0_POP_i4) + if (errorCode /= POP_Success) then + call exit_POP(sigAbort, & + 'read_field_netcdf: error updating halo for field_i_2d') + endif + end if + + else if (associated(io_field%field_i_1d)) then + + ! 1d vectors are not distributed to blocks; therefore, no scatter_global needed + iostat = pio_get_var (data_file%File,io_field%varDesc, & + io_field%field_i_1d) + + else if (associated(io_field%field_i_1d)) then + + ! scalars are not distributed to blocks; therefore, no scatter_global needed + iostat = pio_get_var (data_file%File, io_field%varDesc, & + io_field%field_i_0d) + else + call exit_POP(sigAbort, & + 'No field associated for reading from netCDF') + end if + +!----------------------------------------------------------------------- +!EOC + + end subroutine read_field_netcdf + +!*********************************************************************** +!BOP +! !IROUTINE: define_nstd_netcdf +! !INTERFACE: + + subroutine define_nstd_netcdf(data_file,ndims,io_dims,field_id, & + short_name,long_name,units,coordinates, & + fill_value,method_string,nftype) + +! !DESCRIPTION: +! This routine defines the nonstandard CCSM time-averaged diagnostic fields +! on nonstandard grids: MOC, N_HEAT, and N_SALT +! This routine is totally CCSM-specific +! +! +! !REVISION HISTORY: +! same as module + +! !INPUT PARAMETERS: + + type (datafile), target, intent (inout) :: & + data_file ! data file in which field contained + + real (r4), intent (in) :: & + fill_value + + integer (int_kind), intent(in) :: & + ndims ! number of dimensions for nonstandard field + + character (*), intent (in) :: & + short_name, & + long_name, & + units, & + coordinates, & + nftype, & + method_string + +! !INPUT/OUTPUT PARAMETERS: + + type (io_dim), dimension(:), intent (inout) :: & + io_dims + + integer (i4), intent (inout) :: & + field_id ! variable id + + optional :: coordinates,fill_value,nftype,method_string + +!EOP +!BOP +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (i4) :: & + iostat, &! status flag for netCDF calls + n, &! loop index + dimid, &! dimension id + xtype, & + len + + + logical (log_kind) :: & + define_error ! error flag + + ! Note this is a local variable since it is only used to satisfy + ! pio_def_var interface needs. Only pio_put_var is used for + ! non-standard variablesand all output is from the master processor. + ! So vardesc is never directly. + + type(var_desc_t) :: & + vardesc + + define_error = .false. + + +!----------------------------------------------------------------------- +! +! make sure file has been opened and is in define mode +! +!----------------------------------------------------------------------- + + call check_definemode (data_file, 'define_nstd_netcdf') + +!----------------------------------------------------------------------- +! +! define the dimensions +! +!----------------------------------------------------------------------- +! +! Set pio to return errors to this subroutine instead of handling them internally +! + call pio_seterrorhandling(data_file%File, PIO_BCAST_ERROR) + do n = 1,ndims + dimid = 0 + + !*** check to see whether dimension is already defined + iostat = PIO_INQ_DIMID(data_file%File, name=trim(io_dims(n)%name),& + dimid=dimid) + if (iostat /= PIO_NOERR) then ! dimension not yet defined + iostat = PIO_DEF_DIM (data_file%File, name=trim(io_dims(n)%name), & + len=io_dims(n)%length, dimid=io_dims(n)%id) + else + io_dims(n)%id = dimid + end if + end do + +!----------------------------------------------------------------------- +! +! define the field +! +!----------------------------------------------------------------------- + + if (present(nftype)) then + select case (trim(nftype)) + case ('float','FLOAT') + xtype = PIO_REAL + case ('double','DOUBLE') + xtype = PIO_DOUBLE + case ('integer','INTEGER') + xtype = PIO_INT + case ('char','CHAR','character', 'CHARACTER') + xtype = PIO_CHAR + case default + call exit_POP(sigAbort,'unknown nftype') + end select + else + xtype = PIO_REAL + endif + + !*** check to see whether field of this name already defined. + + iostat = PIO_INQ_VARID(data_file%File, trim(short_name), field_id) + if (iostat /= PIO_NOERR) then ! variable was not yet defined + ! Note currently must use vardesc to define var + iostat = PIO_DEF_VAR (data_file%File,name=trim(short_name), type=xtype,& + dimids=(/ (io_dims(n)%id, n=1,ndims) /),& + vardesc=vardesc) + if (iostat /= pio_noerr) define_error = .true. + + iostat = PIO_INQ_VARID(data_file%File, trim(short_name), field_id) + if (iostat /= pio_noerr) define_error = .true. + end if + + if (define_error) then + write(stdout,*) '(define_nstd_netcdf) Error for field = ', trim(short_name) + call exit_POP(sigAbort, 'Error defining nonstandard CCSM netCDF field') + endif + +!----------------------------------------------------------------------- +! +! Now define the field attributes +! +!----------------------------------------------------------------------- + + !*** long_name + iostat = pio_inq_att(data_file%File, field_id, 'long_name', & + xtype, len) + if (iostat /= PIO_NOERR) then ! attrib probably not defined + iostat = pio_put_att(data_file%File, varid=field_id, & + name='long_name', & + value=trim(long_name)) + if (iostat /= PIO_NOERR) define_error = .true. + end if + + !*** units + iostat = pio_inq_att(data_file%File, field_id, 'units', & + xtype, len) + if (iostat /= PIO_NOERR) then ! attrib probably not defined + iostat = pio_put_att(data_file%File, varid=field_id, & + name='units', & + value=trim(units)) + if (iostat /= PIO_NOERR) define_error = .true. + end if + + !*** coordinates + if (present(coordinates)) then + iostat = pio_inq_att(data_file%File, field_id, 'coordinates', & + xtype, len) + if (iostat /= PIO_NOERR) then ! attrib probably not defined + iostat = pio_put_att(data_file%File, varid=field_id, & + name='coordinates', & + value=trim(coordinates)) + if (iostat /= PIO_NOERR) define_error = .true. + end if + endif + + !*** cell_methods + if (present(method_string)) then + iostat = pio_inq_att(data_file%File, field_id, 'cell_methods', & + xtype, len) + if (iostat /= PIO_NOERR) then ! attrib probably not defined + iostat = pio_put_att(data_file%File, varid=field_id, & + name='cell_methods', & + value=trim(method_string)) + if (iostat /= PIO_NOERR) define_error = .true. + end if + endif + + !*** fill_value -- and missing_value, for now + if (present(fill_value)) then + iostat = pio_inq_att(data_file%File, varid=field_id, name='_FillValue', & + xtype=xtype, len=len) + if (iostat /= PIO_NOERR) then ! attrib probably not defined + iostat = pio_put_att(data_file%File, varid=field_id, & + name='_FillValue', & + value=fill_value) + if (iostat /= PIO_NOERR) define_error = .true. + end if + iostat = pio_inq_att(data_file%File, varid=field_id, name='missing_value', & + xtype=xtype, len=len) + if (iostat /= PIO_NOERR) then ! attrib probably not defined + iostat = pio_put_att(data_file%File, varid=field_id, & + name='missing_value', & + value=fill_value) + if (iostat /= PIO_NOERR) define_error = .true. + end if + endif + + + if (define_error) call exit_POP(sigAbort, & + '(define_nstd_netcdf) Error adding attributes to field') + +! +! Reset PIO to handle errors internally +! + call pio_seterrorhandling(data_file%File, PIO_INTERNAL_ERROR) + +!----------------------------------------------------------------------- +!EOC + + end subroutine define_nstd_netcdf + +!*********************************************************************** +!BOP +! !IROUTINE: write_time_bounds +! !INTERFACE: + + subroutine write_time_bounds (data_file, time_bound_id, & + time_bound_dims, time_bound_data) + +! !INPUT PARAMETERS: + integer (i4), intent (in) :: time_bound_id + type (io_dim), dimension(:), intent (in) :: time_bound_dims + real (r8), dimension(2,1),intent (in) :: time_bound_data + +! !INPUT/OUTPUT PARAMETERS: + type (datafile), target, intent (inout) :: & + data_file ! file to which field will be written + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (i4), dimension(2) :: & + start,length,count ! dimension quantities for netCDF + + integer :: & + iostat, &! netCDF status flag + n ! index + + integer :: ncid, nout(5) + + logical (log_kind) :: & + write_error ! error flag + +!----------------------------------------------------------------------- +! +! exit define mode if necessary +! +!----------------------------------------------------------------------- + + write_error = .false. + + + if (data_file%ldefine) then + iostat = pio_enddef(data_file%File) + data_file%ldefine = .false. + endif + +!----------------------------------------------------------------------- +! +! make sure field has been defined +! +!----------------------------------------------------------------------- + + if (time_bound_id == 0) write_error = .true. + + if (write_error) then + write(stdout,*) '(write_time_bounds) ERROR: undefined field -- time_bound' + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + call exit_POP(sigAbort,' Attempt to write undefined time_bound in netCDF write') + endif + +!----------------------------------------------------------------------- +! +! allocate dimension start,stop quantities +! +!----------------------------------------------------------------------- + + do n=1,2 + start (n) = time_bound_dims(n)%start + length(n) = time_bound_dims(n)%stop - start(n) + 1 + end do + + iostat = pio_put_var(data_file%File, varid=time_bound_id, start=start(:), count=length(:), & + ival=time_bound_data) + + end subroutine write_time_bounds + +!*********************************************************************** +!BOP +! !IROUTINE: write_nstd_netcdf +! !INTERFACE: + + subroutine write_nstd_netcdf(data_file,field_id, & + ndims, io_dims, & + nftype, & + lactive_time_dim, & + indata_1d_r8, & + indata_2d_r8, & + indata_2d_r4, & + indata_3d_r4 , & + indata_4d_r4, & + indata_1d_ch, & + indata_2d_ch ) + +! !DESCRIPTION: +! This is a specialized, CCSM-speicific routine to write any desired +! output field that cannot presently be defined through construct_io_field +! to the CCSM version of the netCDF time-averaged history output files +! +! !REVISION HISTORY: +! same as module +! USES + use shr_pio_mod, only : shr_pio_getioroot +! !INPUT PARAMETERS: + + character (*), intent (in) :: & + nftype + + integer (i4), intent (in) :: & + field_id ! netCDF id for the nonstandard variables + + integer (int_kind), intent (in) :: & + ndims + + type (io_dim), dimension(:), intent (in) :: & + io_dims + + real (r8), dimension(:,:),intent (in) :: & + indata_2d_r8 + real (r8), dimension(:), intent (in) :: & + indata_1d_r8 + + real (r4), dimension(:,:,:,:), intent (in) :: & + indata_4d_r4 + real (r4), dimension(:,:,:), intent (in) :: & + indata_3d_r4 + real (r4), dimension(:,:), intent (in) :: & + indata_2d_r4 + + character (*), dimension(:,:), intent (in) :: & + indata_2d_ch + character (*), dimension(:), intent (in) :: & + indata_1d_ch + + logical (log_kind), intent(in) :: & + lactive_time_dim + + +! !INPUT/OUTPUT PARAMETERS: + + type (datafile), target, intent (inout) :: & + data_file ! file to which field will be written + + optional :: & + indata_1d_r8, & + indata_2d_r8, & + indata_2d_r4, & + indata_3d_r4, & + indata_4d_r4, & + indata_1d_ch, & + indata_2d_ch + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer, parameter :: & + max_dims = 20 + + integer , dimension(max_dims) :: & + start,count ! dimension quantities for netCDF + + integer :: & + iostat, &! netCDF status flag + n,m, &! general indices + tb ! time indices + + integer :: nout(5) + + logical (log_kind) :: & + write_error, &! error flag + supported + + real (r4), allocatable, dimension (:,:,:,:,:) :: & + outdata_5d_r4 + + real (r4), allocatable, dimension (:,:,:,:) :: & + outdata_4d_r4 + + real (r4), allocatable, dimension (:,:,:) :: & + outdata_3d_r4 + + real (r4), allocatable, dimension (:,:) :: & + outdata_2d_r4 + + real (r8), allocatable, dimension (:) :: & + outdata_1d_r8 + real (r8), allocatable, dimension (:,:) :: & + outdata_2d_r8 + + character(char_len), allocatable, dimension (:,:) :: & + outdata_2d_ch + + character(1), dimension(char_len) :: & + tmpString ! temp for manipulating output string + + integer :: ioroot + +!----------------------------------------------------------------------- +! +! exit define mode if necessary +! +!----------------------------------------------------------------------- + + + write_error = .false. + + if (data_file%ldefine) then + iostat = pio_enddef(data_file%File) + data_file%ldefine = .false. + endif + +!----------------------------------------------------------------------- +! +! make sure field has been defined +! +!----------------------------------------------------------------------- + if (field_id == 0) write_error = .true. + + if (write_error) & + call exit_POP(sigAbort, & + '(write_nstd_netcdf) Attempt to write undefined field in netCDF write') + + supported = .true. + + ioroot = shr_pio_getioroot(inst_name) + +!----------------------------------------------------------------------- +! +! define start, count for all dimensions; do not allow out-of-bounds +! +!----------------------------------------------------------------------- + if (ndims > max_dims) & + call exit_POP(sigAbort, & + '(write_nstd_netcdf) ndims > max_dims -- increase max_dims') + + do n=1,ndims + start (n) = io_dims(n)%start + count(n) = io_dims(n)%stop - start(n) + 1 + end do + + select case (trim(nftype)) + + case('double','DOUBLE') + select case (lactive_time_dim) + case (.true.) + select case (ndims) + case(2) + if (my_task == ioroot) then + nout(1) = size(indata_1d_r8,DIM=1) + allocate (outdata_2d_r8(nout(1),1)) + outdata_2d_r8(:,1) = indata_1d_r8(:) + else + allocate (outdata_2d_r8(1,1)) + endif + iostat = pio_put_var (data_file%File, field_id, outdata_2d_r8 ) + deallocate (outdata_2d_r8) + case default + supported = .false. + end select ! ndims + case (.false.) + select case (ndims) + case(1) + iostat = pio_put_var (data_file%File, field_id, indata_1d_r8 ) + case(2) + iostat = pio_put_var (data_file%File, field_id, indata_2d_r8 ) + case default + supported = .false. + End select ! ndims + end select ! lactive_time_dim + + case('float','FLOAT') + select case (lactive_time_dim) + case (.true.) + select case (ndims) + case(1) + supported = .false. + case(2) + supported = .false. + case(3) + if (my_task == ioroot) then + do n=1,ndims-1 + nout(n) = size(indata_2d_r4,DIM=n) + enddo + tb = io_dims(ndims)%start + allocate (outdata_3d_r4(nout(1),nout(2),tb:tb)) + outdata_3d_r4(:,:,tb) = indata_2d_r4(:,:) + else + allocate (outdata_3d_r4(1,1,1)) + endif + iostat = pio_put_var (data_file%File, field_id, ival=outdata_3d_r4, & + start=start(:), count=count(:)) + deallocate (outdata_3d_r4) + case(4) + if (my_task == ioroot) then + do n=1,ndims-1 + nout(n) = size(indata_3d_r4,DIM=n) + enddo + tb = io_dims(ndims)%start + allocate (outdata_4d_r4(nout(1),nout(2),nout(3),tb:tb)) + outdata_4d_r4(:,:,:,tb) = indata_3d_r4(:,:,:) + else + allocate (outdata_4d_r4(1,1,1,1)) + endif + iostat = pio_put_var (data_file%File, field_id, ival=outdata_4d_r4, & + start=start(:), count=count(:)) + deallocate (outdata_4d_r4) + case(5) + if (my_task == ioroot) then + do n=1,ndims-1 + nout(n) = size(indata_4d_r4,DIM=n) + enddo + tb = io_dims(ndims)%start + allocate (outdata_5d_r4(nout(1),nout(2),nout(3),nout(4),tb:tb)) + outdata_5d_r4(:,:,:,:,tb) = indata_4d_r4(:,:,:,:) + else + allocate (outdata_5d_r4(1,1,1,1,1)) + endif + iostat = pio_put_var (data_file%File, field_id, ival=outdata_5d_r4, & + start=start(:), count=count(:)) + deallocate (outdata_5d_r4) + case default + supported = .false. + end select ! ndims + case (.false.) + select case (ndims) + case(1) + supported = .false. + case(2) + iostat = pio_put_var (data_file%File, field_id, indata_2d_r4 ) + case(3) + iostat = pio_put_var (data_file%File, field_id, indata_3d_r4 ) + case(4) + iostat = pio_put_var (data_file%File, field_id, indata_4d_r4 ) + case default + supported = .false. + end select ! ndims + end select ! lactive_time_dim + + case('char','character','CHAR','CHARACTER') + select case (lactive_time_dim) + case (.true.) + select case (ndims) + case default + supported = .false. + end select ! ndims + case (.false.) + select case (ndims) + case(2) + do n=1,io_dims(2)%length + start(1) = 1 + start(2) = n + count(1) = len_trim(indata_1d_ch(n)) + count(2) = 1 + do m = 1,count(1) + tmpString(m:m) = indata_1d_ch(n)(m:m) + end do + iostat = pio_put_var (data_file%File, field_id, & + ival=tmpString(1:count(1)), start=start, count=count) + enddo + + case default + supported = .false. + end select ! ndims + end select ! lactive_time_dim + + case default + + end select ! nftype + +!----------------------------------------------------------------------- +! +! check for errors +! +!----------------------------------------------------------------------- + + if (.not. supported) then + call document('write_nstd_netcdf', 'ndims', ndims) + call document('write_nstd_netcdf', 'nftype', trim(nftype)) + call document('write_nstd_netcdf', 'lactive_time_dim', lactive_time_dim) + call exit_POP(sigAbort, '(write_nstd_netcdf) option not supported') + endif + +!----------------------------------------------------------------------- +!EOC + + end subroutine write_nstd_netcdf + + +!*********************************************************************** +!BOP +! !IROUTINE: check_definemode +! !INTERFACE: + + subroutine check_definemode (data_file, name) + +! !DESCRIPTION: +! This utility routine checks if the data file is in define mode +! +! !REVISION HISTORY: +! same as module + +! !INPUT/OUTPUT PARAMETERS: + + type (datafile), target, intent (inout) :: & + data_file + + character(*),intent (in):: name + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer :: & + iostat ! netCDF status flag + + logical (log_kind) :: & + write_error ! error flag + + character (char_len) :: string + + +!----------------------------------------------------------------------- +! +! make sure file is in define mode +! +!----------------------------------------------------------------------- + + + if (.not. data_file%ldefine) & + call exit_POP(sigAbort, & + '('//trim(name)//') attempt to define field but not in define mode') + +!----------------------------------------------------------------------- +!EOC + + end subroutine check_definemode + + +!*********************************************************************** +end module io_netcdf + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/ocn.base.tavg.csh b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/ocn.base.tavg.csh new file mode 100755 index 0000000000..e689514a84 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/ocn.base.tavg.csh @@ -0,0 +1,44 @@ +#!/bin/csh -f +# +# DART note: this file started life as: +# /glade/p/cesmdata/cseg/collections/cesm1_1_1/models/ocn/pop2/input_templates/ocn.base.tavg.csh + +if ( $OCN_GRID =~ gx* ) then +#shut off time-invariant stream until vertical grid issues are resolved +cat >! $CASEBUILD/pop2conf/base.tavg.nml << EOF +tavg_freq_opt = 'nmonth' 'nday' 'once' +tavg_freq = 1 1 1 +tavg_stream_filestrings = 'nmonth1' 'nday1' 'once' +tavg_file_freq_opt = 'nmonth' 'nmonth' 'once' +tavg_file_freq = 1 1 1 +tavg_start_opt = 'nstep' 'nstep' 'nstep' +tavg_start = 0 0 0 +tavg_fmt_in = 'nc' 'nc' 'nc' +tavg_fmt_out = 'nc' 'nc' 'nc' +ltavg_has_offset_date = .false. .false. .false. +tavg_offset_years = 1 1 1 +tavg_offset_months = 1 1 1 +tavg_offset_days = 2 2 2 +ltavg_one_time_header = .false. .false. .false. +EOF +endif + +if ( $OCN_GRID =~ tx* ) then +cat >! $CASEBUILD/pop2conf/base.tavg.nml << EOF +tavg_freq_opt = 'nmonth' 'nday' +tavg_freq = 1 1 +tavg_stream_filestrings = 'nmonth1' 'nday1' +tavg_file_freq_opt = 'nmonth' 'nmonth' +tavg_file_freq = 1 1 +tavg_start_opt = 'nstep' 'nstep' +tavg_start = 0 0 +tavg_fmt_in = 'nc' 'nc' +tavg_fmt_out = 'nc' 'nc' +ltavg_has_offset_date = .false. .false. +tavg_offset_years = 1 1 +tavg_offset_months = 1 1 +tavg_offset_days = 2 2 +ltavg_one_time_header = .false. .false. +EOF +endif + diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/ocn.cfc.tavg.csh b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/ocn.cfc.tavg.csh new file mode 100755 index 0000000000..e0281f7308 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/ocn.cfc.tavg.csh @@ -0,0 +1,65 @@ +#!/bin/csh -f +# +# DART note: this file started life as: +# /glade/p/cesmdata/cseg/collections/cesm1_1_1/models/ocn/pop2/input_templates/ocn.cfc.tavg.csh + +#------------------------------------------------------------------------------------ +# For now, set streams manually. You must only set as many streams as are declared +# in the tavg_nml section. For example, if there are three streams: +# @ s1 = $my_stream +# @ s2 = $s1 + 1 +# @ s3 = $s2 + 1 +#------------------------------------------------------------------------------------ + +@ my_stream = $1 +if ($my_stream < 1) then + echo invalid my_stream number ($my_stream) + exit 5 +endif + +@ s1 = 1 # use base-model stream 1 + +cat >! $CASEROOT/Buildconf/pop2conf/cfc_tavg_contents << EOF +$s1 CFC_IFRAC +$s1 CFC_XKW +$s1 CFC_ATM_PRESS +$s1 STF_CFC11 +$s1 STF_CFC12 +$s1 CFC11 +$s1 CFC12 +EOF + +if ($OCN_TAVG_TRACER_BUDGET == TRUE) then +cat >> $CASEROOT/Buildconf/pop2conf/cfc_tavg_contents << EOF +$s1 KPP_SRC_CFC11 +$s1 KPP_SRC_CFC12 +$s1 DIA_IMPVF_CFC11 +$s1 DIA_IMPVF_CFC12 +$s1 HDIFE_CFC11 +$s1 HDIFE_CFC12 +$s1 HDIFN_CFC11 +$s1 HDIFN_CFC12 +$s1 HDIFB_CFC11 +$s1 HDIFB_CFC12 +$s1 UE_CFC11 +$s1 UE_CFC12 +$s1 VN_CFC11 +$s1 VN_CFC12 +$s1 WT_CFC11 +$s1 WT_CFC12 +EOF +endif + +#=============================================================================== +# The following are fields computed by the CFC modules that are not placed in +# the tavg file by default. +# +#1 pCFC11 +#1 pCFC12 +#1 CFC11_SCHMIDT +#1 CFC12_SCHMIDT +#1 CFC11_PV +#1 CFC11_surf_sat +#1 CFC12_PV +#1 CFC12_surf_sat +#=============================================================================== diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/ocn.ecosys.tavg.csh b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/ocn.ecosys.tavg.csh new file mode 100755 index 0000000000..b60beead06 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/ocn.ecosys.tavg.csh @@ -0,0 +1,248 @@ +#!/bin/csh -f +# +# DART note: this file started life as: +# /glade/p/cesmdata/cseg/collections/cesm1_1_1/models/ocn/pop2/input_templates/ocn.ecosys.tavg.csh + +cat >! $CASEBUILD/pop2conf/ecosys.tavg.nml << EOF +tavg_freq_opt = 'nday' 'nyear' +tavg_freq = 1 1 +tavg_file_freq_opt = 'nmonth' 'nyear' +tavg_file_freq = 1 1 +tavg_start_opt = 'nstep' 'nstep' +tavg_start = 0 0 +tavg_fmt_in = 'nc' 'nc' +tavg_fmt_out = 'nc' 'nc' +ltavg_has_offset_date = .false. .false. +tavg_offset_years = 1 1 +tavg_offset_months = 1 1 +tavg_offset_days = 2 2 +ltavg_one_time_header = .false. .false. +tavg_stream_filestrings = 'ecosys.nday1' 'ecosys.nyear1' +EOF + +#------------------------------------------------------------------------------------ +# For now, set streams manually. You must only set as many streams as are declared +# in the tavg_nml section. For example, if there are three streams: +# @ s1 = $my_stream +# @ s2 = $s1 + 1 +# @ s3 = $s2 + 1 +#------------------------------------------------------------------------------------ + +@ my_stream = $1 +if ($my_stream < 1) then + echo invalid my_stream number ($my_stream) + exit 5 +endif + +@ s1 = 1 # use the base-model stream 1 +@ s2 = $my_stream # use an ecosystem-defined stream +@ s3 = $s2 + 1 # use an ecosystem-defined stream + +cat >! $CASEROOT/Buildconf/pop2conf/ecosys_tavg_contents << EOF +$s1 ECOSYS_ATM_PRESS +$s1 ECOSYS_IFRAC +$s1 ECOSYS_XKW +$s1 SCHMIDT_O2 +$s1 SCHMIDT_CO2 +$s1 IRON_FLUX +$s1 NOx_FLUX +$s1 NHy_FLUX +$s1 PH +$s1 O2SAT +$s1 STF_O2 +$s1 CO2STAR +$s1 DCO2STAR +$s1 pCO2SURF +$s1 DpCO2 +$s1 FG_CO2 +$s1 ATM_CO2 +$s1 FvPER_DIC +$s1 FvICE_DIC +$s1 FvPER_ALK +$s1 FvICE_ALK +$s1 PO4 +$s1 NO3 +$s1 SiO3 +$s1 NH4 +$s1 Fe +$s1 O2 +$s1 O2_ZMIN +$s1 O2_ZMIN_DEPTH +$s1 O2_PRODUCTION +$s1 O2_CONSUMPTION +$s1 AOU +$s1 DIC +$s1 J_DIC +$s1 ALK +$s1 H2CO3 +$s1 HCO3 +$s1 CO3 +$s1 pH_3D +$s1 co3_sat_calc +$s1 zsatcalc +$s1 co3_sat_arag +$s1 zsatarag +$s1 DOC +$s1 DOC_prod +$s1 DOC_remin +$s1 spC +$s1 spChl +$s1 spCaCO3 +$s1 diatC +$s1 diatChl +$s1 zooC +$s1 spFe +$s1 diatSi +$s1 diatFe +$s1 diazC +$s1 diazChl +$s1 diazFe +$s1 DON +$s1 DOFe +$s1 DOP +$s1 graze_sp +$s1 graze_diat +$s1 graze_diaz +$s1 sp_agg +$s1 diat_agg +$s1 photoC_sp +$s1 CaCO3_form +$s1 photoC_diat +$s1 photoC_diaz +$s1 photoC_NO3_sp +$s1 photoC_NO3_diat +$s1 photoC_NO3_diaz +$s1 Fe_scavenge +$s1 Fe_scavenge_rate +$s1 diaz_Nfix +$s1 bSi_form +$s1 NITRIF +$s1 DENITRIF +$s1 POC_PROD +$s1 CaCO3_PROD +$s1 SiO2_PROD +$s1 P_iron_PROD +$s1 POC_FLUX_IN +$s1 CaCO3_FLUX_IN +$s1 SiO2_FLUX_IN +$s1 P_iron_FLUX_IN +$s1 PAR_avg +$s1 sp_Fe_lim +$s1 diat_Fe_lim +$s1 diaz_Fe_lim +$s1 sp_N_lim +$s1 diat_N_lim +$s1 sp_PO4_lim +$s1 diat_PO4_lim +$s1 diaz_P_lim +$s1 diat_SiO3_lim +$s1 sp_light_lim +$s1 diat_light_lim +$s1 diaz_light_lim +$s1 DON_prod +$s1 DOFe_prod +$s1 DOP_prod +$s1 sp_loss +$s1 diat_loss +$s1 zoo_loss +$s1 diaz_loss +$s1 Jint_100m_DIC +$s1 Jint_100m_NO3 +$s1 Jint_100m_NH4 +$s1 Jint_100m_PO4 +$s1 Jint_100m_Fe +$s1 Jint_100m_SiO3 +$s1 Jint_100m_ALK +$s1 Jint_100m_O2 +$s1 Jint_100m_DOC +$s1 tend_zint_100m_DIC +$s1 tend_zint_100m_NO3 +$s1 tend_zint_100m_NH4 +$s1 tend_zint_100m_PO4 +$s1 tend_zint_100m_Fe +$s1 tend_zint_100m_SiO3 +$s1 tend_zint_100m_ALK +$s1 tend_zint_100m_O2 +$s1 tend_zint_100m_DOC +$s2 photoC_sp_zint +$s2 CaCO3_form_zint +$s2 photoC_diaz_zint +$s2 photoC_diat_zint +$s1 photoC_NO3_sp_zint +$s1 photoC_NO3_diat_zint +$s1 photoC_NO3_diaz_zint +$s2 ECOSYS_IFRAC_2 +$s2 ECOSYS_XKW_2 +$s2 DpCO2_2 +$s2 FG_CO2_2 +$s2 STF_O2_2 +$s2 spC_zint_100m +$s2 spCaCO3_zint_100m +$s2 diazC_zint_100m +$s2 diatC_zint_100m +$s2 zooC_zint_100m +$s2 spChl_SURF +$s2 diazChl_SURF +$s2 diatChl_SURF +$s3 J_NO3 +$s3 J_NH4 +$s3 J_PO4 +$s3 J_Fe +$s3 J_SiO3 +$s3 J_ALK +$s3 UE_O2 +$s3 VN_O2 +$s3 WT_O2 +$s3 KPP_SRC_O2 +$s3 DIA_IMPVF_O2 +$s3 HDIFE_O2 +$s3 HDIFN_O2 +$s3 HDIFB_O2 +$s3 UE_DOC +$s3 VN_DOC +$s3 WT_DOC +$s3 DIA_IMPVF_DOC +$s3 HDIFE_DOC +$s3 HDIFN_DOC +$s3 HDIFB_DOC +$s3 UE_DIC +$s3 VN_DIC +$s3 WT_DIC +$s3 KPP_SRC_DIC +$s3 DIA_IMPVF_DIC +$s3 HDIFE_DIC +$s3 HDIFN_DIC +$s3 HDIFB_DIC +$s3 UE_Fe +$s3 VN_Fe +$s3 WT_Fe +$s3 KPP_SRC_Fe +$s3 DIA_IMPVF_Fe +$s3 HDIFE_Fe +$s3 HDIFN_Fe +$s3 HDIFB_Fe +EOF + +#1 dust_FLUX_IN +#1 DON_remin +#1 DOFe_remin +#1 DOP_remin +#1 photoFe_diaz +#1 photoFe_diat +#1 photoFe_sp +#1 Jint_PO4 +#1 Jint_NO3 +#1 Jint_SiO3 +#1 Jint_NH4 +#1 Jint_Fe +#1 Jint_O2 +#1 Jint_DIC +#1 Jint_ALK +#1 Jint_DOC +#1 Jint_spC +#1 Jint_spChl +#1 Jint_spCaCO3 +#1 Jint_diatC +#1 Jint_diatChl +#1 Jint_zooC + diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/ocn.iage.tavg.csh b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/ocn.iage.tavg.csh new file mode 100755 index 0000000000..67e66b5d1d --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/ocn.iage.tavg.csh @@ -0,0 +1,54 @@ +#!/bin/csh -f +# +# DART note: this file started life as: +# /glade/p/cesmdata/cseg/collections/cesm1_1_1/models/ocn/pop2/input_templates/ocn.iage.tavg.csh + +#------------------------------------------------------------------------------------ +# For now, set streams manually. You must only set as many streams as are declared +# in the tavg_nml section. For example, if there are three streams: +# @ s1 = $my_stream +# @ s2 = $s1 + 1 +# @ s3 = $s2 + 1 +#------------------------------------------------------------------------------------ + +@ my_stream = $1 +if ($my_stream < 1) then + echo invalid my_stream number $my_stream + exit 5 +endif + +@ s1 = 1 # use base-model stream 1 + +cat >! $CASEROOT/Buildconf/pop2conf/iage_tavg_contents << EOF +$s1 IAGE +EOF + +#------------------------------------------------------------------------------------- +# Add optional tracer budget terms +#------------------------------------------------------------------------------------- +if ($OCN_TAVG_TRACER_BUDGET == TRUE) then +cat >> $CASEROOT/Buildconf/pop2conf/iage_tavg_contents << EOF +$s1 IAGE_RESET_TEND +$s1 DIA_IMPVF_IAGE +$s1 HDIFE_IAGE +$s1 HDIFN_IAGE +$s1 HDIFB_IAGE +$s1 UE_IAGE +$s1 VN_IAGE +$s1 WT_IAGE +EOF +endif + +# disable the following until they are computed correctly +# IAGE_SQR +# UE_IAGE +# VN_IAGE +# WT_IAGE +# ADV_IAGE +# J_IAGE +# Jint_IAGE +# STF_IAGE +# RESID_IAGE +# FvPER_IAGE +# FvICE_IAGE + diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/overflows.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/overflows.F90 new file mode 100644 index 0000000000..3ab66a7a3b --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/overflows.F90 @@ -0,0 +1,5850 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1_1/models/ocn/pop2/source/overflows.F90 + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + + MODULE overflows + +!BOP +! !MODULE: overflows +! !DESCRIPTION: +! This module contains data types and routines for computing +! parameterized overflows. Overflows are sub-grid scale flows +! along topography thought to be important for bottom water +! formation. +! +! !REVISION HISTORY: +! SVN: +! + +! !USES: + + use POP_KindsMod + use POP_ErrorMod + use POP_BlocksMod + use POP_CommMod + use POP_ConfigMod + use POP_DistributionMod + use POP_DomainSizeMod + use POP_FieldMod + use POP_GridHorzMod + use POP_HaloMod + use POP_RedistributeMod + + use POP_SolversMod + + + use blocks + use broadcast + use communicate + use constants + use domain + use exit_mod + use global_reductions + use grid + use io_types + use kinds_mod + use prognostic + use time_management + use registry + use state_mod + + !*** ccsm + use gather_scatter + use shr_sys_mod + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + + public :: init_overflows1, & ! initial.F90 + init_overflows2, & ! initial.F90 + init_overflows_kmt, & + init_overflows_mask, & + init_overflows3, & ! initial.F90 + init_overflows4, & ! initial.F90 + init_overflows5, & ! initial.F90 + ovf_write_restart, & ! step_mod.F90 + ovf_read_restart, & ! init_overflows1 + ovf_read_broadcast, & + ovf_advt, & ! advection.F90 + ovf_wtkb_check, & ! advection.F90 + ovf_UV_check, & + ovf_Utlda, & ! baroclinic.F90 + ovf_driver, & ! step_mod.F90 + ovf_reg_avgs, & + ovf_transports, & + ovf_loc_prd, & + ovf_W, & + ovf_UV, & + ovf_rhs_brtrpc_momentum, & ! barotropic.F90 + ovf_brtrpc_renorm, & ! barotropic.F90 + ovf_rhs_brtrpc_continuity, & ! barotropic.F90 + ovf_solvers_9pt, & ! barotropic.F90 + ovf_HU, & + ovf_UV_solution ! step_mod.F90 + +! !PUBLIC DATA MEMBERS: + +!----------------------------------------------------------------------- +! list of nomenclature definitions +!----------------------------------------------------------------------- +! +! ovf = overflow +! inf = inflow (refering to inflow region) +! src = source (either region or grid box) +! ent = entrainment (either region or grid box) +! prd = product (either region or grid box) +! reg = region (for averaging density and tracers over region) +! adj = adjacent (for averaging density and tracers over adjacent boxes) +! num = number (usually refers to actual number used based on input) +! no. = number (usually refers to actual number used based on input) +! locs = locations (i.e. grid boxes) +! orient = orientation (1,2,3 or 4; refers to grid box sidewall) +! params = parameters +! ssb = shelf-slope break- shelf/slope transition to abyssal depth +! +!----------------------------------------------------------------------- +! define overflow types and parameters +!----------------------------------------------------------------------- + + logical (log_kind), public :: & + overflows_on, & ! true=on, false=off + overflows_interactive ! true=interactive ovf + + character (POP_charLength) :: & + overflows_infile, &! overflow info file + overflows_diag_outfile, &! current filename for overflow output diagnostics file + outfile_tmp ! temp for appending to outfile name + + character (POP_charLength), public :: & + overflows_restart_type, &! restart type (ccsm_startup, ccsm_continue, ccsm_hybrid, ccsm_branch) + overflows_restfile ! overflow restart file name + + integer (int_kind), parameter, public :: & + max_ovf = 10,& ! max no. ocean overflows + max_kmt = 200,& ! max no. overflow kmt changes + max_src = 50,& ! max no. overflow src locations + max_ent = 50,& ! max no. overflow ent locations + max_prd_sets = 20,& ! max no. overflow prd sets + max_prd = 50 ! max no. overflow prd locs each set + + integer (int_kind), public :: & + num_ovf ! no. of overflows from ovf info file + + type, public :: ovf_params ! parameters for each overflow + real (r8) :: & + lat ,& ! latitude (degrees) + width ,& ! strait width (cm) + source_thick ,& ! source water thickness (cm) + distnc_str_ssb ,& ! distance strait to ssb (cm) + bottom_slope ,& ! bottom slope beyond ssb + bottom_drag ! bottom drag coefficient + end type ovf_params + + type, public :: ovf_kmtbox ! overflow grid-box for kmt changes + integer (int_kind) :: & + i ,& ! x index + j ,& ! y index + korg ,& ! original kmt value + knew ! new kmt value + end type ovf_kmtbox + + type, public :: ovf_region ! overflow regional boundaries + integer (int_kind) :: & + imin ,& ! x index min + imax ,& ! x index max + jmin ,& ! y index min + jmax ,& ! y index ma + kmin ,& ! z index min + kmax ! z index max + end type ovf_region + + type, public :: ovf_mask_reg ! overflow regional mask + real (r8), dimension(nx_block,ny_block,max_blocks_clinic) :: & + inf ,& ! inflow region mask + src ,& ! source region mask + ent ! entrainment region mask + end type ovf_mask_reg + + type, public :: ovf_mask_adj ! overflow adjacent mask + real (r8) :: src(nx_block,ny_block,max_blocks_clinic), & ! src adj mask + ent(nx_block,ny_block,max_blocks_clinic) ! ent adj mask + real (r8) :: prd(nx_block,ny_block,max_blocks_clinic,max_prd_sets) ! prd adj mask(s) + end type ovf_mask_adj + + type, public :: ovf_mask_reg_wght ! overflow regional mask weight + real (r8) :: & + inf ,& ! inflow region mask weight + src ,& ! source region mask weight + ent ! entrainment region mask weight + end type ovf_mask_reg_wght + + type, public :: ovf_mask_adj_wght ! overflow adjacent mask weight + real (r8) :: & + src ,& ! source adj mask weight + ent ,& ! entrainment adj mask weight + prd(max_prd_sets) ! product adj mask weight(s) + end type ovf_mask_adj_wght + + type, public :: ovf_trcr_reg ! overflow regional tracers + real (r8), dimension(nt) :: & + inf ,& ! inflow region tracers + src ,& ! source region tracers + ent ,& ! entrainment region tracers + prd ! product region tracers + end type ovf_trcr_reg + + type, public :: ovf_trcr_adj ! overflow adjacent tracers + real (r8), dimension(nt) :: & + src ,& ! source adj tracers + ent ,& ! entrainment adj tracers + prd ! product adj tracers + end type ovf_trcr_adj + + type, public :: ovf_rho_reg ! overflow regional density + real (r8) :: & + inf ,& ! inflow region density + src ,& ! source region density + ent ! entrainment region density + end type ovf_rho_reg + + type, public :: ovf_rho_adj ! overflow adj density + real (r8) :: & + prd(max_prd_sets) ! product region density(s) + end type ovf_rho_adj + + type, public :: ovf_gridbox ! overflow grid-box info + integer (int_kind) :: & + i ,& ! x index for t grid + j ,& ! y index for t grid + k ,& ! z index for t grid + orient ,& ! sidewall orientation of t grid box + i_adv ,& ! x index for t grid advection + j_adv ,& ! y index for t grid advection + i_u ,& ! x index for u grid + j_u ,& ! y index for u grid + task_u ! task number for (i_u,j_u) + real (r8) :: & + Utlda(km) ,& ! UVEL "tilda" at (n+1) column speed on u grid + Vtlda(km) ,& ! VVEL "tilda" at (n+1) column speed on u grid + Uovf_nm1 ,& ! U at (n-1) speed on u grid + Uovf_n ,& ! U at (n) speed on u grid + Uovf ,& ! U at (n+1) speed on u grid + Wovf ! W at (n+1) vert speed on t grid + end type ovf_gridbox + +!------------------------------------------------------------------------------- +! type overflow that follows contains all diagnostic and prognostic +! data for each overflow; complete list for all overflows is contained +! in the array ovf. each overflow is specified by regions, grid locations, +! and adjacent locations. inf (inflow) and src (source) regions are +! geographically specified volumes from which density differences +! determine source transport Ms. this transport is assumed to flow into +! sidewall locations (possibly modified from original topography by any +! kmt changes) given by src locations, transporting mean tracers from +! adjacent grid boxes to the sidewall specified by adjacent boundaries. +! this transport moves unimpeded to the ent (entrainment) locations, where +! an entrainment region density along with source density (adjusted for +! depth changes) determines mixing. entrainment tracers from means along +! adjacent entrainment grid boxes are mixed with source tracers resulting +! in a total transport Mp and mixed product tracers. this product is then +! injected from a product sidewall for which the product density is neutral +! with the adjacent mean density. each product set is a group of points, +! and the collection of sets represents a product path of increasing depth. +! +! the reader is to be commended for taking in this tedious explanation. +! it is unfortunately necessary to explain the complexity of the overflow +! parameterization. +!------------------------------------------------------------------------------- + + type, public :: overflow ! individual overflow info + ! logicals and name + logical (log_kind) :: interactive ! T=ovf active with ocn + character (32) :: name ! name of ovf + ! parameters + type (ovf_params) :: ovf_params ! ovf specific params + ! kmt mods + integer (int_kind) :: num_kmt ! no. of kmt changes + type (ovf_kmtbox) :: loc_kmt(max_kmt) ! kmt locs + ! source locations + integer (int_kind) :: num_src ! no. of src locs + type (ovf_gridbox) :: loc_src(max_src) ! src locs + ! entrainment locations + integer (int_kind) :: num_ent ! no. of ent locs + type (ovf_gridbox) :: loc_ent(max_ent) ! ent locs + ! product sets (various injection locations) and point for each + integer (int_kind) :: num_prd_sets ! no. prd sets of pnts + integer (int_kind) :: num_prd(max_prd_sets) ! no. prd locs each set + type (ovf_gridbox) :: loc_prd(max_prd_sets,max_prd) ! prd locs + ! region locations, masks, tracer and density means for inf, src and ent + type (ovf_region) :: reg_inf ! inf reg boundaries + type (ovf_region) :: reg_src ! src reg boundaries + type (ovf_region) :: reg_ent ! ent reg boundaries + type (ovf_mask_reg) :: mask_reg ! regional inf, src, ent masks + type (ovf_mask_reg_wght) :: wght_reg ! regional mask weights + type (ovf_trcr_reg) :: trcr_reg ! regional tracers + type (ovf_rho_reg) :: rho_reg ! regional densities + ! adjacent locations, masks, tracer and density means for src, ent and prd + type (ovf_region) :: adj_src ! src adj boundaries + type (ovf_region) :: adj_ent ! ent adj boundaries + type (ovf_region) :: adj_prd(max_prd_sets) ! prd adj boundaries + type (ovf_mask_adj) :: mask_adj ! adj mask + type (ovf_mask_adj_wght) :: wght_adj ! adj mask weights + type (ovf_trcr_adj) :: trcr_adj ! adjacent tracers + type (ovf_rho_adj) :: rho_adj ! regional densities + ! overflow transports and state + real (r8) :: Ms ! src mass flux (Sv) + real (r8) :: Ms_n ! src mass flux (Sv) at n + real (r8) :: Ms_nm1 ! src mass flux (Sv) at n-1 + real (r8) :: Me ! ent mass flux (Sv) + real (r8) :: Me_n ! ent mass flux (Sv) at n + real (r8) :: Me_nm1 ! ent mass flux (Sv) at n-1 + real (r8) :: phi ! ent parameter (Me/Mp) + real (r8) :: Mp ! prd mass flux (Sv) + real (r8) :: Mp_n ! prd mass flux (Sv) at n + real (r8) :: Mp_nm1 ! prd mass flux (Sv) at n-1 + real (r8) :: Tp ! prd temperature (C) + real (r8) :: Sp ! prd salinity (ppt) + integer (int_kind) :: prd_set_n ! prd set index previous time step + integer (int_kind) :: prd_set ! prd set index + end type overflow + + type (overflow), dimension(max_ovf), public :: ovf ! contains all overflow info + + integer (POP_i4) :: & + errorCode + +!EOC +!----------------------------------------------------------------------- +! +! controls for frequency and output of diagnostics +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + ovf_diag_unit ! i/o unit for overflow output diagnostics file + + character (char_len) :: & + ccsm_diag_date + + logical (log_kind) :: & + lccsm = .false. + + character (10) :: & + cdate ! character date + +!*********************************************************************** + + contains + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows1 +! !INTERFACE: + + subroutine init_overflows1 + +! !DESCRIPTION: +! This routine is the first of four which together initialize the overflow +! parameterization. It reads the namelist and overflow_infile (text file +! containing ovf info). See info file comments for description of text file +! format. This routine also computes prd region limits based on prd input, +! writes out to stdout and overflows_diag_outfile, and then broadcasts ovf info +! to all processors. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + save + + namelist /overflows_nml/ overflows_on, overflows_interactive, & + overflows_infile, overflows_diag_outfile, & + overflows_restart_type, overflows_restfile + + integer (i4) :: & + index, &! overflow index + nu, &! unit for overflow input file + nml_error, &! namelist i/o error flag + ovf_error, &! ovf i/o error flag + num_req, &! number requested for error message + imin, &! i index for checking input order + jmin, &! j index for checking input order + kmin, &! k index for checking input number of levels + ornt ! orientation for checking constancy + + character (88) :: line ! temporary for line of text input/output + + integer (int_kind) :: & + n, &! ovf loop index + m, &! sub-ovf loop index + nn, &! tracer loop index + mp, &! sub-ovf sub-loop index + i,j, &! horizontal loop indices + k, &! vertical loop index + iblock, &! local block address + ib,ie,jb,je, &! local domain index boundaries + di,dj ! orientation adjustments in i,j + + type (block) :: & + this_block ! block information for current block + +!----------------------------------------------------------------------- +! read overflow namelist +!----------------------------------------------------------------------- + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,'(a11)') ' Overflows:' + write(stdout,blank_fmt) + call shr_sys_flush(stdout) + endif + + overflows_on = .false. + overflows_interactive = .false. + overflows_infile = 'unknown_ovf_infile' + overflows_diag_outfile = 'unknown_ovf_outfile' + overflows_restart_type = 'ccsm_startup' + overflows_restfile = 'unknown_ovf_restfile' + + if (my_task == master_task) then + open (nml_in, file=nml_filename, status='old',iostat=nml_error) + if (nml_error /= 0) then + nml_error = -1 + else + nml_error = 1 + endif + do while (nml_error > 0) + read(nml_in, nml=overflows_nml,iostat=nml_error) + end do + if (nml_error == 0) close(nml_in) + endif + + call broadcast_scalar(nml_error, master_task) + if (nml_error /= 0) then + call exit_POP(sigAbort,'ERROR reading overflows_nml') + endif + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,'(a33)') ' overflows_nml namelist settings:' + write(stdout,blank_fmt) + write(stdout,overflows_nml) + write(stdout,blank_fmt) + call shr_sys_flush(stdout) + endif + + call broadcast_scalar(overflows_on, master_task) + call broadcast_scalar(overflows_interactive, master_task) + call broadcast_scalar(overflows_infile, master_task) + call broadcast_scalar(overflows_diag_outfile, master_task) + call broadcast_scalar(overflows_restart_type, master_task) + call broadcast_scalar(overflows_restfile, master_task) + +!----------------------------------------------------------------------- +! if overflows off, exit +!----------------------------------------------------------------------- + + if( .not. overflows_on ) return + +!----------------------------------------------------------------------- +! +! determine if this is a ccsm coupled run +!----------------------------------------------------------------------- + + lccsm = registry_match('lccsm') + +!----------------------------------------------------------------------- +! overflows on; read overflows info file if ccsm_startup; otherwise +! read restart data +!----------------------------------------------------------------------- + + if( overflows_restart_type == 'ccsm_startup' ) then + + ovf_error = 0 + call get_unit(nu) + +!----------------------------------------------------------------------- +! master task section +!----------------------------------------------------------------------- + + if (my_task == master_task) then + + open(nu, file=overflows_infile, status='old',iostat=ovf_error) + + write(stdout,2345) ovf_error + 2345 format(' after open nu ovf_error=',i5) + write(stdout,'(a41)') 'reading overflows_infile: contents echoed' + call shr_sys_flush(stdout) + + do m=1,40 + read(nu,'(a88)') line + write(stdout,'(a88)') line + end do + + read(nu,*) num_ovf + write(stdout,*) num_ovf + call shr_sys_flush(stdout) + if( num_ovf <= 0 .or. num_ovf > max_ovf ) then + ovf_error = 1 + num_req = num_ovf + goto 10 + endif + + do n=1,num_ovf + ovf(n)%interactive = overflows_interactive + read(nu,*) index,ovf(n)%name + write(stdout,*) index,ovf(n)%name + + read(nu,*) ovf(n)%ovf_params%lat + read(nu,*) ovf(n)%ovf_params%width + read(nu,*) ovf(n)%ovf_params%source_thick + read(nu,*) ovf(n)%ovf_params%distnc_str_ssb + read(nu,*) ovf(n)%ovf_params%bottom_slope + read(nu,*) ovf(n)%ovf_params%bottom_drag + + write(stdout,*) ovf(n)%ovf_params%lat + write(stdout,*) ovf(n)%ovf_params%width + write(stdout,*) ovf(n)%ovf_params%source_thick + write(stdout,*) ovf(n)%ovf_params%distnc_str_ssb + write(stdout,*) ovf(n)%ovf_params%bottom_slope + write(stdout,*) ovf(n)%ovf_params%bottom_drag + call shr_sys_flush(stdout) + +! kmt changes if any + read(nu,*) ovf(n)%num_kmt + write(stdout,*) ovf(n)%num_kmt + if( ovf(n)%num_kmt < 0 .or. ovf(n)%num_kmt > max_kmt ) then + ovf_error = 2 + num_req = ovf(n)%num_kmt + goto 10 + endif + do m=1,ovf(n)%num_kmt + read(nu,*) ovf(n)%loc_kmt(m)%i, & + ovf(n)%loc_kmt(m)%j, & + ovf(n)%loc_kmt(m)%korg, & + ovf(n)%loc_kmt(m)%knew + write(stdout,*) ovf(n)%loc_kmt(m)%i, & + ovf(n)%loc_kmt(m)%j, & + ovf(n)%loc_kmt(m)%korg, & + ovf(n)%loc_kmt(m)%knew + end do + call shr_sys_flush(stdout) + + read(nu,*) + +! inf,src and ent region limits + read(nu,*) ovf(n)%reg_inf%imin, & + ovf(n)%reg_inf%imax, & + ovf(n)%reg_inf%jmin, & + ovf(n)%reg_inf%jmax, & + ovf(n)%reg_inf%kmin, & + ovf(n)%reg_inf%kmax + read(nu,*) ovf(n)%reg_src%imin, & + ovf(n)%reg_src%imax, & + ovf(n)%reg_src%jmin, & + ovf(n)%reg_src%jmax, & + ovf(n)%reg_src%kmin, & + ovf(n)%reg_src%kmax + read(nu,*) ovf(n)%reg_ent%imin, & + ovf(n)%reg_ent%imax, & + ovf(n)%reg_ent%jmin, & + ovf(n)%reg_ent%jmax, & + ovf(n)%reg_ent%kmin, & + ovf(n)%reg_ent%kmax + + write(stdout,*) ovf(n)%reg_inf%imin, & + ovf(n)%reg_inf%imax, & + ovf(n)%reg_inf%jmin, & + ovf(n)%reg_inf%jmax, & + ovf(n)%reg_inf%kmin, & + ovf(n)%reg_inf%kmax + write(stdout,*) ovf(n)%reg_src%imin, & + ovf(n)%reg_src%imax, & + ovf(n)%reg_src%jmin, & + ovf(n)%reg_src%jmax, & + ovf(n)%reg_src%kmin, & + ovf(n)%reg_src%kmax + write(stdout,*) ovf(n)%reg_ent%imin, & + ovf(n)%reg_ent%imax, & + ovf(n)%reg_ent%jmin, & + ovf(n)%reg_ent%jmax, & + ovf(n)%reg_ent%kmin, & + ovf(n)%reg_ent%kmax + call shr_sys_flush(stdout) + +! src points + read(nu,*) ovf(n)%num_src + write(stdout,*) ovf(n)%num_src + if( ovf(n)%num_src <= 1 .or. ovf(n)%num_src > max_src ) then + ovf_error = 3 + num_req = ovf(n)%num_src + goto 10 + endif + do m=1,ovf(n)%num_src + read(nu,*) ovf(n)%loc_src(m)%i, & + ovf(n)%loc_src(m)%j, & + ovf(n)%loc_src(m)%k, & + ovf(n)%loc_src(m)%orient + if ( ovf(n)%loc_src(m)%orient .eq. 1 ) then + ovf(n)%loc_src(m)%i_adv = ovf(n)%loc_src(m)%i + 1 + ovf(n)%loc_src(m)%j_adv = ovf(n)%loc_src(m)%j + ovf(n)%loc_src(m)%i_u = ovf(n)%loc_src(m)%i + ovf(n)%loc_src(m)%j_u = ovf(n)%loc_src(m)%j +! some u corner points i_u,j_u zeroed because they are inactive + if( m == ovf(n)%num_src ) then + ovf(n)%loc_src(m)%i_u = 0 + ovf(n)%loc_src(m)%j_u = 0 + endif + else if( ovf(n)%loc_src(m)%orient .eq. 2 ) then + ovf(n)%loc_src(m)%i_adv = ovf(n)%loc_src(m)%i + ovf(n)%loc_src(m)%j_adv = ovf(n)%loc_src(m)%j + 1 + ovf(n)%loc_src(m)%i_u = ovf(n)%loc_src(m)%i - 1 + if(ovf(n)%loc_src(m)%i_u==0) ovf(n)%loc_src(m)%i_u = nx_global + ovf(n)%loc_src(m)%j_u = ovf(n)%loc_src(m)%j + if( m == 1 ) then + ovf(n)%loc_src(m)%i_u = 0 + ovf(n)%loc_src(m)%j_u = 0 + endif + else if( ovf(n)%loc_src(m)%orient .eq. 3 ) then + ovf(n)%loc_src(m)%i_adv = ovf(n)%loc_src(m)%i - 1 + if(ovf(n)%loc_src(m)%i_adv==0) ovf(n)%loc_src(m)%i_adv = nx_global + ovf(n)%loc_src(m)%j_adv = ovf(n)%loc_src(m)%j + ovf(n)%loc_src(m)%i_u = ovf(n)%loc_src(m)%i - 1 + if(ovf(n)%loc_src(m)%i_u==0) ovf(n)%loc_src(m)%i_u = nx_global + ovf(n)%loc_src(m)%j_u = ovf(n)%loc_src(m)%j - 1 + if( m == 1 ) then + ovf(n)%loc_src(m)%i_u = 0 + ovf(n)%loc_src(m)%j_u = 0 + endif + else if( ovf(n)%loc_src(m)%orient .eq. 4 ) then + ovf(n)%loc_src(m)%i_adv = ovf(n)%loc_src(m)%i + ovf(n)%loc_src(m)%j_adv = ovf(n)%loc_src(m)%j - 1 + ovf(n)%loc_src(m)%i_u = ovf(n)%loc_src(m)%i + ovf(n)%loc_src(m)%j_u = ovf(n)%loc_src(m)%j - 1 + if( m == ovf(n)%num_src ) then + ovf(n)%loc_src(m)%i_u = 0 + ovf(n)%loc_src(m)%j_u = 0 + endif + endif + write(stdout,*) ovf(n)%loc_src(m)%i, & + ovf(n)%loc_src(m)%j, & + ovf(n)%loc_src(m)%k, & + ovf(n)%loc_src(m)%orient + call shr_sys_flush(stdout) +! check order of ij, constancy of k and range of orient + if( m==1 ) then + imin = ovf(n)%loc_src(m)%i + jmin = ovf(n)%loc_src(m)%j + kmin = ovf(n)%loc_src(m)%k + if( ovf(n)%loc_src(m)%orient < 1 .or. & + ovf(n)%loc_src(m)%orient > 4 ) then + ovf_error = 11 + goto 10 + endif + ornt = ovf(n)%loc_src(m)%orient + else + if( ovf(n)%loc_src(m)%i < imin ) then + ovf_error = 7 + goto 10 + endif + if( ovf(n)%loc_src(m)%j < jmin ) then + ovf_error = 7 + goto 10 + endif + if( ovf(n)%loc_src(m)%i == imin .and. & + ovf(n)%loc_src(m)%j == jmin) then + ovf_error = 8 + goto 10 + endif + if( ovf(n)%loc_src(m)%i > imin .and. & + ovf(n)%loc_src(m)%j > jmin) then + ovf_error = 9 + goto 10 + endif + if( ovf(n)%loc_src(m)%k /= kmin ) then + ovf_error = 10 + goto 10 + endif + if( ovf(n)%loc_src(m)%orient < 1 .or. & + ovf(n)%loc_src(m)%orient > 4 ) then + ovf_error = 11 + goto 10 + endif + if( ovf(n)%loc_src(m)%orient /= ornt ) then + ovf_error = 12 + goto 10 + endif + imin = ovf(n)%loc_src(m)%i + jmin = ovf(n)%loc_src(m)%j + kmin = ovf(n)%loc_src(m)%k + ornt = ovf(n)%loc_src(m)%orient + endif + end do + +! ent points + read(nu,*) ovf(n)%num_ent + write(stdout,*) ovf(n)%num_ent + if( ovf(n)%num_ent <= 1 .or. ovf(n)%num_ent > max_ent ) then + ovf_error = 4 + num_req = ovf(n)%num_ent + goto 10 + endif + do m=1,ovf(n)%num_ent + read(nu,*) ovf(n)%loc_ent(m)%i, & + ovf(n)%loc_ent(m)%j, & + ovf(n)%loc_ent(m)%k, & + ovf(n)%loc_ent(m)%orient + if ( ovf(n)%loc_ent(m)%orient .eq. 1 ) then + ovf(n)%loc_ent(m)%i_adv = ovf(n)%loc_ent(m)%i + 1 + ovf(n)%loc_ent(m)%j_adv = ovf(n)%loc_ent(m)%j + ovf(n)%loc_ent(m)%i_u = ovf(n)%loc_ent(m)%i + ovf(n)%loc_ent(m)%j_u = ovf(n)%loc_ent(m)%j +! some u corner points i_u,j_u zeroed because they are inactive + if( m == ovf(n)%num_ent ) then + ovf(n)%loc_ent(m)%i_u = 0 + ovf(n)%loc_ent(m)%j_u = 0 + endif + else if( ovf(n)%loc_ent(m)%orient .eq. 2 ) then + ovf(n)%loc_ent(m)%i_adv = ovf(n)%loc_ent(m)%i + ovf(n)%loc_ent(m)%j_adv = ovf(n)%loc_ent(m)%j + 1 + ovf(n)%loc_ent(m)%i_u = ovf(n)%loc_ent(m)%i - 1 + if(ovf(n)%loc_ent(m)%i_u==0) ovf(n)%loc_ent(m)%i_u = nx_global + ovf(n)%loc_ent(m)%j_u = ovf(n)%loc_ent(m)%j + if( m == 1 ) then + ovf(n)%loc_ent(m)%i_u = 0 + ovf(n)%loc_ent(m)%j_u = 0 + endif + else if( ovf(n)%loc_ent(m)%orient .eq. 3 ) then + ovf(n)%loc_ent(m)%i_adv = ovf(n)%loc_ent(m)%i - 1 + if(ovf(n)%loc_ent(m)%i_adv==0) ovf(n)%loc_ent(m)%i_adv = nx_global + ovf(n)%loc_ent(m)%j_adv = ovf(n)%loc_ent(m)%j + ovf(n)%loc_ent(m)%i_u = ovf(n)%loc_ent(m)%i - 1 + if(ovf(n)%loc_ent(m)%i_u==0) ovf(n)%loc_ent(m)%i_u = nx_global + ovf(n)%loc_ent(m)%j_u = ovf(n)%loc_ent(m)%j - 1 + if( m == 1 ) then + ovf(n)%loc_ent(m)%i_u = 0 + ovf(n)%loc_ent(m)%j_u = 0 + endif + else if( ovf(n)%loc_ent(m)%orient .eq. 4 ) then + ovf(n)%loc_ent(m)%i_adv = ovf(n)%loc_ent(m)%i + ovf(n)%loc_ent(m)%j_adv = ovf(n)%loc_ent(m)%j - 1 + ovf(n)%loc_ent(m)%i_u = ovf(n)%loc_ent(m)%i + ovf(n)%loc_ent(m)%j_u = ovf(n)%loc_ent(m)%j - 1 + if( m == ovf(n)%num_ent ) then + ovf(n)%loc_ent(m)%i_u = 0 + ovf(n)%loc_ent(m)%j_u = 0 + endif + endif + write(stdout,*) ovf(n)%loc_ent(m)%i, & + ovf(n)%loc_ent(m)%j, & + ovf(n)%loc_ent(m)%k, & + ovf(n)%loc_ent(m)%orient + call shr_sys_flush(stdout) +! check order of ij, constancy of k and range of orient + if( m==1 ) then + imin = ovf(n)%loc_ent(m)%i + jmin = ovf(n)%loc_ent(m)%j + kmin = ovf(n)%loc_ent(m)%k + if( ovf(n)%loc_ent(m)%orient < 1 .or. & + ovf(n)%loc_ent(m)%orient > 4 ) then + ovf_error = 11 + goto 10 + endif + ornt = ovf(n)%loc_ent(m)%orient + else + if( ovf(n)%loc_ent(m)%i < imin ) then + ovf_error = 7 + goto 10 + endif + if( ovf(n)%loc_ent(m)%j < jmin ) then + ovf_error = 7 + goto 10 + endif + if( ovf(n)%loc_ent(m)%i == imin .and. & + ovf(n)%loc_ent(m)%j == jmin) then + ovf_error = 8 + goto 10 + endif + if( ovf(n)%loc_ent(m)%i > imin .and. & + ovf(n)%loc_ent(m)%j > jmin) then + ovf_error = 9 + goto 10 + endif + if( ovf(n)%loc_ent(m)%k /= kmin ) then + ovf_error = 10 + goto 10 + endif + if( ovf(n)%loc_ent(m)%orient < 1 .or. & + ovf(n)%loc_ent(m)%orient > 4 ) then + ovf_error = 11 + goto 10 + endif + if( ovf(n)%loc_ent(m)%orient /= ornt ) then + ovf_error = 12 + goto 10 + endif + imin = ovf(n)%loc_ent(m)%i + jmin = ovf(n)%loc_ent(m)%j + kmin = ovf(n)%loc_ent(m)%k + ornt = ovf(n)%loc_ent(m)%orient + endif + end do + call shr_sys_flush(stdout) + +! prd points + read(nu,*) ovf(n)%num_prd_sets + write(stdout,*) ovf(n)%num_prd_sets + if(ovf(n)%num_prd_sets<=0.or.ovf(n)%num_prd_sets>max_prd_sets) then + ovf_error = 5 + num_req = ovf(n)%num_prd_sets + goto 10 + endif + do m=1,ovf(n)%num_prd_sets + read(nu,*) ovf(n)%num_prd(m) + write(stdout,*) ovf(n)%num_prd(m) + if( ovf(n)%num_prd(m)<=1.or.ovf(n)%num_prd(m)>max_prd) then + ovf_error = 6 + num_req = ovf(n)%num_prd(m) + goto 10 + endif + do mp=1,ovf(n)%num_prd(m) + read(nu,*) ovf(n)%loc_prd(m,mp)%i, & + ovf(n)%loc_prd(m,mp)%j, & + ovf(n)%loc_prd(m,mp)%k, & + ovf(n)%loc_prd(m,mp)%orient + if ( ovf(n)%loc_prd(m,mp)%orient .eq. 1 ) then + ovf(n)%loc_prd(m,mp)%i_adv = ovf(n)%loc_prd(m,mp)%i + 1 + ovf(n)%loc_prd(m,mp)%j_adv = ovf(n)%loc_prd(m,mp)%j + ovf(n)%loc_prd(m,mp)%i_u = ovf(n)%loc_prd(m,mp)%i + ovf(n)%loc_prd(m,mp)%j_u = ovf(n)%loc_prd(m,mp)%j +! some u corner points i_u,j_u zeroed because they are inactive + if( mp == ovf(n)%num_prd(m) ) then + ovf(n)%loc_prd(m,mp)%i_u = 0 + ovf(n)%loc_prd(m,mp)%j_u = 0 + endif + else if( ovf(n)%loc_prd(m,mp)%orient .eq. 2 ) then + ovf(n)%loc_prd(m,mp)%i_adv = ovf(n)%loc_prd(m,mp)%i + ovf(n)%loc_prd(m,mp)%j_adv = ovf(n)%loc_prd(m,mp)%j + 1 + ovf(n)%loc_prd(m,mp)%i_u = ovf(n)%loc_prd(m,mp)%i - 1 + if(ovf(n)%loc_prd(m,mp)%i_u==0) ovf(n)%loc_prd(m,mp)%i_u = nx_global + ovf(n)%loc_prd(m,mp)%j_u = ovf(n)%loc_prd(m,mp)%j + if( mp == 1 ) then + ovf(n)%loc_prd(m,mp)%i_u = 0 + ovf(n)%loc_prd(m,mp)%j_u = 0 + endif + else if( ovf(n)%loc_prd(m,mp)%orient .eq. 3 ) then + ovf(n)%loc_prd(m,mp)%i_adv = ovf(n)%loc_prd(m,mp)%i - 1 + if(ovf(n)%loc_prd(m,mp)%i_adv==0) ovf(n)%loc_prd(m,mp)%i_adv = nx_global + ovf(n)%loc_prd(m,mp)%j_adv = ovf(n)%loc_prd(m,mp)%j + ovf(n)%loc_prd(m,mp)%i_u = ovf(n)%loc_prd(m,mp)%i - 1 + if(ovf(n)%loc_prd(m,mp)%i_u==0) ovf(n)%loc_prd(m,mp)%i_u = nx_global + ovf(n)%loc_prd(m,mp)%j_u = ovf(n)%loc_prd(m,mp)%j - 1 + if( mp == 1 ) then + ovf(n)%loc_prd(m,mp)%i_u = 0 + ovf(n)%loc_prd(m,mp)%j_u = 0 + endif + else if( ovf(n)%loc_prd(m,mp)%orient .eq. 4 ) then + ovf(n)%loc_prd(m,mp)%i_adv = ovf(n)%loc_prd(m,mp)%i + ovf(n)%loc_prd(m,mp)%j_adv = ovf(n)%loc_prd(m,mp)%j - 1 + ovf(n)%loc_prd(m,mp)%i_u = ovf(n)%loc_prd(m,mp)%i + ovf(n)%loc_prd(m,mp)%j_u = ovf(n)%loc_prd(m,mp)%j - 1 + if( mp == ovf(n)%num_prd(m) ) then + ovf(n)%loc_prd(m,mp)%i_u = 0 + ovf(n)%loc_prd(m,mp)%j_u = 0 + endif + endif + write(stdout,*) ovf(n)%loc_prd(m,mp)%i, & + ovf(n)%loc_prd(m,mp)%j, & + ovf(n)%loc_prd(m,mp)%k, & + ovf(n)%loc_prd(m,mp)%orient + call shr_sys_flush(stdout) +! check order of ij, constancy of k and range of orient + if( mp==1 ) then + imin = ovf(n)%loc_prd(m,mp)%i + jmin = ovf(n)%loc_prd(m,mp)%j + kmin = ovf(n)%loc_prd(m,mp)%k + if( ovf(n)%loc_prd(m,mp)%orient < 1 .or. & + ovf(n)%loc_prd(m,mp)%orient > 4 ) then + ovf_error = 11 + goto 10 + endif + ornt = ovf(n)%loc_prd(m,mp)%orient + else + if( ovf(n)%loc_prd(m,mp)%i < imin ) then + ovf_error = 7 + goto 10 + endif + if( ovf(n)%loc_prd(m,mp)%j < jmin ) then + ovf_error = 7 + goto 10 + endif + if( ovf(n)%loc_prd(m,mp)%i == imin .and. & + ovf(n)%loc_prd(m,mp)%j == jmin) then + ovf_error = 8 + goto 10 + endif + if( ovf(n)%loc_prd(m,mp)%i > imin .and. & + ovf(n)%loc_prd(m,mp)%j > jmin) then + ovf_error = 9 + goto 10 + endif + if( ovf(n)%loc_prd(m,mp)%k /= kmin ) then + ovf_error = 10 + goto 10 + endif + if( ovf(n)%loc_prd(m,mp)%orient < 1 .or. & + ovf(n)%loc_prd(m,mp)%orient > 4 ) then + ovf_error = 11 + goto 10 + endif + if( ovf(n)%loc_prd(m,mp)%orient /= ornt ) then + ovf_error = 12 + goto 10 + endif + imin = ovf(n)%loc_prd(m,mp)%i + jmin = ovf(n)%loc_prd(m,mp)%j + kmin = ovf(n)%loc_prd(m,mp)%k + ornt = ovf(n)%loc_prd(m,mp)%orient + endif + end do + call shr_sys_flush(stdout) + end do + +! find src adj limits + di = 0 + dj = 0 + if( ovf(n)%loc_src(1)%orient .eq. 1 ) di = +1 + if( ovf(n)%loc_src(1)%orient .eq. 2 ) dj = +1 + if( ovf(n)%loc_src(1)%orient .eq. 3 ) di = -1 + if( ovf(n)%loc_src(1)%orient .eq. 4 ) dj = -1 + ovf(n)%adj_src%imin = ovf(n)%loc_src(1)%i+di + ovf(n)%adj_src%jmin = ovf(n)%loc_src(1)%j+dj + ovf(n)%adj_src%kmin = ovf(n)%loc_src(1)%k + ovf(n)%adj_src%imax = ovf(n)%loc_src(1)%i+di + ovf(n)%adj_src%jmax = ovf(n)%loc_src(1)%j+dj + ovf(n)%adj_src%kmax = ovf(n)%loc_src(1)%k + do m=2,ovf(n)%num_src + di = 0 + dj = 0 + if( ovf(n)%loc_src(m)%orient .eq. 1 ) di = +1 + if( ovf(n)%loc_src(m)%orient .eq. 2 ) dj = +1 + if( ovf(n)%loc_src(m)%orient .eq. 3 ) di = -1 + if( ovf(n)%loc_src(m)%orient .eq. 4 ) dj = -1 + ovf(n)%adj_src%imin = min & + (ovf(n)%adj_src%imin,ovf(n)%loc_src(m)%i+di) + ovf(n)%adj_src%jmin = min & + (ovf(n)%adj_src%jmin,ovf(n)%loc_src(m)%j+dj) + ovf(n)%adj_src%kmin = min & + (ovf(n)%adj_src%kmin,ovf(n)%loc_src(m)%k) + ovf(n)%adj_src%imax = max & + (ovf(n)%adj_src%imax,ovf(n)%loc_src(m)%i+di) + ovf(n)%adj_src%jmax = max & + (ovf(n)%adj_src%jmax,ovf(n)%loc_src(m)%j+dj) + ovf(n)%adj_src%kmax = max & + (ovf(n)%adj_src%kmax,ovf(n)%loc_src(m)%k) + end do +! print src adj limits + write(stdout,13) & + ovf(n)%adj_src%imin, & + ovf(n)%adj_src%imax, & + ovf(n)%adj_src%jmin, & + ovf(n)%adj_src%jmax, & + ovf(n)%adj_src%kmin, & + ovf(n)%adj_src%kmax +13 format(' Computed source adjacent ijk min/max =',6(i4,2x)) + +! find ent adj limits + di = 0 + dj = 0 + if( ovf(n)%loc_ent(1)%orient .eq. 1 ) di = +1 + if( ovf(n)%loc_ent(1)%orient .eq. 2 ) dj = +1 + if( ovf(n)%loc_ent(1)%orient .eq. 3 ) di = -1 + if( ovf(n)%loc_ent(1)%orient .eq. 4 ) dj = -1 + ovf(n)%adj_ent%imin = ovf(n)%loc_ent(1)%i+di + ovf(n)%adj_ent%jmin = ovf(n)%loc_ent(1)%j+dj + ovf(n)%adj_ent%kmin = ovf(n)%loc_ent(1)%k + ovf(n)%adj_ent%imax = ovf(n)%loc_ent(1)%i+di + ovf(n)%adj_ent%jmax = ovf(n)%loc_ent(1)%j+dj + ovf(n)%adj_ent%kmax = ovf(n)%loc_ent(1)%k + do m=2,ovf(n)%num_ent + di = 0 + dj = 0 + if( ovf(n)%loc_ent(m)%orient .eq. 1 ) di = +1 + if( ovf(n)%loc_ent(m)%orient .eq. 2 ) dj = +1 + if( ovf(n)%loc_ent(m)%orient .eq. 3 ) di = -1 + if( ovf(n)%loc_ent(m)%orient .eq. 4 ) dj = -1 + ovf(n)%adj_ent%imin = min & + (ovf(n)%adj_ent%imin,ovf(n)%loc_ent(m)%i+di) + ovf(n)%adj_ent%jmin = min & + (ovf(n)%adj_ent%jmin,ovf(n)%loc_ent(m)%j+dj) + ovf(n)%adj_ent%kmin = min & + (ovf(n)%adj_ent%kmin,ovf(n)%loc_ent(m)%k) + ovf(n)%adj_ent%imax = max & + (ovf(n)%adj_ent%imax,ovf(n)%loc_ent(m)%i+di) + ovf(n)%adj_ent%jmax = max & + (ovf(n)%adj_ent%jmax,ovf(n)%loc_ent(m)%j+dj) + ovf(n)%adj_ent%kmax = max & + (ovf(n)%adj_ent%kmax,ovf(n)%loc_ent(m)%k) + end do +! print ent adj limits + write(stdout,14) & + ovf(n)%adj_ent%imin, & + ovf(n)%adj_ent%imax, & + ovf(n)%adj_ent%jmin, & + ovf(n)%adj_ent%jmax, & + ovf(n)%adj_ent%kmin, & + ovf(n)%adj_ent%kmax +14 format(' Computed entrainment adjacent ijk min/max =',6(i4,2x)) + +! find prd adj limits + do m=1,ovf(n)%num_prd_sets + di = 0 + dj = 0 + if( ovf(n)%loc_prd(m,1)%orient .eq. 1 ) di = +1 + if( ovf(n)%loc_prd(m,1)%orient .eq. 2 ) dj = +1 + if( ovf(n)%loc_prd(m,1)%orient .eq. 3 ) di = -1 + if( ovf(n)%loc_prd(m,1)%orient .eq. 4 ) dj = -1 + ovf(n)%adj_prd(m)%imin = ovf(n)%loc_prd(m,1)%i+di + ovf(n)%adj_prd(m)%jmin = ovf(n)%loc_prd(m,1)%j+dj + ovf(n)%adj_prd(m)%kmin = ovf(n)%loc_prd(m,1)%k + ovf(n)%adj_prd(m)%imax = ovf(n)%loc_prd(m,1)%i+di + ovf(n)%adj_prd(m)%jmax = ovf(n)%loc_prd(m,1)%j+dj + ovf(n)%adj_prd(m)%kmax = ovf(n)%loc_prd(m,1)%k + do mp=2,ovf(n)%num_prd(m) + di = 0 + dj = 0 + if( ovf(n)%loc_prd(m,mp)%orient .eq. 1 ) di = +1 + if( ovf(n)%loc_prd(m,mp)%orient .eq. 2 ) dj = +1 + if( ovf(n)%loc_prd(m,mp)%orient .eq. 3 ) di = -1 + if( ovf(n)%loc_prd(m,mp)%orient .eq. 4 ) dj = -1 + ovf(n)%adj_prd(m)%imin = min & + (ovf(n)%adj_prd(m)%imin,ovf(n)%loc_prd(m,mp)%i+di) + ovf(n)%adj_prd(m)%jmin = min & + (ovf(n)%adj_prd(m)%jmin,ovf(n)%loc_prd(m,mp)%j+dj) + ovf(n)%adj_prd(m)%kmin = min & + (ovf(n)%adj_prd(m)%kmin,ovf(n)%loc_prd(m,mp)%k) + ovf(n)%adj_prd(m)%imax = max & + (ovf(n)%adj_prd(m)%imax,ovf(n)%loc_prd(m,mp)%i+di) + ovf(n)%adj_prd(m)%jmax = max & + (ovf(n)%adj_prd(m)%jmax,ovf(n)%loc_prd(m,mp)%j+dj) + ovf(n)%adj_prd(m)%kmax = max & + (ovf(n)%adj_prd(m)%kmax,ovf(n)%loc_prd(m,mp)%k) + end do + end do +! print prd adj limits + do m=1,ovf(n)%num_prd_sets + write(stdout,15) m, & + ovf(n)%adj_prd(m)%imin, & + ovf(n)%adj_prd(m)%imax, & + ovf(n)%adj_prd(m)%jmin, & + ovf(n)%adj_prd(m)%jmax, & + ovf(n)%adj_prd(m)%kmin, & + ovf(n)%adj_prd(m)%kmax +15 format(' Computed product adjacent, set=',i3, & + ' ijk min/max =',6(i4,2x)) + end do + end do ! ovf loop + call shr_sys_flush(stdout) + +!----------------------------------------------------------------------- +! end master task section +!----------------------------------------------------------------------- + + close (nu) + endif ! master_task + call release_unit(nu) + +! error from goto 10 +10 continue + + call broadcast_scalar(ovf_error, master_task) + if (ovf_error /= 0) then + call broadcast_scalar(num_req, master_task) + write(stdout,*) 'ERROR on overflow input' + if( ovf_error == 1 ) then + write(stdout,*) 'Overflows on but number requested out of range' + write(stdout,*) 'Number requested = ',num_req + write(stdout,*) 'Must be > 0 and not greater than ',max_ovf + else if ( ovf_error == 2 ) then + write(stdout,*) 'Overflows on with kmt topography changes out of range' + write(stdout,*) 'Number requested = ',num_req + write(stdout,*) 'Must be >= 0 and not greater than ',max_kmt + else if ( ovf_error == 3 ) then + write(stdout,*) 'Overflows on with number source points out of range' + write(stdout,*) 'Number requested = ',num_req + write(stdout,*) 'Must be > 1 and not greater than ',max_src + else if ( ovf_error == 4 ) then + write(stdout,*) 'Overflows on with number entrainment points out of range' + write(stdout,*) 'Number requested = ',num_req + write(stdout,*) 'Must be > 1 and not greater than ',max_ent + else if ( ovf_error == 5 ) then + write(stdout,*) 'Overflows on with number of product sets out of range' + write(stdout,*) 'Number requested = ',num_req + write(stdout,*) 'Must be > 0 and not greater than ',max_prd_sets + else if ( ovf_error == 6 ) then + write(stdout,*) 'Overflows on with number of product points out of range' + write(stdout,*) 'Number requested = ',num_req + write(stdout,*) 'Must be > 1 and not greater than ',max_prd + else if ( ovf_error == 7 ) then + write(stdout,*) 'Overflows on with non-monotonic increasing i or j' + else if ( ovf_error == 8 ) then + write(stdout,*) 'Overflows on with no change in i and j' + else if ( ovf_error == 9 ) then + write(stdout,*) 'Overflows on with both i and j increasing' + else if ( ovf_error == 10 ) then + write(stdout,*) 'Overflows on with non-constant level k' + else if ( ovf_error == 11 ) then + write(stdout,*) 'Overflows on with orientation either < 0 or > 4' + else if ( ovf_error == 12 ) then + write(stdout,*) 'Overflows on with non-constant orientation' + endif + call shr_sys_flush(stdout) + call exit_POP(sigAbort,'ERROR reading overflows_infile') + endif ! ovf error + +!----------------------------------------------------------------------- +! broadcast overflows info to all processors +!----------------------------------------------------------------------- + + call broadcast_scalar(num_ovf, master_task) + do n=1,num_ovf + call broadcast_scalar(ovf(n)%interactive, master_task) + call broadcast_scalar(ovf(n)%name, master_task) +! ovf data + call broadcast_scalar(ovf(n)%ovf_params%lat, master_task) + call broadcast_scalar(ovf(n)%ovf_params%width, master_task) + call broadcast_scalar(ovf(n)%ovf_params%source_thick, master_task) + call broadcast_scalar(ovf(n)%ovf_params%distnc_str_ssb, master_task) + call broadcast_scalar(ovf(n)%ovf_params%bottom_slope, master_task) + call broadcast_scalar(ovf(n)%ovf_params%bottom_drag, master_task) +! kmt locations + call broadcast_scalar(ovf(n)%num_kmt, master_task) + do m=1,ovf(n)%num_kmt + call broadcast_scalar(ovf(n)%loc_kmt(m)%i, master_task) + call broadcast_scalar(ovf(n)%loc_kmt(m)%j, master_task) + call broadcast_scalar(ovf(n)%loc_kmt(m)%korg, master_task) + call broadcast_scalar(ovf(n)%loc_kmt(m)%knew, master_task) + end do +! regional boundaries +! inflow + call broadcast_scalar(ovf(n)%reg_inf%imin, master_task) + call broadcast_scalar(ovf(n)%reg_inf%imax, master_task) + call broadcast_scalar(ovf(n)%reg_inf%jmin, master_task) + call broadcast_scalar(ovf(n)%reg_inf%jmax, master_task) + call broadcast_scalar(ovf(n)%reg_inf%kmin, master_task) + call broadcast_scalar(ovf(n)%reg_inf%kmax, master_task) +! source + call broadcast_scalar(ovf(n)%reg_src%imin, master_task) + call broadcast_scalar(ovf(n)%reg_src%imax, master_task) + call broadcast_scalar(ovf(n)%reg_src%jmin, master_task) + call broadcast_scalar(ovf(n)%reg_src%jmax, master_task) + call broadcast_scalar(ovf(n)%reg_src%kmin, master_task) + call broadcast_scalar(ovf(n)%reg_src%kmax, master_task) +! entrainment + call broadcast_scalar(ovf(n)%reg_ent%imin, master_task) + call broadcast_scalar(ovf(n)%reg_ent%imax, master_task) + call broadcast_scalar(ovf(n)%reg_ent%jmin, master_task) + call broadcast_scalar(ovf(n)%reg_ent%jmax, master_task) + call broadcast_scalar(ovf(n)%reg_ent%kmin, master_task) + call broadcast_scalar(ovf(n)%reg_ent%kmax, master_task) +! src locs and orientation + call broadcast_scalar(ovf(n)%num_src, master_task) + do m=1,ovf(n)%num_src + call broadcast_scalar(ovf(n)%loc_src(m)%i, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%j, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%i_adv, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%j_adv, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%i_u, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%j_u, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%k, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%orient, master_task) + end do +! ent locs and orientation + call broadcast_scalar(ovf(n)%num_ent, master_task) + do m=1,ovf(n)%num_ent + call broadcast_scalar(ovf(n)%loc_ent(m)%i, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%j, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%i_adv, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%j_adv, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%i_u, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%j_u, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%k, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%orient, master_task) + end do +! prd locs and orientation + call broadcast_scalar(ovf(n)%num_prd_sets, master_task) + do m=1,ovf(n)%num_prd_sets + call broadcast_scalar(ovf(n)%num_prd(m), master_task) + do mp=1,ovf(n)%num_prd(m) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%i, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%j, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%i_adv, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%j_adv, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%i_u, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%j_u, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%k, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%orient, master_task) + end do + end do +! adjacent boundaries + call broadcast_scalar(ovf(n)%adj_src%imin, master_task) + call broadcast_scalar(ovf(n)%adj_src%imax, master_task) + call broadcast_scalar(ovf(n)%adj_src%jmin, master_task) + call broadcast_scalar(ovf(n)%adj_src%jmax, master_task) + call broadcast_scalar(ovf(n)%adj_src%kmin, master_task) + call broadcast_scalar(ovf(n)%adj_src%kmax, master_task) + call broadcast_scalar(ovf(n)%adj_ent%imin, master_task) + call broadcast_scalar(ovf(n)%adj_ent%imax, master_task) + call broadcast_scalar(ovf(n)%adj_ent%jmin, master_task) + call broadcast_scalar(ovf(n)%adj_ent%jmax, master_task) + call broadcast_scalar(ovf(n)%adj_ent%kmin, master_task) + call broadcast_scalar(ovf(n)%adj_ent%kmax, master_task) + do m=1,ovf(n)%num_prd_sets + call broadcast_scalar(ovf(n)%adj_prd(m)%imin, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%imax, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%jmin, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%jmax, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%kmin, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%kmax, master_task) + end do + end do ! ovf broadcast loop + +!----------------------------------------------------------------------- +! initialize overflow data for all processors, so no need to broadcast +!----------------------------------------------------------------------- + + do n=1,num_ovf + ovf(n)%Ms = c0 + ovf(n)%Ms_n = c0 + ovf(n)%Ms_nm1 = c0 + ovf(n)%Me = c0 + ovf(n)%Me_n = c0 + ovf(n)%Me_nm1 = c0 + ovf(n)%phi = c0 + ovf(n)%Mp = c0 + ovf(n)%Mp_n = c0 + ovf(n)%Mp_nm1 = c0 + ovf(n)%wght_reg%inf = c0 + ovf(n)%wght_reg%src = c0 + ovf(n)%wght_reg%ent = c0 + do m=1,ovf(n)%num_prd_sets + ovf(n)%wght_adj%prd(m) = c0 + end do + ovf(n)%rho_reg%inf = c0 + ovf(n)%rho_reg%src = c0 + ovf(n)%rho_reg%ent = c0 + do m=1,ovf(n)%num_prd_sets + ovf(n)%rho_adj%prd(m) = c0 + end do + ovf(n)%prd_set_n = 1 + ovf(n)%prd_set = 1 + do nn=1,nt + ovf(n)%trcr_reg%inf(nn) = c0 + ovf(n)%trcr_reg%src(nn) = c0 + ovf(n)%trcr_reg%ent(nn) = c0 + ovf(n)%trcr_adj%src(nn) = c0 + ovf(n)%trcr_adj%ent(nn) = c0 + ovf(n)%trcr_adj%prd(nn) = c0 + end do + do m=1,ovf(n)%num_src + do k=1,km + ovf(n)%loc_src(m)%Utlda(k) = c0 + ovf(n)%loc_src(m)%Vtlda(k) = c0 + end do + ovf(n)%loc_src(m)%Uovf_nm1 = c0 + ovf(n)%loc_src(m)%Uovf_n = c0 + ovf(n)%loc_src(m)%Uovf = c0 + ovf(n)%loc_src(m)%Wovf = c0 + end do + do m=1,ovf(n)%num_ent + do k=1,km + ovf(n)%loc_ent(m)%Utlda(k) = c0 + ovf(n)%loc_ent(m)%Vtlda(k) = c0 + end do + ovf(n)%loc_ent(m)%Uovf_nm1 = c0 + ovf(n)%loc_ent(m)%Uovf_n = c0 + ovf(n)%loc_ent(m)%Uovf = c0 + ovf(n)%loc_ent(m)%Wovf = c0 + end do + do m=1,ovf(n)%num_prd_sets + do mp=1,ovf(n)%num_prd(m) + do k=1,km + ovf(n)%loc_prd(m,mp)%Utlda(k) = c0 + ovf(n)%loc_prd(m,mp)%Vtlda(k) = c0 + end do + ovf(n)%loc_prd(m,mp)%Uovf_nm1 = c0 + ovf(n)%loc_prd(m,mp)%Uovf_n = c0 + ovf(n)%loc_prd(m,mp)%Uovf = c0 + ovf(n)%loc_prd(m,mp)%Wovf = c0 + end do + end do + end do ! ovf initialization loop for all processors + + else if( overflows_restart_type /= 'ccsm_startup' ) then + + call ovf_read_restart + call ovf_read_broadcast + + endif + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_overflows1 + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows2 +! !INTERFACE: + + subroutine init_overflows2 + +! !DESCRIPTION: +! This routine continues the initialization of the overflows by +! scattering KMT_G to KMT, then modifying if desired, and finally +! computing overflow masks. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC + +!----------------------------------------------------------------------- +! +! scatter KMT_G to KMT if topography_opt = file +! +!----------------------------------------------------------------------- + + if (registry_match('topography_opt_file')) then + if (my_task == master_task) write(stdout,'(a30,a)') & + ' Reading topography from file:', trim(topography_filename) + call read_topography(topography_filename,.false.) + endif + + if (.not. overflows_on ) return + +!----------------------------------------------------------------------- +! +! modify KMT for overflows if desired and ccsm_startup run +! make kmt changes regardless of overflows_interactive +! +!----------------------------------------------------------------------- + + call init_overflows_kmt + +!----------------------------------------------------------------------- +! +! set overflow masks for regional averaging +! +!----------------------------------------------------------------------- + + call init_overflows_mask + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_overflows2 + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows_kmt +! !INTERFACE: + + subroutine init_overflows_kmt + +! !DESCRIPTION: +! This routine modifies kmt as required by overflows, if on +! and interactive. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC + +!---------------------------------------------------------------------- +! +! local variables +! +!---------------------------------------------------------------------- + + integer (int_kind) :: & + iblock,i,j,k,m,n, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + kmterr ! error index for kmt changes + + type (block) :: & + this_block ! block information for current block + +!---------------------------------------------------------------------- +! +! search through kmt and modify for overflows +! +!---------------------------------------------------------------------- + + kmterr = 0 + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + do i=ib,ie + do n=1,num_ovf + do m=1,ovf(n)%num_kmt + if( ovf(n)%loc_kmt(m)%i.eq.this_block%i_glob(i).and.& + ovf(n)%loc_kmt(m)%j.eq.this_block%j_glob(j) ) then + if (my_task == master_task) then !AK + write(stdout,100) KMT(i,j,iblock),ovf(n)%loc_kmt(m)%i, & + ovf(n)%loc_kmt(m)%j,ovf(n)%loc_kmt(m)%knew + 100 format(' init_overflows_kmt: KMT = ',i5,& + ' at global (i,j) = ',2(i5,1x),& + ' changed to ',i5) + endif + if( KMT(i,j,iblock) .ne. ovf(n)%loc_kmt(m)%korg ) then + kmterr = kmterr + 1 + endif + KMT(i,j,iblock) = ovf(n)%loc_kmt(m)%knew + endif + end do + end do + enddo + enddo + enddo + if (kmterr > 0) then + if (my_task == master_task) then + write(stdout,200) kmterr + 200 format(' init_overflows_kmt: kmt inconsistencies for ',i3,' points',/ & + ' original kmt not equal to actual kmt') + end if + call shr_sys_flush(stdout) + call exit_POP(sigAbort,'ERROR kmt inconsistency for overflows') + endif + call shr_sys_flush(stdout) + + call POP_HaloUpdate(KMT, POP_haloClinic, POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0_POP_i4) + +!---------------------------------------------------------------------- +!EOC + + end subroutine init_overflows_kmt + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows_mask +! !INTERFACE: + + subroutine init_overflows_mask + +! !DESCRIPTION: +! This routine sets overflow masks for regional and adjacent averaging +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC + +!---------------------------------------------------------------------- +! +! local variables +! +!---------------------------------------------------------------------- + + integer (int_kind) :: & + iblock,i,j,n,m, & ! dummy loop indices + ib,ie,jb,je ! local domain index boundaries + + type (block) :: & + this_block ! block information for current block + +!---------------------------------------------------------------------- +! +! set masks for regional averaging +! +!---------------------------------------------------------------------- + + do n=1,num_ovf + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je +! inflow region + if( ovf(n)%reg_inf%jmin .le. this_block%j_glob(j) .and. & + this_block%j_glob(j) .le. ovf(n)%reg_inf%jmax ) then + do i=ib,ie + ovf(n)%mask_reg%inf(i,j,iblock) = c0 + if( ovf(n)%reg_inf%imin .le. this_block%i_glob(i) .and. & + this_block%i_glob(i) .le. ovf(n)%reg_inf%imax ) then + ovf(n)%mask_reg%inf(i,j,iblock) = c1 + if (my_task == master_task) then !AK + write(stdout,30) ovf(n)%name,this_block%i_glob(i), & + this_block%j_glob(j) + 30 format(' Overflow: ',a24, & + ' Inflow region mask at global (ij)=',2(i3,2x)) + end if + endif + end do + endif ! inflow region +! source region + if( ovf(n)%reg_src%jmin .le. this_block%j_glob(j) .and. & + this_block%j_glob(j) .le. ovf(n)%reg_src%jmax ) then + do i=ib,ie + ovf(n)%mask_reg%src(i,j,iblock) = c0 + if( ovf(n)%reg_src%imin .le. this_block%i_glob(i) .and. & + this_block%i_glob(i) .le. ovf(n)%reg_src%imax ) then + ovf(n)%mask_reg%src(i,j,iblock) = c1 + if (my_task == master_task) then !AK + write(stdout,31) ovf(n)%name,this_block%i_glob(i), & + this_block%j_glob(j) + 31 format(' Overflow: ',a24, & + ' Source region mask at global (ij)=',2(i3,2x)) + end if + endif + end do + endif ! source region +! source adjacent + if( ovf(n)%adj_src%jmin .le. this_block%j_glob(j) .and. & + this_block%j_glob(j) .le. ovf(n)%adj_src%jmax ) then + do i=ib,ie + ovf(n)%mask_adj%src(i,j,iblock) = c0 + if( ovf(n)%adj_src%imin .le. this_block%i_glob(i) .and. & + this_block%i_glob(i) .le. ovf(n)%adj_src%imax ) then + ovf(n)%mask_adj%src(i,j,iblock) = c1 + if (my_task == master_task) then !AK + write(stdout,32) ovf(n)%name,this_block%i_glob(i), & + this_block%j_glob(j) + 32 format(' Overflow: ',a24, & + ' Source adjacent mask at global (ij)=',2(i3,2x)) + end if + endif + end do + endif ! source adjacent +! entrainment region + if( ovf(n)%reg_ent%jmin .le. this_block%j_glob(j) .and. & + this_block%j_glob(j) .le. ovf(n)%reg_ent%jmax ) then + do i=ib,ie + ovf(n)%mask_reg%ent(i,j,iblock) = c0 + if( ovf(n)%reg_ent%imin .le. this_block%i_glob(i) .and. & + this_block%i_glob(i) .le. ovf(n)%reg_ent%imax ) then + ovf(n)%mask_reg%ent(i,j,iblock) = c1 + if (my_task == master_task) then !AK + write(stdout,33) ovf(n)%name,this_block%i_glob(i), & + this_block%j_glob(j) + 33 format(' Overflow: ',a24, & + ' Entrainment region mask at global (ij)=',2(i3,2x)) + end if + endif + end do + endif ! entrainment region +! entrainment adjacent + if( ovf(n)%adj_ent%jmin .le. this_block%j_glob(j) .and. & + this_block%j_glob(j) .le. ovf(n)%adj_ent%jmax ) then + do i=ib,ie + ovf(n)%mask_adj%ent(i,j,iblock) = c0 + if( ovf(n)%adj_ent%imin .le. this_block%i_glob(i) .and. & + this_block%i_glob(i) .le. ovf(n)%adj_ent%imax ) then + ovf(n)%mask_adj%ent(i,j,iblock) = c1 + if (my_task == master_task) then !AK + write(stdout,34) ovf(n)%name,this_block%i_glob(i), & + this_block%j_glob(j) + 34 format(' Overflow: ',a24, & + ' Entrainment adjacent mask at global (ij)=',2(i3,2x)) + endif + endif + end do + endif ! entrainment adjacent + end do ! j loop +! product adjacent + do m=1,ovf(n)%num_prd_sets + do j=jb,je + if( ovf(n)%adj_prd(m)%jmin .le. this_block%j_glob(j) .and. & + this_block%j_glob(j) .le. ovf(n)%adj_prd(m)%jmax ) then + do i=ib,ie + ovf(n)%mask_adj%prd(i,j,iblock,m) = c0 + if( ovf(n)%adj_prd(m)%imin .le. this_block%i_glob(i) .and. & + this_block%i_glob(i) .le. ovf(n)%adj_prd(m)%imax ) then + ovf(n)%mask_adj%prd(i,j,iblock,m) = c1 + if (my_task == master_task) then !AK + write(stdout,35) ovf(n)%name,this_block%i_glob(i), & + this_block%j_glob(j) + 35 format(' Overflow: ',a24, & + ' Product adjacent mask at global (ij)=',2(i3,2x)) + end if + endif + end do + endif ! product adjacent + end do + end do + end do + end do + call shr_sys_flush(stdout) + +!---------------------------------------------------------------------- +!EOC + + end subroutine init_overflows_mask + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows3 +! !INTERFACE: + + subroutine init_overflows3 + +! !DESCRIPTION: +! This routine completes the initialization of the overflows by +! modifying the 9pt coefficients for the barotropic solution +! as required for each overflow grid box +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC + +!----------------------------------------------------------------------- +! +! modify 9pt coefficients for barotropic solver +! +!----------------------------------------------------------------------- + + if( overflows_on .and. overflows_interactive ) then + call ovf_solvers_9pt + endif + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_overflows3 + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows4 +! !INTERFACE: + + subroutine init_overflows4 + +! !DESCRIPTION: +! This routine creates the overflow output diagnostics filename, now +! that the initial model run time is known. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + character (char_len) :: & + string + + save + +!----------------------------------------------------------------------- +! if overflows off, exit +!----------------------------------------------------------------------- + + if (.not. overflows_on ) return + +!----------------------------------------------------------------------- +! set up output file and unit for overflow diagnostics +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! define ccsm overflow diagnostics output filename +!----------------------------------------------------------------------- + if (lccsm) then + call ccsm_date_stamp (ccsm_diag_date, 'ymds') + string = overflows_diag_outfile + overflows_diag_outfile = trim(string)/& + &/'.'/& + &/trim(ccsm_diag_date) + else +!----------------------------------------------------------------------- +! append runid, initial date to output file names +! concatenation operator must be split across lines to avoid problems +! with preprocessors +!----------------------------------------------------------------------- + if (date_separator == ' ') then + cdate(1:4) = cyear + cdate(5:6) = cmonth + cdate(7:8) = cday + cdate(9:10)= ' ' + else + cdate(1:4) = cyear + cdate(5:5) = date_separator + cdate(6:7) = cmonth + cdate(8:8) = date_separator + cdate(9:10) = cday + endif + outfile_tmp = char_blank + outfile_tmp = trim(overflows_diag_outfile)/& + &/'.'/& + &/trim(runid)/& + &/'.'/& + &/trim(cdate) + overflows_diag_outfile = trim(outfile_tmp) + endif ! lccsm + + + call get_unit(ovf_diag_unit) + if (my_task == master_task) then + open(ovf_diag_unit, file=overflows_diag_outfile, status='unknown') + write(ovf_diag_unit,*)' ' + close(ovf_diag_unit) + + write(stdout,'(a,a)') & + 'Overflow diagnostics written to file: ', trim(overflows_diag_outfile) + endif + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_overflows4 + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows5 +! !INTERFACE: + + subroutine init_overflows5 + +! !DESCRIPTION: +! This routine computes regional aveages required at restart +! for overflow regions, using all available tracers, and also +! computes regional product values based on source and entrainment. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + save + + integer (int_kind) :: & + n ,& ! index of overflow + nn ! ovf tracer index + real (r8) :: & + phi ! entrainment parameter from actual ratio Me/Mp + +!----------------------------------------------------------------------- +! +! compute regional averages. +! +!----------------------------------------------------------------------- + + if( overflows_on .and. overflows_interactive ) then + call ovf_reg_avgs(oldtime) +! evaluate regional product values based on src,ent averages just computed + do n=1,num_ovf + phi = ovf(n)%phi + do nn=1,nt + ovf(n)%trcr_reg%prd(nn) = ovf(n)%trcr_reg%src(nn) * (c1 - phi) & + + ovf(n)%trcr_reg%ent(nn) * phi + end do + enddo + endif + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_overflows5 + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_write_restart +! !INTERFACE: + + subroutine ovf_write_restart + +! !DESCRIPTION: +! This routine writes the overflow restart file using +! selected data from overflow array. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + save + + integer (int_kind) :: & + mu, &! unit for ovf restart file + ovf_error, &! error flag + n, &! ovf loop index + m, &! sub-ovf loop index + nn, &! tracer loop index + mp ! sub-ovf sub-loop index + + character (char_len) :: & + write_restart_filename, &! modified file name for restart file + ovf_restart_pointer_file, &! overflows rpointer filename + file_suffix, &! suffix to append to root filename + char_temp ! temporary character string + + character (10) :: &! for input year,month,day + cdate + + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_write_restart called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! if overflows off, exit +!----------------------------------------------------------------------- + + if( .not. overflows_on ) return + + cdate(1:4) = cyear + cdate(5:6) = cmonth + cdate(7:8) = cday + cdate(9:10)= ' ' + + ovf_error = 0 + call get_unit(mu) + + write_restart_filename = char_blank + file_suffix = char_blank + + if (registry_match('lccsm')) then + call ccsm_date_stamp(char_temp, 'ymds') + file_suffix = trim(char_temp) + !*** must split concatenation operator to avoid preprocessor mangling + write_restart_filename = trim(overflows_restfile)/& + &/'.'/& + &/trim(file_suffix) + else + write_restart_filename = trim(overflows_restfile) + endif + + +!----------------------------------------------------------------------- +! master task section +!----------------------------------------------------------------------- + + if (my_task == master_task) then + + open(mu, file=write_restart_filename, status='unknown',iostat=ovf_error) + + write(stdout,987) mu,write_restart_filename + 987 format(' ovf_write_restart unit (mu) = ',i5,' file name = ',a64) + + write(stdout,99) cdate + 99 format(' ovf write restart cdate yyyymmdd = ',a10) + call shr_sys_flush(stdout) + + write(mu,100) cdate,num_ovf + 100 format(30x,' ! Overflow Restart File for yyyymmdd =',a10/ & + 2x,i10,20x,'! number of overflows') + do n=1,num_ovf + write(mu,101) ovf(n)%name + 101 format(2x,a26,' ! name of overflow') + +! ovf parameters + write(mu,102) ovf(n)%ovf_params%lat + 102 format(2x,1PE27.18,' ! latitude in degrees') + write(mu,103) ovf(n)%ovf_params%width + 103 format(2x,1PE27.18,' ! channel width in meters') + write(mu,105) ovf(n)%ovf_params%source_thick + 105 format(2x,1PE27.18,' ! source thickness in meters') + write(mu,106) ovf(n)%ovf_params%distnc_str_ssb + 106 format(2x,1PE27.18,' ! strait to shelf-slope break in meters') + write(mu,107) ovf(n)%ovf_params%bottom_slope + 107 format(2x,1PE27.18,' ! bottom slope dy/dx ') + write(mu,108) ovf(n)%ovf_params%bottom_drag + 108 format(2x,1PE27.18,' ! bottom drag coefficient') + +! kmt changes, if any + write(mu,1090) ovf(n)%num_kmt + 1090 format(2x,i10,20x,'! number of kmt changes') + do m=1,ovf(n)%num_kmt + write(mu,1091) ovf(n)%loc_kmt(m)%i + 1091 format(2x,i10,20x,'! i grid box index for kmt change') + write(mu,1092) ovf(n)%loc_kmt(m)%j + 1092 format(2x,i10,20x,'! j grid box index for kmt change') + write(mu,1093) ovf(n)%loc_kmt(m)%korg + 1093 format(2x,i10,20x,'! korg original grid box k index') + write(mu,1094) ovf(n)%loc_kmt(m)%knew + 1094 format(2x,i10,20x,'! knew new grid box k index') + end do + +! regional boundaries +! inflow + write(mu,110) ovf(n)%reg_inf%imin + 110 format(2x,i10,20x,'! inflow region imin') + write(mu,111) ovf(n)%reg_inf%imax + 111 format(2x,i10,20x,'! inflow region imax') + write(mu,112) ovf(n)%reg_inf%jmin + 112 format(2x,i10,20x,'! inflow region jmin') + write(mu,113) ovf(n)%reg_inf%jmax + 113 format(2x,i10,20x,'! inflow region jmax') + write(mu,114) ovf(n)%reg_inf%kmin + 114 format(2x,i10,20x,'! inflow region kmin') + write(mu,115) ovf(n)%reg_inf%kmax + 115 format(2x,i10,20x,'! inflow region kmax') +! source + write(mu,116) ovf(n)%reg_src%imin + 116 format(2x,i10,20x,'! source region imin') + write(mu,117) ovf(n)%reg_src%imax + 117 format(2x,i10,20x,'! source region imax') + write(mu,118) ovf(n)%reg_src%jmin + 118 format(2x,i10,20x,'! source region jmin') + write(mu,119) ovf(n)%reg_src%jmax + 119 format(2x,i10,20x,'! source region jmax') + write(mu,120) ovf(n)%reg_src%kmin + 120 format(2x,i10,20x,'! source region kmin') + write(mu,121) ovf(n)%reg_src%kmax + 121 format(2x,i10,20x,'! source region kmax') +! entrainment + write(mu,122) ovf(n)%reg_ent%imin + 122 format(2x,i10,20x,'! entrainment region imin') + write(mu,123) ovf(n)%reg_ent%imax + 123 format(2x,i10,20x,'! entrainment region imax') + write(mu,124) ovf(n)%reg_ent%jmin + 124 format(2x,i10,20x,'! entrainment region jmin') + write(mu,125) ovf(n)%reg_ent%jmax + 125 format(2x,i10,20x,'! entrainment region jmax') + write(mu,126) ovf(n)%reg_ent%kmin + 126 format(2x,i10,20x,'! entrainment region kmin') + write(mu,127) ovf(n)%reg_ent%kmax + 127 format(2x,i10,20x,'! entrainment region kmax') +! src locs and orientation + write(mu,128) ovf(n)%num_src + 128 format(2x,i10,20x,'! number of source grid boxes') + do m=1,ovf(n)%num_src + write(mu,129) ovf(n)%loc_src(m)%i + 129 format(2x,i10,20x,'! source box i') + write(mu,130) ovf(n)%loc_src(m)%j + 130 format(2x,i10,20x,'! source box j') + write(mu,131) ovf(n)%loc_src(m)%i_adv + 131 format(2x,i10,20x,'! source box i_adv') + write(mu,132) ovf(n)%loc_src(m)%j_adv + 132 format(2x,i10,20x,'! source box j_adv') + write(mu,133) ovf(n)%loc_src(m)%i_u + 133 format(2x,i10,20x,'! source box i_u') + write(mu,134) ovf(n)%loc_src(m)%j_u + 134 format(2x,i10,20x,'! source box j_u') + write(mu,135) ovf(n)%loc_src(m)%k + 135 format(2x,i10,20x,'! source box k') + write(mu,136) ovf(n)%loc_src(m)%orient + 136 format(2x,i10,20x,'! source box orient') + end do +! ent locs and orientation + write(mu,137) ovf(n)%num_ent + 137 format(2x,i10,20x,'! number of entrainment grid boxes') + do m=1,ovf(n)%num_ent + write(mu,138) ovf(n)%loc_ent(m)%i + 138 format(2x,i10,20x,'! entrainment box i') + write(mu,139) ovf(n)%loc_ent(m)%j + 139 format(2x,i10,20x,'! entrainment box j') + write(mu,140) ovf(n)%loc_ent(m)%i_adv + 140 format(2x,i10,20x,'! entrainment box i_adv') + write(mu,141) ovf(n)%loc_ent(m)%j_adv + 141 format(2x,i10,20x,'! entrainment box j_adv') + write(mu,142) ovf(n)%loc_ent(m)%i_u + 142 format(2x,i10,20x,'! entrainment box i_u') + write(mu,143) ovf(n)%loc_ent(m)%j_u + 143 format(2x,i10,20x,'! entrainment box j_u') + write(mu,144) ovf(n)%loc_ent(m)%k + 144 format(2x,i10,20x,'! entrainment box k') + write(mu,145) ovf(n)%loc_ent(m)%orient + 145 format(2x,i10,20x,'! entrainment box orient') + end do +! prd locs and orientation + write(mu,146) ovf(n)%num_prd_sets + 146 format(2x,i10,20x,'! number of product sets') + do m=1,ovf(n)%num_prd_sets + write(mu,147) ovf(n)%num_prd(m) + 147 format(2x,i10,20x, & + '! number of product grid boxes for this set') + do mp=1,ovf(n)%num_prd(m) + write(mu,148) ovf(n)%loc_prd(m,mp)%i + 148 format(2x,i10,20x,'! product box i') + write(mu,149) ovf(n)%loc_prd(m,mp)%j + 149 format(2x,i10,20x,'! product box j') + write(mu,150) ovf(n)%loc_prd(m,mp)%i_adv + 150 format(2x,i10,20x,'! product box i_adv') + write(mu,151) ovf(n)%loc_prd(m,mp)%j_adv + 151 format(2x,i10,20x,'! product box j_adv') + write(mu,152) ovf(n)%loc_prd(m,mp)%i_u + 152 format(2x,i10,20x,'! product box i_u') + write(mu,153) ovf(n)%loc_prd(m,mp)%j_u + 153 format(2x,i10,20x,'! product box j_u') + write(mu,154) ovf(n)%loc_prd(m,mp)%k + 154 format(2x,i10,20x,'! product box k') + write(mu,155) ovf(n)%loc_prd(m,mp)%orient + 155 format(2x,i10,20x,'! product box orient') + end do + end do +! adjacent boundaries +! src + write(mu,156) ovf(n)%adj_src%imin + 156 format(2x,i10,20x,'! source adjacent imin') + write(mu,157) ovf(n)%adj_src%imax + 157 format(2x,i10,20x,'! source adjacent imax') + write(mu,158) ovf(n)%adj_src%jmin + 158 format(2x,i10,20x,'! source adjacent jmin') + write(mu,159) ovf(n)%adj_src%jmax + 159 format(2x,i10,20x,'! source adjacent jmax') + write(mu,160) ovf(n)%adj_src%kmin + 160 format(2x,i10,20x,'! source adjacent kmin') + write(mu,161) ovf(n)%adj_src%kmax + 161 format(2x,i10,20x,'! source adjacent kmax') +!ent + write(mu,162) ovf(n)%adj_ent%imin + 162 format(2x,i10,20x,'! entrainment adjacent imin') + write(mu,163) ovf(n)%adj_ent%imax + 163 format(2x,i10,20x,'! entrainment adjacent imax') + write(mu,164) ovf(n)%adj_ent%jmin + 164 format(2x,i10,20x,'! entrainment adjacent jmin') + write(mu,165) ovf(n)%adj_ent%jmax + 165 format(2x,i10,20x,'! entrainment adjacent jmax') + write(mu,166) ovf(n)%adj_ent%kmin + 166 format(2x,i10,20x,'! entrainment adjacent kmin') + write(mu,167) ovf(n)%adj_ent%kmax + 167 format(2x,i10,20x,'! entrainment adjacent kmax') +!prd + do m=1,ovf(n)%num_prd_sets + write(mu,168) ovf(n)%adj_prd(m)%imin + 168 format(2x,i10,20x,'! product adjacent imin') + write(mu,169) ovf(n)%adj_prd(m)%imax + 169 format(2x,i10,20x,'! product adjacent imax') + write(mu,170) ovf(n)%adj_prd(m)%jmin + 170 format(2x,i10,20x,'! product adjacent jmin') + write(mu,171) ovf(n)%adj_prd(m)%jmax + 171 format(2x,i10,20x,'! product adjacent jmax') + write(mu,172) ovf(n)%adj_prd(m)%kmin + 172 format(2x,i10,20x,'! product adjacent kmin') + write(mu,173) ovf(n)%adj_prd(m)%kmax + 173 format(2x,i10,20x,'! product adjacent kmax') + end do +! transports + write(mu,174) ovf(n)%Ms + 174 format(2x,1PE27.18,' ! source volume n+1 transport cm3/sec') + write(mu,175) ovf(n)%Ms_n + 175 format(2x,1PE27.18,' ! source volume n transport cm3/sec') + write(mu,176) ovf(n)%Ms_nm1 + 176 format(2x,1PE27.18,' ! source volume n-1 transport cm3/sec') + write(mu,177) ovf(n)%Me + 177 format(2x,1PE27.18,' ! entrainment volume n+1 transport cm3/sec') + write(mu,178) ovf(n)%Me_n + 178 format(2x,1PE27.18,' ! entrainment volume n transport cm3/sec') + write(mu,179) ovf(n)%Me_nm1 + 179 format(2x,1PE27.18,' ! entrainment volume n-1 transport cm3/sec') + write(mu,180) ovf(n)%phi + 180 format(2x,1PE27.18,' ! phi parameter') + write(mu,181) ovf(n)%Mp + 181 format(2x,1PE27.18,' ! product volume n+1 transport cm3/sec') + write(mu,182) ovf(n)%Mp_n + 182 format(2x,1PE27.18,' ! product volume n transport cm3/sec') + write(mu,183) ovf(n)%Mp_nm1 + 183 format(2x,1PE27.18,' ! product volume n-1 transport cm3/sec') + write(mu,184) ovf(n)%Tp + 184 format(2x,1PE27.18,' ! product temperature C') + write(mu,185) ovf(n)%Sp + 185 format(2x,1PE27.18,' ! product salinity') + write(mu,186) ovf(n)%prd_set_n + write(mu,186) ovf(n)%prd_set + 186 format(2x,i10,20x,'! product set index (first is previous time step)') + + end do ! ovf loop + + close(mu) + endif ! my_task == master_task + + call release_unit(mu) + +!----------------------------------------------------------------------- +! +! if pointer files are used, write filename to pointer file +! +!----------------------------------------------------------------------- + + if (luse_pointer_files) then + call get_unit(mu) + if (my_task == master_task) then + ovf_restart_pointer_file = trim(pointer_filename)/& + &/'.ovf' + open(mu, file=ovf_restart_pointer_file, form='formatted', status='unknown') + write(mu,'(a)') trim(write_restart_filename) + close(mu) + write(stdout,blank_fmt) + write(stdout,*) ' overflow restart pointer file written: ',trim(ovf_restart_pointer_file) + call POP_IOUnitsFlush(POP_stdout) + endif + call release_unit(mu) + endif + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_write_restart + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_read_restart +! !INTERFACE: + + subroutine ovf_read_restart + +! !DESCRIPTION: +! This routine reads the overflow restart file for +! selected data from overflow array. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + save + + integer (POP_i4) :: & + mu, &! unit for ovf restart file + ovf_error, &! error flag + n, &! ovf loop index + m, &! sub-ovf loop index + nn, &! tracer loop index + mp, &! sub-ovf sub-loop index + ntrcr, &! number of tracers on read + cindx,cindx2 ! indices into restart pointer character string + + character (POP_charLength) :: & + restart_pointer_file, &! file name for restart pointer file + read_overflows_restfile, &! local restart filename + cdate_label ! for input year,month,day + + logical (POP_logical), parameter :: prnt = .false. + + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_read_restart called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! if overflows off, exit +!----------------------------------------------------------------------- + + if( .not. overflows_on ) return + + ovf_error = 0 + +!----------------------------------------------------------------------- +! +! if pointer files are used, overflows pointer file must be read to get +! actual filenames - skip this for ccsm_branch initialization +! +! otherwise use input filename +!----------------------------------------------------------------------- + + errorCode = POP_Success + + read_overflows_restfile = char_blank + restart_pointer_file = char_blank + + if (luse_pointer_files) then + call get_unit(mu) + if (my_task == master_task) then + restart_pointer_file = pointer_filename + cindx = len_trim(pointer_filename) + 1 + cindx2= cindx + 3 + restart_pointer_file(cindx:cindx2) = '.ovf' + write(stdout,*) 'Reading overflow pointer file: ', trim(restart_pointer_file) + call POP_IOUnitsFlush(POP_stdout) + open(mu, file=trim(restart_pointer_file), form='formatted', status='old') + read(mu,'(a)') read_overflows_restfile + close(mu) + endif + call release_unit(mu) + call broadcast_scalar(read_overflows_restfile, master_task) + else + ! use overflows_restfile from namelist + read_overflows_restfile = trim(overflows_restfile) + endif + +!----------------------------------------------------------------------- +! read overflows restart file +!----------------------------------------------------------------------- + + call get_unit(mu) + if (my_task == master_task) then + + open(mu, file=read_overflows_restfile, status='unknown',iostat=ovf_error) + + write(stdout,987) mu,read_overflows_restfile + 987 format(' ovf_read_restart unit (mu) = ',i5,' file name = ',a) + + read(mu,99) cdate_label,num_ovf + 99 format(a80/2x,i10) + write(stdout,100) cdate_label,num_ovf + 100 format(' ovf read restart label =',/a80/ & + ' number of overflows = ',i5) + call shr_sys_flush(stdout) + + do n=1,num_ovf + read(mu,101) ovf(n)%name + 101 format(2x,a26) + +! ovf parameters + read(mu,102) ovf(n)%ovf_params%lat + 102 format(2x,1PE27.18) + read(mu,103) ovf(n)%ovf_params%width + 103 format(2x,1PE27.18) + read(mu,105) ovf(n)%ovf_params%source_thick + 105 format(2x,1PE27.18) + read(mu,106) ovf(n)%ovf_params%distnc_str_ssb + 106 format(2x,1PE27.18) + read(mu,107) ovf(n)%ovf_params%bottom_slope + 107 format(2x,1PE27.18) + read(mu,108) ovf(n)%ovf_params%bottom_drag + 108 format(2x,1PE27.18) +! kmt changes, if any +! GFORTRAN Compiler complains about constants in read format + read(mu,1090) ovf(n)%num_kmt +1090 format(2x,i10) + do m=1,ovf(n)%num_kmt + read(mu,1090) ovf(n)%loc_kmt(m)%i + read(mu,1090) ovf(n)%loc_kmt(m)%j + read(mu,1090) ovf(n)%loc_kmt(m)%korg + read(mu,1090) ovf(n)%loc_kmt(m)%knew + end do + +! regional boundaries +! inflow + read(mu,110) ovf(n)%reg_inf%imin + 110 format(2x,i10,20x) + read(mu,111) ovf(n)%reg_inf%imax + 111 format(2x,i10,20x) + read(mu,112) ovf(n)%reg_inf%jmin + 112 format(2x,i10,20x) + read(mu,113) ovf(n)%reg_inf%jmax + 113 format(2x,i10,20x) + read(mu,114) ovf(n)%reg_inf%kmin + 114 format(2x,i10,20x) + read(mu,115) ovf(n)%reg_inf%kmax + 115 format(2x,i10,20x) +! source + read(mu,116) ovf(n)%reg_src%imin + 116 format(2x,i10,20x) + read(mu,117) ovf(n)%reg_src%imax + 117 format(2x,i10,20x) + read(mu,118) ovf(n)%reg_src%jmin + 118 format(2x,i10,20x) + read(mu,119) ovf(n)%reg_src%jmax + 119 format(2x,i10,20x) + read(mu,120) ovf(n)%reg_src%kmin + 120 format(2x,i10,20x) + read(mu,121) ovf(n)%reg_src%kmax + 121 format(2x,i10,20x) +! entrainment + read(mu,122) ovf(n)%reg_ent%imin + 122 format(2x,i10,20x) + read(mu,123) ovf(n)%reg_ent%imax + 123 format(2x,i10,20x) + read(mu,124) ovf(n)%reg_ent%jmin + 124 format(2x,i10,20x) + read(mu,125) ovf(n)%reg_ent%jmax + 125 format(2x,i10,20x) + read(mu,126) ovf(n)%reg_ent%kmin + 126 format(2x,i10,20x) + read(mu,127) ovf(n)%reg_ent%kmax + 127 format(2x,i10,20x) +! src locs and orientation + read(mu,128) ovf(n)%num_src + 128 format(2x,i10,20x) + do m=1,ovf(n)%num_src + read(mu,129) ovf(n)%loc_src(m)%i + 129 format(2x,i10,20x) + read(mu,130) ovf(n)%loc_src(m)%j + 130 format(2x,i10,20x) + read(mu,131) ovf(n)%loc_src(m)%i_adv + 131 format(2x,i10,20x) + read(mu,132) ovf(n)%loc_src(m)%j_adv + 132 format(2x,i10,20x) + read(mu,133) ovf(n)%loc_src(m)%i_u + 133 format(2x,i10,20x) + read(mu,134) ovf(n)%loc_src(m)%j_u + 134 format(2x,i10,20x) + read(mu,135) ovf(n)%loc_src(m)%k + 135 format(2x,i10,20x) + read(mu,136) ovf(n)%loc_src(m)%orient + 136 format(2x,i10,20x) + end do +! ent locs and orientation + read(mu,137) ovf(n)%num_ent + 137 format(2x,i10,20x) + do m=1,ovf(n)%num_ent + read(mu,138) ovf(n)%loc_ent(m)%i + 138 format(2x,i10,20x) + read(mu,139) ovf(n)%loc_ent(m)%j + 139 format(2x,i10,20x) + read(mu,140) ovf(n)%loc_ent(m)%i_adv + 140 format(2x,i10,20x) + read(mu,141) ovf(n)%loc_ent(m)%j_adv + 141 format(2x,i10,20x) + read(mu,142) ovf(n)%loc_ent(m)%i_u + 142 format(2x,i10,20x) + read(mu,143) ovf(n)%loc_ent(m)%j_u + 143 format(2x,i10,20x) + read(mu,144) ovf(n)%loc_ent(m)%k + 144 format(2x,i10,20x) + read(mu,145) ovf(n)%loc_ent(m)%orient + 145 format(2x,i10,20x) + end do +! prd locs and orientation + read(mu,146) ovf(n)%num_prd_sets + 146 format(2x,i10,20x) + do m=1,ovf(n)%num_prd_sets + read(mu,147) ovf(n)%num_prd(m) + 147 format(2x,i10,20x) + do mp=1,ovf(n)%num_prd(m) + read(mu,148) ovf(n)%loc_prd(m,mp)%i + 148 format(2x,i10,20x) + read(mu,149) ovf(n)%loc_prd(m,mp)%j + 149 format(2x,i10,20x) + read(mu,150) ovf(n)%loc_prd(m,mp)%i_adv + 150 format(2x,i10,20x) + read(mu,151) ovf(n)%loc_prd(m,mp)%j_adv + 151 format(2x,i10,20x) + read(mu,152) ovf(n)%loc_prd(m,mp)%i_u + 152 format(2x,i10,20x) + read(mu,153) ovf(n)%loc_prd(m,mp)%j_u + 153 format(2x,i10,20x) + read(mu,154) ovf(n)%loc_prd(m,mp)%k + 154 format(2x,i10,20x) + read(mu,155) ovf(n)%loc_prd(m,mp)%orient + 155 format(2x,i10,20x) + end do + end do +! adjacent boundaries +! src + read(mu,156) ovf(n)%adj_src%imin + 156 format(2x,i10,20x) + read(mu,157) ovf(n)%adj_src%imax + 157 format(2x,i10,20x) + read(mu,158) ovf(n)%adj_src%jmin + 158 format(2x,i10,20x) + read(mu,159) ovf(n)%adj_src%jmax + 159 format(2x,i10,20x) + read(mu,160) ovf(n)%adj_src%kmin + 160 format(2x,i10,20x) + read(mu,161) ovf(n)%adj_src%kmax + 161 format(2x,i10,20x) +!ent + read(mu,162) ovf(n)%adj_ent%imin + 162 format(2x,i10,20x) + read(mu,163) ovf(n)%adj_ent%imax + 163 format(2x,i10,20x) + read(mu,164) ovf(n)%adj_ent%jmin + 164 format(2x,i10,20x) + read(mu,165) ovf(n)%adj_ent%jmax + 165 format(2x,i10,20x) + read(mu,166) ovf(n)%adj_ent%kmin + 166 format(2x,i10,20x) + read(mu,167) ovf(n)%adj_ent%kmax + 167 format(2x,i10,20x) +!prd + do m=1,ovf(n)%num_prd_sets + read(mu,168) ovf(n)%adj_prd(m)%imin + 168 format(2x,i10,20x) + read(mu,169) ovf(n)%adj_prd(m)%imax + 169 format(2x,i10,20x) + read(mu,170) ovf(n)%adj_prd(m)%jmin + 170 format(2x,i10,20x) + read(mu,171) ovf(n)%adj_prd(m)%jmax + 171 format(2x,i10,20x) + read(mu,172) ovf(n)%adj_prd(m)%kmin + 172 format(2x,i10,20x) + read(mu,173) ovf(n)%adj_prd(m)%kmax + 173 format(2x,i10,20x) + end do +! transports + read(mu,174) ovf(n)%Ms + 174 format(2x,1PE27.18) + read(mu,175) ovf(n)%Ms_n + 175 format(2x,1PE27.18) + read(mu,176) ovf(n)%Ms_nm1 + 176 format(2x,1PE27.18) + read(mu,177) ovf(n)%Me + 177 format(2x,1PE27.18) + read(mu,178) ovf(n)%Me_n + 178 format(2x,1PE27.18) + read(mu,179) ovf(n)%Me_nm1 + 179 format(2x,1PE27.18) + read(mu,180) ovf(n)%phi + 180 format(2x,1PE27.18) + read(mu,181) ovf(n)%Mp + 181 format(2x,1PE27.18) + read(mu,182) ovf(n)%Mp_n + 182 format(2x,1PE27.18) + read(mu,183) ovf(n)%Mp_nm1 + 183 format(2x,1PE27.18) + read(mu,184) ovf(n)%Tp + 184 format(2x,1PE27.18) + read(mu,185) ovf(n)%Sp + 185 format(2x,1PE27.18) + read(mu,186) ovf(n)%prd_set_n + read(mu,186) ovf(n)%prd_set + 186 format(2x,i10,20x) + + end do ! ovf loop + + close(mu) + endif ! my_task == master_task + + call release_unit(mu) + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_read_restart + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_read_broadcast +! !INTERFACE: + + subroutine ovf_read_broadcast + +! !DESCRIPTION: +! This routine broadcasts selected data in ovf array from the +! master_task to all processors. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + save + + integer (int_kind) :: & + n, &! ovf loop index + m, &! sub-ovf loop index + nn, &! tracer loop index + mp, &! sub-ovf sub-loop index + k ! vertical loop index + +!----------------------------------------------------------------------- +! if overflows off, exit +!----------------------------------------------------------------------- + + if( .not. overflows_on ) return + +!----------------------------------------------------------------------- +! broadcast overflows info to all processors +!----------------------------------------------------------------------- + + call broadcast_scalar(num_ovf, master_task) + do n=1,num_ovf + call broadcast_scalar(ovf(n)%name, master_task) +! ovf data + call broadcast_scalar(ovf(n)%ovf_params%lat, master_task) + call broadcast_scalar(ovf(n)%ovf_params%width, master_task) + call broadcast_scalar(ovf(n)%ovf_params%source_thick, master_task) + call broadcast_scalar(ovf(n)%ovf_params%distnc_str_ssb, master_task) + call broadcast_scalar(ovf(n)%ovf_params%bottom_slope, master_task) + call broadcast_scalar(ovf(n)%ovf_params%bottom_drag, master_task) +! kmt changes, if any + call broadcast_scalar(ovf(n)%num_kmt, master_task) + do m=1,ovf(n)%num_kmt + call broadcast_scalar(ovf(n)%loc_kmt(m)%i, master_task) + call broadcast_scalar(ovf(n)%loc_kmt(m)%j, master_task) + call broadcast_scalar(ovf(n)%loc_kmt(m)%korg, master_task) + call broadcast_scalar(ovf(n)%loc_kmt(m)%knew, master_task) + end do +! regional boundaries +! inflow + call broadcast_scalar(ovf(n)%reg_inf%imin, master_task) + call broadcast_scalar(ovf(n)%reg_inf%imax, master_task) + call broadcast_scalar(ovf(n)%reg_inf%jmin, master_task) + call broadcast_scalar(ovf(n)%reg_inf%jmax, master_task) + call broadcast_scalar(ovf(n)%reg_inf%kmin, master_task) + call broadcast_scalar(ovf(n)%reg_inf%kmax, master_task) +! source + call broadcast_scalar(ovf(n)%reg_src%imin, master_task) + call broadcast_scalar(ovf(n)%reg_src%imax, master_task) + call broadcast_scalar(ovf(n)%reg_src%jmin, master_task) + call broadcast_scalar(ovf(n)%reg_src%jmax, master_task) + call broadcast_scalar(ovf(n)%reg_src%kmin, master_task) + call broadcast_scalar(ovf(n)%reg_src%kmax, master_task) +! entrainment + call broadcast_scalar(ovf(n)%reg_ent%imin, master_task) + call broadcast_scalar(ovf(n)%reg_ent%imax, master_task) + call broadcast_scalar(ovf(n)%reg_ent%jmin, master_task) + call broadcast_scalar(ovf(n)%reg_ent%jmax, master_task) + call broadcast_scalar(ovf(n)%reg_ent%kmin, master_task) + call broadcast_scalar(ovf(n)%reg_ent%kmax, master_task) +! src locs and orientation + call broadcast_scalar(ovf(n)%num_src, master_task) + do m=1,ovf(n)%num_src + call broadcast_scalar(ovf(n)%loc_src(m)%i, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%j, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%i_adv, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%j_adv, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%i_u, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%j_u, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%k, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%orient, master_task) + end do +! ent locs and orientation + call broadcast_scalar(ovf(n)%num_ent, master_task) + do m=1,ovf(n)%num_ent + call broadcast_scalar(ovf(n)%loc_ent(m)%i, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%j, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%i_adv, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%j_adv, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%i_u, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%j_u, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%k, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%orient, master_task) + end do +! prd locs and orientation + call broadcast_scalar(ovf(n)%num_prd_sets, master_task) + do m=1,ovf(n)%num_prd_sets + call broadcast_scalar(ovf(n)%num_prd(m), master_task) + do mp=1,ovf(n)%num_prd(m) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%i, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%j, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%i_adv, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%j_adv, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%i_u, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%j_u, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%k, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%orient, master_task) + end do + end do +! adjacent boundaries + call broadcast_scalar(ovf(n)%adj_src%imin, master_task) + call broadcast_scalar(ovf(n)%adj_src%imax, master_task) + call broadcast_scalar(ovf(n)%adj_src%jmin, master_task) + call broadcast_scalar(ovf(n)%adj_src%jmax, master_task) + call broadcast_scalar(ovf(n)%adj_src%kmin, master_task) + call broadcast_scalar(ovf(n)%adj_src%kmax, master_task) + call broadcast_scalar(ovf(n)%adj_ent%imin, master_task) + call broadcast_scalar(ovf(n)%adj_ent%imax, master_task) + call broadcast_scalar(ovf(n)%adj_ent%jmin, master_task) + call broadcast_scalar(ovf(n)%adj_ent%jmax, master_task) + call broadcast_scalar(ovf(n)%adj_ent%kmin, master_task) + call broadcast_scalar(ovf(n)%adj_ent%kmax, master_task) + do m=1,ovf(n)%num_prd_sets + call broadcast_scalar(ovf(n)%adj_prd(m)%imin, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%imax, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%jmin, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%jmax, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%kmin, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%kmax, master_task) + end do +! transports + call broadcast_scalar(ovf(n)%Ms, master_task) + call broadcast_scalar(ovf(n)%Ms_n, master_task) + call broadcast_scalar(ovf(n)%Ms_nm1, master_task) + call broadcast_scalar(ovf(n)%Me, master_task) + call broadcast_scalar(ovf(n)%Me_n, master_task) + call broadcast_scalar(ovf(n)%Me_nm1, master_task) + call broadcast_scalar(ovf(n)%phi, master_task) + call broadcast_scalar(ovf(n)%Mp, master_task) + call broadcast_scalar(ovf(n)%Mp_n, master_task) + call broadcast_scalar(ovf(n)%Mp_nm1, master_task) + call broadcast_scalar(ovf(n)%Tp, master_task) + call broadcast_scalar(ovf(n)%Sp, master_task) + call broadcast_scalar(ovf(n)%prd_set_n, master_task) + call broadcast_scalar(ovf(n)%prd_set, master_task) + do nn=1,nt + call broadcast_scalar(ovf(n)%trcr_reg%inf(nn), master_task) + call broadcast_scalar(ovf(n)%trcr_reg%src(nn), master_task) + call broadcast_scalar(ovf(n)%trcr_reg%ent(nn), master_task) + call broadcast_scalar(ovf(n)%trcr_reg%prd(nn), master_task) + call broadcast_scalar(ovf(n)%trcr_adj%src(nn), master_task) + call broadcast_scalar(ovf(n)%trcr_adj%ent(nn), master_task) + call broadcast_scalar(ovf(n)%trcr_adj%prd(nn), master_task) + end do + + end do ! ovf broadcast loop for all processors + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_read_broadcast + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_advt +! !INTERFACE: + + subroutine ovf_advt(k,TRACER_E,TRACER_N,ntr,this_block, & + CE,CW,CN,CS) + +! !DESCRIPTION: +! Modify tracer grid interface value for advection for +! overflow points; orientation determines if E or N is modified +! !REVISION HISTORY: +! same as module +! +! ovf t-grid box ij showing advection grid boxes +! (i_adv,j_adv) set by orientation +! ij+1 +! +! ____2_____ +! y ^ | | +! | | | +! | i-1j 3| ij |1 i+1j +! +-----> | | +! x |__________| +! 4 +! +! ij-1 +! +! Note! Orientations are relative to overflow ij, while +! the advection boxes are offset as in the diagram above. +! Thus, the indices for TRACER_E and TRACER_N are reversed. +! For instance, orient=1 src, the advection box is i+1,j +! above, but when ij is that box (see below), then it is the +! western TRACER_E, or i-1j, that is overwritten. This is +! reversed from the center ij, because of the offset in the +! advection boxes relative to box ij. +! +! Note! ij loops include ghost points incase advection +! scheme requires them. + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + integer (int_kind), intent(in) :: & + k ! vertical index + real (r8), dimension(nx_block,ny_block), intent(inout) :: & + TRACER_E, & ! east gridbox interface tracer at level k + TRACER_N ! north gridbox interface tracer at level k + integer (int_kind), intent(in) :: & + ntr ! tracer index + type (block), intent(in) :: & + this_block ! block information for this block + + real (r8), dimension(nx_block,ny_block), intent(in) :: & + CN,CS,CE,CW ! stencil weights based on flux velocities + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + n,m,mp,i,j, & ! dummy loop indices + ksrc,kent,kprd ! overflow level indices + + integer (int_kind) :: & + iblock ! local block address for this block + + logical (log_kind), parameter :: prnt = .false. + +! turn off print 3 Nov 2008 +! if( prnt .and. my_task == master_task ) then +! write(stdout,*) 'ovf_advt called ' +! call shr_sys_flush(stdout) +! endif + + iblock = this_block%local_id + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + do n=1,num_ovf ! each overflow +! src + do m=1,ovf(n)%num_src ! source + ksrc = ovf(n)%loc_src(m)%k + if( k == ksrc ) then + do j=1,ny_block + if( ovf(n)%loc_src(m)%j_adv .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(n)%loc_src(m)%i_adv .eq. this_block%i_glob(i) ) then + if( prnt ) then + write(stdout,5) nsteps_total,n,ovf(n)%loc_src(m)%i_adv, & + ovf(n)%loc_src(m)%j_adv,ovf(n)%loc_src(m)%k, & + ovf(n)%loc_src(m)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1) + 5 format(' In ovf_advt src ',i5,1x,6(i3,1x),4(1pe15.8,1x)) + endif ! print + if( i > 1 ) then + if( ovf(n)%loc_src(m)%orient .eq. 1 ) then + TRACER_E(i-1,j) = ovf(n)%trcr_reg%src(ntr) + endif + endif + if( j > 1 ) then + if( ovf(n)%loc_src(m)%orient .eq. 2 ) then + TRACER_N(i,j-1) = ovf(n)%trcr_reg%src(ntr) + endif + endif + if( ovf(n)%loc_src(m)%orient .eq. 3 ) then + TRACER_E(i,j) = ovf(n)%trcr_reg%src(ntr) + endif + if( ovf(n)%loc_src(m)%orient .eq. 4 ) then + TRACER_N(i,j) = ovf(n)%trcr_reg%src(ntr) + endif + if( prnt ) then + write(stdout,10) nsteps_total,n,ovf(n)%loc_src(m)%i_adv, & + ovf(n)%loc_src(m)%j_adv,ovf(n)%loc_src(m)%k, & + ovf(n)%loc_src(m)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1), & + nsteps_total,n,ovf(n)%loc_src(m)%i_adv, & + ovf(n)%loc_src(m)%j_adv,ovf(n)%loc_src(m)%k, & + ovf(n)%loc_src(m)%orient,ntr, & + CE(i,j)*dz(ksrc)*TAREA(i,j,iblock),CW(i,j)*dz(ksrc)*TAREA(i,j,iblock), & + CN(i,j)*dz(ksrc)*TAREA(i,j,iblock),CS(i,j)*dz(ksrc)*TAREA(i,j,iblock), & + nsteps_total,n,ovf(n)%loc_src(m)%i_adv, & + ovf(n)%loc_src(m)%j_adv,ovf(n)%loc_src(m)%k, & + ovf(n)%loc_src(m)%orient,ntr, & + CE(i,j)*dz(ksrc)*TAREA(i,j,iblock)*TRACER_E(i,j), & + CW(i,j)*dz(ksrc)*TAREA(i,j,iblock)*TRACER_E(i-1,j) + 10 format(' Out ovf_advt src ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out ovf_advt src M ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out ovf_advt src CT',i5,1x,6(i3,1x),2(1pe15.8,1x)) + endif ! print + endif + end do ! i + endif + end do ! j + endif ! k + end do ! source +! ent + do m=1,ovf(n)%num_ent ! entrainment + kent = ovf(n)%loc_ent(m)%k + if( k == kent ) then + do j=1,ny_block + if( ovf(n)%loc_ent(m)%j_adv .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(n)%loc_ent(m)%i_adv .eq. this_block%i_glob(i) ) then + if( prnt ) then + write(stdout,15) nsteps_total,n,ovf(n)%loc_ent(m)%i_adv, & + ovf(n)%loc_ent(m)%j_adv,ovf(n)%loc_ent(m)%k, & + ovf(n)%loc_ent(m)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1) + 15 format(' In ovf_advt ent ',i5,1x,6(i3,1x),4(1pe15.8,1x)) + endif ! print + if( i > 1 ) then + if( ovf(n)%loc_ent(m)%orient .eq. 1 ) then + TRACER_E(i-1,j) = ovf(n)%trcr_reg%ent(ntr) + endif + endif + if( j > 1 ) then + if( ovf(n)%loc_ent(m)%orient .eq. 2 ) then + TRACER_N(i,j-1) = ovf(n)%trcr_reg%ent(ntr) + endif + endif + if( ovf(n)%loc_ent(m)%orient .eq. 3 ) then + TRACER_E(i,j) = ovf(n)%trcr_reg%ent(ntr) + endif + if( ovf(n)%loc_ent(m)%orient .eq. 4 ) then + TRACER_N(i,j) = ovf(n)%trcr_reg%ent(ntr) + endif + if( prnt ) then + write(stdout,20) nsteps_total,n,ovf(n)%loc_ent(m)%i_adv, & + ovf(n)%loc_ent(m)%j_adv,ovf(n)%loc_ent(m)%k, & + ovf(n)%loc_ent(m)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1), & + nsteps_total,n,ovf(n)%loc_ent(m)%i_adv, & + ovf(n)%loc_ent(m)%j_adv,ovf(n)%loc_ent(m)%k, & + ovf(n)%loc_ent(m)%orient,ntr, & + CE(i,j)*dz(kent)*TAREA(i,j,iblock),CW(i,j)*dz(kent)*TAREA(i,j,iblock), & + CN(i,j)*dz(kent)*TAREA(i,j,iblock),CS(i,j)*dz(kent)*TAREA(i,j,iblock), & + nsteps_total,n,ovf(n)%loc_ent(m)%i_adv, & + ovf(n)%loc_ent(m)%j_adv,ovf(n)%loc_ent(m)%k, & + ovf(n)%loc_ent(m)%orient,ntr, & + CE(i,j)*dz(kent)*TAREA(i,j,iblock)*TRACER_E(i,j), & + CW(i,j)*dz(kent)*TAREA(i,j,iblock)*TRACER_E(i-1,j) + 20 format(' Out ovf_advt ent ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out ovf_advt ent M ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out ovf_advt ent CT',i5,1x,6(i3,1x),2(1pe15.8,1x)) + endif ! print + endif + end do ! i + endif + end do ! j + endif ! k + end do ! entrainment +! prd + m = ovf(n)%prd_set ! product set for insertion + do mp=1,ovf(n)%num_prd(m) ! product points for insertion + kprd = ovf(n)%loc_prd(m,mp)%k + if( k == kprd ) then + do j=1,ny_block + if( ovf(n)%loc_prd(m,mp)%j_adv .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(n)%loc_prd(m,mp)%i_adv .eq. this_block%i_glob(i) ) then + if( prnt ) then + write(stdout,25) nsteps_total,n,ovf(n)%loc_prd(m,mp)%i_adv, & + ovf(n)%loc_prd(m,mp)%j_adv,ovf(n)%loc_prd(m,mp)%k, & + ovf(n)%loc_prd(m,mp)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1) + 25 format(' In ovf_advt prd ',i5,1x,6(i3,1x),4(1pe15.8,1x)) + endif ! print + if( i > 1 ) then + if( ovf(n)%loc_prd(m,mp)%orient .eq. 1 ) then + TRACER_E(i-1,j) = ovf(n)%trcr_reg%prd(ntr) + endif + endif + if( j > 1 ) then + if( ovf(n)%loc_prd(m,mp)%orient .eq. 2 ) then + TRACER_N(i,j-1) = ovf(n)%trcr_reg%prd(ntr) + endif + endif + if( ovf(n)%loc_prd(m,mp)%orient .eq. 3 ) then + TRACER_E(i,j) = ovf(n)%trcr_reg%prd(ntr) + endif + if( ovf(n)%loc_prd(m,mp)%orient .eq. 4 ) then + TRACER_N(i,j) = ovf(n)%trcr_reg%prd(ntr) + endif + if( prnt ) then + write(stdout,35) nsteps_total,n,ovf(n)%loc_prd(m,mp)%i_adv, & + ovf(n)%loc_prd(m,mp)%j_adv,ovf(n)%loc_prd(m,mp)%k, & + ovf(n)%loc_prd(m,mp)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1), & + nsteps_total,n,ovf(n)%loc_prd(m,mp)%i_adv, & + ovf(n)%loc_prd(m,mp)%j_adv,ovf(n)%loc_prd(m,mp)%k, & + ovf(n)%loc_prd(m,mp)%orient,ntr, & + CE(i,j)*dz(kprd)*TAREA(i,j,iblock),CW(i,j)*dz(kprd)*TAREA(i,j,iblock), & + CN(i,j)*dz(kprd)*TAREA(i,j,iblock),CS(i,j)*dz(kprd)*TAREA(i,j,iblock), & + nsteps_total,n,ovf(n)%loc_prd(m,mp)%i_adv, & + ovf(n)%loc_prd(m,mp)%j_adv,ovf(n)%loc_prd(m,mp)%k, & + ovf(n)%loc_prd(m,mp)%orient,ntr, & + CE(i,j)*dz(kprd)*TAREA(i,j,iblock)*TRACER_E(i,j), & + CW(i,j)*dz(kprd)*TAREA(i,j,iblock)*TRACER_E(i-1,j) + 35 format(' Out ovf_advt prd ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out ovf_advt prd M ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out ovf_advt prd CT',i5,1x,6(i3,1x),2(1pe15.8,1x)) + endif ! print + endif + end do ! i + endif + end do ! j + endif ! k + end do ! product points for insertion set +! If prd set just moved and time averaging done previous time step + if( ovf(n)%prd_set .ne. ovf(n)%prd_set_n ) then + m = ovf(n)%prd_set_n ! product set for insertion + do mp=1,ovf(n)%num_prd(m) ! product points for insertion + kprd = ovf(n)%loc_prd(m,mp)%k + if( k == kprd ) then + do j=1,ny_block + if( ovf(n)%loc_prd(m,mp)%j_adv .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(n)%loc_prd(m,mp)%i_adv .eq. this_block%i_glob(i) ) then + if( prnt ) then + write(stdout,26) nsteps_total,n,ovf(n)%loc_prd(m,mp)%i_adv, & + ovf(n)%loc_prd(m,mp)%j_adv,ovf(n)%loc_prd(m,mp)%k, & + ovf(n)%loc_prd(m,mp)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1) + 26 format(' In_n ovf_advt prd ',i5,1x,6(i3,1x),4(1pe15.8,1x)) + endif ! print + if( avg_ts_last ) then + if( i > 1 ) then + if( ovf(n)%loc_prd(m,mp)%orient .eq. 1 ) then + TRACER_E(i-1,j) = ovf(n)%trcr_reg%prd(ntr) + endif + endif + if( j > 1 ) then + if( ovf(n)%loc_prd(m,mp)%orient .eq. 2 ) then + TRACER_N(i,j-1) = ovf(n)%trcr_reg%prd(ntr) + endif + endif + if( ovf(n)%loc_prd(m,mp)%orient .eq. 3 ) then + TRACER_E(i,j) = ovf(n)%trcr_reg%prd(ntr) + endif + if( ovf(n)%loc_prd(m,mp)%orient .eq. 4 ) then + TRACER_N(i,j) = ovf(n)%trcr_reg%prd(ntr) + endif + endif + if( prnt ) then + write(stdout,36) nsteps_total,n,ovf(n)%loc_prd(m,mp)%i_adv, & + ovf(n)%loc_prd(m,mp)%j_adv,ovf(n)%loc_prd(m,mp)%k, & + ovf(n)%loc_prd(m,mp)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1), & + nsteps_total,n,ovf(n)%loc_prd(m,mp)%i_adv, & + ovf(n)%loc_prd(m,mp)%j_adv,ovf(n)%loc_prd(m,mp)%k, & + ovf(n)%loc_prd(m,mp)%orient,ntr, & + CE(i,j)*dz(kprd)*TAREA(i,j,iblock),CW(i,j)*dz(kprd)*TAREA(i,j,iblock), & + CN(i,j)*dz(kprd)*TAREA(i,j,iblock),CS(i,j)*dz(kprd)*TAREA(i,j,iblock), & + nsteps_total,n,ovf(n)%loc_prd(m,mp)%i_adv, & + ovf(n)%loc_prd(m,mp)%j_adv,ovf(n)%loc_prd(m,mp)%k, & + ovf(n)%loc_prd(m,mp)%orient,ntr, & + CE(i,j)*dz(kprd)*TAREA(i,j,iblock)*TRACER_E(i,j), & + CW(i,j)*dz(kprd)*TAREA(i,j,iblock)*TRACER_E(i-1,j) + 36 format(' Out_n ovf_advt prd ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out_n ovf_advt prd M ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out_n ovf_advt prd CT',i5,1x,6(i3,1x),2(1pe15.8,1x)) + endif ! print + endif + end do ! i + endif + end do ! j + endif ! k + end do ! product points for insertion set + endif + end do ! each overflow +! special diagnostic 11 nov 2008 + call ovf_UV_check + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_advt + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_wtkb_check +! !INTERFACE: + + subroutine ovf_wtkb_check(k,WTKB,this_block) + +! !DESCRIPTION: +! Print out wtkb for overflow gridboxes +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + integer (int_kind), intent(in) :: & + k ! vertical index + real (r8), dimension(nx_block,ny_block,nblocks_clinic), intent(in) :: & + WTKB ! WTKB = W at bottom of t-grid box + type (block), intent(in) :: & + this_block ! block information for this block + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + n,m,mp,i,j, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + iblock ! local block address for this block + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_wtkb_check called ' + call shr_sys_flush(stdout) + endif + + iblock = this_block%local_id + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + do n=1,num_ovf ! each overflow +! ovf ij +! src + do m=1,ovf(n)%num_src ! source + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_src(m)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_src(m)%i .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,10) n,nsteps_total,ovf(n)%loc_src(m)%i, & + ovf(n)%loc_src(m)%j,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 10 format(' ovf_wtkb_ch n=',i3, & + ' src t,i,j,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif + endif + end do ! i + endif + end do ! j + end do ! source +! ent + do m=1,ovf(n)%num_ent ! entrainment + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_ent(m)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_ent(m)%i .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,20) n,nsteps_total,ovf(n)%loc_ent(m)%i, & + ovf(n)%loc_ent(m)%j,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 20 format(' ovf_wtkb_ch n=',i3, & + ' ent t,i,j,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif + endif + end do ! i + endif + end do ! j + end do ! entrainment +! prd + m = ovf(n)%prd_set ! product set for insertion + do mp=1,ovf(n)%num_prd(m) ! product points for insertion + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,30) n,nsteps_total,ovf(n)%loc_prd(m,mp)%i, & + ovf(n)%loc_prd(m,mp)%j,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 30 format(' ovf_wtkb_ch n=',i3, & + ' prd t,i,j,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif + endif + end do ! i + endif + end do ! j + end do ! product points for insertion set +! prd + do m=1,ovf(n)%num_prd_sets + do mp=1,ovf(n)%num_prd(m) ! product points for insertion + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,31) n,nsteps_total,ovf(n)%loc_prd(m,mp)%i, & + ovf(n)%loc_prd(m,mp)%j,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 31 format(' ovf_wtkb_ch n=',i3, & + ' all prd t,i,j,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif + endif + end do ! i + endif + end do ! j + end do ! product points for insertion set + end do ! product sets +! ovf i_adv j_adv +! src + do m=1,ovf(n)%num_src ! source + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_src(m)%j_adv .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_src(m)%i_adv .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,40) n,nsteps_total,ovf(n)%loc_src(m)%i_adv, & + ovf(n)%loc_src(m)%j_adv,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 40 format(' ovf_wtkb_ch n=',i3, & + ' src t,i_adv,j_adv,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif ! k + endif + end do ! i + endif + end do ! j + end do ! source +! ent + do m=1,ovf(n)%num_ent ! entrainment + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_ent(m)%j_adv .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_ent(m)%i_adv .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,50) n,nsteps_total,ovf(n)%loc_ent(m)%i_adv, & + ovf(n)%loc_ent(m)%j_adv,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 50 format(' ovf_wtkb_ch n=',i3, & + ' ent t,i_adv,j_adv,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif ! k + endif + end do ! i + endif + end do ! j + end do ! entrainment +! prd + m = ovf(n)%prd_set ! product set for insertion + do mp=1,ovf(n)%num_prd(m) ! product points for insertion + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j_adv .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i_adv .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,60) n,nsteps_total,ovf(n)%loc_prd(m,mp)%i_adv, & + ovf(n)%loc_prd(m,mp)%j_adv,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 60 format(' ovf_wtkb_ch n=',i3, & + ' prd t,i_adv,j_adv,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif ! k + endif + end do ! i + endif + end do ! j + end do ! product points for insertion set +! prd + do m=1,ovf(n)%num_prd_sets + do mp=1,ovf(n)%num_prd(m) ! product points for insertion if moved + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j_adv .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i_adv .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,61) n,nsteps_total,ovf(n)%loc_prd(m,mp)%i_adv, & + ovf(n)%loc_prd(m,mp)%j_adv,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 61 format(' ovf_wtkb_ch n=',i3, & + ' all prd t,i_adv,j_adv,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif ! k + endif + end do ! i + endif + end do ! j + end do ! product points for insertion set + end do ! original product set if moved + end do ! each overflow + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_wtkb_check + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_UV_check +! !INTERFACE: + + subroutine ovf_UV_check + +! !DESCRIPTION: +! Print out column UVEL, VVEL for overflow gridboxes +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + n,m,mp,i,j,k, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + iblock, & ! local block address for this block + ksrc,kent,kprd ! overflow level indices + type (block) :: & + this_block ! block information for this block + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_UV_check called ' + call shr_sys_flush(stdout) + endif + + if( prnt ) then + write(stdout,5) nsteps_total + 5 format(' ovf_UV_check called at nsteps_total=',i6) +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + do n=1,num_ovf ! each overflow +! src + do m=1,ovf(n)%num_src ! source + ksrc = ovf(n)%loc_src(m)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + write(stdout,15) n,ovf(n)%loc_src(m)%i_u, & + ovf(n)%loc_src(m)%j_u + 15 format(' ovf_UV_check n=',i2,' src i_u j_u = ',2(i3,1x)) +! do k=1,ksrc + k=ksrc +! write(stdout,10) k,UVEL(i,j,k,oldtime,iblock), & +! UVEL(i,j,k,curtime,iblock),UVEL(i,j,k,newtime,iblock), & +! VVEL(i,j,k,oldtime,iblock), & +! VVEL(i,j,k,curtime,iblock),VVEL(i,j,k,newtime,iblock) + 10 format(' k old cur new UVEL= ',i2,1x,3(f9.5,1x), & + ' VVEL=',3(f9.5,1x)) +! end do ! k + endif + end do ! i + endif + end do ! j + enddo ! block + end do ! source +! ent + do m=1,ovf(n)%num_ent ! entrainment + kent = ovf(n)%loc_ent(m)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + write(stdout,25) n,ovf(n)%loc_ent(m)%i_u, & + ovf(n)%loc_ent(m)%j_u + 25 format(' ovf_UV_check n=',i2,' ent i_u j_u = ',2(i3,1x)) +! do k=1,kent + k=kent +! write(stdout,20) k,UVEL(i,j,k,oldtime,iblock), & +! UVEL(i,j,k,curtime,iblock),UVEL(i,j,k,newtime,iblock), & +! VVEL(i,j,k,oldtime,iblock), & +! VVEL(i,j,k,curtime,iblock),VVEL(i,j,k,newtime,iblock) + 20 format(' k old cur new UVEL= ',i2,1x,3(f9.5,1x), & + ' VVEL=',3(f9.5,1x)) +! end do ! k + endif + end do ! i + endif + end do ! j + enddo ! block + end do ! entrainment +! prd + do m=1,ovf(n)%num_prd_sets + do mp=1,ovf(n)%num_prd(m) + kprd = ovf(n)%loc_prd(m,mp)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + write(stdout,35) n,ovf(n)%loc_prd(m,mp)%i_u, & + ovf(n)%loc_prd(m,mp)%j_u + 35 format(' ovf_UV_check n=',i2,' prd i_u j_u = ',2(i3,1x)) +! do k=1,kprd + k=kprd + write(stdout,30) nsteps_total,n, & + ovf(n)%loc_prd(m,mp)%i_u,ovf(n)%loc_prd(m,mp)%j_u, & + k,UVEL(i,j,k,oldtime,iblock), & + UVEL(i,j,k,curtime,iblock),UVEL(i,j,k,newtime,iblock) + 30 format(' prd t,n,i,j,k old cur new UVEL= ',5(i4,1x),1x,3(f9.5,1x)) +! end do ! k + endif + end do ! i + endif + end do ! j + enddo ! block + end do ! product + end do + end do ! each overflow + endif ! print +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_UV_check + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_Utlda +! !INTERFACE: + + subroutine ovf_Utlda(iblock) + +! !DESCRIPTION: +! Save ovf sidewall unnormalized baroclinic velocities Utlda. Must be +! called AFTER the baroclinic solution Utlda is found but BEFORE the +! baroclinic velocities are normalized (i.e. vertical integral of +! baroclinic velocity from surface to bottom topography is zero). +! +! ij t-grid i_u,j_u u-grid +! +! assignment of U on u-grid +! orientation=1 i_u = i j_u = j +! =2 i_u = i-1 j_u = j +! =3 i_u = i-1 j_u = j-1 +! =4 i_u = i j_u = j-1 +! +! ovf t-grid box ij with u-grid +! corners and orientations +! 2 (i_u,j_u) +! i-1j __________ij +! y ^ | | +! | | | +! | 3 | ij | 1 +! +-----> | | +! x |__________| +! i-1j-1 ij-1 +! 4 +! for example, for ovf grid box ij, +! with product orientation 4, the Utlda +! in the above diagram would be ij-1 +! lower right corner +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + integer (int_kind), & + intent(in) :: & + iblock ! block index + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + i,j,k,n,m,mp, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + ksrc,kent,kprd ! overflow level indices + type (block) :: & + this_block ! block information for current block + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_Utlda called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + do n=1,num_ovf ! each overflow +! src + do m=1,ovf(n)%num_src ! source + ksrc = ovf(n)%loc_src(m)%k + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + do k=1,ksrc-1 + ovf(n)%loc_src(m)%Utlda(k) = UVEL(i,j,k,newtime,iblock) + ovf(n)%loc_src(m)%Vtlda(k) = VVEL(i,j,k,newtime,iblock) + enddo + if(prnt) then + write(stdout,10) n,ovf(n)%loc_src(m)%i_u, & + ovf(n)%loc_src(m)%j_u, & + ovf(n)%loc_src(m)%orient,ksrc + 10 format(' ovf_Utlda n=',i3, & + ' src i_u j_u orient k=',4(i4,1x)) + do k=1,ksrc-1 + write(stdout,15) k,ovf(n)%loc_src(m)%Utlda(k), & + ovf(n)%loc_src(m)%Vtlda(k) + 15 format(' k=',i3,1x,'Utlda Vtlda= ',2(f9.5,2x)) + enddo + endif + endif + end do ! i + endif + end do ! j + end do ! source +! ent + do m=1,ovf(n)%num_ent ! entrainment + kent = ovf(n)%loc_ent(m)%k + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + do k=1,kent-1 + ovf(n)%loc_ent(m)%Utlda(k) = UVEL(i,j,k,newtime,iblock) + ovf(n)%loc_ent(m)%Vtlda(k) = VVEL(i,j,k,newtime,iblock) + enddo + if(prnt) then + write(stdout,20) n,ovf(n)%loc_ent(m)%i_u, & + ovf(n)%loc_ent(m)%j_u, & + ovf(n)%loc_ent(m)%orient,kent + 20 format(' ovf_Utlda n=',i3, & + ' ent i_u j_u orient k=',4(i4,1x)) + do k=1,kent-1 + write(stdout,25) k,ovf(n)%loc_ent(m)%Utlda(k), & + ovf(n)%loc_ent(m)%Vtlda(k) + 25 format(' k=',i3,1x,'Utlda Vtlda= ',2(f9.5,2x)) + enddo + endif + endif + end do ! i + endif + end do ! j + end do ! entrainment +! prd + do m=1,ovf(n)%num_prd_sets + do mp=1,ovf(n)%num_prd(m) ! product points for each set + kprd = ovf(n)%loc_prd(m,mp)%k + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + do k=1,kprd-1 + ovf(n)%loc_prd(m,mp)%Utlda(k) = UVEL(i,j,k,newtime,iblock) + ovf(n)%loc_prd(m,mp)%Vtlda(k) = VVEL(i,j,k,newtime,iblock) + enddo + if(prnt) then + write(stdout,30) n,ovf(n)%loc_prd(m,mp)%i_u, & + ovf(n)%loc_prd(m,mp)%j_u, & + ovf(n)%loc_prd(m,mp)%orient,kprd + 30 format(' ovf_Utlda n=',i3, & + ' prd i_u j_u orient k=',4(i4,1x)) + do k=1,kprd-1 + write(stdout,35) k,ovf(n)%loc_prd(m,mp)%Utlda(k), & + ovf(n)%loc_prd(m,mp)%Vtlda(k) + 35 format(' k=',i3,1x,'Utlda Vtlda= ',2(f9.5,2x)) + enddo + endif + endif + end do ! i + endif + end do ! j + end do ! product points for each set + end do ! product sets + end do ! each overflow + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_Utlda + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_driver +! !INTERFACE: + + subroutine ovf_driver + +! !DESCRIPTION: +! This routine is the main overflow (ovf) driver, called +! in step_mod.F90 between baroclinic and barotropic drivers. +! It calls routines to compute ovf regional means, transports, +! product locations and sidewall velocity evaluation. +! +! !REVISION HISTORY: +! same as module + + logical (log_kind), parameter :: prnt = .false. + +!EOP +!BOC + + if(prnt) then + write(stdout,*) ' ovf_driver entered ' + call shr_sys_flush(stdout) + endif + +!---------------------------------------------------------------------- +! +! ovf regional averages +! +!---------------------------------------------------------------------- + + call ovf_reg_avgs(curtime) + +!---------------------------------------------------------------------- +! +! ovf transports +! +!---------------------------------------------------------------------- + + call ovf_transports + +!---------------------------------------------------------------------- +! +! ovf location of product +! +!---------------------------------------------------------------------- + + call ovf_loc_prd + +!---------------------------------------------------------------------- +! +! ovf top W evaluation +! +!---------------------------------------------------------------------- + + call ovf_W + +!---------------------------------------------------------------------- +! +! ovf sidewall UV evaluation +! +!---------------------------------------------------------------------- + + call ovf_UV + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_driver + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_reg_avgs +! !INTERFACE: + + subroutine ovf_reg_avgs(time_level) + +! !DESCRIPTION: +! Evaluate the ovf regional averages +! +! !REVISION HISTORY: +! same as module + +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + integer (int_kind) :: &! time indices for prognostic arrays + time_level ! current time level (n) + +!---------------------------------------------------------------------- +! +! local variables +! +!---------------------------------------------------------------------- + + integer (int_kind) :: & + iblock,k,n,nn,m ! dummy loop indices + + type (block) :: & + this_block ! block information for current block + + real (r8), dimension(nx_block,ny_block,max_blocks_clinic) :: & + WRK ! temp work array + real (r8) vsum_reg_wght, & ! vertical sum regional weight + vsum_adj_wght ! vertical sum adjacent weight + + logical (log_kind), parameter :: prnt = .false. + +!EOP +!BOC + + if(prnt) then + write(stdout,*) ' ovf_reg_avgs called ' + call shr_sys_flush(stdout) + endif + +! inflow region + do n=1,num_ovf + if( ovf(n)%wght_reg%inf .eq. c0 ) then + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = DXT(:,:,iblock)*DYT(:,:,iblock) & + *ovf(n)%mask_reg%inf(:,:,iblock) + end do + ovf(n)%wght_reg%inf = & + global_sum(WRK,distrb_clinic,field_loc_center) + endif + do nn = 1,nt + ovf(n)%trcr_reg%inf(nn) = c0 + end do + vsum_reg_wght = c0 + ovf(n)%rho_reg%inf = c0 + do k = ovf(n)%reg_inf%kmin, ovf(n)%reg_inf%kmax + vsum_reg_wght = vsum_reg_wght + ovf(n)%wght_reg%inf*dz(k) + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = RHO(:,:,k,time_level,iblock) & + *DXT(:,:,iblock)*DYT(:,:,iblock)*dz(k) & + *ovf(n)%mask_reg%inf(:,:,iblock) + end do + ovf(n)%rho_reg%inf = ovf(n)%rho_reg%inf + & + global_sum(WRK,distrb_clinic,field_loc_center) + do nn = 1,nt + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = TRACER(:,:,k,nn,time_level,iblock) & + *DXT(:,:,iblock)*DYT(:,:,iblock)*dz(k) & + *ovf(n)%mask_reg%inf(:,:,iblock) + end do + ovf(n)%trcr_reg%inf(nn) = ovf(n)%trcr_reg%inf(nn) + & + global_sum(WRK,distrb_clinic,field_loc_center) + end do + end do + do nn = 1,nt + ovf(n)%trcr_reg%inf(nn) = ovf(n)%trcr_reg%inf(nn) / vsum_reg_wght + end do + ovf(n)%rho_reg%inf = ovf(n)%rho_reg%inf / vsum_reg_wght + end do + +! source region + do n=1,num_ovf + if( ovf(n)%wght_reg%src .eq. c0 ) then + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = DXT(:,:,iblock)*DYT(:,:,iblock) & + *ovf(n)%mask_reg%src(:,:,iblock) + end do + ovf(n)%wght_reg%src = & + global_sum(WRK,distrb_clinic,field_loc_center) + endif + do nn = 1,nt + ovf(n)%trcr_reg%src(nn) = c0 + end do + vsum_reg_wght = c0 + ovf(n)%rho_reg%src = c0 + do k = ovf(n)%reg_src%kmin, ovf(n)%reg_src%kmax + vsum_reg_wght = vsum_reg_wght + ovf(n)%wght_reg%src*dz(k) + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = RHO(:,:,k,time_level,iblock) & + *DXT(:,:,iblock)*DYT(:,:,iblock)*dz(k) & + *ovf(n)%mask_reg%src(:,:,iblock) + end do + ovf(n)%rho_reg%src = ovf(n)%rho_reg%src + & + global_sum(WRK,distrb_clinic,field_loc_center) + do nn = 1,nt + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = TRACER(:,:,k,nn,time_level,iblock) & + *DXT(:,:,iblock)*DYT(:,:,iblock)*dz(k) & + *ovf(n)%mask_reg%src(:,:,iblock) + end do + ovf(n)%trcr_reg%src(nn) = ovf(n)%trcr_reg%src(nn) + & + global_sum(WRK,distrb_clinic,field_loc_center) + end do + end do + do nn = 1,nt + ovf(n)%trcr_reg%src(nn) = ovf(n)%trcr_reg%src(nn) / vsum_reg_wght + end do + ovf(n)%rho_reg%src = ovf(n)%rho_reg%src / vsum_reg_wght + end do + +! source adjacent + do n=1,num_ovf + if( ovf(n)%wght_adj%src .eq. c0 ) then + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = DXT(:,:,iblock)*DYT(:,:,iblock) & + *ovf(n)%mask_adj%src(:,:,iblock) + end do + ovf(n)%wght_adj%src = & + global_sum(WRK,distrb_clinic,field_loc_center) + endif + do nn = 1,nt + ovf(n)%trcr_adj%src(nn) = c0 + end do + vsum_adj_wght = c0 + do k = ovf(n)%adj_src%kmin, ovf(n)%adj_src%kmax + vsum_adj_wght = vsum_adj_wght + ovf(n)%wght_adj%src*dz(k) + do nn = 1,nt + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = TRACER(:,:,k,nn,time_level,iblock) & + *DXT(:,:,iblock)*DYT(:,:,iblock)*dz(k) & + *ovf(n)%mask_adj%src(:,:,iblock) + end do + ovf(n)%trcr_adj%src(nn) = ovf(n)%trcr_adj%src(nn) + & + global_sum(WRK,distrb_clinic,field_loc_center) + end do + end do + do nn = 1,nt + ovf(n)%trcr_adj%src(nn) = ovf(n)%trcr_adj%src(nn) / vsum_adj_wght + end do + end do + +! entrainment region + do n=1,num_ovf + if( ovf(n)%wght_reg%ent .eq. c0 ) then + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = DXT(:,:,iblock)*DYT(:,:,iblock) & + *ovf(n)%mask_reg%ent(:,:,iblock) + end do + ovf(n)%wght_reg%ent = & + global_sum(WRK,distrb_clinic,field_loc_center) + endif + do nn = 1,nt + ovf(n)%trcr_reg%ent(nn) = c0 + end do + vsum_reg_wght = c0 + ovf(n)%rho_reg%ent = c0 + do k = ovf(n)%reg_ent%kmin, ovf(n)%reg_ent%kmax + vsum_reg_wght = vsum_reg_wght + ovf(n)%wght_reg%ent*dz(k) + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = RHO(:,:,k,time_level,iblock) & + *DXT(:,:,iblock)*DYT(:,:,iblock)*dz(k) & + *ovf(n)%mask_reg%ent(:,:,iblock) + end do + ovf(n)%rho_reg%ent = ovf(n)%rho_reg%ent + & + global_sum(WRK,distrb_clinic,field_loc_center) + do nn = 1,nt + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = TRACER(:,:,k,nn,time_level,iblock) & + *DXT(:,:,iblock)*DYT(:,:,iblock)*dz(k) & + *ovf(n)%mask_reg%ent(:,:,iblock) + end do + ovf(n)%trcr_reg%ent(nn) = ovf(n)%trcr_reg%ent(nn) + & + global_sum(WRK,distrb_clinic,field_loc_center) + end do + end do + do nn = 1,nt + ovf(n)%trcr_reg%ent(nn) = ovf(n)%trcr_reg%ent(nn) / vsum_reg_wght + end do + ovf(n)%rho_reg%ent = ovf(n)%rho_reg%ent / vsum_reg_wght + end do + +! entrainment adjacent + do n=1,num_ovf + if( ovf(n)%wght_adj%ent .eq. c0 ) then + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = DXT(:,:,iblock)*DYT(:,:,iblock) & + *ovf(n)%mask_adj%ent(:,:,iblock) + end do + ovf(n)%wght_adj%ent = & + global_sum(WRK,distrb_clinic,field_loc_center) + endif + do nn = 1,nt + ovf(n)%trcr_adj%ent(nn) = c0 + end do + vsum_adj_wght = c0 + do k = ovf(n)%adj_ent%kmin, ovf(n)%adj_ent%kmax + vsum_adj_wght = vsum_adj_wght + ovf(n)%wght_adj%ent*dz(k) + do nn = 1,nt + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = TRACER(:,:,k,nn,time_level,iblock) & + *DXT(:,:,iblock)*DYT(:,:,iblock)*dz(k) & + *ovf(n)%mask_adj%ent(:,:,iblock) + end do + ovf(n)%trcr_adj%ent(nn) = ovf(n)%trcr_adj%ent(nn) + & + global_sum(WRK,distrb_clinic,field_loc_center) + end do + end do + do nn = 1,nt + ovf(n)%trcr_adj%ent(nn) = ovf(n)%trcr_adj%ent(nn) / vsum_adj_wght + end do + end do + +! product adjacent + do n=1,num_ovf + do m=1,ovf(n)%num_prd_sets + if( ovf(n)%wght_adj%prd(m) .eq. c0 ) then + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = DXT(:,:,iblock)*DYT(:,:,iblock) & + *ovf(n)%mask_adj%prd(:,:,iblock,m) + end do + ovf(n)%wght_adj%prd(m) = & + global_sum(WRK,distrb_clinic,field_loc_center) + endif + end do + do m=1,ovf(n)%num_prd_sets + vsum_adj_wght = c0 + ovf(n)%rho_adj%prd(m) = c0 + do k = ovf(n)%adj_prd(m)%kmin, ovf(n)%adj_prd(m)%kmax + vsum_adj_wght = vsum_adj_wght + ovf(n)%wght_adj%prd(m)*dz(k) + do iblock = 1,nblocks_clinic + WRK(:,:,iblock) = RHO(:,:,k,time_level,iblock) & + *DXT(:,:,iblock)*DYT(:,:,iblock)*dz(k) & + *ovf(n)%mask_adj%prd(:,:,iblock,m) + end do + ovf(n)%rho_adj%prd(m) = ovf(n)%rho_adj%prd(m) + & + global_sum(WRK,distrb_clinic,field_loc_center) + end do + ovf(n)%rho_adj%prd(m) = ovf(n)%rho_adj%prd(m) / vsum_adj_wght + end do + end do + + if( prnt .and. my_task == master_task ) then + do n=1,num_ovf + write(stdout,10) n,ovf(n)%trcr_reg%inf(1), & + (ovf(n)%trcr_reg%inf(2))*c1000,(ovf(n)%rho_reg%inf-c1)*c1000, & + ovf(n)%trcr_reg%src(1), & + (ovf(n)%trcr_reg%src(2))*c1000,(ovf(n)%rho_reg%src-c1)*c1000, & + ovf(n)%trcr_reg%ent(1), & + (ovf(n)%trcr_reg%ent(2))*c1000,(ovf(n)%rho_reg%ent-c1)*c1000 + 10 format(1x,'ovf reg',i3,1x,3(f6.3,1x),3(f6.3,1x),3(f6.3,1x)) + if( n.eq.1 ) then + write(stdout,11) n,ovf(n)%trcr_adj%src(1), & + (ovf(n)%trcr_adj%src(2))*c1000, & + ovf(n)%trcr_adj%ent(1), & + (ovf(n)%trcr_adj%ent(2))*c1000, & + (ovf(n)%rho_adj%prd(1)-c1)*c1000 + 11 format(1x,'ovf adj',i3,1x,2(f6.3,1x),1x,2(f6.3,1x),f6.3) + else + write(stdout,12) n,ovf(n)%trcr_adj%src(1), & + (ovf(n)%trcr_adj%src(2))*c1000, & + ovf(n)%trcr_adj%ent(1), & + (ovf(n)%trcr_adj%ent(2))*c1000, & + (ovf(n)%rho_adj%prd(1)-c1)*c1000, & + (ovf(n)%rho_adj%prd(2)-c1)*c1000 + 12 format(1x,'ovf adj',i3,1x,2(f6.3,1x),1x,2(f6.3,1x), & + f6.3,1x,f6.3) + endif + end do + endif + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_reg_avgs + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_transports +! !INTERFACE: + + subroutine ovf_transports + +! !DESCRIPTION: +! Evaluate the ovf transports. For each overflow, set overflow parameters +! and evaluate transports. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + save + + integer (int_kind) :: & + n ,& ! ovf loop index + nn ,& ! ovf tracer index + m ,& ! product level + k_p ! product k level +! + real (r8) :: & + lat ,& ! inflow/source latitude for coriolis parameter (degrees) + fs ! coriolis parameter (/s) +! + real (r8) :: & + hu ,& ! upstream source thickness (cm) + hs ,& ! source water vertical thickness (cm) + Ws ,& ! source water width (cm) + xse ,& ! distance from source to entrainment (cm) + di ,& ! depth of inflow (cm) + ds ,& ! depth of source (cm) + de ,& ! depth of entrainment (cm) + dp ,& ! depth of product (cm) + alpha ,& ! continental slope between source to entrainment + cd ! bottom drag coefficient for spreading, entrained flow +! + real (r8) :: & + T_i ,& ! inflow mean temperature (C) + S_i ,& ! inflow mean salinity + T_s ,& ! source mean temperature (C) + S_s ,& ! source mean salinity + T_e ,& ! entrainment mean temperature (C) + S_e ,& ! entrainment mean salinity + T_p ,& ! product temperature (C) + S_p ! product salinity +! + real (r8) :: & + rho_i ,& ! inflow mass density (g/cm3) + rho_s ,& ! source mass density (g/cm3) + rho_e ,& ! entrainment mass density (g/cm3) + rho_sed ,& ! source at entrainment depth mass density (g/cm3) + rho_p ! product mass density (g/cm3) +! + real (r8) :: & + gp_s ,& ! source reduced gravity (cm/s2) + Ms ,& ! source mass flux (Sv) + As ,& ! source cross sectional area (cm2) + Us ! source speed (cm/s) +! + real (r8) :: & + gp_e ,& ! entrainment reduced gravity (cm/s2) + Me ,& ! entrainment mass flux (Sv) + Ue ,& ! entrainment speed (cm/s) + Ugeo ,& ! geostrophic entrainment speed (m/s) + Uavg ,& ! average source and geostrophic speed (cm/s) + a,b,c ,& ! parameters for quadratic solution + Wgeo ,& ! width of geostrophically spread source (cm) + Kgeo ,& ! geostrophic Ekman number + hgeo ,& ! depth of geostrophically spread source (cm) + Fgeo ,& ! Froude number of entrained flow + phi ,& ! entrainment parameter from actual ratio Me/Mp + Mp ! product mass flux (Sv) + + logical (log_kind) :: & + print_overflows_diag + + character (POP_charLength) :: & + string + + integer (POP_i4) :: & + ier +! +!EOP +!BOC +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! open overflows_diag_outfile file +! append overflows diagnostics to end of overflows diagnostics output file +! +!----------------------------------------------------------------------- + print_overflows_diag = .false. + if (my_task == master_task .and. eod) then + open(ovf_diag_unit, file=overflows_diag_outfile, status='old', position='append') + print_overflows_diag = .true. + endif + +! for each overflow + do n=1,num_ovf + ! set parameters + lat = ovf(n)%ovf_params%lat + fs = c2*omega*sin(lat*pi/180.0_r8) + hu = ovf(n)%ovf_params%source_thick + hs = hu*(c2/c3) + xse = ovf(n)%ovf_params%distnc_str_ssb + alpha = ovf(n)%ovf_params%bottom_slope + cd = ovf(n)%ovf_params%bottom_drag + di = p5*(zt(ovf(n)%reg_inf%kmin)+zt(ovf(n)%reg_inf%kmax)) + ds = zt(ovf(n)%loc_src(1)%k) + de = zt(ovf(n)%loc_ent(1)%k) + Ws = ovf(n)%ovf_params%width + ! set region T,S and compute densities + T_i = ovf(n)%trcr_reg%inf(1) + S_i = ovf(n)%trcr_reg%inf(2) + call state_singlept(T_i,S_i,ds,rho_i) + T_s = ovf(n)%trcr_reg%src(1) + S_s = ovf(n)%trcr_reg%src(2) + call state_singlept(T_s,S_s,ds,rho_s) + call state_singlept(T_s,S_s,de,rho_sed) + T_e = ovf(n)%trcr_reg%ent(1) + S_e = ovf(n)%trcr_reg%ent(2) + call state_singlept(T_e,S_e,de,rho_e) + ! compute inflow/source reduced gravity and source transport + gp_s = grav*(rho_s-rho_i)/rho_sw + ! if no source overflow, zero out transports + if( gp_s > c0 ) then + Ms = gp_s*hu*hu/(c2*fs) + As = hs*Ws + Us = Ms/As + ! compute overflow spreading and entrainment transport + gp_e = grav*(rho_sed-rho_e)/rho_sw + ! zero entrainment transport if gp_e < 0 + if( gp_e > c0 ) then + Ugeo = gp_e*alpha/fs + Uavg = p5*(Us+Ugeo) + a = fs*Ws/c2 + b = fs*Ws*hs/c2 + c2*cd*Uavg*xse - Ms*fs/(c2*Ugeo) + c = -fs*Ms*hs/(c2*Ugeo) + hgeo = (-b + sqrt(b*b-c4*a*c))/(c2*a) + Fgeo = Ugeo/sqrt(gp_e*hgeo) + phi = c1-Fgeo**(-c2/c3) + Me = Ms*phi/(c1-phi) + ! zero entrainment transport if phi < c0 + if( phi > c0 ) then + Mp = Ms + Me + else + Me = c0 + Mp = Ms + endif + else + Me = c0 + Mp = Ms + endif + else + Ms = c0 + Me = c0 + Mp = c0 + endif + ! time shift transports and set output in ovf array + ovf(n)%Ms_nm1 = ovf(n)%Ms_n + ovf(n)%Ms_n = ovf(n)%Ms + ovf(n)%Me_nm1 = ovf(n)%Me_n + ovf(n)%Me_n = ovf(n)%Me + ovf(n)%Mp_nm1 = ovf(n)%Mp_n + ovf(n)%Mp_n = ovf(n)%Mp + ovf(n)%Ms = Ms + ovf(n)%Me = Me + ovf(n)%Mp = Mp + ! recompute phi based on actual transports + phi = ovf(n)%Me / (ovf(n)%Mp + c1) + ! if time averaging time step, include last time step + if( avg_ts ) then + phi = (ovf(n)%Me_n + ovf(n)%Me) / (ovf(n)%Mp_n + ovf(n)%Mp + c1) + endif + ovf(n)%phi = phi + ! compute product T,S + T_p = T_s*(c1-phi) + T_e*phi + S_p = S_s*(c1-phi) + S_e*phi + ovf(n)%Tp = T_p + ovf(n)%Sp = S_p + do nn=1,nt + ovf(n)%trcr_adj%prd(nn) = ovf(n)%trcr_adj%src(nn) * (c1 - phi) & + + ovf(n)%trcr_adj%ent(nn) * phi + ovf(n)%trcr_reg%prd(nn) = ovf(n)%trcr_reg%src(nn) * (c1 - phi) & + + ovf(n)%trcr_reg%ent(nn) * phi + end do + ! product set for insertion + m = ovf(n)%prd_set + if (print_overflows_diag .and. my_task == master_task) then + k_p = (ovf(n)%adj_prd(m)%kmin+ovf(n)%adj_prd(m)%kmax)/2 + write(ovf_diag_unit,1234) tday,n,phi,1.e-12*Ms,1.e-12*Me,1.e-12*Mp,m,zt(k_p)/100. + 1234 format(' ovf_tr: ',f7.1,1x,i2,25x,f7.4,2x,3(f7.4,1x),1x,i2,1x,f8.1) + write(ovf_diag_unit,1235) tday, n,T_i,S_i*c1000,T_s,S_s*c1000,T_e,S_e*c1000,T_p,S_p*c1000 + 1235 format(' ovf_TS: ',f7.1,1x,i2,1x,8(f7.4,1x)) + call shr_sys_flush(ovf_diag_unit) + endif ! print_overflows_diag + + end do ! n loop over all overflows + +!----------------------------------------------------------------------- +! +! close overflows_diag_outfile file +! +!----------------------------------------------------------------------- + + if (print_overflows_diag .and. my_task == master_task) then + close(ovf_diag_unit) + endif ! print_overflows_diag + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_transports + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_loc_prd +! !INTERFACE: + + subroutine ovf_loc_prd + +! !DESCRIPTION: +! Evaluate the ovf location of product. If product location has moved, +! set original sidewall velocities on the ugrid to zero and compute +! Uovf_n, Uovf_nm1 sidewall velocities on the u-grid at new product +! location using Mp_n, Mp_nm1 transport respectively. +! +! !REVISION HISTORY: +! same as module +! +! ovf t-grid box ij with u-grid +! corners and orientations +! product moves out of ij ovf box +! +! ^ +! +V | 2 +! | __________ ---> +U +! y ^ | | 1 +! | | | +! | | ij | +! +-----> | | +! x 3 |__________| +! -U <--- | +! 4 | -V + +!EOP +!BOC +!---------------------------------------------------------------------- +! local variables +!---------------------------------------------------------------------- + + integer (int_kind) :: & + m_neut_org, & ! original neutral product density set index + m_neut ! neutral product density set index + real (r8) :: & + T_p ,& ! product temperature (C) + S_p ,& ! product salinity + rho_p ,& ! product density at each product + ufrc ,& ! fraction of ovf velocity for each box + Uovf_n ,& ! U at n + Uovf_nm1 ! U at n-1 + integer (int_kind) :: & + iblock,i,j,n,m,mp, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + k_p,kprd ! overflow loop and level indices + type (block) :: & + this_block ! block information for current block + logical (log_kind), parameter :: prnt = .false. + + if(prnt .and. my_task == master_task) then + write(stdout,*) 'ovf_loc_prd called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + do n=1,num_ovf + ! find new product location + T_p = ovf(n)%Tp + S_p = ovf(n)%Sp + m_neut_org = ovf(n)%prd_set + m_neut = 0 + if(ovf(n)%num_prd_sets .eq. 1) then + m_neut = 1 + k_p = (ovf(n)%adj_prd(1)%kmin+ovf(n)%adj_prd(1)%kmax)/2 + call state_singlept(T_p,S_p,zt(k_p),rho_p) + else +! search from deepest to shallowest to allow product water +! to go to the deepest possible level + do m=ovf(n)%num_prd_sets-1,1,-1 + k_p = (ovf(n)%adj_prd(m)%kmin+ovf(n)%adj_prd(m)%kmax)/2 + ! get product level for this set + call state_singlept(T_p,S_p,zt(k_p),rho_p) + if(prnt .and. my_task == master_task) then + write(stdout,5) m,(ovf(n)%rho_adj%prd(m-1)-c1)*c1000, & + (ovf(n)%rho_adj%prd(m)-c1)*c1000, & + k_p,T_p,S_p,zt(k_p),(rho_p-c1)*c1000 + 5 format(' neutral lev search- m rho_adj_m-1 rho_adj_m ', & + 'k_p T_p S_p zt(k_p) rho_p =',/ & + 2x,i2,2x,2(f12.8,2x),4x,i2,4(f12.8,2x)) + endif + if(rho_p .gt. ovf(n)%rho_adj%prd(m)) then + m_neut = m+1 + goto 999 + else + m_neut = m + endif + enddo + 999 continue + endif + ! error check + if( m_neut .eq. 0 ) then + write(stdout,10) T_p,S_p,rho_p + 10 format(' ovf_loc_prd: no prd lev found for T,S,rho=', & + 3(f10.5,2x)) + call shr_sys_flush(stdout) + call exit_POP(sigAbort,'ERROR no product level found') + endif + ovf(n)%prd_set_n = m_neut_org + ovf(n)%prd_set = m_neut + if(prnt .and. my_task == master_task) then + write(stdout,20) n,T_p,S_p*c1000,(rho_p-c1)*c1000,m_neut + 20 format(' For ovf = ',i3,' prd T,S,rho = ',3(f12.8,2x),' prd set =',i5) + endif + if( m_neut_org .ne. 0 .and. m_neut_org .ne. m_neut ) then +! product point has moved + if ( overflows_on .and. my_task == master_task) then + write(stdout,*) 'ovf_loc_prd: nsteps_total=',nsteps_total, & + ' ovf=',n,' swap ovf UV old/new ', & + 'prd set old/new=',m_neut_org,m_neut + call shr_sys_flush(stdout) + endif + ! compute Uovf_n, Uovf_nm1 velocities for product sidewall + m = ovf(n)%prd_set ! product set for insertion + do mp=1,ovf(n)%num_prd(m) ! product points for each set + kprd = ovf(n)%loc_prd(m,mp)%k + ufrc = c1/real(ovf(n)%num_prd(m)-1) + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + if( ovf(n)%loc_prd(m,mp)%orient .eq. 1 ) then + Uovf_nm1 = ovf(n)%Mp_nm1*ufrc/(dz(kprd)*DYU(i,j,iblock)) + Uovf_n = ovf(n)%Mp_n *ufrc/(dz(kprd)*DYU(i,j,iblock)) + endif + if( ovf(n)%loc_prd(m,mp)%orient .eq. 2 ) then + Uovf_nm1 = ovf(n)%Mp_nm1*ufrc/(dz(kprd)*DXU(i,j,iblock)) + Uovf_n = ovf(n)%Mp_n *ufrc/(dz(kprd)*DXU(i,j,iblock)) + endif + if( ovf(n)%loc_prd(m,mp)%orient .eq. 3 ) then + Uovf_nm1 = ovf(n)%Mp_nm1*ufrc/(dz(kprd)*DYU(i,j,iblock)) + Uovf_n = ovf(n)%Mp_n *ufrc/(dz(kprd)*DYU(i,j,iblock)) + endif + if( ovf(n)%loc_prd(m,mp)%orient .eq. 4 ) then + Uovf_nm1 = ovf(n)%Mp_nm1*ufrc/(dz(kprd)*DXU(i,j,iblock)) + Uovf_n = ovf(n)%Mp_n *ufrc/(dz(kprd)*DXU(i,j,iblock)) + endif + ovf(n)%loc_prd(m,mp)%Uovf_nm1 = Uovf_nm1 + ovf(n)%loc_prd(m,mp)%Uovf_n = Uovf_n + if(prnt) then + write(stdout,30) ovf(n)%loc_prd(m,mp)%i,ovf(n)%loc_prd(m,mp)%j, & + ovf(n)%loc_prd(m,mp)%k,ovf(n)%Mp_nm1,ufrc,dz(kprd),Uovf_nm1 + 30 format(' loc_prd ijk=',3(i4,1x),'Mp_nm1 uf dz=',3(1pe10.3,1x), & + 'Uovf_nm1=',1pe10.3) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for each set + if( overflows_interactive ) then +! zero out original product sidewall U + m = m_neut_org + do mp=1,ovf(n)%num_prd(m) ! product points for each set + ! prd set original Uold sidewalls to zero + kprd = ovf(n)%loc_prd(m,mp)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + UVEL(i,j,kprd,newtime,iblock) = c0 + VVEL(i,j,kprd,newtime,iblock) = c0 + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for each set + endif ! interactive overflows + endif ! product point has moved + end do ! overflows + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_loc_prd + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_W +! !INTERFACE: + + subroutine ovf_W + +! !DESCRIPTION: +! Evaluate ovf vertical velocity W on the t-grid +! +! !REVISION HISTORY: +! same as module +! +! ovf t-grid box ij from top +! sidewall transports and top TAREA +! used to compute Wovf at top +! signs of Wovf important! +! +! __________ +! | | +! Me ----> | ij | <---- Ms +! Mp <---- | TAREAij | +! |__________| +! + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + iblock,i,j,n,m,mp, & ! dummy loop indices + ib,ie,jb,je ! local domain index boundaries + type (block) :: & + this_block ! block information for current block + real (r8) :: & + ufrc ! fraction of ovf velocity for each box + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_W called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + do n=1,num_ovf ! each overflow +! src + do m=1,ovf(n)%num_src ! source + ufrc = c1/real(ovf(n)%num_src-1) + if(m==1 .or. m==ovf(n)%num_src) ufrc = ufrc/c2 + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_src(m)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_src(m)%i .eq. this_block%i_glob(i) ) then + ovf(n)%loc_src(m)%Wovf = -abs(ovf(n)%Ms*ufrc & + /TAREA(i,j,iblock)) + if(prnt) then + write(stdout,10) n,ovf(n)%loc_src(m)%i, & + ovf(n)%loc_src(m)%j,ovf(n)%loc_src(m)%k, & + ovf(n)%Ms,ufrc,TAREA(i,j,iblock), & + ovf(n)%loc_src(m)%Wovf + 10 format(' ovf_W n=',i3,' src ijk=',3(i4,1x), & + 'Ms uf Ta Wovf=',4(1pe10.3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! source +! ent + do m=1,ovf(n)%num_ent ! entrainment + ufrc = c1/real(ovf(n)%num_ent-1) + if(m==1 .or. m==ovf(n)%num_ent) ufrc = ufrc/c2 + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_ent(m)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_ent(m)%i .eq. this_block%i_glob(i) ) then + ovf(n)%loc_ent(m)%Wovf = -abs(ovf(n)%Me*ufrc & + /TAREA(i,j,iblock)) + if(prnt) then + write(stdout,20) n,ovf(n)%loc_ent(m)%i, & + ovf(n)%loc_ent(m)%j,ovf(n)%loc_ent(m)%k, & + ovf(n)%Me,ufrc,TAREA(i,j,iblock), & + ovf(n)%loc_ent(m)%Wovf + 20 format(' ovf_W n=',i3,' ent ijk=',3(i4,1x), & + 'Me uf Ta Wovf=',4(1pe10.3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! entrainment +! prd +! set Wovf terms to zero at product points, incase product has moved + do m=1,ovf(n)%num_prd_sets + do mp=1,ovf(n)%num_prd(m) + ovf(n)%loc_prd(m,mp)%Wovf = c0 + end do + end do + m = ovf(n)%prd_set ! product set for insertion + do mp=1,ovf(n)%num_prd(m) ! product points for each set + ufrc = c1/real(ovf(n)%num_prd(m)-1) + if(mp==1 .or. mp==ovf(n)%num_prd(m)) ufrc = ufrc/c2 + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i .eq. this_block%i_glob(i) ) then + ovf(n)%loc_prd(m,mp)%Wovf = abs(ovf(n)%Mp*ufrc & + /TAREA(i,j,iblock)) + if(prnt) then + write(stdout,30) n,ovf(n)%loc_prd(m,mp)%i, & + ovf(n)%loc_prd(m,mp)%j,ovf(n)%loc_prd(m,mp)%k, & + ovf(n)%Mp,ufrc,TAREA(i,j,iblock), & + ovf(n)%loc_prd(m,mp)%Wovf + 30 format(' ovf_W n=',i3,' prd ijk=',3(i4,1x), & + 'Mp uf Ta Wovf=',4(1pe10.3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for insertion set + end do ! each overflow +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_W + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_UV +! !INTERFACE: + + subroutine ovf_UV + +! !DESCRIPTION: +! Evaluate the ovf sidewall velocities UV on the u-grid +! !REVISION HISTORY: +! same as module +! +! ovf t-grid box ij with U on u-grid +! at corner set by orientation +! +! 2 +! U __________ U +! y ^ | | 1 +! | | | +! | | ij | +! +-----> | | +! x 3 |__________| +! U U +! 4 + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + iblock,i,j,n,m,mp, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + ksrc,kent,kprd ! overflow level indices + type (block) :: & + this_block ! block information for current block + real (r8) :: & + ufrc, & ! fraction of ovf velocity for each box + Uovf ! Uovf at one corner + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_UV called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + do n=1,num_ovf ! each overflow +! src + do m=1,ovf(n)%num_src ! source + ksrc = ovf(n)%loc_src(m)%k + ufrc = c1/real(ovf(n)%num_src-1) + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + if( ovf(n)%loc_src(m)%orient .eq. 1 ) then + Uovf = ovf(n)%Ms*ufrc/(dz(ksrc)*DYU(i,j,iblock)) + if( overflows_interactive ) then + UVEL(i,j,ksrc,newtime,iblock) = -Uovf + endif + endif + if( ovf(n)%loc_src(m)%orient .eq. 2 ) then + Uovf = ovf(n)%Ms*ufrc/(dz(ksrc)*DXU(i,j,iblock)) + if( overflows_interactive ) then + VVEL(i,j,ksrc,newtime,iblock) = -Uovf + endif + endif + if( ovf(n)%loc_src(m)%orient .eq. 3 ) then + Uovf = ovf(n)%Ms*ufrc/(dz(ksrc)*DYU(i,j,iblock)) + if( overflows_interactive ) then + UVEL(i,j,ksrc,newtime,iblock) = +Uovf + endif + endif + if( ovf(n)%loc_src(m)%orient .eq. 4 ) then + Uovf = ovf(n)%Ms*ufrc/(dz(ksrc)*DXU(i,j,iblock)) + if( overflows_interactive ) then + VVEL(i,j,ksrc,newtime,iblock) = +Uovf + endif + endif + ovf(n)%loc_src(m)%Uovf = Uovf + if( prnt ) then + write(stdout,10) n,ovf(n)%loc_src(m)%i_u, & + ovf(n)%loc_src(m)%j_u,ovf(n)%loc_src(m)%k,Uovf + 10 format(' ovf_UV n=',i3,' src i_u j_u k Uovf=', & + 3(i3,1x),f9.5,2x) + endif ! print + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! source +! ent + do m=1,ovf(n)%num_ent ! entrainment + kent = ovf(n)%loc_ent(m)%k + ufrc = c1/real(ovf(n)%num_ent-1) + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + if( ovf(n)%loc_ent(m)%orient .eq. 1 ) then + Uovf = ovf(n)%Me*ufrc/(dz(kent)*DYU(i,j,iblock)) + if( overflows_interactive ) then + UVEL(i,j,kent,newtime,iblock) = -Uovf + endif + endif + if( ovf(n)%loc_ent(m)%orient .eq. 2 ) then + Uovf = ovf(n)%Me*ufrc/(dz(kent)*DXU(i,j,iblock)) + if( overflows_interactive ) then + VVEL(i,j,kent,newtime,iblock) = -Uovf + endif + endif + if( ovf(n)%loc_ent(m)%orient .eq. 3 ) then + Uovf = ovf(n)%Me*ufrc/(dz(kent)*DYU(i,j,iblock)) + if( overflows_interactive ) then + UVEL(i,j,kent,newtime,iblock) = +Uovf + endif + endif + if( ovf(n)%loc_ent(m)%orient .eq. 4 ) then + Uovf = ovf(n)%Me*ufrc/(dz(kent)*DXU(i,j,iblock)) + if( overflows_interactive ) then + VVEL(i,j,kent,newtime,iblock) = +Uovf + endif + endif + ovf(n)%loc_ent(m)%Uovf = Uovf + if( prnt ) then + write(stdout,20) n,ovf(n)%loc_ent(m)%i_u, & + ovf(n)%loc_ent(m)%j_u,ovf(n)%loc_ent(m)%k,Uovf + 20 format(' ovf_UV n=',i3,' ent i_u j_u k Uovf=', & + 3(i3,1x),f9.5,2x) + endif ! print + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! entrainment +! prd + m = ovf(n)%prd_set ! product set for insertion + do mp=1,ovf(n)%num_prd(m) ! product points for each set + kprd = ovf(n)%loc_prd(m,mp)%k + ufrc = c1/real(ovf(n)%num_prd(m)-1) + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + if( ovf(n)%loc_prd(m,mp)%orient .eq. 1 ) then + Uovf = ovf(n)%Mp*ufrc/(dz(kprd)*DYU(i,j,iblock)) + if( overflows_interactive ) then + UVEL(i,j,kprd,newtime,iblock) = +Uovf + endif + endif + if( ovf(n)%loc_prd(m,mp)%orient .eq. 2 ) then + Uovf = ovf(n)%Mp*ufrc/(dz(kprd)*DXU(i,j,iblock)) + if( overflows_interactive ) then + VVEL(i,j,kprd,newtime,iblock) = +Uovf + endif + endif + if( ovf(n)%loc_prd(m,mp)%orient .eq. 3 ) then + Uovf = ovf(n)%Mp*ufrc/(dz(kprd)*DYU(i,j,iblock)) + if( overflows_interactive ) then + UVEL(i,j,kprd,newtime,iblock) = -Uovf + endif + endif + if( ovf(n)%loc_prd(m,mp)%orient .eq. 4 ) then + Uovf = ovf(n)%Mp*ufrc/(dz(kprd)*DXU(i,j,iblock)) + if( overflows_interactive ) then + VVEL(i,j,kprd,newtime,iblock) = -Uovf + endif + endif + ovf(n)%loc_prd(m,mp)%Uovf = Uovf + if( prnt ) then + write(stdout,30) n,ovf(n)%loc_prd(m,mp)%i_u, & + ovf(n)%loc_prd(m,mp)%j_u,ovf(n)%loc_prd(m,mp)%k,Uovf + 30 format(' ovf_UV n=',i3,' prd i_u j_u k Uovf=', & + 3(i3,1x),f9.5,2x) + endif ! print + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for insertion set + end do ! each overflow + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_UV + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_rhs_brtrpc_momentum +! !INTERFACE: + + subroutine ovf_rhs_brtrpc_momentum(ZX,ZY) + +! !DESCRIPTION: +! Renormalize overflow ZX and ZY vertical integrals of forcing +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + real (r8), dimension(nx_block,ny_block,max_blocks_clinic), & + intent(inout) :: & + ZX, ZY ! vertical integrals of forcing + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + i,j,k,n,m,mp, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + ksrc,kent,kprd, & ! level indices + iblock ! block index + type (block) :: & + this_block ! block information for current block + real (r8) :: & + dz_sidewall ! sidewall U-grid depth from top to ovf level + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_rhs_brtrpc_momentum called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + do n=1,num_ovf ! each overflow +! src + do m=1,ovf(n)%num_src ! source + ksrc = ovf(n)%loc_src(m)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,ksrc + dz_sidewall = dz_sidewall + dz(k) + enddo + ZX(i,j,iblock) = (ZX(i,j,iblock)* HU(i,j,iblock)) & + / (HU(i,j,iblock)+dz_sidewall) + ZY(i,j,iblock) = (ZY(i,j,iblock)* HU(i,j,iblock)) & + / (HU(i,j,iblock)+dz_sidewall) + if(prnt) then + write(stdout,10) n,ovf(n)%loc_src(m)%i_u,ovf(n)%loc_src(m)%j_u + 10 format(' ovf_rhs_brtrpc_momentum n=',i3, & + ' src ZX,ZY adj at i_u j_u=',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! source +! ent + do m=1,ovf(n)%num_ent ! entrainment + kent = ovf(n)%loc_ent(m)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,kent + dz_sidewall = dz_sidewall + dz(k) + enddo + ZX(i,j,iblock) = (ZX(i,j,iblock)* HU(i,j,iblock)) & + / (HU(i,j,iblock)+dz_sidewall) + ZY(i,j,iblock) = (ZY(i,j,iblock)* HU(i,j,iblock)) & + / (HU(i,j,iblock)+dz_sidewall) + if(prnt) then + write(stdout,20) n,ovf(n)%loc_ent(m)%i_u,ovf(n)%loc_ent(m)%j_u + 20 format(' ovf_rhs_brtrpc_momentum n=',i3, & + ' ent ZX,ZY adj at i_u j_u=',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! entrainment +! prd + do m=1,ovf(n)%num_prd_sets + do mp=1,ovf(n)%num_prd(m) ! product points for each set + kprd = ovf(n)%loc_prd(m,mp)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,kprd + dz_sidewall = dz_sidewall + dz(k) + enddo + ZX(i,j,iblock) = (ZX(i,j,iblock)* HU(i,j,iblock)) & + / (HU(i,j,iblock)+dz_sidewall) + ZY(i,j,iblock) = (ZY(i,j,iblock)* HU(i,j,iblock)) & + / (HU(i,j,iblock)+dz_sidewall) + if(prnt) then + write(stdout,30) n,ovf(n)%loc_prd(m,mp)%i_u, & + ovf(n)%loc_prd(m,mp)%j_u + 30 format(' ovf_rhs_brtrpc_momentum n=',i3, & + ' prd ZX,ZY adj at i_u j_u=',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for each set + end do ! all product sets + end do ! each overflow + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_rhs_brtrpc_momentum + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_brtrpc_renorm +! !INTERFACE: + + subroutine ovf_brtrpc_renorm(WORK3,WORK4,iblock) + +! !DESCRIPTION: +! Renormalize overflow HU for WORK3 and WORK4 in barotropic solution +! Note- ij limits are 1,nx_block and 1,ny_block to compute ghost values +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + real (r8), dimension(nx_block,ny_block), & + intent(inout) :: & + WORK3,WORK4 ! grid x,y work arrays respectively + integer (int_kind), & + intent(in) :: & + iblock ! block index + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + i,j,k,n,m,mp, & ! dummy loop indices + ksrc,kent,kprd ! level indices + type (block) :: & + this_block ! block information for current block + real (r8) :: & + dz_sidewall ! sidewall U-grid depth from top to ovf level + + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_brtrpc_renorm called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + do n=1,num_ovf ! each overflow +! src + do m=1,ovf(n)%num_src ! source + ksrc = ovf(n)%loc_src(m)%k + this_block = get_block(blocks_clinic(iblock),iblock) + do j=1,ny_block + if( ovf(n)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(n)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,ksrc + dz_sidewall = dz_sidewall + dz(k) + enddo + WORK3(i,j) = WORK3(i,j)*HUR(i,j,iblock) & + *(HU(i,j,iblock)+dz_sidewall) + WORK4(i,j) = WORK4(i,j)*HUR(i,j,iblock) & + *(HU(i,j,iblock)+dz_sidewall) + if(prnt) then + write(stdout,10) n,ovf(n)%loc_src(m)%i_u, & + ovf(n)%loc_src(m)%j_u + 10 format(' ovf_brtrpc_renorm n=',i3, & + ' src WORK3/WORK4 adj at i_u j_u=',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! source +! ent + do m=1,ovf(n)%num_ent ! entrainment + kent = ovf(n)%loc_ent(m)%k + this_block = get_block(blocks_clinic(iblock),iblock) + do j=1,ny_block + if( ovf(n)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(n)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,kent + dz_sidewall = dz_sidewall + dz(k) + enddo + WORK3(i,j) = WORK3(i,j)*HUR(i,j,iblock) & + *(HU(i,j,iblock)+dz_sidewall) + WORK4(i,j) = WORK4(i,j)*HUR(i,j,iblock) & + *(HU(i,j,iblock)+dz_sidewall) + if(prnt) then + write(stdout,20) n,ovf(n)%loc_ent(m)%i_u, & + ovf(n)%loc_ent(m)%j_u + 20 format(' ovf_brtrpc_renorm n=',i3, & + ' ent WORK3/WORK4 adj at i_u j_u=',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! entrainment +! prd + do m=1,ovf(n)%num_prd_sets + do mp=1,ovf(n)%num_prd(m) ! product points for each set + kprd = ovf(n)%loc_prd(m,mp)%k + this_block = get_block(blocks_clinic(iblock),iblock) + do j=1,ny_block + if( ovf(n)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(n)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,kprd + dz_sidewall = dz_sidewall + dz(k) + enddo + WORK3(i,j) = WORK3(i,j)*HUR(i,j,iblock) & + *(HU(i,j,iblock)+dz_sidewall) + WORK4(i,j) = WORK4(i,j)*HUR(i,j,iblock) & + *(HU(i,j,iblock)+dz_sidewall) + if(prnt) then + write(stdout,30) n,ovf(n)%loc_prd(m,mp)%i_u, & + ovf(n)%loc_prd(m,mp)%j_u + 30 format(' ovf_brtrpc_renorm n=',i3, & + ' prd WORK3/WORK4 adj at i_u j_u=',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! product points for each set + end do ! all product sets + end do ! each overflow + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_brtrpc_renorm + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_rhs_brtrpc_continuity +! !INTERFACE: + + subroutine ovf_rhs_brtrpc_continuity(RHS,iblock) + +! !DESCRIPTION: +! Add overflow vertical velocity to RHS barotropic continuity equation +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + real (r8), dimension(nx_block,ny_block,max_blocks_clinic), & + intent(inout) :: & + RHS ! RHS barotropic continuity equation + integer (int_kind), & + intent(in) :: & + iblock ! block index + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + i,j,n,m,mp, & ! dummy loop indices + ib,ie,jb,je ! local domain index boundaries + type (block) :: & + this_block ! block information for current block + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_rhs_brtrpc_continuity called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + do n=1,num_ovf ! each overflow +! src + do m=1,ovf(n)%num_src ! source + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_src(m)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_src(m)%i .eq. this_block%i_glob(i) ) then + RHS(i,j,iblock) = RHS(i,j,iblock) - (ovf(n)%loc_src(m)%Wovf & + * TAREA(i,j,iblock)/(beta*c2dtp)) + if(prnt) then + write(stdout,10) n,ovf(n)%loc_src(m)%i,ovf(n)%loc_src(m)%j, & + ovf(n)%loc_src(m)%Wovf,TAREA(i,j,iblock) + 10 format(' n=',i3,' src RHS adjusted at ij=',2(i3,1x), & + ' Wovf=',f9.6,' TAREA=',1pe11.4) + endif + endif + end do ! i + endif + end do ! j + end do ! source +! ent + do m=1,ovf(n)%num_ent ! entrainment + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_ent(m)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_ent(m)%i .eq. this_block%i_glob(i) ) then + RHS(i,j,iblock) = RHS(i,j,iblock) - (ovf(n)%loc_ent(m)%Wovf & + * TAREA(i,j,iblock)/(beta*c2dtp)) + if(prnt) then + write(stdout,20) n,ovf(n)%loc_ent(m)%i,ovf(n)%loc_ent(m)%j, & + ovf(n)%loc_ent(m)%Wovf,TAREA(i,j,iblock) + 20 format(' n=',i3,' ent RHS adjusted at ij=',2(i3,1x), & + ' Wovf=',f9.6,' TAREA=',1pe11.4) + endif + endif + end do ! i + endif + end do ! j + end do ! entrainment +! prd + m = ovf(n)%prd_set + do mp=1,ovf(n)%num_prd(m) ! product points for each set + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i .eq. this_block%i_glob(i) ) then + RHS(i,j,iblock) = RHS(i,j,iblock) - (ovf(n)%loc_prd(m,mp)%Wovf & + * TAREA(i,j,iblock)/(beta*c2dtp)) + if(prnt) then + write(stdout,30) n,ovf(n)%loc_prd(m,mp)%i,ovf(n)%loc_prd(m,mp)%j, & + ovf(n)%loc_prd(m,mp)%Wovf,TAREA(i,j,iblock) + 30 format(' n=',i3,' prd RHS adjusted at ij=',2(i3,1x), & + ' Wovf=',f9.6,' TAREA=',1pe11.4) + endif + endif + end do ! i + endif + end do ! j + end do ! product points for each set + end do ! each overflow + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_rhs_brtrpc_continuity + +!*********************************************************************** +!BOP +! !IROUTINE: ovf_solvers_9pt +! !INTERFACE: + + subroutine ovf_solvers_9pt + +! !DESCRIPTION: +! This routine updates the coefficients of the 9-point stencils for +! the barotropic operator for the overflow points +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables: +! +! {X,Y}{NE,SE,NW,SW} = contribution to {ne,se,nw,sw} coefficients +! from {x,y} components of divergence +! HU = depth at U points +! +!----------------------------------------------------------------------- + integer (POP_i4) :: & + errorCode, &! error return code + numBlocksTropic, &!num local blocks in barotropic distribution + numBlocksClinic !num local blocks in baroclinic distribution + + real (POP_r8) :: & + xne,xse,xnw,xsw, &! contribution to coefficients from x,y + yne,yse,ynw,ysw, &! components of divergence + ase,anw,asw + + integer (int_kind) :: & + i,j,n, &! dummy counter + iblock, &! block counter + istat + + real (POP_r8), dimension(:,:,:), allocatable :: & + workNorth, &! + workEast, &! + workNE, &! + HUM ! HU if no overflows; modified if overflows + +!----------------------------------------------------------------------- +! +! compute nine point operator coefficients: compute on baroclinic +! decomposition first where grid info defined and redistribute +! to barotropic distribution +! leave A0,AC in baroclinic distribution to facilitate easy +! time-dependent changes in barotropic routine +! +!----------------------------------------------------------------------- + + call POP_DistributionGet(POP_distrbClinic, errorCode, & + numLocalBlocks = numBlocksClinic) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error retrieving clinic local block count') +! activate later, when errorCode is fully supported +! return + endif + + allocate(workNorth (POP_nxBlock,POP_nyBlock,numBlocksClinic), & + workEast (POP_nxBlock,POP_nyBlock,numBlocksClinic), & + workNE (POP_nxBlock,POP_nyBlock,numBlocksClinic), & + HUM (POP_nxBlock,POP_nyBlock,numBlocksClinic), & + stat=istat) + + if (istat > 0) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error allocating temporary arrays') + call exit_POP (sigAbort,'ERROR ovf_solvers_9pt: error allocating temporary arrays') +! activate later, when errorCode is fully supported +! return + endif + + HUM(:,:,:) = HU(:,:,:) + call ovf_HU(HU,HUM) + call POP_HaloUpdate(HUM, POP_haloClinic, POP_gridHorzLocNECorner,& + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + !$OMP PARALLEL DO PRIVATE(iblock,i,j,xne,xse,xnw,xsw,yne,yse,ynw,ysw,ase,anw,asw) + do iblock = 1,numBlocksClinic + + workNorth (:,:,iblock) = 0.0_POP_r8 + workEast (:,:,iblock) = 0.0_POP_r8 + workNE (:,:,iblock) = 0.0_POP_r8 + centerWgtClinicIndep (:,:,iblock) = 0.0_POP_r8 + + do j=2,POP_nyBlock + do i=2,POP_nxBlock + + xne = 0.25_POP_r8*HUM(i ,j ,iblock)*DXUR(i ,j ,iblock)* & + DYU (i ,j ,iblock) + xse = 0.25_POP_r8*HUM(i ,j-1,iblock)*DXUR(i ,j-1,iblock)* & + DYU (i ,j-1,iblock) + xnw = 0.25_POP_r8*HUM(i-1,j ,iblock)*DXUR(i-1,j ,iblock)* & + DYU (i-1,j ,iblock) + xsw = 0.25_POP_r8*HUM(i-1,j-1,iblock)*DXUR(i-1,j-1,iblock)* & + DYU (i-1,j-1,iblock) + + yne = 0.25_POP_r8*HUM(i ,j ,iblock)*DYUR(i ,j ,iblock)* & + DXU (i ,j ,iblock) + yse = 0.25_POP_r8*HUM(i ,j-1,iblock)*DYUR(i ,j-1,iblock)* & + DXU (i ,j-1,iblock) + ynw = 0.25_POP_r8*HUM(i-1,j ,iblock)*DYUR(i-1,j ,iblock)* & + DXU (i-1,j ,iblock) + ysw = 0.25_POP_r8*HUM(i-1,j-1,iblock)*DYUR(i-1,j-1,iblock)* & + DXU (i-1,j-1,iblock) + + workNE(i,j,iblock) = xne + yne + ase = xse + yse + anw = xnw + ynw + asw = xsw + ysw + + workEast (i,j,iblock) = xne + xse - yne - yse + workNorth(i,j,iblock) = yne + ynw - xne - xnw + + centerWgtClinicIndep(i,j,iblock) = & + -(workNE(i,j,iblock) + ase + anw + asw) + + end do + end do + end do + !$OMP END PARALLEL DO + + +!----------------------------------------------------------------------- +! +! redistribute operator weights and mask to barotropic distribution +! +!----------------------------------------------------------------------- + + call POP_DistributionGet(POP_distrbTropic, errorCode, & + numLocalBlocks = numBlocksTropic) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error retrieving tropic local block count') + call exit_POP (sigAbort,'ERROR ovf_solvers_9pt: error retrieving tropic local block count') +! activate later, when errorCode is fully supported +! return + endif + + + call POP_RedistributeBlocks(btropWgtNorth, POP_distrbTropic, & + workNorth, POP_distrbClinic, errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error redistributing north operator weight') + call exit_POP (sigAbort,'ERROR ovf_solvers_9pt: error redistributing north operator weight') +! activate later, when errorCode is fully supported +! return + endif + + + call POP_RedistributeBlocks(btropWgtEast, POP_distrbTropic, & + workEast, POP_distrbClinic, errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error redistributing east operator weight') + call exit_POP (sigAbort,'ERROR ovf_solvers_9pt: error redistributing east operator weight') +! activate later, when errorCode is fully supported +! return + endif + + call POP_RedistributeBlocks(btropWgtNE, POP_distrbTropic, & + workNE, POP_distrbClinic, errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error redistributing NE operator weight') + call exit_POP (sigAbort,'ERROR ovf_solvers_9pt: error redistributing NE operator weight') +! activate later, when errorCode is fully supported +! return + endif + +!----------------------------------------------------------------------- +! +! clean up temporary arrays +! +!----------------------------------------------------------------------- + + deallocate(workNorth, workEast, workNE, HUM, stat=istat) + + if (istat > 0) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error deallocating temp mask') + call exit_POP (sigAbort,'ERROR ovf_solvers_9pt: error deallocating temp mask') +! activate later, when errorCode is fully supported +! return + endif + + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_solvers_9pt + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_HU +! !INTERFACE: + + subroutine ovf_HU(HU,HUM) + +! !DESCRIPTION: +! Modify HU for overflows sidewalls +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + real (r8), dimension(nx_block,ny_block,max_blocks_clinic), & + intent(in) :: HU ! HU + + real (r8), dimension(nx_block,ny_block,max_blocks_clinic), & + intent(inout) :: HUM ! HUM (modified HU) + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + i,j,k,n,m,mp, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + ksrc,kent,kprd, & ! level indices + iblock ! block index + real (r8) :: & + dz_sidewall ! sidewall U-grid depth from top to ovf level + type (block) :: & + this_block ! block information for current block + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_HU called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + do n=1,num_ovf ! each overflow +! src + do m=1,ovf(n)%num_src ! source + ksrc = ovf(n)%loc_src(m)%k + do iblock=1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,ksrc + dz_sidewall = dz_sidewall + dz(k) + enddo + HUM(i,j,iblock) = HU(i,j,iblock) + dz_sidewall + if(prnt) then + write(stdout,10) n, & + ovf(n)%loc_src(m)%i_u,ovf(n)%loc_src(m)%j_u + 10 format(' n=',i3,' src HU adjusted at i_u j_u =',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblocks + end do ! source +! ent + do m=1,ovf(n)%num_ent ! entrainment + kent = ovf(n)%loc_ent(m)%k + do iblock=1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,kent + dz_sidewall = dz_sidewall + dz(k) + enddo + HUM(i,j,iblock) = HU(i,j,iblock) + dz_sidewall + if(prnt) then + write(stdout,20) n, & + ovf(n)%loc_ent(m)%i_u,ovf(n)%loc_ent(m)%j_u + 20 format(' n=',i3,' ent HU adjusted at i_u j_u =',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblocks + end do ! entrainment +! prd + do m=1,ovf(n)%num_prd_sets + do mp=1,ovf(n)%num_prd(m) ! product points for each set + kprd = ovf(n)%loc_prd(m,mp)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,kprd + dz_sidewall = dz_sidewall + dz(k) + enddo + HUM(i,j,iblock) = HU(i,j,iblock) + dz_sidewall + if(prnt) then + write(stdout,30) n,ovf(n)%loc_prd(m,mp)%i_u, & + ovf(n)%loc_prd(m,mp)%j_u + 30 format(' n=',i3,' prd HU adjusted at i_u j_u =',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for each set + end do ! all product sets + end do ! each overflow + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_HU + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_UV_solution +! !INTERFACE: + + subroutine ovf_UV_solution + +! !DESCRIPTION: +! Evaluate ovf column solution for baroclinic U and V. Should be called +! BEFORE the final addition of baroclinic and barotropic velocities. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + iblock,i,j,k,n,m,mp, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + ksrc,kent,kprd ! overflow level indices + + real (r8) :: & + Uovf, & ! overflow U + Uovf_nm1, & ! overflow U at n-1 + ubar, & ! barotropic velocity + utlda(km) ! unnormalized baroclinic velocity + + type (block) :: & + this_block ! block information for current block + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_UV_solution called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + do n=1,num_ovf ! each overflow +! src + do m=1,ovf(n)%num_src ! source + ksrc = ovf(n)%loc_src(m)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + if(prnt) then + write(stdout,10) n,ovf(n)%loc_src(m)%i_u, & + ovf(n)%loc_src(m)%j_u + 10 format(' n=',i3,' src iu ju column evaluated=',2(i3,1x)) + endif +! U + do k=1,km + utlda(k) = ovf(n)%loc_src(m)%Utlda(k) + enddo + Uovf = UVEL(i,j,ksrc,newtime,iblock) + ubar = UBTROP(i,j,newtime,iblock) + Uovf_nm1 = UVEL(i,j,ksrc,oldtime,iblock) + call ovf_U_column(i,j,ksrc,iblock, & + Uovf,ubar,utlda,Uovf_nm1) +! V + do k=1,km + utlda(k) = ovf(n)%loc_src(m)%Vtlda(k) + enddo + Uovf = VVEL(i,j,ksrc,newtime,iblock) + ubar = VBTROP(i,j,newtime,iblock) + Uovf_nm1 = VVEL(i,j,ksrc,oldtime,iblock) + call ovf_V_column(i,j,ksrc,iblock, & + Uovf,ubar,utlda,Uovf_nm1) + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! source +! ent + do m=1,ovf(n)%num_ent ! entrainment + kent = ovf(n)%loc_ent(m)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + if(prnt) then + write(stdout,20) n,ovf(n)%loc_ent(m)%i_u, & + ovf(n)%loc_ent(m)%j_u + 20 format(' n=',i3,' ent iu ju column evaluated=',2(i3,1x)) + endif +! U + do k=1,km + utlda(k) = ovf(n)%loc_ent(m)%Utlda(k) + enddo + Uovf = UVEL(i,j,kent,newtime,iblock) + ubar = UBTROP(i,j,newtime,iblock) + Uovf_nm1 = UVEL(i,j,kent,oldtime,iblock) + call ovf_U_column(i,j,kent,iblock, & + Uovf,ubar,utlda,Uovf_nm1) +! V + do k=1,km + utlda(k) = ovf(n)%loc_ent(m)%Vtlda(k) + enddo + Uovf = VVEL(i,j,kent,newtime,iblock) + ubar = VBTROP(i,j,newtime,iblock) + Uovf_nm1 = VVEL(i,j,kent,oldtime,iblock) + call ovf_V_column(i,j,kent,iblock, & + Uovf,ubar,utlda,Uovf_nm1) + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! entrainment +! prd + do m=1,ovf(n)%num_prd_sets + do mp=1,ovf(n)%num_prd(m) ! product points for each set + kprd = ovf(n)%loc_prd(m,mp)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(n)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(n)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + if(prnt) then + write(stdout,30) n,ovf(n)%loc_prd(m,mp)%i_u, & + ovf(n)%loc_prd(m,mp)%j_u + 30 format(' n=',i3,' prd iu ju column evaluated=',2(i3,1x)) + endif +! U + do k=1,km + utlda(k) = ovf(n)%loc_prd(m,mp)%Utlda(k) + enddo + Uovf = UVEL(i,j,kprd,newtime,iblock) + ubar = UBTROP(i,j,newtime,iblock) + Uovf_nm1 = UVEL(i,j,kprd,oldtime,iblock) + call ovf_U_column(i,j,kprd,iblock, & + Uovf,ubar,utlda,Uovf_nm1) +! V + do k=1,km + utlda(k) = ovf(n)%loc_prd(m,mp)%Vtlda(k) + enddo + Uovf = VVEL(i,j,kprd,newtime,iblock) + ubar = VBTROP(i,j,newtime,iblock) + Uovf_nm1 = VVEL(i,j,kprd,oldtime,iblock) + call ovf_V_column(i,j,kprd,iblock, & + Uovf,ubar,utlda,Uovf_nm1) + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for each set + end do ! all product sets + end do ! each overflow + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_UV_solution + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_U_column +! !INTERFACE: + + subroutine ovf_U_column(i,j,kovf,iblock,Uovf,ubar,utlda,Uovf_nm1) + +! !DESCRIPTION: +! Evaluate ovf column solution for U baroclinic +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + integer (int_kind), & + intent(in) :: & + i, & ! local block i index on u-grid + j, & ! local block j index on u-grid + kovf, & ! k index of overflow + iblock ! block index + + real (r8), intent(in) :: & + Uovf, & ! overflow U + ubar, & ! barotropic velocity + utlda(km), & ! unnormalized baroclinic velocity + Uovf_nm1 ! overflow U at n-1 + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + k ! vertical loop index + + real (r8) :: & + uprime, & ! overflow sidewall baroclinic velocity + hu, & ! HU after accumulation of column dz + vert_sum, & ! vertical sum accumulation of utlda*dz + utlda_bar ! vertical mean of utlda + + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_U_column called ' + call shr_sys_flush(stdout) + endif + +! evaluate baroclinic normalization for the overflow column by including +! the overflow contributions along the sidewall above the overflow + +! above the topography + hu = c0 + vert_sum = c0 + do k=1,KMU(i,j,iblock) + hu = hu + dz(k) + vert_sum = vert_sum + utlda(k)*dz(k) + enddo + +! below the topography but above the overflow + uprime = -ubar + do k=KMU(i,j,iblock)+1,kovf-1 + vert_sum = vert_sum + uprime*dz(k) + enddo + +! the overflow contribution + uprime = Uovf - ubar + vert_sum = vert_sum + uprime*dz(kovf) + +! adjusted utlda_bar + utlda_bar = vert_sum/hu + +! evaluate overflow modified baroclinic velocity for the column + do k=1,KMU(i,j,iblock) + UVEL(i,j,k,newtime,iblock) = utlda(k) - utlda_bar + enddo + +! check of zero vertical sum + hu = c0 + vert_sum = c0 + do k=1,KMU(i,j,iblock) + hu = hu + dz(k) + vert_sum = vert_sum + UVEL(i,j,k,newtime,iblock)*dz(k) + end do + uprime = -ubar + do k=KMU(i,j,iblock)+1,kovf-1 + vert_sum = vert_sum + uprime*dz(k) + enddo + uprime = Uovf - ubar + vert_sum = vert_sum + uprime*dz(kovf) + vert_sum = vert_sum / hu + + if( prnt ) then + write(stdout,*) 'ovf_U_column ' + write(stdout,5) KMU(i,j,iblock),kovf,Uovf,ubar,utlda_bar,Uovf_nm1, & + vert_sum + 5 format(' kmu,kovf,Uovf ubar utlda_bar Uovf_nm1 vert_sum='/ & + 1x,2(i3,1x),2x,4(f10.5,1x),1pe11.4) + do k=1,kovf + if( k <= KMU(i,j,iblock) ) then + write(stdout,10) k,dz(k),utlda(k)-utlda_bar + 10 format(' k dz U_baroclinic =',i3,1x, & + f8.2,1x,f9.5) + else if( k > KMU(i,j,iblock) .and. k < kovf ) then + write(stdout,15) k,dz(k),-ubar + 15 format(' k dz U_baroclinic =',i3,1x, & + f8.2,1x,f9.5) + else + write(stdout,20) k,dz(k),Uovf-ubar + 20 format(' k dz U_baroclinic =',i3,1x, & + f8.2,1x,f9.5) + endif + end do + endif + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_U_column + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_V_column +! !INTERFACE: + + subroutine ovf_V_column(i,j,kovf,iblock,Uovf,ubar,utlda,Uovf_nm1) + +! !DESCRIPTION: +! Evaluate ovf column solution for V baroclinic +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + integer (int_kind), & + intent(in) :: & + i, & ! local block i index on u-grid + j, & ! local block j index on u-grid + kovf, & ! k index of overflow + iblock ! block index + + real (r8), intent(in) :: & + Uovf, & ! overflow U + ubar, & ! barotropic velocity + utlda(km), & ! unnormalized baroclinic velocity + Uovf_nm1 ! overflow U at n-1 + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + k ! vertical loop index + + real (r8) :: & + uprime, & ! overflow sidewall baroclinic velocity + hu, & ! HU after accumulation of column dz + vert_sum, & ! vertical sum accumulation of utlda*dz + utlda_bar ! vertical mean of utlda + + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_V_column called ' + call shr_sys_flush(stdout) + endif + +! evaluate baroclinic normalization for the overflow column by including +! the overflow contributions along the sidewall above the overflow + +! above the topography + hu = c0 + vert_sum = c0 + do k=1,KMU(i,j,iblock) + hu = hu + dz(k) + vert_sum = vert_sum + utlda(k)*dz(k) + enddo + +! below the topography but above the overflow + uprime = -ubar + do k=KMU(i,j,iblock)+1,kovf-1 + vert_sum = vert_sum + uprime*dz(k) + enddo + +! the overflow contribution + uprime = Uovf - ubar + vert_sum = vert_sum + uprime*dz(kovf) + +! adjusted utlda_bar + utlda_bar = vert_sum/hu + +! evaluate overflow modified baroclinic velocity for the column + do k=1,KMU(i,j,iblock) + VVEL(i,j,k,newtime,iblock) = utlda(k) - utlda_bar + enddo + +! check of zero vertical sum + hu = c0 + vert_sum = c0 + do k=1,KMU(i,j,iblock) + hu = hu + dz(k) + vert_sum = vert_sum + VVEL(i,j,k,newtime,iblock)*dz(k) + end do + uprime = -ubar + do k=KMU(i,j,iblock)+1,kovf-1 + vert_sum = vert_sum + uprime*dz(k) + enddo + uprime = Uovf - ubar + vert_sum = vert_sum + uprime*dz(kovf) + vert_sum = vert_sum / hu + + if( prnt ) then + write(stdout,*) 'ovf_V_column ' + write(stdout,5) KMU(i,j,iblock),kovf,Uovf,ubar,utlda_bar,Uovf_nm1, & + vert_sum + 5 format(' kmu,kovf,Uovf ubar utlda_bar Uovf_nm1 vert_sum='/ & + 1x,2(i3,1x),2x,4(f10.5,1x),1pe11.4) + do k=1,kovf + if( k <= KMU(i,j,iblock) ) then + write(stdout,10) k,dz(k),utlda(k)-utlda_bar + 10 format(' k dz U_baroclinic =',i3,1x, & + f8.2,1x,f9.5) + else if( k > KMU(i,j,iblock) .and. k < kovf ) then + write(stdout,15) k,dz(k),-ubar + 15 format(' k dz U_baroclinic =',i3,1x, & + f8.2,1x,f9.5) + else + write(stdout,20) k,dz(k),Uovf-ubar + 20 format(' k dz U_baroclinic =',i3,1x, & + f8.2,1x,f9.5) + endif + end do + endif + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_V_column + +!*********************************************************************** + + end module overflows + +!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/restart.F90 b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/restart.F90 new file mode 100644 index 0000000000..9dedae1441 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/SourceMods/src.pop2/restart.F90 @@ -0,0 +1,2285 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_1/models/ocn/pop2/source/restart.F90 + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + + module restart + +!BOP +! !MODULE: restart +! !DESCRIPTION: +! This module contains routins for reading and writing data necessary +! for restarting a POP simulation. +! +! !REVISION HISTORY: +! SVN:$Id: restart.F90 20992 2010-02-12 23:01:33Z njn01 $ +! +! !USES: + + use POP_KindsMod + use POP_ErrorMod + use POP_IOUnitsMod + use POP_FieldMod + use POP_GridHorzMod + use POP_HaloMod + + use domain_size + use domain + use constants, only: char_blank, field_loc_NEcorner, field_type_vector, & + field_loc_center, field_type_scalar, blank_fmt, c0, grav + use blocks, only: nx_block, ny_block, block, get_block + use prognostic, only: UBTROP, VBTROP, PSURF, GRADPX, GRADPY, UVEL, VVEL, & + PGUESS, TRACER, nt, nx_global, ny_global, km, curtime, newtime, oldtime, & + tracer_d + use broadcast, only: broadcast_scalar + use communicate, only: my_task, master_task + use operators, only: div,grad !!POPDART added by AK on Sept 21,2012 + use grid, only: sfc_layer_type, sfc_layer_varthick, CALCU, CALCT, KMU, & + KMT, HU, TAREA_R + use io, only: data_set + use io_types, only: io_field_desc, datafile, io_dim, luse_pointer_files, & + pointer_filename, stdout, construct_io_field, construct_file, & + rec_type_dbl, construct_io_dim, nml_in, nml_filename, get_unit, & + release_unit, destroy_file, add_attrib_file, destroy_io_field, & + extract_attrib_file + use time_management + use ice, only: tlast_ice, liceform, AQICE, FW_FREEZE, QFLUX + use forcing_fields, only: FW_OLD + use forcing_ap, only: ap_interp_last + use forcing_ws, only: ws_interp_last + use forcing_shf, only: shf_interp_last + use forcing_sfwf, only: sfwf_interp_last, sum_precip, precip_fact, & + ssh_initial, sal_initial + use forcing_pt_interior, only: pt_interior_interp_last + use forcing_s_interior, only: s_interior_interp_last + use exit_mod, only: sigAbort, exit_pop, flushm + use registry + use passive_tracers, only: write_restart_passive_tracers + use overflows + use global_reductions !!POPDART added by AK on Sept 21,2012 + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + + public :: init_restart, & + write_restart, & + read_restart + +! !PUBLIC DATA MEMBERS: + public :: restart_fmt, & + read_restart_filename, & + lrestart_write + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- + + character (POP_charLength) :: & + restart_outfile ! restart output filename root + + character (POP_charLength) :: & + restart_fmt ! format (bin or nc) of output restart + + character (POP_charLength) :: & + read_restart_filename = 'undefined' ! file name for restart file + + character (POP_charLength) :: & + exit_string = 'undefined' ! error-exit string + + logical (POP_logical) :: & + pressure_correction, &! fix pressure for exact restart + lrestart_on, &! flag to turn restarts on/off + leven_odd_on, &! flag to turn even_odd restarts on/off + lrestart_write ! flag to determine whether restart is written + + + integer (POP_i4) :: & + even_odd_freq, &! even/odd restart files every freq steps + last_even_odd, &! last even/odd dump + restart_flag, &! time flag id for restarts + evenodd_flag, &! time flag id for even-odd restarts + out_stop_now, &! time flag id for stop_now flag + restart_cpl_ts, &! time flag id for coupled_ts time flag + restart_freq_iopt, &! restart frequency option + restart_freq, &! restart frequency + restart_start_iopt, &! start after option + restart_start ! start regular restart writes after restart_start + + integer (POP_i4), parameter :: & + even = 0, &! integer for which even/odd dump + odd = 1 + + !*** field descriptors for all output fields + + type (io_field_desc) :: & + UBTROP_CUR, UBTROP_OLD, &! barotropic U at current, old times + VBTROP_CUR, VBTROP_OLD, &! barotropic U at current, old times + PSURF_CUR, PSURF_OLD, &! surface press at current, old times + GRADPX_CUR, GRADPX_OLD, &! sfc press gradient in x at both times + GRADPY_CUR, GRADPY_OLD, &! sfc press gradient in y at both times + PGUESSd, &! guess for next surface pressure + FW_OLDd, &! freshwater input at old time + FW_FREEZEd, &! water flux at T points due to frazil ice formation + AQICEd, &! accumulated ice melt/freeze + QFLUXd, &! internal ocn heat flux due to ice formation + UVEL_CUR, UVEL_OLD, &! U at current, old times + VVEL_CUR, VVEL_OLD ! V at current, old times + + type (io_field_desc), dimension(nt) :: & + TRACER_CUR, TRACER_OLD ! tracers at current, old times + +!----------------------------------------------------------------------- +! ccsm coupling variable +!----------------------------------------------------------------------- + integer (POP_i4) :: & + cpl_write_restart ! flag id for restart-file signal from cpl + + +!----------------------------------------------------------------------- +! +! scalar data to be written/read from restart file +! +! runid, +! iyear, imonth, iday, ihour, iminute, isecond +! iyear0, imonth0, iday0, ihour0, iminute0, isecond0 +! dtt, iday_of_year, iday_of_year_last +! elapsed_days, elapsed_months, elapsed_years +! elapsed_days_this_year +! seconds_this_day, seconds_this_day_next +! seconds_this_year, seconds_this_year_next +! nsteps_total +! eod, eod_last, eom, eom_last, eom_next, eoy, eoy_last +! midnight_last, adjust_year_next, newday, newhour +! leapyear, days_in_year, days_in_prior_year +! seconds_in_year, hours_in_year +! tlast_ice +! lcoupled_ts +! shf_interp_last, sfwf_interp_last, ws_interp_last +! ap_interp_last, pt_interior_interp_last +! s_interior_interp_last +! sal_initial, sum_precip, precip_fact, ssh_initial +! +!----------------------------------------------------------------------- + +!EOC +!*********************************************************************** + + contains + +!*********************************************************************** +!BOP +! !IROUTINE: read_restart +! !INTERFACE: + + subroutine read_restart(in_filename,lccsm_branch,lccsm_hybrid, & + in_restart_fmt, errorCode, ldata_assim ) !POPDART added by AK on Sept 21,2012 + +! !DESCRIPTION: +! This routine reads restart data from a file. +! +! Prognostic fields read are: +! UBTROP,VBTROP : barotropic velocities +! PSURF : surface pressure +! GRADPX,GRADPY : surface pressure gradient +! PGUESS : next guess for pressure +! UVEL,VVEL : 3d velocities +! TRACER : 3d tracers +! +! !REVISION HISTORY: +! same as module + +! !INPUT PARAMETERS: + + character (*), intent(in) :: & + in_filename, &! filename of restart file + in_restart_fmt ! format of restart file (bin,nc) + + logical (POP_logical), intent(in) :: & + lccsm_branch ,&! flag if ccsm branch initialization + lccsm_hybrid ! flag if ccsm hybrid initialization + + logical (POP_logical), intent(in), optional :: & + ldata_assim ! flag if continuation after DART data assimilation !POPDART added by AK on Sept 21,2012 + +! !OUTPUT PARAMETERS: + + integer (POP_i4), intent(out) :: & + errorCode ! returned error code + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (POP_i4) :: & + n, k, &! dummy counters + nu, &! i/o unit for pointer file reads + iblock, &! local block index + cindx,cindx2 ! indices into character strings + + real (POP_r8), dimension(nx_block,ny_block) :: & + WORK1,WORK2 ! work space for pressure correction + + character (POP_charLength) :: & + restart_pointer_file, &! file name for restart pointer file + short_name, long_name ! tracer name temporaries + + logical (POP_logical) :: & + lcoupled_ts ! flag to check whether coupled time step + + type (block) :: & + this_block ! block information for current block + + type (datafile) :: & + restart_file ! io file descriptor + + type (io_dim) :: & + i_dim, j_dim, &! dimension descriptors for horiz dims + k_dim ! dimension descriptor for vertical levels + +!----------------------------------------------------------------------- +! +! if pointer files are used, pointer file must be read to get +! actual filenames - skip this for branch initialization +! +!----------------------------------------------------------------------- + + errorCode = POP_Success + + read_restart_filename = char_blank + restart_pointer_file = char_blank + + if (luse_pointer_files) then + call get_unit(nu) + if (my_task == master_task) then + restart_pointer_file = pointer_filename + cindx = len_trim(pointer_filename) + 1 + cindx2= cindx + 7 + restart_pointer_file(cindx:cindx2) = '.restart' + write(stdout,*) 'Reading pointer file: ', & + trim(restart_pointer_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + open(nu, file=trim(restart_pointer_file), form='formatted', & + status='old') + read(nu,'(a)') read_restart_filename + close(nu) + endif + call release_unit(nu) + + call broadcast_scalar(read_restart_filename, master_task) + +!----------------------------------------------------------------------- +! +! otherwise use input filename +! +!----------------------------------------------------------------------- + + else + cindx2 = len_trim(in_filename) + read_restart_filename(1:cindx2) = trim(in_filename) + endif + +!----------------------------------------------------------------------- +! +! create input file and define scalars with default values +! +!----------------------------------------------------------------------- + + restart_file = construct_file(in_restart_fmt, & + full_name=trim(read_restart_filename), & + record_length=rec_type_dbl, & + recl_words=nx_global*ny_global) + + !*** set some defaults for namelist variables not initialized + !*** under some options + + tlast_ice = c0 + lcoupled_ts = .false. + + !*** add defaults as file attributes + + call add_attrib_file(restart_file, 'runid', runid ) + call add_attrib_file(restart_file, 'iyear', iyear ) + call add_attrib_file(restart_file, 'imonth', imonth ) + call add_attrib_file(restart_file, 'iday', iday ) + call add_attrib_file(restart_file, 'ihour', ihour ) + call add_attrib_file(restart_file, 'iminute', iminute ) + call add_attrib_file(restart_file, 'isecond', isecond ) + call add_attrib_file(restart_file, 'iyear0', iyear0 ) + call add_attrib_file(restart_file, 'imonth0', imonth0 ) + call add_attrib_file(restart_file, 'iday0', iday0 ) + call add_attrib_file(restart_file, 'ihour0', ihour0 ) + call add_attrib_file(restart_file, 'iminute0', iminute0) + call add_attrib_file(restart_file, 'isecond0', isecond0) + call add_attrib_file(restart_file, 'dtt', dtt ) + call add_attrib_file(restart_file, 'iday_of_year', iday_of_year) + call add_attrib_file(restart_file, 'iday_of_year_last', & + iday_of_year_last) + call add_attrib_file(restart_file, 'elapsed_days', elapsed_days) + call add_attrib_file(restart_file, 'elapsed_months', elapsed_months) + call add_attrib_file(restart_file, 'elapsed_years', elapsed_years) + call add_attrib_file(restart_file, 'elapsed_days_this_year', & + elapsed_days_this_year) + call add_attrib_file(restart_file, 'seconds_this_day', & + seconds_this_day) + call add_attrib_file(restart_file, 'seconds_this_day_next', & + seconds_this_day_next) + call add_attrib_file(restart_file, 'seconds_this_year', & + seconds_this_year) + call add_attrib_file(restart_file, 'seconds_this_year_next', & + seconds_this_year_next) + call add_attrib_file(restart_file, 'nsteps_total' , nsteps_total) + call add_attrib_file(restart_file, 'eod' , eod ) + call add_attrib_file(restart_file, 'eod_last', eod_last) + call add_attrib_file(restart_file, 'eom' , eom ) + call add_attrib_file(restart_file, 'eom_last', eom_last) + call add_attrib_file(restart_file, 'eom_next', eom_next) + call add_attrib_file(restart_file, 'eoy' , eoy ) + call add_attrib_file(restart_file, 'eoy_last', eoy_last) + call add_attrib_file(restart_file, 'midnight_last', midnight_last) + call add_attrib_file(restart_file, 'adjust_year_next', & + adjust_year_next) + call add_attrib_file(restart_file, 'newday' , newday ) + call add_attrib_file(restart_file, 'newhour', newhour ) + call add_attrib_file(restart_file, 'leapyear',leapyear) + call add_attrib_file(restart_file, 'days_in_year', days_in_year) + call add_attrib_file(restart_file, 'days_in_prior_year', & + days_in_prior_year) + call add_attrib_file(restart_file, 'seconds_in_year', & + seconds_in_year) + call add_attrib_file(restart_file, 'hours_in_year', hours_in_year) + call add_attrib_file(restart_file, 'tlast_ice', tlast_ice ) + call add_attrib_file(restart_file, 'lcoupled_ts', lcoupled_ts) + call add_attrib_file(restart_file, 'shf_interp_last', & + shf_interp_last) + call add_attrib_file(restart_file, 'sfwf_interp_last', & + sfwf_interp_last) + call add_attrib_file(restart_file, 'ws_interp_last', & + ws_interp_last) + call add_attrib_file(restart_file, 'ap_interp_last', & + ap_interp_last) + call add_attrib_file(restart_file, 'pt_interior_interp_last', & + pt_interior_interp_last) + call add_attrib_file(restart_file, 's_interior_interp_last', & + s_interior_interp_last) + call add_attrib_file(restart_file, 'sum_precip' , sum_precip ) + call add_attrib_file(restart_file, 'precip_fact', precip_fact) + call add_attrib_file(restart_file, 'ssh_initial', ssh_initial) + + short_name = char_blank + do k=1,km + write(short_name,'(a11,i3.3)') 'sal_initial',k + call add_attrib_file(restart_file,trim(short_name),sal_initial(k)) + end do + +!----------------------------------------------------------------------- +! +! open a file and extract scalars as file attributes +! do not extract if this is a ccsm branch initialization - values are set elsewhere +! +!----------------------------------------------------------------------- + + !*** open file and read attributes + + call data_set(restart_file, 'open_read') + + !*** extract scalars if not a ccsm branch initialization + + if (.not. lccsm_branch .and. .not. lccsm_hybrid) then + call extract_attrib_file(restart_file, 'runid', runid ) + endif + + + if (.not. lccsm_hybrid) then + call extract_attrib_file(restart_file, 'iyear', iyear ) + call extract_attrib_file(restart_file, 'imonth', imonth ) + call extract_attrib_file(restart_file, 'iday', iday ) + call extract_attrib_file(restart_file, 'ihour', ihour ) + call extract_attrib_file(restart_file, 'iminute', iminute ) + call extract_attrib_file(restart_file, 'isecond', isecond ) + call extract_attrib_file(restart_file, 'iyear0', iyear0 ) + call extract_attrib_file(restart_file, 'imonth0', imonth0 ) + call extract_attrib_file(restart_file, 'iday0', iday0 ) + call extract_attrib_file(restart_file, 'ihour0', ihour0 ) + call extract_attrib_file(restart_file, 'iminute0', iminute0) + call extract_attrib_file(restart_file, 'isecond0', isecond0) + call extract_attrib_file(restart_file, 'dtt', dtt ) + call extract_attrib_file(restart_file, 'iday_of_year', & + iday_of_year) + call extract_attrib_file(restart_file, 'iday_of_year_last',& + iday_of_year_last) + call extract_attrib_file(restart_file, 'elapsed_days', & + elapsed_days) + call extract_attrib_file(restart_file, 'elapsed_months', & + elapsed_months) + call extract_attrib_file(restart_file, 'elapsed_years', & + elapsed_years) + call extract_attrib_file(restart_file, 'elapsed_days_this_year', & + elapsed_days_this_year) + call extract_attrib_file(restart_file, 'seconds_this_day', & + seconds_this_day) + call extract_attrib_file(restart_file, 'seconds_this_day_next', & + seconds_this_day_next) + call extract_attrib_file(restart_file, 'seconds_this_year', & + seconds_this_year) + call extract_attrib_file(restart_file, 'seconds_this_year_next', & + seconds_this_year_next) + call extract_attrib_file(restart_file, 'nsteps_total', & + nsteps_total) + call extract_attrib_file(restart_file, 'eod' , eod ) + call extract_attrib_file(restart_file, 'eod_last', eod_last) + call extract_attrib_file(restart_file, 'eom' , eom ) + call extract_attrib_file(restart_file, 'eom_last', eom_last) + call extract_attrib_file(restart_file, 'eom_next', eom_next) + call extract_attrib_file(restart_file, 'eoy' , eoy ) + call extract_attrib_file(restart_file, 'eoy_last', eoy_last) + call extract_attrib_file(restart_file, 'midnight_last', & + midnight_last) + call extract_attrib_file(restart_file, 'adjust_year_next', & + adjust_year_next) + call extract_attrib_file(restart_file, 'newday' , newday ) + call extract_attrib_file(restart_file, 'newhour', newhour ) + call extract_attrib_file(restart_file, 'leapyear',leapyear) + call extract_attrib_file(restart_file, 'days_in_year', & + days_in_year) + call extract_attrib_file(restart_file, 'days_in_prior_year',& + days_in_prior_year) + call extract_attrib_file(restart_file, 'seconds_in_year', & + seconds_in_year) + call extract_attrib_file(restart_file, 'hours_in_year', & + hours_in_year) + call extract_attrib_file(restart_file, 'tlast_ice', tlast_ice ) + endif ! .not. lccsm_hybrid + + + call extract_attrib_file(restart_file, 'lcoupled_ts', & + lcoupled_ts) + + if (.not. lccsm_hybrid) then + call extract_attrib_file(restart_file, 'shf_interp_last', & + shf_interp_last) + call extract_attrib_file(restart_file, 'sfwf_interp_last', & + sfwf_interp_last) + call extract_attrib_file(restart_file, 'ws_interp_last', & + ws_interp_last) + call extract_attrib_file(restart_file, 'ap_interp_last', & + ap_interp_last) + call extract_attrib_file(restart_file, 'pt_interior_interp_last',& + pt_interior_interp_last) + call extract_attrib_file(restart_file, 's_interior_interp_last', & + s_interior_interp_last) + call extract_attrib_file(restart_file, 'sum_precip' , sum_precip ) + call extract_attrib_file(restart_file, 'precip_fact', precip_fact) + call extract_attrib_file(restart_file, 'ssh_initial', ssh_initial) + + + short_name = char_blank + do k=1,km + write(short_name,'(a11,i3.3)') 'sal_initial',k + call extract_attrib_file(restart_file, trim(short_name), & + sal_initial(k)) + end do + + call int_to_char(4, iyear,cyear) + call int_to_char(2, imonth,cmonth) + call int_to_char(2, iday,cday) + cmonth3 = month3_all(imonth) + + !*** set old value for the time flag 'coupled_ts' + + if (lcoupled_ts) then + call register_string('coupled_ts_last_true') + ! coupled_ts will be initialized accordingly in pop_init_coupled + endif + + endif ! .not. lccsm_hybrid + +!----------------------------------------------------------------------- +! +! define all fields to be read +! +!----------------------------------------------------------------------- + + !*** define dimensions + + i_dim = construct_io_dim('i', nx_global) + j_dim = construct_io_dim('j', ny_global) + k_dim = construct_io_dim('k', km) + + UBTROP_CUR = construct_io_field('UBTROP_CUR', dim1=i_dim, dim2=j_dim, & + long_name='U barotropic velocity at current time', & + units ='cm/s', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =UBTROP(:,:,curtime,:)) + call data_set (restart_file, 'define', UBTROP_CUR) + + UBTROP_OLD = construct_io_field('UBTROP_OLD', dim1=i_dim, dim2=j_dim, & + long_name='U barotropic velocity at old time', & + units ='cm/s', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =UBTROP(:,:,oldtime,:)) + call data_set (restart_file, 'define', UBTROP_OLD) + + VBTROP_CUR = construct_io_field('VBTROP_CUR', dim1=i_dim, dim2=j_dim, & + long_name='V barotropic velocity at current time', & + units ='cm/s', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =VBTROP(:,:,curtime,:)) + call data_set (restart_file, 'define', VBTROP_CUR) + + VBTROP_OLD = construct_io_field('VBTROP_OLD', dim1=i_dim, dim2=j_dim, & + long_name='V barotropic velocity at old time', & + units ='cm/s', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =VBTROP(:,:,oldtime,:)) + call data_set (restart_file, 'define', VBTROP_OLD) + + PSURF_CUR = construct_io_field('PSURF_CUR', dim1=i_dim, dim2=j_dim, & + long_name='surface pressure at current time', & + units ='dyne/cm2', grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array =PSURF(:,:,curtime,:)) + call data_set (restart_file, 'define', PSURF_CUR) + + PSURF_OLD = construct_io_field('PSURF_OLD', dim1=i_dim, dim2=j_dim, & + long_name='surface pressure at old time', & + units ='dyne/cm2', grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array =PSURF(:,:,oldtime,:)) + call data_set (restart_file, 'define', PSURF_OLD) + + GRADPX_CUR = construct_io_field('GRADPX_CUR', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in x at current time',& + units ='dyne/cm3', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =GRADPX(:,:,curtime,:)) + call data_set (restart_file, 'define', GRADPX_CUR) + + GRADPX_OLD = construct_io_field('GRADPX_OLD', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in x at old time', & + units ='dyne/cm3', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =GRADPX(:,:,oldtime,:)) + call data_set (restart_file, 'define', GRADPX_OLD) + + GRADPY_CUR = construct_io_field('GRADPY_CUR', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in y at current time',& + units ='dyne/cm3', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =GRADPY(:,:,curtime,:)) + call data_set (restart_file, 'define', GRADPY_CUR) + + GRADPY_OLD = construct_io_field('GRADPY_OLD', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in y at old time', & + units ='dyne/cm3', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =GRADPY(:,:,oldtime,:)) + call data_set (restart_file, 'define', GRADPY_OLD) + + PGUESSd = construct_io_field('PGUESS', dim1=i_dim, dim2=j_dim, & + long_name='guess for sfc pressure at new time', & + units ='dyne/cm2', grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array =PGUESS) + call data_set (restart_file, 'define', PGUESSd) + + if (sfc_layer_type == sfc_layer_varthick) then + FW_OLDd = construct_io_field('FW_OLD', dim1=i_dim, dim2=j_dim, & + long_name='fresh water input at old time', & + grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array = FW_OLD) + call data_set (restart_file, 'define', FW_OLDd) + FW_FREEZEd = construct_io_field('FW_FREEZE', dim1=i_dim, dim2=j_dim, & + long_name='water flux due to frazil ice formation',& + grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array = FW_FREEZE) + call data_set (restart_file, 'define', FW_FREEZEd) + endif + + if (liceform) then + if (lcoupled_ts) then + QFLUXd = construct_io_field('QFLUX', dim1=i_dim, dim2=j_dim, & + long_name='Internal Ocean Heat Flux Due to Ice Formation',& + grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array = QFLUX) + call data_set (restart_file, 'define', QFLUXd) + else + AQICEd = construct_io_field('AQICE', dim1=i_dim, dim2=j_dim, & + long_name='accumulated ice melt/heat', & + grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array = AQICE) + call data_set (restart_file, 'define', AQICEd) + endif + endif + + UVEL_CUR = construct_io_field('UVEL_CUR', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='U velocity at current time', & + units ='cm/s', & + grid_loc ='3221', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d3d_array = UVEL(:,:,:,curtime,:)) + call data_set (restart_file, 'define', UVEL_CUR) + + + UVEL_OLD = construct_io_field('UVEL_OLD', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='U velocity at old time', & + units ='cm/s', & + grid_loc ='3221', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d3d_array = UVEL(:,:,:,oldtime,:)) + call data_set (restart_file, 'define', UVEL_OLD) + + VVEL_CUR = construct_io_field('VVEL_CUR', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='V velocity at current time', & + units ='cm/s', & + grid_loc ='3221', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d3d_array = VVEL(:,:,:,curtime,:)) + call data_set (restart_file, 'define', VVEL_CUR) + + VVEL_OLD = construct_io_field('VVEL_OLD', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='V velocity at old time', & + units ='cm/s', & + grid_loc ='3221', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d3d_array = VVEL(:,:,:,oldtime,:)) + call data_set (restart_file, 'define', VVEL_OLD) + + do n=1,2 + short_name = char_blank + short_name = trim(tracer_d(n)%short_name)/& + &/'_CUR' + long_name = char_blank + long_name = trim(tracer_d(n)%long_name)/& + &/' at current time' + TRACER_CUR(n) = construct_io_field(trim(short_name), & + dim1=i_dim, dim2=j_dim, dim3=k_dim, & + long_name=trim(long_name), & + units =trim(tracer_d(n)%units), & + grid_loc ='3111', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d3d_array = TRACER(:,:,:,n,curtime,:)) + call data_set (restart_file, 'define', TRACER_CUR(n)) + end do + + + do n=1,2 + + short_name = char_blank + short_name = trim(tracer_d(n)%short_name)/& + &/'_OLD' + long_name = char_blank + long_name = trim(tracer_d(n)%long_name)/& + &/' at old time' + + TRACER_OLD(n) = construct_io_field(trim(short_name), & + dim1=i_dim, dim2=j_dim, dim3=k_dim, & + long_name=trim(long_name), & + units =trim(tracer_d(n)%units), & + grid_loc ='3111', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d3d_array = TRACER(:,:,:,n,oldtime,:)) + + call data_set (restart_file, 'define', TRACER_OLD(n)) + end do + +!----------------------------------------------------------------------- +! +! now we actually read each field +! after reading, get rid of io field descriptors and close file +! +!----------------------------------------------------------------------- + + call data_set (restart_file, 'read', UBTROP_CUR) + call data_set (restart_file, 'read', UBTROP_OLD) + call data_set (restart_file, 'read', VBTROP_CUR) + call data_set (restart_file, 'read', VBTROP_OLD) + call data_set (restart_file, 'read', PSURF_CUR) + call data_set (restart_file, 'read', PSURF_OLD) + call data_set (restart_file, 'read', GRADPX_CUR) + call data_set (restart_file, 'read', GRADPX_OLD) + call data_set (restart_file, 'read', GRADPY_CUR) + call data_set (restart_file, 'read', GRADPY_OLD) + call data_set (restart_file, 'read', PGUESSd) + + if (sfc_layer_type == sfc_layer_varthick) then + call data_set (restart_file, 'read', FW_OLDd) + call data_set (restart_file, 'read', FW_FREEZEd) + endif + if (liceform) then + if (lcoupled_ts) then + call data_set (restart_file, 'read', QFLUXd) + else + call data_set (restart_file, 'read', AQICEd) + endif + endif + + call data_set (restart_file, 'read', UVEL_CUR) + call data_set (restart_file, 'read', UVEL_OLD) + call data_set (restart_file, 'read', VVEL_CUR) + call data_set (restart_file, 'read', VVEL_OLD) + + do n=1,2 + call data_set (restart_file, 'read', TRACER_CUR(n)) + call data_set (restart_file, 'read', TRACER_OLD(n)) + end do + + call destroy_io_field (UBTROP_CUR) + call destroy_io_field (UBTROP_OLD) + call destroy_io_field (VBTROP_CUR) + call destroy_io_field (VBTROP_OLD) + call destroy_io_field (PSURF_CUR) + call destroy_io_field (PSURF_OLD) + call destroy_io_field (GRADPX_CUR) + call destroy_io_field (GRADPX_OLD) + call destroy_io_field (GRADPY_CUR) + call destroy_io_field (GRADPY_OLD) + call destroy_io_field (PGUESSd) + + if (sfc_layer_type == sfc_layer_varthick) then + call destroy_io_field (FW_OLDd) + call destroy_io_field (FW_FREEZEd) + endif + if (liceform) then + if (lcoupled_ts) then + call destroy_io_field (QFLUXd) + else + call destroy_io_field (AQICEd) + endif + endif + + call destroy_io_field (UVEL_CUR) + call destroy_io_field (UVEL_OLD) + call destroy_io_field (VVEL_CUR) + call destroy_io_field (VVEL_OLD) + do n=1,2 + call destroy_io_field (TRACER_CUR(n)) + call destroy_io_field (TRACER_OLD(n)) + end do + + call data_set (restart_file, 'close') + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,*) ' file read: ', trim(read_restart_filename) + endif + + call destroy_file(restart_file) + +!----------------------------------------------------------------------- +! +! zero prognostic variables at land points +! +!----------------------------------------------------------------------- + + do iblock = 1,nblocks_clinic + + this_block = get_block(blocks_clinic(iblock),iblock) + + where (.not. CALCU(:,:,iblock)) + UBTROP(:,:,curtime,iblock) = c0 + VBTROP(:,:,curtime,iblock) = c0 + GRADPX(:,:,curtime,iblock) = c0 + GRADPY(:,:,curtime,iblock) = c0 + UBTROP(:,:,oldtime,iblock) = c0 + VBTROP(:,:,oldtime,iblock) = c0 + GRADPX(:,:,oldtime,iblock) = c0 + GRADPY(:,:,oldtime,iblock) = c0 + endwhere + + where (.not. CALCT(:,:,iblock)) + PSURF(:,:,curtime,iblock) = c0 + PSURF(:,:,oldtime,iblock) = c0 + PGUESS(:,:,iblock) = c0 + endwhere + + if (liceform) then + if (lcoupled_ts) then + where (.not. CALCT(:,:,iblock)) + QFLUX(:,:,iblock) = c0 + endwhere + else + where (.not. CALCT(:,:,iblock)) + AQICE(:,:,iblock) = c0 + endwhere + endif + endif + + if (sfc_layer_type == sfc_layer_varthick) then + where (.not. CALCT(:,:,iblock)) + FW_OLD (:,:,iblock) = c0 + FW_FREEZE(:,:,iblock) = c0 + endwhere + endif + + if( overflows_on .and. overflows_interactive & + .and. overflows_restart_type /= 'ccsm_startup' ) then + ! Do not set sidewall velocities to zero when overflows + ! on and interactive; otherwise, valid overflow velocities + ! will be lost + else + do k = 1,km + where (k > KMU(:,:,iblock)) + UVEL(:,:,k,curtime,iblock) = c0 + VVEL(:,:,k,curtime,iblock) = c0 + endwhere + enddo + endif + + do n = 1,2 + do k = 1,km + where (k > KMT(:,:,iblock)) + TRACER(:,:,k,n,curtime,iblock) = c0 + TRACER(:,:,k,n,oldtime,iblock) = c0 + endwhere + enddo + enddo + +!----------------------------------------------------------------------- +! +! reset PSURF(oldtime) to eliminate error in barotropic continuity +! eqn due to (possible) use of different timestep after restart +! +! NOTE: use pressure_correction = .false. for exact restart +! +!----------------------------------------------------------------------- + + if (pressure_correction) then + + WORK1 = HU(:,:,iblock)*UBTROP(:,:,curtime,iblock) + WORK2 = HU(:,:,iblock)*VBTROP(:,:,curtime,iblock) + + !*** use PSURF(oldtime) as temp + call div(1, PSURF(:,:,oldtime,iblock),WORK1,WORK2,this_block) + + PSURF(:,:,oldtime,iblock) = PSURF(:,:,curtime,iblock) + & + grav*dtp*PSURF(:,:,oldtime,iblock)* & + TAREA_R(:,:,iblock) + + endif + end do !block loop + + if (pressure_correction) then + call POP_HaloUpdate(PSURF(:,:,oldtime,:), POP_haloClinic, & + POP_gridHorzLocCenter, POP_fieldKindScalar, & + errorCode, fillValue = 0.0_POP_r8) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'read_restart: error updating sfc pressure halo') + return + endif + endif + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + + call POP_HaloUpdate(UBTROP, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(VBTROP, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(UVEL, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(VVEL, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(TRACER(:,:,:,:,curtime,:), & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(TRACER(:,:,:,:,newtime,:), & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(GRADPX, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(GRADPY, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(PSURF, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(PGUESS, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + if (sfc_layer_type == sfc_layer_varthick) then + call POP_HaloUpdate(FW_OLD, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(FW_FREEZE, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + if (liceform) then + if (lcoupled_ts) then + call POP_HaloUpdate(QFLUX, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + else + call POP_HaloUpdate(AQICE, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + endif + endif + endif + +!****POPDART added by AK on Sept 21,2012 + +if (present(ldata_assim)) then + if (ldata_assim) then + if (my_task == master_task) then + write(stdout,*) 'read_restart: calling DART_modify_restart because ldata_assim = ',ldata_assim + call POP_IOUnitsFlush(POP_stdout) + call POP_IOUnitsFlush(stdout) + endif + call DART_modify_restart + endif +else + if (my_task == master_task) then + write(stdout,*) 'read_restart: ldata_assim not present.' + endif +endif + +!************************** + +!----------------------------------------------------------------------- +!EOC + + end subroutine read_restart + +!!***POPDART added by AK on Sept 21,2012 +!*********************************************************************** +!BOP +! !IROUTINE: DART_modify_restart +! !INTERFACE: + + subroutine DART_modify_restart + +! !DESCRIPTION: +! This routine modifies POP restart variables as needed +! when initializing POP from restart files which are altered by +! the DART data assimilation code (init_ts_suboption == 'data_assim'). +! +! !REVISION HISTORY: +! same as module +! +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (POP_i4) :: & + i,j, &! dummy indices for horizontal directions + n,k, &! dummy indices for vertical level, tracer + iblock ! counter for block loops + + real (POP_r8), dimension(nx_block,ny_block) :: & + WORK1,WORK2 ! local work space, single-block + + real (POP_r8), dimension(nx_block,ny_block,max_blocks_clinic) :: & + WORK3, WORK4 ! local work space, multi-block + + real (POP_r8) :: & + psurf_hor_ave, &! area-weighted mean of PSURF + psurf_hor_area, &! total area of PSURF + psurf_mean ! mean of PSURF + + type (block) :: & + this_block ! block information for current block + + integer (POP_i4) :: & + errorCode ! returned error code + + errorCode = POP_Success +!----------------------------------------------------------------------- +! +! recalculate UBTROP_CUR and VBTROP_CUR as vertical integrals +! of UVEL_CUR and VVEL_CUR +! +! !!!NEEDS MODS FOR OVERFLOWS!!! +! +!----------------------------------------------------------------------- + WORK3 = c0 ! initialize sums + WORK4 = c0 + + if (partial_bottom_cells) then + do k = 1,km + WORK3 = WORK3 + UVEL(:,:,k,curtime,:)*DZU(:,:,k,:) + WORK4 = WORK4 + VVEL(:,:,k,curtime,:)*DZU(:,:,k,:) + enddo + else + do k = 1,km + WORK3 = WORK3 + UVEL(:,:,k,curtime,:)*dz(k) + WORK4 = WORK4 + VVEL(:,:,k,curtime,:)*dz(k) + enddo + endif + + UBTROP(:,:,curtime,:) = WORK3*HUR ! normalize by dividing by depth + VBTROP(:,:,curtime,:) = WORK4*HUR ! normalize by dividing by depth + +!----------------------------------------------------------------------- +! +! ensure zero horizontal mean PSURF_CUR, seperately in marginal seas +! and open ocean. +! +!----------------------------------------------------------------------- + do n = 0,num_regions + WORK3 = c0 + WORK4 = c0 + if (n.eq.0) then + WORK3 = merge(TAREA*PSURF(:,:,curtime,:),c0, REGION_MASK > 0) + WORK4 = merge(TAREA,c0, REGION_MASK > 0) + else + if (region_info(n)%marginal_sea) then + WORK3 = merge(TAREA*PSURF(:,:,curtime,:), c0, & + REGION_MASK == region_info(n)%number) + WORK4 = merge(TAREA, c0, & + REGION_MASK == region_info(n)%number) + endif + endif + + psurf_hor_ave = global_sum(WORK3, distrb_clinic, field_loc_center) + psurf_hor_area = global_sum(WORK4, distrb_clinic, field_loc_center) + if (psurf_hor_area > c0) then + psurf_mean = psurf_hor_ave/psurf_hor_area + else + psurf_mean = c0 + endif + + if (n.eq.0) then + if (my_task == master_task) then + write(stdout,*)'(DART_modify_restart): region_id = ',0, & + ' psurf_mean = ', psurf_mean + end if + else + if (my_task == master_task) then + write(stdout,*)'(DART_modify_restart): region_id = ', & + region_info(n)%number, ' psurf_mean = ', psurf_mean + endif + endif + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + + where (WORK4 > c0) + PSURF(:,:,curtime,:) = PSURF(:,:,curtime,:) - psurf_mean + endwhere + + enddo ! n loop + +!----------------------------------------------------------------------- +! +! recompute GRADPX_CUR and GRADPY_CUR using new PSURF_CUR +! +!----------------------------------------------------------------------- + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + + call grad(1,GRADPX(:,:,curtime,iblock), & + GRADPY(:,:,curtime,iblock), & + PSURF(:,:,curtime,iblock),this_block) + enddo ! block loop + +!----------------------------------------------------------------------- +! +! reset PGUESS +! +!----------------------------------------------------------------------- + do iblock = 1,nblocks_clinic + + PGUESS(:,:,iblock) = PSURF(:,:,curtime,iblock) + + enddo ! block loop + +!----------------------------------------------------------------------- +! +! redo Halo Updates +! +!----------------------------------------------------------------------- + + call POP_HaloUpdate(PGUESS, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(UBTROP, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(VBTROP, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(GRADPX, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(GRADPY, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(PSURF, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + +!----------------------------------------------------------------------- +! +! reset OLD to CUR +! +!----------------------------------------------------------------------- + do iblock = 1,nblocks_clinic + + UBTROP(:,:,oldtime,iblock) = UBTROP(:,:,curtime,iblock) + VBTROP(:,:,oldtime,iblock) = VBTROP(:,:,curtime,iblock) + PSURF(:,:,oldtime,iblock) = PSURF(:,:,curtime,iblock) + GRADPX(:,:,oldtime,iblock) = GRADPX(:,:,curtime,iblock) + GRADPY(:,:,oldtime,iblock) = GRADPY(:,:,curtime,iblock) + do k = 1,km + UVEL(:,:,k,oldtime,iblock) = UVEL(:,:,k,curtime,iblock) + VVEL(:,:,k,oldtime,iblock) = VVEL(:,:,k,curtime,iblock) + do n = 1,2 + TRACER(:,:,k,n,oldtime,iblock) = TRACER(:,:,k,n,curtime,iblock) + enddo + enddo + + enddo ! block loop + +!----------------------------------------------------------------------- +!EOC + + end subroutine DART_modify_restart + + + + +!*********************************************************************** +!BOP +! !IROUTINE: write_restart +! !INTERFACE: + + subroutine write_restart(restart_type) + +! !DESCRIPTION: +! This routine writes all the data necessary for restarting a POP +! simulation if it is determined that the time has come to write +! the data. It also returns the type of restart that was written +! so that the tavg module can determine whether it need to write +! a restart file for tavg fields. +! +! !REVISION HISTORY: +! same as module +! +! !OUTPUT PARAMETERS: + + character(POP_charLength), intent(out) :: & + restart_type ! type of restart file written if any + ! possible values are: none,restart,even,odd,end + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character (POP_charLength) :: & + file_suffix ! suffix to append to root filename + + integer (POP_i4) :: & + k, n, &! dummy counters + nu ! i/o unit for pointer file writes + + character (POP_charLength) :: & + write_restart_filename, &! modified file name for restart file + restart_pointer_file, &! file name for restart pointer file + short_name, &! temporary for short name for io fields + long_name ! temporary for long name for io fields + + logical (POP_logical) :: & + lcoupled_ts ! flag to check whether coupled time step + + type (datafile) :: & + restart_file ! io file descriptor + + type (io_dim) :: & + i_dim, j_dim, &! dimension descriptors for horiz dims + k_dim ! dimension descriptor for vertical levels + +!----------------------------------------------------------------------- +! +! always set restart_type, because it is used in write_tavg +! +!----------------------------------------------------------------------- + + restart_type = char_blank + restart_type = 'none' + +!----------------------------------------------------------------------- +! +! check to see if it is time to begin regularly writing restart files +! +!----------------------------------------------------------------------- + + + if (check_time_flag(out_stop_now) ) then + ! procede regardless of time_to_start option + else + if ( .not. time_to_start(restart_start_iopt,restart_start)) return + endif + +!----------------------------------------------------------------------- +! +! check to see whether it is time to write files +! +!----------------------------------------------------------------------- + + lrestart_write = .false. + + !*** write restart files if code is stopping for any reason + + if (check_time_flag(out_stop_now) .and. & + (lrestart_on .or. leven_odd_on)) then + + lrestart_write = .true. + restart_type = char_blank + restart_type = 'end' + endif + + !*** check if it is time for even/odd output + !*** (but not if an end file is written) + + if (.not. lrestart_write .and. check_time_flag(evenodd_flag) & + .and. .not. check_time_flag(out_stop_now)) then + + lrestart_write = .true. + restart_type = char_blank + + if (last_even_odd == even) then + restart_type = 'odd' + last_even_odd = odd + else + restart_type = 'even' + last_even_odd = even + endif + + endif + + !*** check if it is time for regularly-scheduled restart output + !*** note that this option over-rides others + + if (check_time_flag(restart_flag) .or. & + (check_time_flag(cpl_write_restart) .and. & + (nsteps_this_interval == nsteps_per_interval)) ) then + + lrestart_write = .true. + restart_type = char_blank + restart_type = 'restart' + + endif + + !*** turn off cpl_write_restart if necessary + + if (check_time_flag(cpl_write_restart) .and. eod) & + call override_time_flag(cpl_write_restart, value=.false.) + + +!----------------------------------------------------------------------- +! +! the rest of this routine is only executed if it is time to write a +! restart file +! +!----------------------------------------------------------------------- + + if (lrestart_write) then + + +!----------------------------------------------------------------------- +! +! create filename for user-supplied root and append date +! +!----------------------------------------------------------------------- + + write_restart_filename = char_blank + file_suffix = char_blank + + if (registry_match('lccsm')) then + call create_restart_suffix_ccsm(file_suffix, restart_type,freq_opt_nsecond) + else + call create_restart_suffix(file_suffix, restart_type) + endif + + !*** must split concatenation operator to avoid preprocessor mangling + + write_restart_filename = trim(restart_outfile)/& + &/'.'/& + &/trim(file_suffix) + +!----------------------------------------------------------------------- +! +! create output file +! +!----------------------------------------------------------------------- + + restart_file = construct_file(restart_fmt, & + full_name=trim(write_restart_filename), & + record_length=rec_type_dbl, & + recl_words=nx_global*ny_global) + +!----------------------------------------------------------------------- +! +! scalar variables in restart file are output as file attributes +! so define them here +! +!----------------------------------------------------------------------- + + !*** query time_flag routine for present value of lcoupled_ts + + lcoupled_ts = check_time_flag (restart_cpl_ts) + + !*** add defaults as file attributes + + call add_attrib_file(restart_file, 'runid', runid ) + call add_attrib_file(restart_file, 'iyear', iyear ) + call add_attrib_file(restart_file, 'imonth', imonth ) + call add_attrib_file(restart_file, 'iday', iday ) + call add_attrib_file(restart_file, 'ihour', ihour ) + call add_attrib_file(restart_file, 'iminute', iminute ) + call add_attrib_file(restart_file, 'isecond', isecond ) + call add_attrib_file(restart_file, 'iyear0', iyear0 ) + call add_attrib_file(restart_file, 'imonth0', imonth0 ) + call add_attrib_file(restart_file, 'iday0', iday0 ) + call add_attrib_file(restart_file, 'ihour0', ihour0 ) + call add_attrib_file(restart_file, 'iminute0', iminute0) + call add_attrib_file(restart_file, 'isecond0', isecond0) + call add_attrib_file(restart_file, 'dtt', dtt ) + call add_attrib_file(restart_file, 'iday_of_year', iday_of_year) + call add_attrib_file(restart_file, 'iday_of_year_last', & + iday_of_year_last) + call add_attrib_file(restart_file, 'elapsed_days', elapsed_days) + call add_attrib_file(restart_file, 'elapsed_months', elapsed_months) + call add_attrib_file(restart_file, 'elapsed_years', elapsed_years) + call add_attrib_file(restart_file, 'elapsed_days_this_year', & + elapsed_days_this_year) + call add_attrib_file(restart_file, 'seconds_this_day', & + seconds_this_day) + call add_attrib_file(restart_file, 'seconds_this_day_next', & + seconds_this_day_next) + call add_attrib_file(restart_file, 'seconds_this_year', & + seconds_this_year) + call add_attrib_file(restart_file, 'seconds_this_year_next', & + seconds_this_year_next) + call add_attrib_file(restart_file, 'nsteps_total', & + nsteps_total) + call add_attrib_file(restart_file, 'eod' , eod ) + call add_attrib_file(restart_file, 'eod_last', eod_last) + call add_attrib_file(restart_file, 'eom' , eom ) + call add_attrib_file(restart_file, 'eom_last', eom_last) + call add_attrib_file(restart_file, 'eom_next', eom_next) + call add_attrib_file(restart_file, 'eoy' , eoy ) + call add_attrib_file(restart_file, 'eoy_last', eoy_last) + call add_attrib_file(restart_file, 'midnight_last', midnight_last) + call add_attrib_file(restart_file, 'adjust_year_next', & + adjust_year_next) + call add_attrib_file(restart_file, 'newday' , newday ) + call add_attrib_file(restart_file, 'newhour', newhour ) + call add_attrib_file(restart_file, 'leapyear',leapyear) + call add_attrib_file(restart_file, 'days_in_year', days_in_year) + call add_attrib_file(restart_file, 'days_in_prior_year', & + days_in_prior_year) + call add_attrib_file(restart_file, 'seconds_in_year', & + seconds_in_year) + call add_attrib_file(restart_file, 'hours_in_year', hours_in_year) + call add_attrib_file(restart_file, 'tlast_ice', tlast_ice ) + call add_attrib_file(restart_file, 'lcoupled_ts', lcoupled_ts) + call add_attrib_file(restart_file, 'shf_interp_last', & + shf_interp_last) + call add_attrib_file(restart_file, 'sfwf_interp_last', & + sfwf_interp_last) + call add_attrib_file(restart_file, 'ws_interp_last', & + ws_interp_last) + call add_attrib_file(restart_file, 'ap_interp_last', & + ap_interp_last) + call add_attrib_file(restart_file, 'pt_interior_interp_last', & + pt_interior_interp_last) + call add_attrib_file(restart_file, 's_interior_interp_last', & + s_interior_interp_last) + call add_attrib_file(restart_file, 'sum_precip' , sum_precip ) + call add_attrib_file(restart_file, 'precip_fact', precip_fact) + call add_attrib_file(restart_file, 'ssh_initial', ssh_initial) + + short_name = char_blank + do k=1,km + write(short_name,'(a11,i3.3)') 'sal_initial',k + call add_attrib_file(restart_file,trim(short_name),sal_initial(k)) + end do + + if (nt > 2) call write_restart_passive_tracers(restart_file,'add_attrib_file') + +!----------------------------------------------------------------------- +! +! open a file (also writes scalars as attributes to file) +! +!----------------------------------------------------------------------- + + call data_set(restart_file, 'open') + +!----------------------------------------------------------------------- +! +! construct all fields to be written +! +!----------------------------------------------------------------------- + + !*** define dimensions + + i_dim = construct_io_dim('i', nx_global) + j_dim = construct_io_dim('j', ny_global) + k_dim = construct_io_dim('k', km) + + UBTROP_CUR = construct_io_field('UBTROP_CUR', dim1=i_dim, dim2=j_dim, & + long_name='U barotropic velocity at current time', & + units ='cm/s', & + grid_loc ='2220', & + d2d_array =UBTROP(:,:,curtime,:)) + + UBTROP_OLD = construct_io_field('UBTROP_OLD', dim1=i_dim, dim2=j_dim, & + long_name='U barotropic velocity at old time', & + units ='cm/s', & + grid_loc ='2220', & + d2d_array =UBTROP(:,:,oldtime,:)) + + VBTROP_CUR = construct_io_field('VBTROP_CUR', dim1=i_dim, dim2=j_dim, & + long_name='V barotropic velocity at current time', & + units ='cm/s', & + grid_loc ='2220', & + d2d_array =VBTROP(:,:,curtime,:)) + + VBTROP_OLD = construct_io_field('VBTROP_OLD', dim1=i_dim, dim2=j_dim, & + long_name='V barotropic velocity at old time', & + units ='cm/s', & + grid_loc ='2220', & + d2d_array =VBTROP(:,:,oldtime,:)) + + PSURF_CUR = construct_io_field('PSURF_CUR', dim1=i_dim, dim2=j_dim, & + long_name='surface pressure at current time', & + units ='dyne/cm2', & + grid_loc ='2110', & + d2d_array =PSURF(:,:,curtime,:)) + + PSURF_OLD = construct_io_field('PSURF_OLD', dim1=i_dim, dim2=j_dim, & + long_name='surface pressure at old time', & + units ='dyne/cm2', & + grid_loc ='2110', & + d2d_array =PSURF(:,:,oldtime,:)) + + GRADPX_CUR = construct_io_field('GRADPX_CUR', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in x at current time',& + units ='dyne/cm3', & + grid_loc ='2220', & + d2d_array =GRADPX(:,:,curtime,:)) + + GRADPX_OLD = construct_io_field('GRADPX_OLD', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in x at old time', & + units ='dyne/cm3', & + grid_loc ='2220', & + d2d_array =GRADPX(:,:,oldtime,:)) + + GRADPY_CUR = construct_io_field('GRADPY_CUR', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in y at current time',& + units ='dyne/cm3', & + grid_loc ='2220', & + d2d_array =GRADPY(:,:,curtime,:)) + + GRADPY_OLD = construct_io_field('GRADPY_OLD', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in y at old time', & + units ='dyne/cm3', & + grid_loc ='2220', & + d2d_array =GRADPY(:,:,oldtime,:)) + + PGUESSd = construct_io_field('PGUESS', dim1=i_dim, dim2=j_dim, & + long_name='guess for sfc pressure at new time', & + units ='dyne/cm2', & + grid_loc ='2110', & + d2d_array =PGUESS) + + if (sfc_layer_type == sfc_layer_varthick) then + FW_OLDd = construct_io_field('FW_OLD', dim1=i_dim, dim2=j_dim, & + long_name='fresh water input at old time', & + grid_loc ='2110', & + d2d_array = FW_OLD) + FW_FREEZEd = construct_io_field('FW_FREEZE', dim1=i_dim, dim2=j_dim, & + long_name='water flux due to frazil ice formation',& + grid_loc ='2110', & + d2d_array = FW_FREEZE) + endif + + if (liceform) then + if (lcoupled_ts) then + QFLUXd = construct_io_field('QFLUX', dim1=i_dim, dim2=j_dim, & + long_name='Internal Ocean Heat Flux Due to Ice Formation',& + grid_loc ='2110', & + d2d_array = QFLUX) + else + AQICEd = construct_io_field('AQICE', dim1=i_dim, dim2=j_dim, & + long_name='accumulated ice melt/heat', & + grid_loc ='2110', & + d2d_array = AQICE) + endif + endif + + UVEL_CUR = construct_io_field('UVEL_CUR', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='U velocity at current time', & + units ='cm/s', & + grid_loc ='3221', & + d3d_array = UVEL(:,:,:,curtime,:)) + + UVEL_OLD = construct_io_field('UVEL_OLD', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='U velocity at old time', & + units ='cm/s', & + grid_loc ='3221', & + d3d_array = UVEL(:,:,:,oldtime,:)) + + VVEL_CUR = construct_io_field('VVEL_CUR', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='V velocity at current time', & + units ='cm/s', & + grid_loc ='3221', & + d3d_array = VVEL(:,:,:,curtime,:)) + + VVEL_OLD = construct_io_field('VVEL_OLD', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='V velocity at old time', & + units ='cm/s', & + grid_loc ='3221', & + d3d_array = VVEL(:,:,:,oldtime,:)) + + do n=1,nt + short_name = char_blank + short_name = trim(tracer_d(n)%short_name)/& + &/'_CUR' + long_name = char_blank + long_name = trim(tracer_d(n)%long_name)/& + &/' at current time' + + TRACER_CUR(n) = construct_io_field(trim(short_name), & + dim1=i_dim, dim2=j_dim, dim3=k_dim, & + long_name=trim(long_name), & + units =trim(tracer_d(n)%units), & + grid_loc ='3111', & + d3d_array = TRACER(:,:,:,n,curtime,:)) + end do + + do n=1,nt + short_name = char_blank + short_name = trim(tracer_d(n)%short_name)/& + &/'_OLD' + long_name = char_blank + long_name = trim(tracer_d(n)%long_name)/& + &/' at old time' + + TRACER_OLD(n) = construct_io_field(trim(short_name), & + dim1=i_dim, dim2=j_dim, dim3=k_dim, & + long_name=trim(long_name), & + units =trim(tracer_d(n)%units), & + grid_loc ='3111', & + d3d_array = TRACER(:,:,:,n,oldtime,:)) + end do + +!----------------------------------------------------------------------- +! +! define all fields to be read +! +!----------------------------------------------------------------------- + + !*** must call in this order for back compatibility + + call data_set (restart_file, 'define', UBTROP_CUR) + call data_set (restart_file, 'define', UBTROP_OLD) + call data_set (restart_file, 'define', VBTROP_CUR) + call data_set (restart_file, 'define', VBTROP_OLD) + call data_set (restart_file, 'define', PSURF_CUR) + call data_set (restart_file, 'define', PSURF_OLD) + call data_set (restart_file, 'define', GRADPX_CUR) + call data_set (restart_file, 'define', GRADPX_OLD) + call data_set (restart_file, 'define', GRADPY_CUR) + call data_set (restart_file, 'define', GRADPY_OLD) + call data_set (restart_file, 'define', PGUESSd) + + if (sfc_layer_type == sfc_layer_varthick) then + call data_set (restart_file, 'define', FW_OLDd) + call data_set (restart_file, 'define', FW_FREEZEd) + endif + if (liceform) then + if (lcoupled_ts) then + call data_set (restart_file, 'define', QFLUXd) + else + call data_set (restart_file, 'define', AQICEd) + endif + endif + + call data_set (restart_file, 'define', UVEL_CUR) + call data_set (restart_file, 'define', UVEL_OLD) + call data_set (restart_file, 'define', VVEL_CUR) + call data_set (restart_file, 'define', VVEL_OLD) + + do n=1,nt + call data_set (restart_file, 'define', TRACER_CUR(n)) + call data_set (restart_file, 'define', TRACER_OLD(n)) + end do + + if (nt > 2) call write_restart_passive_tracers(restart_file,'define') + +!----------------------------------------------------------------------- +! +! now we actually write each field +! +!----------------------------------------------------------------------- + + call data_set (restart_file, 'write', UBTROP_CUR) + call data_set (restart_file, 'write', UBTROP_OLD) + call data_set (restart_file, 'write', VBTROP_CUR) + call data_set (restart_file, 'write', VBTROP_OLD) + call data_set (restart_file, 'write', PSURF_CUR) + call data_set (restart_file, 'write', PSURF_OLD) + call data_set (restart_file, 'write', GRADPX_CUR) + call data_set (restart_file, 'write', GRADPX_OLD) + call data_set (restart_file, 'write', GRADPY_CUR) + call data_set (restart_file, 'write', GRADPY_OLD) + call data_set (restart_file, 'write', PGUESSd) + + if (sfc_layer_type == sfc_layer_varthick) then + call data_set (restart_file, 'write', FW_OLDd) + call data_set (restart_file, 'write', FW_FREEZEd) + endif + if (liceform) then + if (lcoupled_ts) then + call data_set (restart_file, 'write', QFLUXd) + else + call data_set (restart_file, 'write', AQICEd) + endif + endif + + call data_set (restart_file, 'write', UVEL_CUR) + call data_set (restart_file, 'write', UVEL_OLD) + call data_set (restart_file, 'write', VVEL_CUR) + call data_set (restart_file, 'write', VVEL_OLD) + do n=1,nt + call data_set (restart_file, 'write', TRACER_CUR(n)) + call data_set (restart_file, 'write', TRACER_OLD(n)) + end do + + if (nt > 2) call write_restart_passive_tracers(restart_file,'write') + +!----------------------------------------------------------------------- +! +! close and destroy file +! +!----------------------------------------------------------------------- + + call data_set (restart_file, 'close') + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,*) ' restart file written: ', trim(write_restart_filename) + endif + + call destroy_file(restart_file) + +!----------------------------------------------------------------------- +! +! if pointer files are used, write filename to pointer file +! +!----------------------------------------------------------------------- + + if (luse_pointer_files) then + call get_unit(nu) + if (my_task == master_task) then + restart_pointer_file = trim(pointer_filename)/& + &/'.restart' + + open(nu, file=restart_pointer_file, form='formatted', & + status='unknown') + write(nu,'(a)') trim(write_restart_filename) + write(nu,'(a,a)') 'RESTART_FMT=',trim(restart_fmt) + close(nu) + write(stdout,blank_fmt) + write(stdout,*) ' restart pointer file written: ',trim(restart_pointer_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + call release_unit(nu) + endif + + +!----------------------------------------------------------------------- +! +! finished writing file +! +!----------------------------------------------------------------------- + + endif ! lrestart_write + +!----------------------------------------------------------------------- +!EOC + + end subroutine write_restart + + +!*********************************************************************** +!BOP +! !IROUTINE: init_restart +! !INTERFACE: + + subroutine init_restart + +! !DESCRIPTION: +! Initializes quantities associated with writing all the data +! necessary for restarting a simulation. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables and input namelist +! +!----------------------------------------------------------------------- + + integer (POP_i4) :: & + n, &! tracer loop index + nml_error ! namelist i/o error flag + + character (POP_charLength) :: & + restart_freq_opt, &! input option for freq of restart dumps + restart_start_opt ! choice for starting regular restart writes + + character (POP_charLength), parameter :: & + start_fmt = "('regular restart writes will start at ',a,i8)" + + namelist /restart_nml/ restart_freq_opt, restart_freq, & + restart_outfile, restart_fmt, & + leven_odd_on, even_odd_freq, & + pressure_correction, & + restart_start_opt, restart_start + +!----------------------------------------------------------------------- +! +! register init_restart +! +!----------------------------------------------------------------------- + call register_string('init_restart') + +!----------------------------------------------------------------------- +! +! read namelist input and broadcast variables +! +!----------------------------------------------------------------------- + + restart_outfile = 'd' + restart_fmt = 'bin' + restart_freq_iopt = freq_opt_never + restart_start_iopt= start_opt_nstep + restart_start = 0 + restart_freq = 100000 + leven_odd_on = .false. + even_odd_freq = 100000 + pressure_correction = .false. + + if (my_task == master_task) then + open (nml_in, file=nml_filename, status='old',iostat=nml_error) + if (nml_error /= 0) then + nml_error = -1 + else + nml_error = 1 + endif + do while (nml_error > 0) + read(nml_in, nml=restart_nml,iostat=nml_error) + end do + if (nml_error == 0) close(nml_in) + endif + + call broadcast_scalar(nml_error, master_task) + if (nml_error /= 0) then + exit_string = 'FATAL ERROR: reading restart_nml' + call document ('init_restart', exit_string) + call exit_POP (sigAbort, exit_string, out_unit=stdout) + endif + + if (my_task == master_task) then + select case (restart_freq_opt) + case ('never') + restart_freq_iopt = freq_opt_never + case ('nyear') + restart_freq_iopt = freq_opt_nyear + case ('nmonth') + restart_freq_iopt = freq_opt_nmonth + case ('nday') + restart_freq_iopt = freq_opt_nday + case ('nhour') + restart_freq_iopt = freq_opt_nhour + case ('nsecond') + restart_freq_iopt = freq_opt_nsecond + case ('nstep') + restart_freq_iopt = freq_opt_nstep + case default + restart_freq_iopt = -1000 + end select + + if (restart_freq_iopt /= freq_opt_never) then + select case (restart_start_opt) + case ('nstep') + restart_start_iopt = start_opt_nstep + write(stdout,start_fmt) 'step ', restart_start + case ('nday') + restart_start_iopt = start_opt_nday + write(stdout,start_fmt) 'day ', restart_start + case ('nyear') + restart_start_iopt = start_opt_nyear + write(stdout,start_fmt) 'year ', restart_start + case ('date') + restart_start_iopt = start_opt_date + write(stdout,start_fmt) ' ', restart_start + case default + restart_start_iopt = -1000 + end select + endif + + endif + + call broadcast_scalar (restart_outfile, master_task) + call broadcast_scalar (restart_freq_iopt, master_task) + call broadcast_scalar (restart_freq, master_task) + call broadcast_scalar (restart_start_iopt, master_task) + call broadcast_scalar (restart_start, master_task) + call broadcast_scalar (restart_fmt, master_task) + call broadcast_scalar (leven_odd_on, master_task) + call broadcast_scalar (even_odd_freq, master_task) + call broadcast_scalar (pressure_correction, master_task) + + if (restart_freq_iopt == -1000) then + exit_string = 'FATAL ERROR: unknown restart frequency option' + call document ('init_restart', exit_string) + call exit_POP (sigAbort, exit_string, out_unit=stdout) + else if (restart_start_iopt == -1000) then + exit_string = 'FATAL ERROR: unknown restart start option' + call document ('init_restart', exit_string) + call exit_POP (sigAbort, exit_string, out_unit=stdout) + else if (restart_freq_iopt == freq_opt_never) then + lrestart_on = .false. + else + lrestart_on = .true. + endif + +!----------------------------------------------------------------------- +! +! create some time flags +! +!----------------------------------------------------------------------- + + call init_time_flag('restart',restart_flag, default=.false., & + owner = 'init_restart', & + freq_opt = restart_freq_iopt, & + freq = restart_freq) + + if (leven_odd_on) then + last_even_odd = even + call init_time_flag('evenodd', evenodd_flag, default=.false., & + owner = 'init_restart', & + freq_opt = freq_opt_nstep, & + freq = even_odd_freq) + else + call init_time_flag('evenodd',evenodd_flag, default=.false., & + owner = 'init_restart', & + freq_opt = freq_opt_never, & + freq = even_odd_freq) + endif + +!----------------------------------------------------------------------- +! +! get handle for time flags defined in other modules +! +!----------------------------------------------------------------------- + + call access_time_flag('cpl_write_restart',cpl_write_restart) + call access_time_flag('coupled_ts',restart_cpl_ts) + call access_time_flag('stop_now',out_stop_now) + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_restart + +!*********************************************************************** +!BOP +! !IROUTINE: create_restart_suffix +! !INTERFACE: + + subroutine create_restart_suffix(file_suffix, restart_type) + +! !DESCRIPTION: +! Determines suffix to append to restart files based on restart type. +! +! !REVISION HISTORY: +! same as module + +! !INPUT PARAMETERS: + + character (*), intent(in) :: & + restart_type ! type of restart file to be written + ! (restart,even,odd,end) + +! !OUTPUT PARAMETERS: + + character (POP_charLength), intent(out) :: & + file_suffix ! suffix to append to root filename + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variable +! +!----------------------------------------------------------------------- + + integer (POP_i4) :: & + cindx, cindx2, &! indices into character strings + len_date ! length of date string + + character (POP_charLength) :: & + char_temp ! temp character space + + character (10) :: & + cdate ! date string + +!----------------------------------------------------------------------- +! +! clear character strings +! +!----------------------------------------------------------------------- + + file_suffix = char_blank + char_temp = char_blank + +!----------------------------------------------------------------------- +! +! for even, odd, or end, simply add the appropriate string +! +!----------------------------------------------------------------------- + + select case (trim(restart_type)) + case('end') + file_suffix = trim(runid)/& + &/'.end' + case('even') + file_suffix = trim(runid)/& + &/'.even' + case('odd') + file_suffix = trim(runid)/& + &/'.odd' + +!----------------------------------------------------------------------- +! +! for a regular restart file, append a date/time string +! +!----------------------------------------------------------------------- + + case('restart') + + if (date_separator == ' ') then + len_date = 8 + cdate(1:4) = cyear + cdate(5:6) = cmonth + cdate(7:8) = cday + cdate(9:10)= ' ' + else + len_date = 10 + cdate(1:4) = cyear + cdate(5:5) = date_separator + cdate(6:7) = cmonth + cdate(8:8) = date_separator + cdate(9:10) = cday + endif + + select case (restart_freq_iopt) + case (freq_opt_nyear, freq_opt_nmonth, freq_opt_nday) + + !*** append the date after the runid + + file_suffix = trim(runid)/& + &/'.'/& + &/trim(cdate) + + case (freq_opt_nhour) + + !*** append the date to runid and add hour + + write(file_suffix,'(i2)') ihour + char_temp = adjustl(file_suffix) + + file_suffix = trim(runid)/& + &/'.'/& + &/trim(cdate)/& + &/'.h'/& + &/trim(char_temp) + + case (freq_opt_nsecond) + + !*** append the date to runid and the elapsed seconds in day + + write (file_suffix,'(i6)') isecond + char_temp = adjustl(file_suffix) + + file_suffix = trim(runid)/& + &/'.'/& + &/trim(cdate)/& + &/'.s'/& + &/trim(char_temp) + + case (freq_opt_nstep) + + !*** append the step number + + write (file_suffix,'(i10)') nsteps_total + char_temp = adjustl(file_suffix) + + file_suffix = trim(runid)/& + &/'.'/& + &/trim(char_temp) + + case default + file_suffix = trim(runid) + end select + + end select + +!----------------------------------------------------------------------- +!EOC + + end subroutine create_restart_suffix +!*********************************************************************** + +!BOP +! !IROUTINE: create_restart_suffix_ccsm +! !INTERFACE: + + subroutine create_restart_suffix_ccsm(file_suffix, restart_type,in_freq_opt) + +! !DESCRIPTION: +! Determines suffix to append to CCSM restart files based on restart type. +! +! !REVISION HISTORY: +! same as module + +! !INPUT PARAMETERS: + + character (*), intent(in) :: & + restart_type ! type of restart file to be written + ! (restart,even,odd,end) + integer (POP_i4), intent(in) :: & + in_freq_opt ! type of ccsm date string + ! (annual, monthly, daily, or instantaneous) + +! !OUTPUT PARAMETERS: + + character (POP_charLength), intent(out) :: & + file_suffix ! suffix to append to root filename + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variable +! +!----------------------------------------------------------------------- + + integer (POP_i4) :: & + cindx, cindx2, &! indices into character strings + len_date ! length of date string + + character (POP_charLength) :: & + char_temp, &! temp character space + ccsm_date_string + + character (10) :: & + cdate ! date string + +!----------------------------------------------------------------------- +! +! clear character strings +! +!----------------------------------------------------------------------- + + file_suffix = char_blank + char_temp = char_blank + +!----------------------------------------------------------------------- +! +! for even, odd, or end, simply add the appropriate string +! +!----------------------------------------------------------------------- + + select case (trim(restart_type)) + case('end') + file_suffix = trim(runid)/& + &/'.end' + case('even') + file_suffix = trim(runid)/& + &/'.even' + case('odd') + file_suffix = trim(runid)/& + &/'.odd' + +!----------------------------------------------------------------------- +! +! for a regular restart file, append a date/time string +! +!----------------------------------------------------------------------- + + case('restart') + + char_temp = char_blank + file_suffix = char_blank + + select case (in_freq_opt) + case (freq_opt_nyear) + char_temp = 'y' + + case (freq_opt_nmonth) + char_temp = 'ym' + + case (freq_opt_nday) + char_temp = 'ymd' + + case (freq_opt_nhour) + char_temp = 'ymds' + + case (freq_opt_nsecond) + char_temp = 'ymds' + + case (freq_opt_nstep) + char_temp = 'ymds' + + case default + char_temp = 'ymds' + end select + + + call ccsm_date_stamp (ccsm_date_string, char_temp) + + file_suffix = trim(ccsm_date_string) + + end select + + +!----------------------------------------------------------------------- +! +! for a restart file in netCDF format, append the suffix '.nc' +! +!----------------------------------------------------------------------- + + select case (trim(restart_fmt)) + case('nc') + file_suffix = trim(file_suffix)/& + &/'.'/& + &/'nc' + end select + +!----------------------------------------------------------------------- +!EOC + + end subroutine create_restart_suffix_ccsm + + + +!*********************************************************************** + + end module restart + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/models/clm/DART_SourceMods/cesm1_1_1/clm.buildnml.csh b/models/clm/DART_SourceMods/cesm1_1_1/clm.buildnml.csh new file mode 100755 index 0000000000..2e7ff9ee4b --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/clm.buildnml.csh @@ -0,0 +1,109 @@ +#! /bin/csh -f + +if !(-d $CASEBUILD/clmconf) mkdir -p $CASEBUILD/clmconf + +#-------------------------------------------------------------------- +# Invoke clm configure - output will go in CASEBUILD/clmconf +#-------------------------------------------------------------------- + +set config_opts=" " +if ($LND_GRID == "reg" && $GRID != "CLM_USRDAT" ) then + set config_opts=" -sitespf_pt $GRID" +endif +if ("$CCSM_COMPSET" =~ P* || "$CCSM_COMPSET" =~ R* ) then + set config_opts=" -sitespf_pt $LND_GRID" +endif + +cd $CASEBUILD/clmconf +$CODEROOT/lnd/clm/bld/configure $config_opts -comp_intf $COMP_INTERFACE \ + $CLM_CONFIG_OPTS -usr_src $CASEROOT/SourceMods/src.clm || exit -1 + +#-------------------------------------------------------------------- +# Create clm.buildnml.csh +#-------------------------------------------------------------------- + +if ($RUN_TYPE == startup ) then + if ($CLM_FORCE_COLDSTART == on) then + set START_TYPE = "cold" + else + set START_TYPE = "default" + endif +else + if ($RUN_TYPE == hybrid ) then + set START_TYPE = "startup" + else + set START_TYPE = $RUN_TYPE + endif +endif + +set RESOLUTION = $LND_GRID +set clmusr = "" +if ($LND_GRID == reg ) then + if ( $GRID == CLM_USRDAT ) then + set RESOLUTION = $CLM_USRDAT_NAME + set clmusr = " -clm_usr_name $CLM_USRDAT_NAME" + else + set RESOLUTION = $GRID + endif +endif + +set default_lnd_in_filename = "lnd_in" + +set inst_counter = 1 +while ($inst_counter <= $NINST_LND) + +if ($NINST_LND > 1) then + set inst_string = $inst_counter + if ($inst_counter <= 999) set inst_string = "0$inst_string" + if ($inst_counter <= 99) set inst_string = "0$inst_string" + if ($inst_counter <= 9) set inst_string = "0$inst_string" + set inst_string = "_${inst_string}" +else + set inst_string = "" +endif +set lnd_in_filename = ${default_lnd_in_filename}${inst_string} + +setenv INST_STRING $inst_string + +cd $CASEBUILD/clmconf + +if (-e $CASEBUILD/clm.input_data_list) rm $CASEBUILD/clm.input_data_list + +if (-e $CASEROOT/user_nl_clm${inst_string}) then + $UTILROOT/Tools/user_nlcreate -user_nl_file $CASEROOT/user_nl_clm${inst_string} \ + -namelist_name clm_inparm >! $CASEBUILD/clmconf/cesm_namelist || exit -2 +endif + +set glc_opts = "" +if ("$COMP_GLC" != "sglc" )then + set glc_opts = "-glc_grid $GLC_GRID -glc_smb .$GLC_SMB. " +endif + +set usecase = " " +if ($CLM_NML_USE_CASE != "UNSET") set usecase = "-use_case $CLM_NML_USE_CASE" + +set clm_startfile = " " +if ( $RUN_TYPE == "hybrid" || $RUN_TYPE == "branch" ) then + set clm_startfile = "-clm_startfile ${RUN_REFCASE}.clm2${inst_string}.r.${RUN_REFDATE}-${RUN_REFTOD}.nc" +endif + +$CODEROOT/lnd/clm/bld/build-namelist -infile $CASEBUILD/clmconf/cesm_namelist \ + -csmdata $DIN_LOC_ROOT \ + -inputdata $CASEBUILD/clm.input_data_list \ + -namelist "&clm_inparm $CLM_NAMELIST_OPTS /" $usecase $glc_opts \ + -res $RESOLUTION $clmusr -clm_start_type $START_TYPE $clm_startfile \ + -l_ncpl $LND_NCPL -lnd_frac "${LND_DOMAIN_PATH}/${LND_DOMAIN_FILE}" \ + -glc_nec $GLC_NEC -co2_ppmv $CCSM_CO2_PPMV -co2_type $CLM_CO2_TYPE \ + -config $CASEBUILD/clmconf/config_cache.xml $CLM_BLDNML_OPTS || exit -3 + +if (-d ${RUNDIR}) then + cp $CASEBUILD/clmconf/lnd_in ${RUNDIR}/$lnd_in_filename || exit -2 + # Only copy drv_flds_in namelist file if one doesn't already exist + if ( ! -f "${RUNDIR}/drv_flds_in" ) cp $CASEBUILD/clmconf/drv_flds_in ${RUNDIR}/. >& /dev/null +endif + +@ inst_counter = $inst_counter + 1 + +end + + diff --git a/models/clm/DART_SourceMods/cesm1_1_1/lt_archive.sh b/models/clm/DART_SourceMods/cesm1_1_1/lt_archive.sh new file mode 100755 index 0000000000..4e9c1fea56 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/lt_archive.sh @@ -0,0 +1,281 @@ +#!/bin/bash + +# DART note: this file started life as: +# /glade/p/cesmdata/cseg/collections/cesm1_1/scripts/ccsm_utils/Tools/lt_archive.sh + +msls () { + + rd=$1 + ssh_loc=$2 + scp_loc=$3 + if [ "${ssh_loc}" != "" ] && [ "${scp_loc}" != "" ]; then + ssh -q ${ssh_loc} "ssh -q ${scp_loc} ls -l ${rd}" + return ?$ + fi +} + +msmkdir () { + + rd=$1 + ssh_loc=$2 + scp_loc=$3 + if [ `which hsi | wc -w` == 1 ]; then + echo "msmkdir: hsi 'mkdir -p ${rd}'" + hsi -q "mkdir -p ${rd}" + if [ $? -eq 0 ]; then + return 0 + else + echo "mksmkdir: error" + return $? + fi + else + echo "msmkdir: ssh -q ${ssh_loc} ssh -q ${scp_loc} mkdir -p ${rd} ": + ssh -q ${ssh_loc} "ssh -q ${scp_loc} mkdir -p ${rd}" + sleep 10 + return 0 + fi +} + +msfsize() { + # function to get the size of a file + # from its long listing + if [ $# -lt 5 ]; then + echo "0" + else + echo $5 + fi +} + +msget () { + + #------------------------------------------------------------------ + # Copy files from the local mass store + # "Usage msget mssdir/file2 locdir/file1" + # rdf = remote dir/filename ldf = local dir/filename + # rd = remote dir rf = remote filename + # ld = local dir lf = local filename + # Split inputs into r(remote) and l(local) d(directories) and f(files) + # If the local filename is empty, set it to the remote filename + # If the local filename doesn't exist, exit + #------------------------------------------------------------------ + rdf=$1; rd=`dirname ${rdf}`; rf=`basename ${rdf}` + ldf=$2; ld=`dirname ${ldf}`; lf=`basename ${ldf}` + if [ "${lf}" == '' ]; then + lf=${rf} + fi + if [ `which hsi | wc -w` == 1 ]; then + hsi -q "cd ${rd} ; get ${ldf} : ${rf}" >& /dev/null + return $? + fi +} + +mscpdir () { + #------------------------------------------------------------------ + # Copy entire directory to the local mass store + #------------------------------------------------------------------ + + ldr=$1 + rdr=$2 + ssh_loc=$3 + scp_loc=$4 + + # ssh/scp to ssh_loc by first ssh to ssh_loc. + myld=`pwd` + echo "mscpdir: ssh -q ${ssh_loc} scp -r -q ${ldr} ${scp_loc}:${rdr}" + ssh -q ${ssh_loc} "scp -r -q ${ldr} ${scp_loc}:${rdr}" + sleep 10 + + return 0 +} + +msput() { + + #------------------------------------------------------------------ + # Copy files to the local mass store + # rdf = remote dir/filename # ldf = local dir/filename + # rd = remote dir # rf = remote filename + # ld = local dir # lf = local filename + # Split inputs into r(remote) and l(local) d(directories) and f(files) + # If the remote file is empty, set it to the local filename + # Then execute site dependent mass store write + #------------------------------------------------------------------ + + ldf=$1; ld=`dirname ${ldf}`; lf=`basename ${ldf}` + rdf=$2; rd=`dirname ${rdf}`; rf=`basename ${rdf}` + ssh_loc=$3 + scp_loc=$4 + if [ "${rf}" == "" ]; then + rf=$lf + fi + if [ `which hsi | wc -w` == 1 ]; then + opts=" " + if ! [[ "$DOUT_L_HPSS_ACCNT" =~ "0000*" ]]; then + opts=" -a ${DOUT_L_HPSS_ACCNT} " + fi + # note that the -d flag will delete the local copy + echo "msput: hsi ${opts} 'cd ${rd} ; put -d ${ldf} : ${rf}'" + hsi ${opts} -q "cd ${rd} ; put -d ${ldf} : ${rf} ; chmod +r ${rf}" + return $? + fi + if [ "${ssh_loc}" != "" ] && [ "${scp_loc}" != "" ]; then + ssh -q ${ssh_loc} "scp -q ${ldf} ${scp_loc}:${rdf}" + sleep 5 + fi +} + +#*********************************************************************** +# Long term archiving functionality +#*********************************************************************** + +# Assume that have access to the following environment variables +# $DOUT_S_ROOT, $DOUT_L_MSROOT, $DOUT_L_HPSS_ACCNT +# Above name for $MACH is there just for brief backwards compatibility + +mode="unknown" +ssh_loc="unknown" +scp_loc="unknown" + +while [ $# -gt 0 ]; do + case $1 in + -m|--mode ) + mode=$2 + echo " mode is $2" + shift + ;; + --ssh_loc ) + ssh_loc=$2 + shift + ;; + --scp_loc ) + scp_loc=$2 + shift + ;; + * ) + esac + shift +done + +found=0 +for name in copy_files copy_dirs_hsi copy_dirs_sshscp ; do + if [ "$name" == "$mode" ] ; then + found=1 + break + fi +done +if [ $found -ne 1 ] ; then + echo "$current value of mode $model not supported" + exit 1 +fi + +#---------------------------------------------------------------------- + +if [ "$mode" == "copy_dirs_hsi" ]; then + + if_hsi=`which hsi | wc -w` + if [ $if_hsi != 1 ] ; then + echo "lt_archive: asked for copy_dirs_hsi - but hsi not found" + echo "lt_archive: check path" + exit -1 + fi + + # Long-term archiver for HPSS (Trey White, December 6, 2011) + date + + if [ ! $?DOUT_L_HPSS_ACCNT ]; then + DOUT_L_HPSS_ACCNT=0 + fi + + # send files to HPSS and delete upon success + + cd $DOUT_S_ROOT + if [ $DOUT_L_HPSS_ACCNT -gt 0 ]; then + hsi -a $DOUT_L_HPSS_ACCNT "mkdir -p $DOUT_L_MSROOT ; chmod +t $DOUT_L_MSROOT ; cd $DOUT_L_MSROOT ; put -dPR *" + else + hsi "mkdir -p $DOUT_L_MSROOT ; chmod +t $DOUT_L_MSROOT ; cd $DOUT_L_MSROOT ; put -dPR *" + fi + + date +fi + +#---------------------------------------------------------------------- + +if [ "$mode" == "copy_files" ]; then + + #------------------------------------------------------------------ + # Copy files and dir structure from short term archiving + # Assume there are up to two levels of dirs below $DOUT_S_ROOT + # $DOUT_S_ROOT/$dirl1/$dirl2 + # dirl1 => normallly [atm,lnd,ocn,ice,cpl,glc,rof,rest] + # dirl2 => normally [init,hist,logs,date(for rest)] + #------------------------------------------------------------------ + cd $DOUT_S_ROOT + msmkdir $DOUT_L_MSROOT + for dirl1 in */ ; do + cd ${DOUT_S_ROOT}/${dirl1} + msmkdir ${DOUT_L_MSROOT}/${dirl1} + for dirl2 in */ ; do + cd ${DOUT_S_ROOT}/${dirl1}/${dirl2} + msmkdir ${DOUT_L_MSROOT}/${dirl1}/${dirl2} + for file in * ; do + if [ -f ${file} ]; then + # first remove any local file with name checkmssfile + if [ -e checkmssfile ]; then + rm -f checkmssfile + fi + # try to copy file from mass store into local checkmssfile + msget ${DOUT_L_MSROOT}/${dirl1}/${dirl2}/${file} checkmssfile + # compare local file and remote file, either remove local file + # OR write local file to mass store based on cmp return status + cmp -s ${file} checkmssfile + if [ $? == 0 ]; then + echo "l_archive.sh rm ${file}" + rm -f $file + else + echo "l_archive.sh: msput ${file} ${DOUT_L_MSROOT}/${dirl1}/${dirl2}/${file}" + msput ${file} ${DOUT_L_MSROOT}/${dirl1}/${dirl2}/${file} + fi + fi + done # for file + done # for dirl2 + done # for dirl + +fi # if copy_files + +#---------------------------------------------------------------------- + +if [ "$mode" == "copy_dirs_sshscp" ]; then + + cd $DOUT_S_ROOT + + msmkdir ${DOUT_L_MSROOT} $ssh_loc $scp_loc + + for dirl1 in */ ; do + cd $DOUT_S_ROOT/${dirl1} + mscpdir ${DOUT_S_ROOT}/${dirl1} ${DOUT_L_MSROOT} $ssh_loc $scp_loc + for dirl2 in */ ; do + cd ${DOUT_S_ROOT}/${dirl1}/${dirl2} + for file in `ls -1`; do + if [ -f ${file} ]; then + echo "local file: $file ... long-term archive file: ${DOUT_L_MSROOT}/${dirl1}/${dirl2}/${file}" + lta_listing=`msls ${DOUT_L_MSROOT}/${dirl1}/${dirl2}/${file} $ssh_loc $scp_loc` + loc_listing=`ls -l ${file}` + lta_size=`msfsize $lta_listing` + loc_size=`msfsize $loc_listing` + if [ $loc_size -gt 0 ] && [ $loc_size -eq $lta_size ]; then + echo "local file and long-term archive file are same size" + echo rm -f ${file} + rm -f ${file} + else + echo "local file and long-term archive file are NOT the same size... ${file} will remain on local disk" + #exit -1 #??? ask francis if this is right + # Not sure what to do here... maybe make the log entry and carry on... + fi + fi + done # for file + done # for dirl2 + done # dirl1 + +fi # if copy_dirs + + + diff --git a/models/clm/DART_SourceMods/cesm1_1_1/preview_namelists b/models/clm/DART_SourceMods/cesm1_1_1/preview_namelists new file mode 100755 index 0000000000..9394ce3375 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/preview_namelists @@ -0,0 +1,74 @@ +#! /bin/csh -f + +source ./Tools/ccsm_getenv || exit -1 + +if !($?LID) then + setenv LID "`date +%y%m%d-%H%M%S`" +endif + +unsetenv PREVIEW_NML +if ($argv =~ *verbose*) then + setenv PREVIEW_NML 1 +endif + +# ------------------------------------------------------------------------- +# Make necessary directories +# ------------------------------------------------------------------------- + +foreach DIR ( $EXEROOT $LIBROOT $INCROOT $RUNDIR) + if !(-d $DIR) mkdir -p $DIR || "cannot make $DIR" && exit -1 +end + +foreach model ($MODELS) + set objdir = $EXEROOT/$model/obj ; if !(-d $objdir) mkdir -p $objdir + set libdir = $EXEROOT/$model ; if !(-d $libdir) mkdir -p $libdir +end + +# ------------------------------------------------------------------------- +# Build Namelist +# ------------------------------------------------------------------------- + +@ n = 0 +foreach model ($MODELS) + @ n = $n + 1 + set comp = $COMPONENTS[$n] + $CASEBUILD/$comp.buildnml.csh + if ($status != 0) then + echo ERROR: $comp.buildnml.csh failed; exit 99 + endif +end + +# ------------------------------------------------------------------------- +# Save namelist to docdir +# ------------------------------------------------------------------------- + +set docdir = $CASEROOT/CaseDocs +if !(-d $docdir) then + mkdir -p $docdir + echo " CESM Resolved Namelist Files" >& $docdir/README + echo " For documentation only" >>& $docdir/README + echo " DO NOT MODIFY" >>& $docdir/README +endif +chmod +w $docdir/* + +cd $RUNDIR +if ($MP_INSTANCES > 0) then + cp -p *_in_[0-9]* $docdir/ >& /dev/null + cp -p *modelio*nml_[0-9]* $docdir/ >& /dev/null +else + cp -p *_in $docdir/ >& /dev/null + cp -p *modelio*nml $docdir/ >& /dev/null +endif +cp -p *streams*txt* $docdir/ >& /dev/null +cp -p *.stxt $docdir/ >& /dev/null +cp -p *maps.rc $docdir/ >& /dev/null +cp -p cism.config* $docdir/ >& /dev/null + +# copy over chemistry mechanism docs if they exist +cp $CASEBUILD/camconf/chem_mech.* $docdir/ >& /dev/null + +chmod 444 $docdir/* + + + + diff --git a/models/clm/DART_SourceMods/cesm1_1_1/rtm.buildnml.csh b/models/clm/DART_SourceMods/cesm1_1_1/rtm.buildnml.csh new file mode 100755 index 0000000000..94510a37d5 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_1_1/rtm.buildnml.csh @@ -0,0 +1,86 @@ +#! /bin/csh -f + +if !(-d $CASEBUILD/rtmconf) mkdir -p $CASEBUILD/rtmconf + +set default_rof_in_filename = "rof_in" + +set inst_counter = 1 +while ($inst_counter <= $NINST_ROF) + +if ($NINST_ROF > 1) then + set inst_string = $inst_counter + if ($inst_counter <= 999) set inst_string = "0$inst_string" + if ($inst_counter <= 99) set inst_string = "0$inst_string" + if ($inst_counter <= 9) set inst_string = "0$inst_string" + set inst_string = "_${inst_string}" +else + set inst_string = "" +endif +set rof_in_filename = ${default_rof_in_filename}${inst_string} + +setenv INST_STRING $inst_string + +cd $CASEBUILD/rtmconf + +if (-e $CASEBUILD/rtm.input_data_list) rm $CASEBUILD/rtm.input_data_list + +set lnd_grid = $LND_GRID + +set rof_grid = $ROF_GRID +if ("$PTS_MODE" == TRUE ) set rof_grid = "null" +if ("$CCSM_COMPSET" =~ P* || "$CCSM_COMPSET" =~ R* ) set rof_grid = "null" + +# The following is for backwards compatibility when runoff restart data was on clm restart files +set finidat_rtm = "" +if ($RUN_TYPE == 'hybrid') then + set finidat_rtm = "finidat_rtm ='${RUN_REFCASE}.rtm${inst_string}.r.${RUN_REFDATE}-${RUN_REFTOD}.nc'" + if ($GET_REFCASE == 'TRUE') then + set refdir = "ccsm4_init/$RUN_REFCASE/$RUN_REFDATE" + ls $refdir/*rtm* >& /dev/null + if ( $status != 0 ) then + set finidat_rtm = "finidat_rtm ='${RUN_REFCASE}.clm2${inst_string}.r.${RUN_REFDATE}-${RUN_REFTOD}.nc'" + endif + endif +endif + +set nrevsn_rtm = "" +if ($RUN_TYPE == 'branch') then + set nrevsn_rtm = "nrevsn_rtm ='${RUN_REFCASE}.rtm${inst_string}.r.${RUN_REFDATE}-${RUN_REFTOD}.nc'" + if ($GET_REFCASE == 'TRUE') then + set refdir = "ccsm4_init/$RUN_REFCASE/$RUN_REFDATE" + ls $refdir/*rtm* >& /dev/null + if ( $status != 0 ) then + set nrevsn_rtm = "nrevsn_rtm ='${RUN_REFCASE}.clm2${inst_string}.r.${RUN_REFDATE}-${RUN_REFTOD}.nc'" + endif + endif +endif + +cat >! $CASEBUILD/rtmconf/cesm_namelist << EOF2 +&rtm_inparm + $finidat_rtm + $nrevsn_rtm +EOF2 +if (-e $CASEROOT/user_nl_rtm${inst_string}) then + $UTILROOT/Tools/user_nl_add -user_nl_file $CASEROOT/user_nl_rtm${inst_string} >> $CASEBUILD/rtmconf/cesm_namelist || exit -2 +endif +cat >> $CASEBUILD/rtmconf/cesm_namelist << EOF2 +/ +EOF2 + +cd $CASEBUILD/rtmconf +$CODEROOT/rof/rtm/bld/build-namelist \ + -infile $CASEBUILD/rtmconf/cesm_namelist \ + -caseroot $CASEROOT \ + -scriptsroot $SCRIPTSROOT \ + -inst_string "$inst_string" \ + -r_ncpl $ROF_NCPL -rtm_grid $rof_grid -lnd_grid $lnd_grid || exit -4 + +if (-d ${RUNDIR}) then + cp $CASEBUILD/rtmconf/rof_in ${RUNDIR}/$rof_in_filename || exit -2 +endif + +@ inst_counter = $inst_counter + 1 + +end + + diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/README b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/README new file mode 100644 index 0000000000..8e4ee8b477 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/README @@ -0,0 +1,4 @@ + + + +/glade/p/cesmdata/cseg/collections/cesm1_2_1/models/atm/cam/src/chemistry/mozart/mo_usrrxt.F90 diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/atm_comp_mct.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/atm_comp_mct.F90 new file mode 100644 index 0000000000..bc88dbd598 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/atm_comp_mct.F90 @@ -0,0 +1,1332 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_2_1/models/atm/cam/src/cpl_mct/atm_comp_mct.F90 +! +! This atm_comp_mod.F90 forces CAM to use initial conditions file while +! all other model components use restart files. This allows us to run +! CONTINUE_RUN = TRUE, but this also means we have to write out CAM restart +! files because we need to use the information CAM sends to the coupler to +! avoid lagging the ocean by a day. The time is also read from the coupler. +! -- TJH Tue Mar 4 13:57:49 MST 2014 + +module atm_comp_mct + + use pio , only: file_desc_t, io_desc_t, var_desc_t, pio_double, pio_def_dim, & + pio_put_att, pio_enddef, pio_initdecomp, pio_read_darray, pio_freedecomp, & + pio_closefile, pio_write_darray, pio_def_var, pio_inq_varid, & + pio_noerr, pio_bcast_error, pio_internal_error, pio_seterrorhandling + use mct_mod + use esmf + use seq_flds_mod + use seq_cdata_mod + use seq_infodata_mod + use seq_timemgr_mod + + use shr_kind_mod , only: r8 => shr_kind_r8, cl=>shr_kind_cl + use shr_file_mod , only: shr_file_getunit, shr_file_freeunit, & + shr_file_setLogUnit, shr_file_setLogLevel, & + shr_file_getLogUnit, shr_file_getLogLevel, & + shr_file_setIO + use shr_sys_mod , only: shr_sys_flush, shr_sys_abort + + use cam_cpl_indices + use cam_comp + use cam_instance , only: cam_instance_init, inst_suffix + use cam_control_mod , only: nsrest, adiabatic, ideal_phys, aqua_planet, eccen, obliqr, lambm0, mvelpp + use radiation , only: radiation_get, radiation_do, radiation_nextsw_cday + use phys_grid , only: get_ncols_p, get_gcol_all_p, & + ngcols, get_gcol_p, get_rlat_all_p, & + get_rlon_all_p, get_area_all_p + use ppgrid , only: pcols, begchunk, endchunk + use dyn_grid , only: get_horiz_grid_dim_d + use camsrfexch , only: cam_out_t, cam_in_t + use cam_restart , only: get_restcase, get_restartdir + use cam_history , only: outfld, ctitle + use abortutils , only: endrun + use filenames , only: interpret_filename_spec, caseid, brnch_retain_casename +#ifdef SPMD + use spmd_utils , only: spmdinit, masterproc, iam + use mpishorthand , only: mpicom +#else + use spmd_utils , only: spmdinit, masterproc, mpicom, iam +#endif + use time_manager , only: get_curr_calday, advance_timestep, get_curr_date, get_nstep, & + is_first_step, get_step_size, timemgr_init, timemgr_check_restart + use ioFileMod + use perf_mod + use cam_logfile , only: iulog + use co2_cycle , only: c_i, co2_readFlux_ocn, co2_readFlux_fuel, co2_transport, & + co2_time_interp_ocn, co2_time_interp_fuel, data_flux_ocn, data_flux_fuel + use physconst , only: mwco2 + use runtime_opts , only: read_namelist + use phys_control , only: cam_chempkg_is + use scamMod , only: single_column,scmlat,scmlon + +! +! !PUBLIC TYPES: + implicit none + save + private ! except + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: atm_init_mct + public :: atm_run_mct + public :: atm_final_mct + +!-------------------------------------------------------------------------- +! Private interfaces +!-------------------------------------------------------------------------- + + private :: atm_SetgsMap_mct + private :: atm_import_mct + private :: atm_export_mct + private :: atm_domain_mct + private :: atm_read_srfrest_mct + private :: atm_write_srfrest_mct + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + + type(cam_in_t) , pointer :: cam_in(:) + type(cam_out_t), pointer :: cam_out(:) + + type(mct_aVect) :: a2x_a_SNAP + type(mct_aVect) :: a2x_a_SUM + + integer, parameter :: nlen = 256 ! Length of character strings + character(len=nlen) :: fname_srf_cam ! surface restart filename + character(len=nlen) :: pname_srf_cam ! surface restart full pathname + + ! Filename specifier for restart surface file + character(len=cl) :: rsfilename_spec_cam +! +! Time averaged counter for flux fields +! + integer :: avg_count +! +! Time averaged flux fields +! + character(*), parameter :: a2x_avg_flds = "Faxa_rainc:Faxa_rainl:Faxa_snowc:Faxa_snowl" +! +! Are all surface types present +! + logical :: lnd_present ! if true => land is present + logical :: ocn_present ! if true => ocean is present + + logical :: dart_mode = .true. +! +!================================================================================ +CONTAINS +!================================================================================ + + subroutine atm_init_mct( EClock, cdata_a, x2a_a, a2x_a, NLFilename ) + + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(ESMF_Clock),intent(in) :: EClock + type(seq_cdata), intent(inout) :: cdata_a + type(mct_aVect), intent(inout) :: x2a_a + type(mct_aVect), intent(inout) :: a2x_a + character(len=*), optional, intent(IN) :: NLFilename ! Namelist filename + ! + ! Locals + ! + type(mct_gsMap), pointer :: gsMap_atm + type(mct_gGrid), pointer :: dom_a + type(seq_infodata_type),pointer :: infodata + integer :: ATMID + integer :: mpicom_atm + integer :: lsize + integer :: iradsw + logical :: exists ! true if file exists + real(r8):: nextsw_cday ! calendar of next atm shortwave + integer :: stepno ! time step + integer :: dtime_sync ! integer timestep size + integer :: currentymd ! current year-month-day + integer :: currenttod ! current time of day + integer :: dtime ! time step increment (sec) + integer :: atm_cpl_dt ! driver atm coupling time step + integer :: nstep ! CAM nstep + real(r8):: caldayp1 ! CAM calendar day for for next cam time step + integer :: dtime_cam ! Time-step increment (sec) + integer :: ymd ! CAM current date (YYYYMMDD) + integer :: yr ! CAM current year + integer :: mon ! CAM current month + integer :: day ! CAM current day + integer :: tod ! CAM current time of day (sec) + integer :: start_ymd ! Start date (YYYYMMDD) + integer :: start_tod ! Start time of day (sec) + integer :: ref_ymd ! Reference date (YYYYMMDD) + integer :: ref_tod ! Reference time of day (sec) + integer :: stop_ymd ! Stop date (YYYYMMDD) + integer :: stop_tod ! Stop time of day (sec) + logical :: perpetual_run ! If in perpetual mode or not + integer :: perpetual_ymd ! Perpetual date (YYYYMMDD) + integer :: shrlogunit,shrloglev ! old values + logical :: first_time = .true. + character(len=SHR_KIND_CS) :: calendar ! Calendar type + character(len=SHR_KIND_CS) :: starttype ! infodata start type + integer :: lbnum + integer :: hdim1_d, hdim2_d ! dimensions of rectangular horizontal grid + ! data structure, If 1D data structure, then + ! hdim2_d == 1. + character(len=64) :: filein ! Input namelist filename + !----------------------------------------------------------------------- + ! + ! Determine cdata points + ! +#if (defined _MEMTRACE) + if(masterproc) then + lbnum=1 + call memmon_dump_fort('memmon.out','atm_init_mct:start::',lbnum) + endif +#endif + call seq_cdata_setptrs(cdata_a, ID=ATMID, mpicom=mpicom_atm, & + gsMap=gsMap_atm, dom=dom_a, infodata=infodata) + + if (masterproc) write(iulog,*)'TJH atm_init_mct: first_time is ',first_time + + if (first_time) then + + call cam_instance_init(ATMID) + + ! Set filename specifier for restart surface file + ! (%c=caseid, $y=year, $m=month, $d=day, $s=seconds in day) + rsfilename_spec_cam = '%c.cam' // trim(inst_suffix) // '.rs.%y-%m-%d-%s.nc' + + ! Determine attribute vector indices + + call cam_cpl_indices_set() + + ! Redirect share output to cam log + + call spmdinit(mpicom_atm) + + if (masterproc) then + inquire(file='atm_modelio.nml'//trim(inst_suffix), exist=exists) + if (exists) then + iulog = shr_file_getUnit() + call shr_file_setIO('atm_modelio.nml'//trim(inst_suffix), iulog) + endif + write(iulog,*) "CAM atmosphere model initialization" + endif + + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (iulog) + ! + ! Consistency check + ! + if (co2_readFlux_ocn .and. index_x2a_Faoo_fco2_ocn /= 0) then + write(iulog,*)'error co2_readFlux_ocn and index_x2a_Faoo_fco2_ocn cannot both be active' + call shr_sys_abort() + end if + ! + ! Get data from infodata object + ! + call seq_infodata_GetData( infodata, & + case_name=caseid, case_desc=ctitle, & + start_type=starttype, & + atm_adiabatic=adiabatic, & + atm_ideal_phys=ideal_phys, & + aqua_planet=aqua_planet, & + brnch_retain_casename=brnch_retain_casename, & + single_column=single_column, scmlat=scmlat, scmlon=scmlon, & + orb_eccen=eccen, orb_mvelpp=mvelpp, orb_lambm0=lambm0, orb_obliqr=obliqr, & + lnd_present=lnd_present, ocn_present=ocn_present, & + perpetual=perpetual_run, perpetual_ymd=perpetual_ymd) + ! + ! Get nsrest from startup type methods + ! + + if (dart_mode) then + ! TJH : force the atm into an initial run while everyone else is a restart + ! TJH : This allows us to (potentially) use POP in the restart mode + ! TJH : huge step towards coupled assimilation with coupled models. + starttype = trim(seq_infodata_start_type_start) + end if + + if ( trim(starttype) == trim(seq_infodata_start_type_start)) then + nsrest = 0 + else if (trim(starttype) == trim(seq_infodata_start_type_cont) ) then + nsrest = 1 + else if (trim(starttype) == trim(seq_infodata_start_type_brnch)) then + nsrest = 3 + else + write(iulog,*) 'atm_comp_mct: ERROR: unknown starttype' + call shr_sys_abort() + end if + ! + ! Initialize time manager. + ! + call seq_timemgr_EClockGetData(EClock, & + start_ymd=start_ymd, start_tod=start_tod, & + ref_ymd=ref_ymd, ref_tod=ref_tod, & + stop_ymd=stop_ymd, stop_tod=stop_tod, & + curr_ymd=CurrentYMD, curr_tod=CurrentTOD, & + calendar=calendar ) + + ! In DART mode we allow the coupler to be running in a restart mode, + ! but force CAM into an initial mode. To do this CAM's start time must + ! be set to the current time from the driver's clock. + if (dart_mode) then + if (masterproc) write(iulog,*)'TJH timemgr ref ',ref_ymd, ref_tod + if (masterproc) write(iulog,*)'TJH timemgr start ',start_ymd, start_tod + start_ymd = CurrentYMD + start_tod = CurrentTOD + if (masterproc) write(iulog,*)'TJH reset to ',start_ymd, start_tod + end if + + ! + ! Read namelist + ! + filein = "atm_in" // trim(inst_suffix) + call read_namelist(single_column_in=single_column, scmlat_in=scmlat, & + scmlon_in=scmlon, nlfilename_in=filein) + ! + ! Initialize cam time manager + ! + if ( nsrest == 0 )then + call timemgr_init( calendar_in=calendar, start_ymd=start_ymd, & + start_tod=start_tod, ref_ymd=ref_ymd, & + ref_tod=ref_tod, stop_ymd=stop_ymd, & + stop_tod=stop_tod, & + perpetual_run=perpetual_run, & + perpetual_ymd=perpetual_ymd ) + end if + ! + ! First phase of cam initialization + ! Initialize mpicom_atm, allocate cam_in and cam_out and determine + ! atm decomposition (needed to initialize gsmap) + ! for an initial run, cam_in and cam_out are allocated in cam_initial + ! for a restart/branch run, cam_in and cam_out are allocated in restart + ! Set defaults then override with user-specified input and initialize time manager + ! Note that the following arguments are needed to cam_init for timemgr_restart only + ! + call cam_init( cam_out, cam_in, mpicom_atm, & + start_ymd, start_tod, ref_ymd, ref_tod, stop_ymd, stop_tod, & + perpetual_run, perpetual_ymd, calendar) + ! + ! Check consistency of restart time information with input clock + ! + if (nsrest /= 0) then + dtime_cam = get_step_size() + call timemgr_check_restart( calendar, start_ymd, start_tod, ref_ymd, & + ref_tod, dtime_cam, perpetual_run, perpetual_ymd) + end if + ! + ! Initialize MCT gsMap, domain and attribute vectors + ! + call atm_SetgsMap_mct( mpicom_atm, ATMID, gsMap_atm ) + lsize = mct_gsMap_lsize(gsMap_atm, mpicom_atm) + ! + ! Initialize MCT domain + ! + call atm_domain_mct( lsize, gsMap_atm, dom_a ) + ! + ! Initialize MCT attribute vectors + ! + call mct_aVect_init(a2x_a, rList=seq_flds_a2x_fields, lsize=lsize) + call mct_aVect_zero(a2x_a) + + call mct_aVect_init(x2a_a, rList=seq_flds_x2a_fields, lsize=lsize) + call mct_aVect_zero(x2a_a) + + call mct_aVect_init(a2x_a_SNAP, rList=a2x_avg_flds, lsize=lsize) + call mct_aVect_zero(a2x_a_SNAP) + + call mct_aVect_init(a2x_a_SUM , rList=a2x_avg_flds, lsize=lsize) + call mct_aVect_zero(a2x_a_SUM ) + ! + ! Initialize averaging counter + ! + avg_count = 0 + ! + ! Create initial atm export state + ! + call atm_export_mct( cam_out, a2x_a ) + ! + ! Set flag to specify that an extra albedo calculation is to be done (i.e. specify active) + ! + call seq_infodata_PutData(infodata, atm_prognostic=.true.) + call get_horiz_grid_dim_d(hdim1_d, hdim2_d) + call seq_infodata_PutData(infodata, atm_nx=hdim1_d, atm_ny=hdim2_d) + + ! Set flag to indicate that CAM will provide carbon and dust deposition fluxes. + ! This is now hardcoded to .true. since the ability of CICE to read these + ! fluxes from a file has been removed. + call seq_infodata_PutData(infodata, atm_aero=.true.) + + ! + ! Set time step of radiation computation as the current calday + ! This will only be used on the first timestep of an initial run + ! + if (nsrest == 0) then + nextsw_cday = get_curr_calday() + call seq_infodata_PutData( infodata, nextsw_cday=nextsw_cday ) + end if + + ! End redirection of share output to cam log + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + + first_time = .false. + + else + + ! For initial run, run cam radiation/clouds and return + ! For restart run, read restart x2a_a + ! Note - a2x_a is computed upon the completion of the previous run - cam_run1 is called + ! only for the purposes of finishing the flux averaged calculation to compute a2x_a + ! Note - cam_run1 is called on restart only to have cam internal state consistent with the + ! a2x_a state sent to the coupler + + ! Redirect share output to cam log + + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (iulog) + + call seq_timemgr_EClockGetData(EClock,curr_ymd=CurrentYMD, StepNo=StepNo, dtime=DTime_Sync ) + + if (masterproc) write(iulog,*)'TJH StepNo check. StepNo is ',StepNo + + if (StepNo == 0) then + call atm_import_mct( x2a_a, cam_in ) + call cam_run1 ( cam_in, cam_out ) + call atm_export_mct( cam_out, a2x_a ) + else + call atm_read_srfrest_mct( EClock, cdata_a, x2a_a, a2x_a ) + call atm_import_mct( x2a_a, cam_in ) + call cam_run1 ( cam_in, cam_out ) + end if + + ! Compute time of next radiation computation, like in run method for exact restart + +! tcx was +! nextsw_cday = radiation_nextsw_cday() + + call seq_timemgr_EClockGetData(Eclock,dtime=atm_cpl_dt) + dtime = get_step_size() + nstep = get_nstep() + if (nstep < 1 .or. dtime < atm_cpl_dt) then + nextsw_cday = radiation_nextsw_cday() + else if (dtime == atm_cpl_dt) then + caldayp1 = get_curr_calday(offset=int(dtime)) + nextsw_cday = radiation_nextsw_cday() + if (caldayp1 /= nextsw_cday) nextsw_cday = -1._r8 + else + call shr_sys_abort('dtime must be less than or equal to atm_cpl_dt') + end if + call seq_infodata_PutData( infodata, nextsw_cday=nextsw_cday ) + + ! End redirection of share output to cam log + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + + end if + +#if (defined _MEMTRACE ) + if(masterproc) then + lbnum=1 + call memmon_dump_fort('memmon.out','atm_init_mct:end::',lbnum) + call memmon_reset_addr() + endif +#endif + + call shr_sys_flush(iulog) + + end subroutine atm_init_mct + +!================================================================================ + + subroutine atm_run_mct( EClock, cdata_a, x2a_a, a2x_a) + + !----------------------------------------------------------------------- + ! + ! Uses + ! + use time_manager, only: advance_timestep, get_curr_date, get_curr_calday, & + get_nstep, get_step_size +! use iop, only: scam_use_iop_srf + use pmgrid, only: plev, plevp + use constituents, only: pcnst + use shr_sys_mod, only: shr_sys_flush + use chemistry, only: chem_reset_fluxes + use offline_driver, only: offline_driver_dorun, offline_driver_end_of_data + + ! + ! Arguments + ! + type(ESMF_Clock) ,intent(in) :: EClock + type(seq_cdata) ,intent(inout) :: cdata_a + type(mct_aVect) ,intent(inout) :: x2a_a + type(mct_aVect) ,intent(inout) :: a2x_a + ! + ! Local variables + ! + type(seq_infodata_type),pointer :: infodata + integer :: lsize ! size of attribute vector + integer :: StepNo ! time step + integer :: DTime_Sync ! integer timestep size + integer :: CurrentYMD ! current year-month-day + integer :: iradsw ! shortwave radation frequency (time steps) + logical :: dosend ! true => send data back to driver + integer :: dtime ! time step increment (sec) + integer :: atm_cpl_dt ! driver atm coupling time step + integer :: ymd_sync ! Sync date (YYYYMMDD) + integer :: yr_sync ! Sync current year + integer :: mon_sync ! Sync current month + integer :: day_sync ! Sync current day + integer :: tod_sync ! Sync current time of day (sec) + integer :: ymd ! CAM current date (YYYYMMDD) + integer :: yr ! CAM current year + integer :: mon ! CAM current month + integer :: day ! CAM current day + integer :: tod ! CAM current time of day (sec) + integer :: nstep ! CAM nstep + integer :: shrlogunit,shrloglev ! old values + real(r8):: caldayp1 ! CAM calendar day for for next cam time step + real(r8):: nextsw_cday ! calendar of next atm shortwave + logical :: rstwr ! .true. ==> write restart file before returning + logical :: nlend ! Flag signaling last time-step + logical :: rstwr_sync ! .true. ==> write restart file before returning + logical :: nlend_sync ! Flag signaling last time-step + logical :: first_time = .true. + character(len=*), parameter :: subname="atm_run_mct" + !----------------------------------------------------------------------- + integer :: lbnum + +#if (defined _MEMTRACE) + if(masterproc) then + lbnum=1 + call memmon_dump_fort('memmon.out',SubName //':start::',lbnum) + endif +#endif + + ! Redirect share output to cam log + + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (iulog) + + ! Note that sync clock time should match cam time at end of time step/loop not beginning + + call seq_cdata_setptrs(cdata_a, infodata=infodata) + call seq_timemgr_EClockGetData(EClock,curr_ymd=ymd_sync,curr_tod=tod_sync, & + curr_yr=yr_sync,curr_mon=mon_sync,curr_day=day_sync) + + !load orbital parameters + call seq_infodata_GetData( infodata, & + orb_eccen=eccen, orb_mvelpp=mvelpp, orb_lambm0=lambm0, orb_obliqr=obliqr) + + nlend_sync = seq_timemgr_StopAlarmIsOn(EClock) + rstwr_sync = seq_timemgr_RestartAlarmIsOn(EClock) + + ! Map input from mct to cam data structure + + call t_startf ('CAM_import') + call atm_import_mct( x2a_a, cam_in ) + call t_stopf ('CAM_import') + + ! Cycle over all time steps in the atm coupling interval + + dosend = .false. + do while (.not. dosend) + + ! (re)set surface fluxes of chem tracers here to MEGAN fluxes (from CLM) + ! or to zero so that fluxes read from file can be added to MEGAN + call chem_reset_fluxes( x2a_a%rAttr, cam_in ) + + ! Determine if dosend + ! When time is not updated at the beginning of the loop - then return only if + ! are in sync with clock before time is updated + + call get_curr_date( yr, mon, day, tod ) + ymd = yr*10000 + mon*100 + day + tod = tod + if( offline_driver_dorun ) then + dosend = offline_driver_end_of_data() + else + dosend = (seq_timemgr_EClockDateInSync( EClock, ymd, tod)) + endif + + ! Determine if time to write cam restart and stop + + rstwr = .false. + if (rstwr_sync .and. dosend) rstwr = .true. + nlend = .false. + if (nlend_sync .and. dosend) nlend = .true. + + ! Single column specific input + + if (single_column) then + call scam_use_iop_srf( cam_in ) + endif + + ! Run CAM (run2, run3, run4) + + call t_startf ('CAM_run2') + call cam_run2( cam_out, cam_in ) + call t_stopf ('CAM_run2') + + call t_startf ('CAM_run3') + call cam_run3( cam_out ) + call t_stopf ('CAM_run3') + + call t_startf ('CAM_run4') + call cam_run4( cam_out, cam_in, rstwr, nlend, & + yr_spec=yr_sync, mon_spec=mon_sync, day_spec=day_sync, sec_spec=tod_sync) + call t_stopf ('CAM_run4') + + ! Advance cam time step + if( .not.offline_driver_dorun ) then + call t_startf ('CAM_adv_timestep') + call advance_timestep() + call t_stopf ('CAM_adv_timestep') + endif + + ! Run cam radiation/clouds (run1) + + call t_startf ('CAM_run1') + call cam_run1 ( cam_in, cam_out ) + call t_stopf ('CAM_run1') + + ! Map output from cam to mct data structures + + call t_startf ('CAM_export') + call atm_export_mct( cam_out, a2x_a ) + call t_stopf ('CAM_export') + + ! Compute snapshot attribute vector for accumulation + +! don't accumulate on first coupling freq ts1 and ts2 +! for consistency with ccsm3 when flxave is off + nstep = get_nstep() + if (nstep <= 2) then + call mct_aVect_copy( a2x_a, a2x_a_SUM ) + avg_count = 1 + else + call mct_aVect_copy( a2x_a, a2x_a_SNAP ) + call mct_aVect_accum( aVin=a2x_a_SNAP, aVout=a2x_a_SUM ) + avg_count = avg_count + 1 + endif + + end do + + ! Finish accumulation of attribute vector and average and copy accumulation + ! field into output attribute vector + + call mct_aVect_avg ( a2x_a_SUM, avg_count) + call mct_aVect_copy( a2x_a_SUM, a2x_a ) + call mct_aVect_zero( a2x_a_SUM) + avg_count = 0 + + ! Get time of next radiation calculation - albedos will need to be + ! calculated by each surface model at this time + + call seq_timemgr_EClockGetData(Eclock,dtime=atm_cpl_dt) + dtime = get_step_size() + if (dtime < atm_cpl_dt) then + nextsw_cday = radiation_nextsw_cday() + else if (dtime == atm_cpl_dt) then + caldayp1 = get_curr_calday(offset=int(dtime)) + nextsw_cday = radiation_nextsw_cday() + if (caldayp1 /= nextsw_cday) nextsw_cday = -1._r8 + else + call shr_sys_abort('dtime must be less than or equal to atm_cpl_dt') + end if + call seq_infodata_PutData( infodata, nextsw_cday=nextsw_cday ) + + ! Write merged surface data restart file if appropriate + + if (rstwr_sync) then + call atm_write_srfrest_mct( cdata_a, x2a_a, a2x_a, & + yr_spec=yr_sync, mon_spec=mon_sync, day_spec=day_sync, sec_spec=tod_sync) + end if + + ! Check for consistency of internal cam clock with master sync clock + + dtime = get_step_size() + call get_curr_date( yr, mon, day, tod, offset=-dtime ) + ymd = yr*10000 + mon*100 + day + tod = tod + if ((.not.seq_timemgr_EClockDateInSync( EClock, ymd, tod )) .and. (.not.offline_driver_dorun))then + call seq_timemgr_EClockGetData(EClock, curr_ymd=ymd_sync, curr_tod=tod_sync ) + write(iulog,*)' cam ymd=',ymd ,' cam tod= ',tod + write(iulog,*)'sync ymd=',ymd_sync,' sync tod= ',tod_sync + call shr_sys_abort( subname//': CAM clock is not in sync with master Sync Clock' ) + end if + + ! End redirection of share output to cam log + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + +#if (defined _MEMTRACE) + if(masterproc) then + lbnum=1 + call memmon_dump_fort('memmon.out',SubName //':end::',lbnum) + call memmon_reset_addr() + endif +#endif + + end subroutine atm_run_mct + +!================================================================================ + + subroutine atm_final_mct( EClock, cdata_a, x2a_a, a2x_a) + type(ESMF_Clock) ,intent(in) :: EClock + type(seq_cdata) ,intent(inout) :: cdata_a + type(mct_aVect) ,intent(inout) :: x2a_a + type(mct_aVect) ,intent(inout) :: a2x_a + + call cam_final( cam_out, cam_in ) + + end subroutine atm_final_mct + +!================================================================================ + + subroutine atm_SetgsMap_mct( mpicom_atm, ATMID, GSMap_atm ) + use phys_grid, only : get_nlcols_p + !------------------------------------------------------------------- + ! + ! Arguments + ! + integer , intent(in) :: mpicom_atm + integer , intent(in) :: ATMID + type(mct_gsMap), intent(out) :: GSMap_atm + ! + ! Local variables + ! + integer, allocatable :: gindex(:) + integer :: i, n, c, ncols, sizebuf, nlcols + integer :: ier ! error status + !------------------------------------------------------------------- + + ! Build the atmosphere grid numbering for MCT + ! NOTE: Numbering scheme is: West to East and South to North + ! starting at south pole. Should be the same as what's used in SCRIP + + ! Determine global seg map + + sizebuf=0 + do c = begchunk, endchunk + ncols = get_ncols_p(c) + do i = 1,ncols + sizebuf = sizebuf+1 + end do + end do + + allocate(gindex(sizebuf)) + + n=0 + do c = begchunk, endchunk + ncols = get_ncols_p(c) + do i = 1,ncols + n=n+1 + gindex(n) = get_gcol_p(c,i) + end do + end do + + nlcols = get_nlcols_p() + call mct_gsMap_init( gsMap_atm, gindex, mpicom_atm, ATMID, nlcols, ngcols) + + deallocate(gindex) + + end subroutine atm_SetgsMap_mct + +!=============================================================================== + + subroutine atm_import_mct( x2a_a, cam_in ) + + !----------------------------------------------------------------------- + ! + ! Uses + ! + use dust_intr, only: dust_idx1 +#if (defined MODAL_AERO) + use mo_chem_utls, only: get_spc_ndx +#endif + use shr_const_mod, only: shr_const_stebol + use seq_drydep_mod,only: n_drydep + ! + ! Arguments + ! + type(mct_aVect), intent(inout) :: x2a_a + type(cam_in_t), intent(inout) :: cam_in(begchunk:endchunk) + ! + ! Local variables + ! + integer :: i,lat,n,c,ig ! indices + integer :: ncols ! number of columns + integer :: dust_ndx + logical, save :: first_time = .true. + +#if (defined MODAL_AERO) + integer, parameter:: ndst =2 + integer, target :: spc_ndx(ndst) +#if (defined MODAL_AERO_7MODE) + integer, pointer :: dst_a5_ndx, dst_a7_ndx +#elif (defined MODAL_AERO_3MODE) + integer, pointer :: dst_a1_ndx, dst_a3_ndx +#endif +#endif + !----------------------------------------------------------------------- + ! +#if (defined MODAL_AERO) +#if (defined MODAL_AERO_7MODE) + dst_a5_ndx => spc_ndx(1) + dst_a7_ndx => spc_ndx(2) + dst_a5_ndx = get_spc_ndx( 'dst_a5' ) + dst_a7_ndx = get_spc_ndx( 'dst_a7' ) +#elif (defined MODAL_AERO_3MODE) + dst_a1_ndx => spc_ndx(1) + dst_a3_ndx => spc_ndx(2) + dst_a1_ndx = get_spc_ndx( 'dst_a1' ) + dst_a3_ndx = get_spc_ndx( 'dst_a3' ) +#endif +#endif + + ! ccsm sign convention is that fluxes are positive downward + + ig=1 + do c=begchunk,endchunk + ncols = get_ncols_p(c) + + ! initialize constituent surface fluxes to zero + cam_in(c)%cflx(:,:) = 0._r8 + + do i =1,ncols + cam_in(c)%wsx(i) = -x2a_a%rAttr(index_x2a_Faxx_taux,ig) + cam_in(c)%wsy(i) = -x2a_a%rAttr(index_x2a_Faxx_tauy,ig) + cam_in(c)%lhf(i) = -x2a_a%rAttr(index_x2a_Faxx_lat, ig) + cam_in(c)%shf(i) = -x2a_a%rAttr(index_x2a_Faxx_sen, ig) + cam_in(c)%lwup(i) = -x2a_a%rAttr(index_x2a_Faxx_lwup,ig) + cam_in(c)%cflx(i,1) = -x2a_a%rAttr(index_x2a_Faxx_evap,ig) + cam_in(c)%asdir(i) = x2a_a%rAttr(index_x2a_Sx_avsdr, ig) + cam_in(c)%aldir(i) = x2a_a%rAttr(index_x2a_Sx_anidr, ig) + cam_in(c)%asdif(i) = x2a_a%rAttr(index_x2a_Sx_avsdf, ig) + cam_in(c)%aldif(i) = x2a_a%rAttr(index_x2a_Sx_anidf, ig) + cam_in(c)%ts(i) = x2a_a%rAttr(index_x2a_Sx_t, ig) + cam_in(c)%sst(i) = x2a_a%rAttr(index_x2a_So_t, ig) + cam_in(c)%snowhland(i) = x2a_a%rAttr(index_x2a_Sl_snowh, ig) + cam_in(c)%snowhice(i) = x2a_a%rAttr(index_x2a_Si_snowh, ig) + cam_in(c)%tref(i) = x2a_a%rAttr(index_x2a_Sx_tref, ig) + cam_in(c)%qref(i) = x2a_a%rAttr(index_x2a_Sx_qref, ig) + cam_in(c)%u10(i) = x2a_a%rAttr(index_x2a_Sx_u10, ig) + cam_in(c)%icefrac(i) = x2a_a%rAttr(index_x2a_Sf_ifrac, ig) + cam_in(c)%ocnfrac(i) = x2a_a%rAttr(index_x2a_Sf_ofrac, ig) + cam_in(c)%landfrac(i) = x2a_a%rAttr(index_x2a_Sf_lfrac, ig) + if ( associated(cam_in(c)%ram1) ) & + cam_in(c)%ram1(i) = x2a_a%rAttr(index_x2a_Sl_ram1 , ig) + if ( associated(cam_in(c)%fv) ) & + cam_in(c)%fv(i) = x2a_a%rAttr(index_x2a_Sl_fv , ig) + if ( associated(cam_in(c)%soilw) ) & + cam_in(c)%soilw(i) = x2a_a%rAttr(index_x2a_Sl_soilw, ig) + dust_ndx = dust_idx1() + ! check that dust constituents are actually in the simulation + if (dust_ndx>0) then +#if (defined MODAL_AERO) +#if (defined MODAL_AERO_7MODE) + cam_in(c)%cflx(i,dust_ndx ) = 0.13_r8 & ! 1st mode, based on Zender et al (2003) Table 1 +#elif (defined MODAL_AERO_3MODE) + cam_in(c)%cflx(i,dust_ndx ) = 0.032_r8 & ! 1st mode, based on Zender et al (2003) Table 1 +#endif + * (-x2a_a%rAttr(index_x2a_Fall_flxdst1, ig) & + -x2a_a%rAttr(index_x2a_Fall_flxdst2, ig) & + -x2a_a%rAttr(index_x2a_Fall_flxdst3, ig) & + -x2a_a%rAttr(index_x2a_Fall_flxdst4, ig)) +#if (defined MODAL_AERO_7MODE) + cam_in(c)%cflx(i,dust_ndx-spc_ndx(1)+spc_ndx(2)) = 0.87_r8 & ! 2nd mode +#elif (defined MODAL_AERO_3MODE) + cam_in(c)%cflx(i,dust_ndx-spc_ndx(1)+spc_ndx(2)) = 0.968_r8 & ! 2nd mode +#endif + * (-x2a_a%rAttr(index_x2a_Fall_flxdst1, ig) & + -x2a_a%rAttr(index_x2a_Fall_flxdst2, ig) & + -x2a_a%rAttr(index_x2a_Fall_flxdst3, ig) & + -x2a_a%rAttr(index_x2a_Fall_flxdst4, ig)) +#else + cam_in(c)%cflx(i,dust_ndx ) = -x2a_a%rAttr(index_x2a_Fall_flxdst1, ig) + cam_in(c)%cflx(i,dust_ndx +1) = -x2a_a%rAttr(index_x2a_Fall_flxdst2, ig) + cam_in(c)%cflx(i,dust_ndx +2) = -x2a_a%rAttr(index_x2a_Fall_flxdst3, ig) + cam_in(c)%cflx(i,dust_ndx +3) = -x2a_a%rAttr(index_x2a_Fall_flxdst4, ig) +#endif + endif + + ! dry dep velocities + if ( index_x2a_Sl_ddvel/=0 .and. n_drydep>0 ) then + cam_in(c)%depvel(i,:n_drydep) = & + x2a_a%rAttr(index_x2a_Sl_ddvel:index_x2a_Sl_ddvel+n_drydep-1, ig) + endif + ! + ! fields needed to calculate water isotopes to ocean evaporation processes + ! + cam_in(c)%ustar(i) = x2a_a%rAttr(index_x2a_So_ustar,ig) + cam_in(c)%re(i) = x2a_a%rAttr(index_x2a_So_re ,ig) + cam_in(c)%ssq(i) = x2a_a%rAttr(index_x2a_So_ssq ,ig) + ! + ! bgc scenarios + ! + if (index_x2a_Fall_fco2_lnd /= 0) then + cam_in(c)%fco2_lnd(i) = -x2a_a%rAttr(index_x2a_Fall_fco2_lnd,ig) + end if + if (index_x2a_Faoo_fco2_ocn /= 0) then + cam_in(c)%fco2_ocn(i) = -x2a_a%rAttr(index_x2a_Faoo_fco2_ocn,ig) + end if + if (index_x2a_Faoo_fdms_ocn /= 0) then + cam_in(c)%fdms(i) = -x2a_a%rAttr(index_x2a_Faoo_fdms_ocn,ig) + end if + + ig=ig+1 + + end do + end do + + ! Get total co2 flux from components, + ! Note - co2_transport determines if cam_in(c)%cflx(i,c_i(1:4)) is allocated + + if (co2_transport()) then + + ! Interpolate in time for flux data read in + if (co2_readFlux_ocn) then + call co2_time_interp_ocn + end if + if (co2_readFlux_fuel) then + call co2_time_interp_fuel + end if + + ! from ocn : data read in or from coupler or zero + ! from fuel: data read in or zero + ! from lnd : through coupler or zero + do c=begchunk,endchunk + ncols = get_ncols_p(c) + do i=1,ncols + + ! all co2 fluxes in unit kgCO2/m2/s ! co2 flux from ocn + if (index_x2a_Faoo_fco2_ocn /= 0) then + cam_in(c)%cflx(i,c_i(1)) = cam_in(c)%fco2_ocn(i) + else if (co2_readFlux_ocn) then + ! convert from molesCO2/m2/s to kgCO2/m2/s + cam_in(c)%cflx(i,c_i(1)) = & + -data_flux_ocn%co2flx(i,c)*(1._r8- cam_in(c)%landfrac(i)) & + *mwco2*1.0e-3_r8 + else + cam_in(c)%cflx(i,c_i(1)) = 0._r8 + end if + + ! co2 flux from fossil fuel + if (co2_readFlux_fuel) then + cam_in(c)%cflx(i,c_i(2)) = data_flux_fuel%co2flx(i,c) + else + cam_in(c)%cflx(i,c_i(2)) = 0._r8 + end if + + ! co2 flux from land (cpl already multiplies flux by land fraction) + if (index_x2a_Fall_fco2_lnd /= 0) then + cam_in(c)%cflx(i,c_i(3)) = cam_in(c)%fco2_lnd(i) + else + cam_in(c)%cflx(i,c_i(3)) = 0._r8 + end if + + ! merged co2 flux + cam_in(c)%cflx(i,c_i(4)) = cam_in(c)%cflx(i,c_i(1)) + & + cam_in(c)%cflx(i,c_i(2)) + & + cam_in(c)%cflx(i,c_i(3)) + end do + end do + end if + ! + ! if first step, determine longwave up flux from the surface temperature + ! + if (first_time) then + if (is_first_step()) then + do c=begchunk, endchunk + ncols = get_ncols_p(c) + do i=1,ncols + cam_in(c)%lwup(i) = shr_const_stebol*(cam_in(c)%ts(i)**4) + end do + end do + end if + first_time = .false. + end if + + end subroutine atm_import_mct + +!=============================================================================== + + subroutine atm_export_mct( cam_out, a2x_a ) + + !------------------------------------------------------------------- + ! + ! Arguments + ! + type(cam_out_t), intent(in) :: cam_out(begchunk:endchunk) + type(mct_aVect), intent(inout) :: a2x_a + ! + ! Local variables + ! + integer :: avsize, avnat + integer :: i,m,c,n,ig ! indices + integer :: ncols ! Number of columns + !----------------------------------------------------------------------- + + ! Copy from component arrays into chunk array data structure + ! Rearrange data from chunk structure into lat-lon buffer and subsequently + ! create attribute vector + + ig=1 + do c=begchunk, endchunk + ncols = get_ncols_p(c) + do i=1,ncols + a2x_a%rAttr(index_a2x_Sa_pslv ,ig) = cam_out(c)%psl(i) + a2x_a%rAttr(index_a2x_Sa_z ,ig) = cam_out(c)%zbot(i) + a2x_a%rAttr(index_a2x_Sa_u ,ig) = cam_out(c)%ubot(i) + a2x_a%rAttr(index_a2x_Sa_v ,ig) = cam_out(c)%vbot(i) + a2x_a%rAttr(index_a2x_Sa_tbot ,ig) = cam_out(c)%tbot(i) + a2x_a%rAttr(index_a2x_Sa_ptem ,ig) = cam_out(c)%thbot(i) + a2x_a%rAttr(index_a2x_Sa_pbot ,ig) = cam_out(c)%pbot(i) + a2x_a%rAttr(index_a2x_Sa_shum ,ig) = cam_out(c)%qbot(i,1) + a2x_a%rAttr(index_a2x_Sa_dens ,ig) = cam_out(c)%rho(i) + a2x_a%rAttr(index_a2x_Faxa_swnet,ig) = cam_out(c)%netsw(i) + a2x_a%rAttr(index_a2x_Faxa_lwdn ,ig) = cam_out(c)%flwds(i) + a2x_a%rAttr(index_a2x_Faxa_rainc,ig) = (cam_out(c)%precc(i)-cam_out(c)%precsc(i))*1000._r8 + a2x_a%rAttr(index_a2x_Faxa_rainl,ig) = (cam_out(c)%precl(i)-cam_out(c)%precsl(i))*1000._r8 + a2x_a%rAttr(index_a2x_Faxa_snowc,ig) = cam_out(c)%precsc(i)*1000._r8 + a2x_a%rAttr(index_a2x_Faxa_snowl,ig) = cam_out(c)%precsl(i)*1000._r8 + a2x_a%rAttr(index_a2x_Faxa_swndr,ig) = cam_out(c)%soll(i) + a2x_a%rAttr(index_a2x_Faxa_swvdr,ig) = cam_out(c)%sols(i) + a2x_a%rAttr(index_a2x_Faxa_swndf,ig) = cam_out(c)%solld(i) + a2x_a%rAttr(index_a2x_Faxa_swvdf,ig) = cam_out(c)%solsd(i) + + ! aerosol deposition fluxes + a2x_a%rAttr(index_a2x_Faxa_bcphidry,ig) = cam_out(c)%bcphidry(i) + a2x_a%rAttr(index_a2x_Faxa_bcphodry,ig) = cam_out(c)%bcphodry(i) + a2x_a%rAttr(index_a2x_Faxa_bcphiwet,ig) = cam_out(c)%bcphiwet(i) + a2x_a%rAttr(index_a2x_Faxa_ocphidry,ig) = cam_out(c)%ocphidry(i) + a2x_a%rAttr(index_a2x_Faxa_ocphodry,ig) = cam_out(c)%ocphodry(i) + a2x_a%rAttr(index_a2x_Faxa_ocphiwet,ig) = cam_out(c)%ocphiwet(i) + a2x_a%rAttr(index_a2x_Faxa_dstwet1,ig) = cam_out(c)%dstwet1(i) + a2x_a%rAttr(index_a2x_Faxa_dstdry1,ig) = cam_out(c)%dstdry1(i) + a2x_a%rAttr(index_a2x_Faxa_dstwet2,ig) = cam_out(c)%dstwet2(i) + a2x_a%rAttr(index_a2x_Faxa_dstdry2,ig) = cam_out(c)%dstdry2(i) + a2x_a%rAttr(index_a2x_Faxa_dstwet3,ig) = cam_out(c)%dstwet3(i) + a2x_a%rAttr(index_a2x_Faxa_dstdry3,ig) = cam_out(c)%dstdry3(i) + a2x_a%rAttr(index_a2x_Faxa_dstwet4,ig) = cam_out(c)%dstwet4(i) + a2x_a%rAttr(index_a2x_Faxa_dstdry4,ig) = cam_out(c)%dstdry4(i) + + if (index_a2x_Sa_co2prog /= 0) then + a2x_a%rAttr(index_a2x_Sa_co2prog,ig) = cam_out(c)%co2prog(i) ! atm prognostic co2 + end if + if (index_a2x_Sa_co2diag /= 0) then + a2x_a%rAttr(index_a2x_Sa_co2diag,ig) = cam_out(c)%co2diag(i) ! atm diagnostic co2 + end if + + ig=ig+1 + end do + end do + + end subroutine atm_export_mct + +!=============================================================================== + + subroutine atm_domain_mct( lsize, gsMap_a, dom_a ) + + !------------------------------------------------------------------- + ! + ! Arguments + ! + integer , intent(in) :: lsize + type(mct_gsMap), intent(in) :: gsMap_a + type(mct_ggrid), intent(inout):: dom_a + ! + ! Local Variables + ! + integer :: n,i,c,ncols ! indices + real(r8) :: lats(pcols) ! array of chunk latitudes + real(r8) :: lons(pcols) ! array of chunk longitude + real(r8) :: area(pcols) ! area in radians squared for each grid point + real(r8), pointer :: data(:) ! temporary + integer , pointer :: idata(:) ! temporary + real(r8), parameter:: radtodeg = 180.0_r8/SHR_CONST_PI + !------------------------------------------------------------------- + ! + ! Initialize mct atm domain + ! + call mct_gGrid_init( GGrid=dom_a, CoordChars=trim(seq_flds_dom_coord), OtherChars=trim(seq_flds_dom_other), lsize=lsize ) + ! + ! Allocate memory + ! + allocate(data(lsize)) + ! + ! Initialize attribute vector with special value + ! + call mct_gsMap_orderedPoints(gsMap_a, iam, idata) + call mct_gGrid_importIAttr(dom_a,'GlobGridNum',idata,lsize) + ! + ! Determine domain (numbering scheme is: West to East and South to North to South pole) + ! Initialize attribute vector with special value + ! + data(:) = -9999.0_R8 + call mct_gGrid_importRAttr(dom_a,"lat" ,data,lsize) + call mct_gGrid_importRAttr(dom_a,"lon" ,data,lsize) + call mct_gGrid_importRAttr(dom_a,"area" ,data,lsize) + call mct_gGrid_importRAttr(dom_a,"aream",data,lsize) + data(:) = 0.0_R8 + call mct_gGrid_importRAttr(dom_a,"mask" ,data,lsize) + data(:) = 1.0_R8 + call mct_gGrid_importRAttr(dom_a,"frac" ,data,lsize) + ! + ! Fill in correct values for domain components + ! + n=0 + do c = begchunk, endchunk + ncols = get_ncols_p(c) + call get_rlat_all_p(c, ncols, lats) + do i=1,ncols + n = n+1 + data(n) = lats(i)*radtodeg + end do + end do + call mct_gGrid_importRAttr(dom_a,"lat",data,lsize) + + n=0 + do c = begchunk, endchunk + ncols = get_ncols_p(c) + call get_rlon_all_p(c, ncols, lons) + do i=1,ncols + n = n+1 + data(n) = lons(i)*radtodeg + end do + end do + call mct_gGrid_importRAttr(dom_a,"lon",data,lsize) + + n=0 + do c = begchunk, endchunk + ncols = get_ncols_p(c) + call get_area_all_p(c, ncols, area) + do i=1,ncols + n = n+1 + data(n) = area(i) + end do + end do + call mct_gGrid_importRAttr(dom_a,"area",data,lsize) + + n=0 + do c = begchunk, endchunk + ncols = get_ncols_p(c) + do i=1,ncols + n = n+1 + data(n) = 1._r8 ! mask + end do + end do + call mct_gGrid_importRAttr(dom_a,"mask" ,data,lsize) + deallocate(data) + + end subroutine atm_domain_mct + +!=========================================================================================== +! + subroutine atm_read_srfrest_mct( EClock, cdata_a, x2a_a, a2x_a) + use cam_pio_utils + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(ESMF_Clock),intent(in) :: EClock + type(seq_cdata), intent(inout) :: cdata_a + type(mct_aVect), intent(inout) :: x2a_a + type(mct_aVect), intent(inout) :: a2x_a + ! + ! Local variables + ! + integer :: npts ! array size + integer :: rcode ! return error code + type(mct_aVect) :: gData ! global/gathered bundle data + integer :: yr_spec ! Current year + integer :: mon_spec ! Current month + integer :: day_spec ! Current day + integer :: sec_spec ! Current time of day (sec) + + character(len=4) :: str_year + character(len=2) :: str_month + character(len=2) :: str_day + character(len=5) :: str_sec + !----------------------------------------------------------------------- + ! + ! Determine and open surface restart dataset + ! + integer, pointer :: dof(:) + integer :: lnx, nf_x2a, nf_a2x, k + real(r8), allocatable :: tmp(:) + type(file_desc_t) :: file + type(io_desc_t) :: iodesc + type(var_desc_t) :: varid + character(CL) :: itemc ! string converted to char + type(mct_string) :: mstring ! mct char type + + + + call seq_timemgr_EClockGetData( EClock, curr_yr=yr_spec,curr_mon=mon_spec, & + curr_day=day_spec, curr_tod=sec_spec ) + + if (dart_mode) then + write(str_year ,'(i4.4)') yr_spec + write(str_month,'(i2.2)') mon_spec + write(str_day ,'(i2.2)') day_spec + write(str_sec ,'(i5.5)') sec_spec + fname_srf_cam = trim(caseid) //".cam"// trim(inst_suffix) //".rs."// str_year //"-"// str_month //"-"// str_day //"-"// str_sec //".nc" + call getfil(fname_srf_cam, fname_srf_cam) + else + fname_srf_cam = interpret_filename_spec( rsfilename_spec_cam, case=get_restcase(), & + yr_spec=yr_spec, mon_spec=mon_spec, day_spec=day_spec, sec_spec= sec_spec ) + pname_srf_cam = trim(get_restartdir() )//fname_srf_cam + call getfil(pname_srf_cam, fname_srf_cam) + end if + + call cam_pio_openfile(File, fname_srf_cam, 0) + call mct_gsmap_OrderedPoints(cdata_a%gsmap, iam, Dof) + lnx = mct_gsmap_gsize(cdata_a%gsmap) + call pio_initdecomp(pio_subsystem, pio_double, (/lnx/), dof, iodesc) + allocate(tmp(size(dof))) + deallocate(dof) + + nf_x2a = mct_aVect_nRattr(x2a_a) + + do k=1,nf_x2a + call mct_aVect_getRList(mstring,k,x2a_a) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) + + call pio_seterrorhandling(File, pio_bcast_error) + rcode = pio_inq_varid(File,'x2a_'//trim(itemc) ,varid) + if (rcode == pio_noerr) then + call pio_read_darray(File, varid, iodesc, tmp, rcode) + x2a_a%rattr(k,:) = tmp(:) + else + if (masterproc) then + write(iulog,*)'srfrest warning: field ',trim(itemc),' is not on restart file' + write(iulog,*)'for backwards compatibility will set it to 0' + end if + x2a_a%rattr(k,:) = 0._r8 + end if + call pio_seterrorhandling(File, pio_internal_error) + end do + + nf_a2x = mct_aVect_nRattr(a2x_a) + + do k=1,nf_a2x + call mct_aVect_getRList(mstring,k,a2x_a) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) + + rcode = pio_inq_varid(File,'a2x_'//trim(itemc) ,varid) + call pio_read_darray(File, varid, iodesc, tmp, rcode) + a2x_a%rattr(k,:) = tmp(:) + end do + + call pio_freedecomp(File,iodesc) + call pio_closefile(File) + deallocate(tmp) + + end subroutine atm_read_srfrest_mct +! +!=========================================================================================== +! + subroutine atm_write_srfrest_mct( cdata_a, x2a_a, a2x_a, & + yr_spec, mon_spec, day_spec, sec_spec) + use cam_pio_utils + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(seq_cdata), intent(in) :: cdata_a + type(mct_aVect), intent(in) :: x2a_a + type(mct_aVect), intent(in) :: a2x_a + integer , intent(in) :: yr_spec ! Simulation year + integer , intent(in) :: mon_spec ! Simulation month + integer , intent(in) :: day_spec ! Simulation day + integer , intent(in) :: sec_spec ! Seconds into current simulation day + ! + ! Local variables + ! + integer :: rcode ! return error code + type(mct_aVect) :: gData ! global/gathered bundle data + !----------------------------------------------------------------------- + ! + ! Determine and open surface restart dataset + ! + + integer, pointer :: dof(:) + integer :: nf_x2a, nf_a2x, lnx, dimid(1), k + type(file_desc_t) :: file + type(var_desc_t), pointer :: varid_x2a(:), varid_a2x(:) + type(io_desc_t) :: iodesc + character(CL) :: itemc ! string converted to char + type(mct_string) :: mstring ! mct char type + + + fname_srf_cam = interpret_filename_spec( rsfilename_spec_cam, & + yr_spec=yr_spec, mon_spec=mon_spec, day_spec=day_spec, sec_spec= sec_spec ) + call cam_pio_createfile(File, fname_srf_cam, 0) + + call mct_gsmap_OrderedPoints(cdata_a%gsmap, iam, Dof) + lnx = mct_gsmap_gsize(cdata_a%gsmap) + call pio_initdecomp(pio_subsystem, pio_double, (/lnx/), dof, iodesc) + + deallocate(dof) + + nf_x2a = mct_aVect_nRattr(x2a_a) + allocate(varid_x2a(nf_x2a)) + + rcode = pio_def_dim(File,'x2a_nx',lnx,dimid(1)) + do k = 1,nf_x2a + call mct_aVect_getRList(mstring,k,x2a_a) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) + rcode = pio_def_var(File,'x2a_'//trim(itemc),PIO_DOUBLE,dimid,varid_x2a(k)) + rcode = pio_put_att(File,varid_x2a(k),"_fillvalue",fillvalue) + enddo + + nf_a2x = mct_aVect_nRattr(a2x_a) + allocate(varid_a2x(nf_a2x)) + + rcode = pio_def_dim(File,'a2x_nx',lnx,dimid(1)) + do k = 1,nf_a2x + call mct_aVect_getRList(mstring,k,a2x_a) + itemc = mct_string_toChar(mstring) + call mct_string_clean(mstring) + rcode = PIO_def_var(File,'a2x_'//trim(itemc),PIO_DOUBLE,dimid,varid_a2x(k)) + rcode = PIO_put_att(File,varid_a2x(k),"_fillvalue",fillvalue) + enddo + + rcode = pio_enddef(File) ! don't check return code, might be enddef already + + + do k=1,nf_x2a + call pio_write_darray(File, varid_x2a(k), iodesc, x2a_a%rattr(k,:), rcode) + end do + + do k=1,nf_a2x + call pio_write_darray(File, varid_a2x(k), iodesc, a2x_a%rattr(k,:), rcode) + end do + + deallocate(varid_x2a, varid_a2x) + + call pio_freedecomp(File,iodesc) + call pio_closefile(file) + + + end subroutine atm_write_srfrest_mct + +!================================================================================ + +end module atm_comp_mct diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/mo_usrrxt.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/mo_usrrxt.F90 new file mode 100644 index 0000000000..d383ca142e --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/mo_usrrxt.F90 @@ -0,0 +1,1634 @@ + +! DART note: this file started life as: +! /glade/p/cesmdata/cseg/collections/cesm1_2_1/models/atm/cam/src/chemistry/mozart/mo_usrrxt.F90 + +module mo_usrrxt + + use shr_kind_mod, only : r8 => shr_kind_r8 + use cam_logfile, only : iulog + use ppgrid, only : pver, pcols + use abortutils, only : endrun +#ifdef MODAL_AERO + use modal_aero_data,only : ntot_amode, nspec_amode, modename_amode +#endif + + 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 + 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 :: 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 + + 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_ndx + + integer :: ion1_ndx, ion2_ndx, ion3_ndx, ion11_ndx + integer :: elec1_ndx, elec2_ndx, elec3_ndx + integer :: het1_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, so4_ndx, cb2_ndx, oc2_ndx, soa_ndx, nit_ndx + +!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-- + + logical :: has_aerosols + + 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 + +#ifdef MODAL_AERO + integer :: dgnumwet_idx = -1 + integer :: aitken_idx = -1 + integer, dimension(ntot_amode) :: num_idx = -1 + integer :: index_tot_mass(ntot_amode,10) = -1 + integer :: index_chm_mass(ntot_amode,10) = -1 +#endif + +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 + use physics_buffer, only : pbuf_get_index + + implicit none +#ifdef MODAL_AERO + integer :: l + character(len=6) :: test_name + character(len=64) :: errmes +#endif +! +! 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' ) + ! + 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' ) + ! + ! 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_ndx = get_rxt_ndx( 'tag_CLO_CLO' ) +! +! 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' ) + + 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 + + so4_ndx = get_spc_ndx( 'SO4' ) + cb2_ndx = get_spc_ndx( 'CB2' ) + oc2_ndx = get_spc_ndx( 'OC2' ) + soa_ndx = get_spc_ndx( 'SOA' ) + nit_ndx = get_spc_ndx( 'NH4NO3' ) + 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-- + +#ifdef MODAL_AERO + 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 + do l=1,ntot_amode + if ( trim(modename_amode(l)) == 'aitken' ) then + aitken_idx = l + end if + test_name = ' ' + write(test_name,fmt='(a5,i1)') 'num_a',l + num_idx(l) = get_spc_ndx( trim(test_name) ) + if (num_idx(l) < 0) then + write(errmes,fmt='(a,i1)') 'usrrxt_inti: cannot find MAM num_idx ',l + write(iulog,*) errmes + call endrun(errmes) + endif + end do + dgnumwet_idx = pbuf_get_index('DGNUMWET') + if ( aitken_idx < 0 ) then + errmes = 'usrrxt_inti: cannot find aitken_idx' + call endrun(errmes) + end if +! +! define indeces associated with the various names (defined in +! chemistry/modal_aero/modal_aero_initialize_data.F90) +! +#if ( defined MODAL_AERO_3MODE ) +! +! accumulation mode #1 +! + index_tot_mass(1,1) = get_spc_ndx('so4_a1') + index_tot_mass(1,2) = get_spc_ndx('pom_a1') + index_tot_mass(1,3) = get_spc_ndx('soa_a1') + index_tot_mass(1,4) = get_spc_ndx('bc_a1' ) + index_tot_mass(1,5) = get_spc_ndx('dst_a1') + index_tot_mass(1,6) = get_spc_ndx('ncl_a1') + index_chm_mass(1,1) = get_spc_ndx('so4_a1') + index_chm_mass(1,2) = get_spc_ndx('soa_a1') + index_chm_mass(1,3) = get_spc_ndx('bc_a1' ) +! +! aitken mode +! + index_tot_mass(2,1) = get_spc_ndx('so4_a2') + index_tot_mass(2,2) = get_spc_ndx('soa_a2') + index_tot_mass(2,3) = get_spc_ndx('ncl_a2') + index_chm_mass(2,1) = get_spc_ndx('so4_a2') + index_chm_mass(2,2) = get_spc_ndx('soa_a2') +! +! coarse mode +! + index_tot_mass(3,1) = get_spc_ndx('dst_a3') + index_tot_mass(3,2) = get_spc_ndx('ncl_a3') + index_tot_mass(3,3) = get_spc_ndx('so4_a3') + index_chm_mass(3,1) = get_spc_ndx('so4_a3') +! +#endif +#if ( defined MODAL_AERO_7MODE ) +! +! accumulation mode #1 +! + index_tot_mass(1,1) = get_spc_ndx('so4_a1') + index_tot_mass(1,2) = get_spc_ndx('nh4_a1') + index_tot_mass(1,3) = get_spc_ndx('pom_a1') + index_tot_mass(1,4) = get_spc_ndx('soa_a1') + index_tot_mass(1,5) = get_spc_ndx('bc_a1' ) + index_tot_mass(1,6) = get_spc_ndx('ncl_a1') + index_chm_mass(1,1) = get_spc_ndx('so4_a1') + index_chm_mass(1,2) = get_spc_ndx('nh4_a1') + index_chm_mass(1,3) = get_spc_ndx('soa_a1') + index_chm_mass(1,4) = get_spc_ndx('bc_a1' ) +! +! aitken mode +! + index_tot_mass(2,1) = get_spc_ndx('so4_a2') + index_tot_mass(2,2) = get_spc_ndx('nh4_a2') + index_tot_mass(2,3) = get_spc_ndx('soa_a2') + index_tot_mass(2,4) = get_spc_ndx('ncl_a2') + index_chm_mass(2,1) = get_spc_ndx('so4_a2') + index_chm_mass(2,2) = get_spc_ndx('nh4_a2') + index_chm_mass(2,3) = get_spc_ndx('soa_a2') +! +! primary carbon mode not added +! +! fine sea salt +! + index_tot_mass(4,1) = get_spc_ndx('so4_a4') + index_tot_mass(4,2) = get_spc_ndx('nh4_a4') + index_tot_mass(4,3) = get_spc_ndx('ncl_a4') + index_chm_mass(4,1) = get_spc_ndx('so4_a4') + index_chm_mass(4,2) = get_spc_ndx('nh4_a4') +! +! fine soil dust +! + index_tot_mass(5,1) = get_spc_ndx('so4_a5') + index_tot_mass(5,2) = get_spc_ndx('nh4_a5') + index_tot_mass(5,3) = get_spc_ndx('dst_a5') + index_chm_mass(5,1) = get_spc_ndx('so4_a5') + index_chm_mass(5,2) = get_spc_ndx('nh4_a5') +! +! coarse sea salt +! + index_tot_mass(6,1) = get_spc_ndx('so4_a6') + index_tot_mass(6,2) = get_spc_ndx('nh4_a6') + index_tot_mass(6,3) = get_spc_ndx('ncl_a6') + index_chm_mass(6,1) = get_spc_ndx('so4_a6') + index_chm_mass(6,2) = get_spc_ndx('nh4_a6') +! +! coarse soil dust +! + index_tot_mass(7,1) = get_spc_ndx('so4_a7') + index_tot_mass(7,2) = get_spc_ndx('nh4_a7') + index_tot_mass(7,3) = get_spc_ndx('dst_a7') + index_chm_mass(7,1) = get_spc_ndx('so4_a7') + index_chm_mass(7,2) = get_spc_ndx('nh4_a7') +! +#endif + + + endif +#endif + + 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 + end if + + end subroutine usrrxt_inti + + subroutine usrrxt( rxt, temp, tempi, tempe, invariants, h2ovmr, ps, & + pmid, m, sulfate, mmr, relhum, strato_sad, & + ltrop, ncol, sad_total, cwat, mbar, pbuf ) + +!----------------------------------------------------------------- +! ... set the user specified reaction rates +!----------------------------------------------------------------- + + use mo_constants, only : pi, avo => avogadro, boltz=>boltzmann + use chem_mods, only : nfs, rxntot, gas_pcnst, inv_m_ndx=>indexm + use mo_chem_utls, only : get_rxt_ndx, get_spc_ndx + use mo_setinv, only : inv_o2_ndx=>o2_ndx, inv_h2o_ndx=>h2o_ndx + use physics_buffer,only : physics_buffer_desc + + implicit none + +!----------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------- + integer, intent(in) :: ncol + integer, intent(in) :: ltrop(pcols) ! tropopause vertical index + 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) :: ps(pcols) ! surface 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(inout) :: sad_total(pcols,pver) ! total surface area density (cm2/cm3) + 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 ! + + integer :: i, k + 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) :: 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 + 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 = 8.314e+00_r8 * 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(:) + +#ifdef MODAL_AERO + real(r8), target :: sfc_array(pcols,pver,ntot_amode), dm_array(pcols,pver,ntot_amode) +#else + real(r8), target :: sfc_array(pcols,pver,4), dm_array(pcols,pver,4) +#endif + + 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 +#if (defined MODAL_AERO) + call surfarea( mmr, pmid, temp, pbuf, ncol, sfc_array, dm_array, sad_total ) +#else + call surfarea( mmr, relhum, pmid, temp, strato_sad, sulfate, m, ltrop, ncol, sfc_array, dm_array, sad_total ) +#endif + endif + + level_loop : do k = 1,pver + tinv(:) = 1._r8 / temp(:ncol,k) + tp(:) = 300._r8 * tinv(:) + sqrt_t(:) = sqrt( temp(:ncol,k) ) + +!----------------------------------------------------------------- +! ... o + o2 + m --> o3 + m +!----------------------------------------------------------------- + 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 +!----------------------------------------------------------------- + if ( usr_CL2O2_M_ndx > 0 ) then + if ( tag_CLO_CLO_ndx > 0 ) then + ko(:) = 9.3e-28_r8 * exp( 8835.0_r8* tinv(:) ) + rxt(:,k,usr_CL2O2_M_ndx) = rxt(:,k,tag_CLO_CLO_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 +!----------------------------------------------------------------- + if( usr_N2O5_M_ndx > 0 ) then + if( tag_NO2_NO3_ndx > 0 ) then + call comp_exp( exp_fac, -11000.0_r8*tinv, ncol ) + rxt(:,k,usr_N2O5_M_ndx) = rxt(:,k,tag_NO2_NO3_ndx) * 3.703704e26_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, -11000._r8*tinv, ncol ) + rxt(:,k,usr_XNO2NO3_M_ndx) = rxt(:,k,tag_NO2_NO3_ndx) * 3.703704e26_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, -11000._r8*tinv, ncol ) + rxt(:,k,usr_NO2XNO3_M_ndx) = rxt(:,k,tag_NO2_NO3_ndx) * 3.703704e26_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 CAM-Chem +!----------------------------------------------------------------- + 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*m(:,k)*temp(:ncol,k)) + end if +!----------------------------------------------------------------- +! ... co + oh --> co2 + h (second branch JPL06; pg2.2; 2.10) WACCM +!----------------------------------------------------------------- + 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 * (temp(:ncol,k)/ t0)**(0.6_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, 430._r8*tinv, ncol ) + ko(:) = 3.5e-13_r8 * exp_fac(:) + call comp_exp( exp_fac, 1000._r8*tinv, ncol ) + kinf(:) = 1.7e-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 +!----------------------------------------------------------------- + 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 +!----------------------------------------------------------------- + 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 + +!----------------------------------------------------------------- +! ... 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 ) 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 + + !------------------------------------------------------------------------- + ! 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 + 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 + + 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 + +!----------------------------------------------------------------- +! ... 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 +!------------------------------------------------------------------------- + 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 +!----------------------------------------------------------------- +! ... 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-- + + end subroutine usrrxt + + subroutine usrrxt_hrates( rxt, tempn, tempi, tempe, invariants, & + h2ovmr, pmid, m, ncol, kbot ) +!----------------------------------------------------------------- +! ... set the user specified reaction rates for heating +!----------------------------------------------------------------- + + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : nfs, 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(in) :: pmid(pcols,pver) ! midpoint pressure (Pa) + real(r8), intent(in) :: invariants(ncol,pver,nfs) ! invariants density (1/cm^3) + real(r8), intent(inout) :: rxt(ncol,pver,rxntot) ! gas phase rates + +!----------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------- + real(r8), parameter :: boltz = 1.38044e-16_r8 ! erg / K + real(r8), parameter :: avo = 6.023e23_r8 ! molecules/mole + + integer :: k + real(r8), dimension(ncol) :: & + tp, & + tinv, & + ko, & + kinf, & + fc, & + xr ! factor to increase particle radii depending on rel hum + +!----------------------------------------------------------------- +! ... 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.5e-13_r8 * exp( 430._r8*tinv(:) ) + kinf(:) = 1.7e-33_r8 * m(:,k) * exp( 1000._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 + +#ifdef IBM + call vexp( x, y, n ) +#else + x(:n) = exp( y(:n) ) +#endif + + 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 + if (n==4) then + ! b4b kludge + rate = rxt(1) + rxt(2) + rxt(3) + rxt(4) + else + rate = sum(rxt) + endif + deallocate(rxt) + + endfunction hetrxtrate + +#ifdef MODAL_AERO + !------------------------------------------------------------------------- + ! provides aerosol surface area info for modal aerosols + !------------------------------------------------------------------------- + subroutine surfarea( mmr, pmid, temp, pbuf, ncol, sfc, dm_aer, sad_total ) + use modal_aero_data, only : ntot_amode,nspec_amode,alnsg_amode + use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_get_index + use mo_constants, only : pi + use ref_pres, only : top_lev=>trop_cloud_top_lev + + ! arguments + real(r8), intent(in) :: pmid(:,:) + real(r8), intent(in) :: temp(:,:) + real(r8), intent(in) :: mmr(:,:,:) + type(physics_buffer_desc), pointer :: pbuf(:) + integer, intent(in) :: ncol + real(r8), intent(inout) :: sfc(:,:,:) + real(r8), intent(inout) :: dm_aer(:,:,:) + real(r8), intent(out) :: sad_total(:,:) + + ! local vars + + real(r8), target :: sad_mode(pcols,pver,ntot_amode) + real(r8) :: rho_air + real(r8), pointer, dimension(:,:,:) :: dgnumwet + integer :: l,m + integer :: i,k +! + real(r8) :: chm_mass,tot_mass +! + + call pbuf_get_field(pbuf, dgnumwet_idx, dgnumwet ) + ! + ! compute surface aero for each mode; however, at this point we only use Aitken mode (mode 2 in MAM3; how + ! can we move from hard-wiring this?) as the surface area for chemical reactions. + ! + sad_mode = 0._r8 + sad_total = 0._r8 + do k = top_lev,pver + do i = 1,ncol + rho_air = pmid(i,k)/(temp(i,k)*287.04_r8) + do l=1,ntot_amode +! +! compute a mass weighting of the number +! + tot_mass = 0._r8 + chm_mass = 0._r8 + do m=1,nspec_amode(l) + if ( index_tot_mass(l,m) > 0 ) tot_mass = tot_mass + mmr(i,k,index_tot_mass(l,m)) + if ( index_chm_mass(l,m) > 0 ) chm_mass = chm_mass + mmr(i,k,index_chm_mass(l,m)) + end do + if ( tot_mass > 0._r8 ) then + sad_mode(i,k,l) = chm_mass/tot_mass * mmr(i,k,num_idx(l))*rho_air*pi*dgnumwet(i,k,l)**2*exp(2*alnsg_amode(l)**2) ! m^2/m^3 + sad_mode(i,k,l) = 1.e-2_r8 * sad_mode(i,k,l) ! cm^2/cm^3 + else + sad_mode(i,k,l) = 0._r8 + end if + end do +! +! old code +! +! sad_total(i,k) = sad_mode(i,k,aitken_idx) +! +! new code +! + sad_total(i,k) = sum(sad_mode(i,k,:)) +! + enddo + enddo + + sfc(:,:,:) = sad_mode(:,:,:) ! aitken_idx:aitken_idx) + dm_aer(:,:,:) = dgnumwet(:,:,:) ! aitken_idx:aitken_idx) + dm_aer(:,1:top_lev-1,:) = 0._r8 + + end subroutine surfarea +#else + !------------------------------------------------------------------------- + ! provides aerosol surface area info + !------------------------------------------------------------------------- + subroutine surfarea( mmr,relhum, pmid,temp, strato_sad, sulfate, m, ltrop, ncol, sfc, dm_aer, sad_total ) + use mo_constants, only : pi, avo => avogadro + + ! arguments + real(r8), intent(in) :: pmid(:,:) + real(r8), intent(in) :: temp(:,:) + real(r8), intent(in) :: mmr(:,:,:) + real(r8), intent(in) :: relhum(:,:) + real(r8), intent(in) :: strato_sad(:,:) + real(r8), intent(in) :: sulfate(:,:) + real(r8), intent(in) :: m(:,:) + integer, intent(in) :: ltrop(:) + integer, intent(in) :: ncol + real(r8), intent(inout) :: sfc(:,:,:) + real(r8), intent(inout) :: dm_aer(:,:,:) + real(r8), intent(out) :: sad_total(:,:) + + ! local vars + + integer :: i,k + real(r8) :: rho_air + real(r8) :: v, n, n_exp, r_rd, r_sd + real(r8) :: dm_sulf, dm_sulf_wet, log_sd_sulf, sfc_sulf, sfc_nit + real(r8) :: dm_orgc, dm_orgc_wet, log_sd_orgc, sfc_oc, sfc_soa + real(r8) :: dm_bc, dm_bc_wet, log_sd_bc, sfc_bc + real(r8) :: rxt_sulf, rxt_nit, rxt_oc, rxt_soa + real(r8) :: c_n2o5, c_ho2, c_no2, c_no3 + real(r8) :: s_exp + + !----------------------------------------------------------------- + ! ... parameters for log-normal distribution by number + ! references: + ! Chin et al., JAS, 59, 461, 2003 + ! Liao et al., JGR, 108(D1), 4001, 2003 + ! Martin et al., JGR, 108(D3), 4097, 2003 + !----------------------------------------------------------------- + real(r8), parameter :: rm_sulf = 6.95e-6_r8 ! mean radius of sulfate particles (cm) (Chin) + real(r8), parameter :: sd_sulf = 2.03_r8 ! standard deviation of radius for sulfate (Chin) + real(r8), parameter :: rho_sulf = 1.7e3_r8 ! density of sulfate aerosols (kg/m3) (Chin) + + real(r8), parameter :: rm_orgc = 2.12e-6_r8 ! mean radius of organic carbon particles (cm) (Chin) + real(r8), parameter :: sd_orgc = 2.20_r8 ! standard deviation of radius for OC (Chin) + real(r8), parameter :: rho_orgc = 1.8e3_r8 ! density of OC aerosols (kg/m3) (Chin) + + real(r8), parameter :: rm_bc = 1.18e-6_r8 ! mean radius of soot/BC particles (cm) (Chin) + real(r8), parameter :: sd_bc = 2.00_r8 ! standard deviation of radius for BC (Chin) + real(r8), parameter :: rho_bc = 1.0e3_r8 ! density of BC aerosols (kg/m3) (Chin) + + real(r8), parameter :: mw_so4 = 98.e-3_r8 ! so4 molecular wt (kg/mole) + + integer :: irh, rh_l, rh_u + real(r8) :: factor, rfac_sulf, rfac_oc, rfac_bc, rfac_ss + + !----------------------------------------------------------------- + ! ... table for hygroscopic growth effect on radius (Chin et al) + ! (no growth effect for mineral dust) + !----------------------------------------------------------------- + real(r8), dimension(7) :: table_rh, table_rfac_sulf, table_rfac_bc, table_rfac_oc, table_rfac_ss + + data table_rh(1:7) / 0.0_r8, 0.5_r8, 0.7_r8, 0.8_r8, 0.9_r8, 0.95_r8, 0.99_r8/ + data table_rfac_sulf(1:7) / 1.0_r8, 1.4_r8, 1.5_r8, 1.6_r8, 1.8_r8, 1.9_r8, 2.2_r8/ + data table_rfac_oc(1:7) / 1.0_r8, 1.2_r8, 1.4_r8, 1.5_r8, 1.6_r8, 1.8_r8, 2.2_r8/ + data table_rfac_bc(1:7) / 1.0_r8, 1.0_r8, 1.0_r8, 1.2_r8, 1.4_r8, 1.5_r8, 1.9_r8/ + data table_rfac_ss(1:7) / 1.0_r8, 1.6_r8, 1.8_r8, 2.0_r8, 2.4_r8, 2.9_r8, 4.8_r8/ + + !----------------------------------------------------------------- + ! ... exponent for calculating number density + !----------------------------------------------------------------- + n_exp = exp( -4.5_r8*log(sd_sulf)*log(sd_sulf) ) + + dm_sulf = 2._r8 * rm_sulf + dm_orgc = 2._r8 * rm_orgc + dm_bc = 2._r8 * rm_bc + + log_sd_sulf = log(sd_sulf) + log_sd_orgc = log(sd_orgc) + log_sd_bc = log(sd_bc) + + ver_loop: do k = 1,pver + col_loop: do i = 1,ncol + !------------------------------------------------------------------------- + ! ... air density (kg/m3) + !------------------------------------------------------------------------- + rho_air = pmid(i,k)/(temp(i,k)*287.04_r8) + !------------------------------------------------------------------------- + ! ... aerosol growth interpolated from M.Chin's table + !------------------------------------------------------------------------- + if (relhum(i,k) >= table_rh(7)) then + rfac_sulf = table_rfac_sulf(7) + rfac_oc = table_rfac_oc(7) + rfac_bc = table_rfac_bc(7) + else + do irh = 2,7 + if (relhum(i,k) <= table_rh(irh)) then + exit + end if + end do + rh_l = irh-1 + rh_u = irh + + factor = (relhum(i,k) - table_rh(rh_l))/(table_rh(rh_u) - table_rh(rh_l)) + + rfac_sulf = table_rfac_sulf(rh_l) + factor*(table_rfac_sulf(rh_u) - table_rfac_sulf(rh_l)) + rfac_oc = table_rfac_oc(rh_u) + factor*(table_rfac_oc(rh_u) - table_rfac_oc(rh_l)) + rfac_bc = table_rfac_bc(rh_u) + factor*(table_rfac_bc(rh_u) - table_rfac_bc(rh_l)) + end if + + dm_sulf_wet = dm_sulf * rfac_sulf + dm_orgc_wet = dm_orgc * rfac_oc + dm_bc_wet = dm_bc * rfac_bc + + dm_bc_wet = min(dm_bc_wet ,50.e-6_r8) ! maximum size is 0.5 micron (Chin) + dm_orgc_wet = min(dm_orgc_wet,50.e-6_r8) ! maximum size is 0.5 micron (Chin) + + + !------------------------------------------------------------------------- + ! ... sulfate aerosols + !------------------------------------------------------------------------- + !------------------------------------------------------------------------- + ! ... use ubvals climatology for stratospheric sulfate surface area density + !------------------------------------------------------------------------- + if( k < ltrop(i) ) then + sfc_sulf = strato_sad(i,k) + if ( het1_ndx > 0 ) then + sfc_sulf = 0._r8 ! reaction already taken into account in mo_strato_rates.F90 + end if + else + + if( so4_ndx > 0 ) then + !------------------------------------------------------------------------- + ! convert mass mixing ratio of aerosol to cm3/cm3 (cm^3_aerosol/cm^3_air) + ! v=volume density (m^3/m^3) + ! rho_aer=density of aerosol (kg/m^3) + ! v=m*rho_air/rho_aer [kg/kg * (kg/m3)_air/(kg/m3)_aer] + !------------------------------------------------------------------------- + v = mmr(i,k,so4_ndx) * rho_air/rho_sulf + !------------------------------------------------------------------------- + ! calculate the number density of aerosol (aerosols/cm3) + ! assuming a lognormal distribution + ! n = (aerosols/cm3) + ! dm = geometric mean diameter + ! + ! because only the dry mass of the aerosols is known, we + ! use the mean dry radius + !------------------------------------------------------------------------- + n = v * (6._r8/pi)*(1._r8/(dm_sulf**3._r8))*n_exp + !------------------------------------------------------------------------- + ! find surface area of aerosols using dm_wet, log_sd + ! (increase of sd due to RH is negligible) + ! and number density calculated above as distribution + ! parameters + ! sfc = surface area of wet aerosols (cm^2/cm^3) + !------------------------------------------------------------------------- + s_exp = exp(2._r8*log_sd_sulf*log_sd_sulf) + sfc_sulf = n * pi * (dm_sulf_wet**2._r8) * s_exp + + else + !------------------------------------------------------------------------- + ! if so4 not simulated, use off-line sulfate and calculate as above + ! convert sulfate vmr to volume density of aerosol (cm^3_aerosol/cm^3_air) + !------------------------------------------------------------------------- + v = sulfate(i,k) * m(i,k) * mw_so4 / (avo * rho_sulf) *1.e6_r8 + n = v * (6._r8/pi)*(1._r8/(dm_sulf**3._r8))*n_exp + s_exp = exp(2._r8*log_sd_sulf*log_sd_sulf) + sfc_sulf = n * pi * (dm_sulf_wet**2._r8) * s_exp + + end if + end if + + !------------------------------------------------------------------------- + ! ammonium nitrate (follow same procedure as sulfate, using size and density of sulfate) + !------------------------------------------------------------------------- + if( nit_ndx > 0 ) then + v = mmr(i,k,nit_ndx) * rho_air/rho_sulf + n = v * (6._r8/pi)*(1._r8/(dm_sulf**3._r8))*n_exp + s_exp = exp(2._r8*log_sd_sulf*log_sd_sulf) + sfc_nit = n * pi * (dm_sulf_wet**2._r8) * s_exp + else + sfc_nit = 0._r8 + end if + + !------------------------------------------------------------------------- + ! hydrophylic organic carbon (follow same procedure as sulfate) + !------------------------------------------------------------------------- + if( oc2_ndx > 0 ) then + v = mmr(i,k,oc2_ndx) * rho_air/rho_orgc + n = v * (6._r8/pi)*(1._r8/(dm_orgc**3))*n_exp + s_exp = exp(2._r8*log_sd_orgc*log_sd_orgc) + sfc_oc = n * pi * (dm_orgc_wet**2._r8) * s_exp + else + sfc_oc = 0._r8 + end if + + !------------------------------------------------------------------------- + ! secondary organic carbon (follow same procedure as sulfate) + !------------------------------------------------------------------------- + if( soa_ndx > 0 ) then + v = mmr(i,k,soa_ndx) * rho_air/rho_orgc + n = v * (6._r8/pi)*(1._r8/(dm_orgc**3._r8))*n_exp + s_exp = exp(2._r8*log_sd_orgc*log_sd_orgc) + sfc_soa = n * pi * (dm_orgc_wet**2._r8) * s_exp + else + sfc_soa = 0._r8 + end if + + !------------------------------------------------------------------------- + ! black carbon (follow same procedure as sulfate) + !------------------------------------------------------------------------- + if( cb2_ndx > 0 ) then + v = mmr(i,k,cb2_ndx) * rho_air/rho_bc + n = v * (6._r8/pi)*(1._r8/(dm_bc**3._r8))*n_exp + s_exp = exp(2._r8*log_sd_bc*log_sd_bc) + sfc_bc = n * pi * (dm_bc_wet**2._r8) * s_exp + else + sfc_bc = 0._r8 + end if + + sfc(i,k,:) = (/ sfc_sulf, sfc_nit, sfc_oc, sfc_soa /) + dm_aer(i,k,:) = (/ dm_sulf_wet,dm_sulf_wet,dm_orgc_wet,dm_orgc_wet /) + + !------------------------------------------------------------------------- + ! ... add up total surface area density for output + !------------------------------------------------------------------------- + sad_total(i,k) = sfc_sulf + sfc_nit + sfc_oc + sfc_soa + sfc_bc + + enddo col_loop + enddo ver_loop + + endsubroutine surfarea +#endif + +end module mo_usrrxt diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/src/dynamics/fv/cd_core.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/src/dynamics/fv/cd_core.F90 new file mode 100644 index 0000000000..fa0803f0b1 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/src/dynamics/fv/cd_core.F90 @@ -0,0 +1,1602 @@ + +! DART note: this file started life as: +! /glade/p/cesmdata/cseg/collections/cesm1_2_1/models/atm/cam/src/dynamics/fv/cd_core.F90 + +!----------------------------------------------------------------------- +!BOP +! !ROUTINE: cd_core --- Dynamical core for both C- and D-grid Lagrangian +! dynamics +! +! !INTERFACE: + subroutine cd_core(grid, nx, u, v, pt, & + delp, pe, pk, ns, dt, & + ptopin, umax, pi, ae, cp, akap, & + iord_c, jord_c, iord_d, jord_d, ipe, & + om, hs, cx3 , cy3, mfx, mfy, & + delpf, uc, vc, ptc, dpt, ptk, & + wz3, pkc, wz, hsxy, ptxy, pkxy, & + pexy, pkcc, wzc, wzxy, delpxy, & + pkkp, wzkp, cx_om, cy_om, filtcw, s_trac, & + mlt, ncx, ncy, nmfx, nmfy, iremote, & + cxtag, cytag, mfxtag, mfytag, & + cxreqs, cyreqs, mfxreqs, mfyreqs) + +! !USES: + use shr_kind_mod, only : r8 => shr_kind_r8 + use sw_core, only : d2a2c_winds, c_sw, d_sw + use pft_module, only : pft2d + use dynamics_vars, only : T_FVDYCORE_GRID + use FVperf_module, only : FVstartclock, FVstopclock, FVbarrierclock + use cam_logfile, only : iulog + use fv_control_mod, only: div24del2flag, del2coef + use spmd_utils, only: masterproc + use abortutils, only: endrun + +#if defined( SPMD ) + use mod_comm, only : mp_send4d_ns, mp_recv4d_ns, & + mp_send2_ns, mp_recv2_ns, & + mp_send3d_2, mp_recv3d_2, & + mp_send3d, mp_recv3d, mp_sendirr, & + mp_recvirr + use mpishorthand +#endif + +#if defined( OFFLINE_DYN ) + use metdata, only : get_met_fields, met_winds_on_walls +#endif + use metdata, only : met_rlx + + implicit none + +! !INPUT PARAMETERS: + + type (T_FVDYCORE_GRID), intent(inout) :: grid! grid (for YZ decomp) + integer, intent(in) :: nx ! # of split pieces in longitude direction + integer, intent(in) :: ipe ! ipe=1: end of cd_core() + ! ipe=-1,-2: start of cd_core() + ! ipe=-2,2: second to last call to cd_core() + ! ipe=0 : + integer, intent(in) :: ns ! Number of internal time steps (splitting) + integer, intent(in) :: iord_c, jord_c ! scheme order on C grid in X and Y dir. + integer, intent(in) :: iord_d, jord_d ! scheme order on D grid in X and Y dir. + integer, intent(in) :: filtcw ! flag for filtering C-grid winds + +! ct_overlap data + logical, intent(in) :: s_trac ! true to post send for ct_overlap or + ! tracer decomposition information + integer, intent(in) :: mlt ! multiplicity of sends + integer, intent(in) :: ncx, ncy, nmfx, nmfy ! array sizes + integer, intent(in) :: cxtag(mlt), cytag(mlt) ! tags + integer, intent(in) :: mfxtag(mlt), mfytag(mlt) ! tags + integer, intent(in) :: iremote(mlt) ! target tasks + integer, intent(in) :: cxreqs(mlt), cyreqs(mlt) ! mpi requests + integer, intent(in) :: mfxreqs(mlt), mfyreqs(mlt) ! mpi requests + + + real(r8), intent(in) :: pi + real(r8), intent(in) :: ae ! Radius of the Earth (m) + real(r8), intent(in) :: om ! rotation rate + real(r8), intent(in) :: ptopin + real(r8), intent(in) :: umax + real(r8), intent(in) :: dt !small time step in seconds + real(r8), intent(in) :: cp + real(r8), intent(in) :: akap + +! Input time independent arrays: + real(r8), intent(in) :: & + hs(grid%im,grid%jfirst:grid%jlast) !surface geopotential + real(r8), intent(in) :: & + hsxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy) !surface geopotential XY-decomp. + +! !INPUT/OUTPUT PARAMETERS: + + real(r8), intent(inout) :: & + u(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_s,grid%kfirst:grid%klast) ! u-Wind (m/s) + real(r8), intent(inout) :: & + v(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) ! v-Wind (m/s) + + real(r8), intent(inout) :: & + delp(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) ! Delta pressure (pascal) + real(r8), intent(inout) :: & + pt(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast)! Scaled-Pot. temp. + +! Input/output: accumulated winds & mass fluxes on c-grid for large- +! time-step transport + real(r8), intent(inout) :: & + cx3(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast)! Accum. Courant no. in X + real(r8), intent(inout) :: & + cy3(grid%im,grid%jfirst:grid%jlast+1,grid%kfirst:grid%klast) ! Accumulated Courant no. in Y + real(r8), intent(inout) :: & + mfx(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) ! Mass flux in X (unghosted) + real(r8), intent(inout) :: & + mfy(grid%im,grid%jfirst:grid%jlast+1,grid%kfirst:grid%klast) ! Mass flux in Y + +! Input/output work arrays: + real(r8), intent(inout) :: & + delpf(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) ! filtered delp + real(r8), intent(inout) :: & + uc(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) ! u-Winds on C-grid + real(r8), intent(inout) :: & + vc(grid%im,grid%jfirst-2: grid%jlast+2, grid%kfirst:grid%klast) ! v-Winds on C-grid + + real(r8), intent(inout) :: & + dpt(grid%im,grid%jfirst-1:grid%jlast+1,grid%kfirst:grid%klast) + real(r8), intent(inout) :: & + wz3(grid%im,grid%jfirst-1:grid%jlast ,grid%kfirst:grid%klast+1) + real(r8), intent(inout) :: & + pkc(grid%im,grid%jfirst-1:grid%jlast+1,grid%kfirst:grid%klast+1) + real(r8), intent(inout) :: & + wz(grid%im,grid%jfirst-1:grid%jlast+1,grid%kfirst:grid%klast+1) + real(r8), intent(inout) :: & + pkcc(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) + real(r8), intent(inout) :: & + wzc(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) + real(r8), intent(inout) :: & + wzxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km+1) + real(r8), intent(inout) :: & + delpxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) + real(r8), intent(inout) :: & + pkkp(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) + real(r8), intent(inout) :: & + wzkp(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) + +! !OUTPUT PARAMETERS: + real(r8), intent(out) :: & + pe(grid%im,grid%kfirst:grid%klast+1,grid%jfirst:grid%jlast) ! Edge pressure (pascal) + real(r8), intent(out) :: & + pk(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) ! Pressure to the kappa + real(r8), intent(out) :: & + ptxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! Potential temperature XY decomp + real(r8), intent(out) :: & + pkxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km+1) ! P-to-the-kappa XY decomp + real(r8), intent(out) :: & + pexy(grid%ifirstxy:grid%ilastxy,grid%km+1,grid%jfirstxy:grid%jlastxy) ! Edge pressure XY decomp + real(r8), intent(out) :: & + ptc(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) + real(r8), intent(out) :: & + ptk(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) +! Work arrays + +! ! !DESCRIPTION: +! Perform a dynamical update for one small time step; the small +! time step is limitted by the fastest wave within the Lagrangian control- +! volume +! +! !REVISION HISTORY: +! SJL 99.01.01: Original SMP version +! WS 99.04.13: Added jfirst:jlast concept +! SJL 99.07.15: Merged c_core and d_core to this routine +! WS 99.09.07: Restructuring, cleaning, documentation +! WS 99.10.18: Walkthrough corrections; frozen for 1.0.7 +! WS 99.11.23: Pruning of some 2-D arrays +! SJL 99.12.23: More comments; general optimization; reduction +! of redundant computation & communication +! WS 00.05.14: Modified ghost indices per Kevin's definition +! WS 00.07.13: Changed PILGRIM API +! WS 00.08.28: Cosmetic changes: removed old loop limit comments +! AAM 00.08.30: Introduced kfirst,klast +! WS 00.12.01: Replaced MPI_ON with SPMD; hs now distributed +! WS 01.04.11: PILGRIM optimizations for begin/endtransfer +! WS 01.05.08: Optimizations in the call of c_sw and d_sw +! AAM 01.06.27: Reinstituted 2D decomposition for use in ccm +! WS 01.12.10: Ghosted PT, code now uses mod_comm primitives +! WS 01.12.31: Removed vorticity damping, ghosted U,V,PT +! WS 02.01.15: Completed transition to mod_comm +! WS 02.07.04: Fixed 2D decomposition bug dest/src for mp_send3d +! WS 02.09.04: Integrated fvgcm-1_3_71 zero diff. changes by Lin +! WS 03.07.22: Removed HIGH_P option; this is outdated +! WS 03.10.15: Fixed hack of 00.04.13 for JORD>1 JCD=1, in clean way +! WS 03.12.03: Added grid as argument, some dynamics_vars removed +! WS 04.08.25: Interface simplified with GRID argument +! WS 04.10.07: Removed dependency on spmd_dyn; info now in GRID +! WS 05.05.24: Incorporated OFFLINE_DYN; merge of CAM/GEOS5 +! PW 05.07.26: Changes for Cray X1 +! PW 05.10.12: More changes for Cray X1(E), avoiding array segment copying +! WS 06.09.08: Isolated magic numbers as F90 parameters +! WS 06.09.15: PI now passed as argument +! CC 07.01.29: Corrected calculation of OMEGA +! PW 08.06.29: Added options to call geopk_d and swap-based transposes +! +!EOP +!--------------------------------------------------------------------- +!BOC + +! Local 2D arrays: + real(r8) :: wk(grid%im+2,grid%jfirst: grid%jlast+2) + real(r8) :: wk1(grid%im,grid%jfirst-1:grid%jlast+1) + real(r8) :: wk2(grid%im+1,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) + real(r8) :: wk3(grid%im,grid%jfirst-1:grid%jlast+1) + + real(r8) :: p1d(grid%im) + +! fvitt cell centered u- and v-Winds (m/s) + real(r8) :: u_cen(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) + real(r8) :: v_cen(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) + real(r8) :: ua(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) + real(r8) :: va(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) + + +! Local scalars + + real(r8), parameter :: D0_0 = 0.0_r8 + real(r8), parameter :: D0_1 = 0.1_r8 + real(r8), parameter :: D0_5 = 0.5_r8 + real(r8), parameter :: D1_0 = 1.0_r8 + real(r8), parameter :: D4_0 = 4.0_r8 + real(r8), parameter :: D8_0 = 8.0_r8 + real(r8), parameter :: D10_0 = 10.0_r8 + real(r8), parameter :: D64_0 = 64.0_r8 + real(r8), parameter :: D128_0 = 128.0_r8 + real(r8), parameter :: D180_0 = 180.0_r8 + real(r8), parameter :: D1E5 = 1.0e5_r8 + + real(r8), parameter :: ratmax = 0.81_r8 + real(r8), parameter :: tiny = 1.0e-10_r8 + + real(r8) :: press + real(r8) :: rat, ycrit + real(r8) :: dt5 + + integer :: msgtag ! MPI message tag + + integer :: im, jm, km ! problem dimensions + integer :: nq ! # of tracers to be advected by trac2d + integer :: ifirstxy,ilastxy ! xy-decomp. longitude ranges + integer :: jfirstxy,jlastxy ! xy-decomp. latitude ranges + integer :: ng_c ! ghost latitudes on C grid + integer :: ng_d ! ghost lats on D (Max NS dependencies, ng_d >= ng_c) + integer :: ng_s ! max(ng_c+1,ng_d) significant if ng_c = ng_d + + integer :: jfirst + integer :: jlast + integer :: kfirst + integer :: klast + integer :: klastp ! klast, except km+1 when klast=km + + integer :: iam + integer :: npr_y + integer :: npes_xy + integer :: npes_yz + + integer i, j, k, ml + integer js1g1, js2g0, js2g1, jn2g1 + integer jn2g0, jn1g1 + integer iord , jord + integer ktot, ktotp + + real(r8) :: tau, fac, pk4 + real(r8) :: tau4 ! coefficient for 4th-order divergence damping + +#if defined( SPMD ) + integer dest, src +#endif + + logical :: reset_winds = .false. + logical :: everytime = .false. + ! + ! set damping options: + ! + ! - ldel2: 2nd-order velocity-component damping targetted to top layers, + ! with coefficient del2coef (default 3E5) + ! + ! - ldiv2: 2nd-order divergence damping everywhere and increasing in top layers + ! (default cam3.5 setting) + ! + ! - ldiv4: 4th-order divergence damping everywhere and increasing in top layers + ! + ! - div24del2flag: 2 for ldiv2 (default), 4 for ldiv4, 42 for ldiv4 + ldel2 + ! - ldiv2 and ldel2 cannot coexist + ! + logical :: ldiv2 = .true. + logical :: ldiv4 = .false. + logical :: ldel2 = .false. + + +! C.-C. Chen, omega calculation + real(r8), intent(out) :: & + cx_om(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) ! Courant in X + real(r8), intent(out) :: & + cy_om(grid%im,grid%jfirst:grid%jlast+1,grid%kfirst:grid%klast) ! Courant in Y + +!****************************************************************** +!****************************************************************** +! +! IMPORTANT CODE OPTIONS - SEE BELOW +! +!****************************************************************** +!****************************************************************** + +! Option for which version of geopk to use with yz decomposition. +! If geopkdist=false, variables are transposed to/from xy decomposition +! for use in geopk. +! If geopkdist=true, either geopk_d or geopk16 is used. Both +! compute local partial sums in z and then communicate those +! sums to combine them. geopk_d does not try to parallelize in the +! z-direction except in a pipeline fashion controlled by the +! parameter geopkblocks, and is bit-for-bit the same as the +! transpose-based algorithm. geopk16 exploits z-direction +! parallelism and requires 16-byte arithmetic (DSIZE=16) +! to reproduce the same numerics (and to be reproducible with +! respect to process count). The geopk16 default is to use +! 8-byte arithmetic (DSIZE=8). This is faster than +! 16-byte, but also gives up reproducibility. On many systems +! performance of geopk_d is comparable to geopk16 even with +! 8-byte numerics. +! On the last two small timesteps (ipe=1,2 or 1,-2) for D-grid, +! the version of geopk that uses transposes is called regardless, +! as some transposed quantities are required for the te_map phase +! and for the calculation of omega. +! For non-SPMD mode, geopk_[cd]dist are set to false. + + logical geopk_cdist, geopk_ddist + + geopk_cdist = .false. + geopk_ddist = .false. +#if defined( SPMD ) + if (grid%geopkdist) then + geopk_cdist = .true. + if ((ipe == -1) .or. (ipe == 0)) geopk_ddist = .true. + endif +#endif + +!****************************************************************** + + npes_xy = grid%npes_xy + npes_yz = grid%npes_yz + + im = grid%im + jm = grid%jm + km = grid%km + nq = grid%nq + + ng_c = grid%ng_c + ng_d = grid%ng_d + ng_s = grid%ng_s + + jfirst = grid%jfirst + jlast = grid%jlast + kfirst = grid%kfirst + klast = grid%klast + klastp = grid%klastp + + iam = grid%iam + npr_y = grid%npr_y + + ifirstxy = grid%ifirstxy + ilastxy = grid%ilastxy + jfirstxy = grid%jfirstxy + jlastxy = grid%jlastxy + + ktot = klast - kfirst + 1 + ktotp = ktot + 1 + + if (iam .lt. npes_yz) then + + call FVstartclock(grid,'---PRE_C_CORE') + +#if defined( SPMD ) + call FVstartclock(grid,'---PRE_C_CORE_COMM') + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_s, u ) + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_s, ng_d, v ) + call FVstopclock(grid,'---PRE_C_CORE_COMM') +#endif + +! Set general loop limits +! jfirst >= 1; jlast <= jm + js1g1 = max(1,jfirst-1) + js2g0 = max(2,jfirst) + js2g1 = max(2,jfirst-1) + jn2g0 = min(jm-1,jlast) + jn1g1 = min(jm,jlast+1) + jn2g1 = min(jm-1,jlast+1) + + if( abs(grid%dt0-dt) > D0_1 ) then + + grid%dt0 = dt + dt5 = D0_5*dt + + grid%rdy = D1_0/(ae*grid%dp) + grid%dtdy = dt *grid%rdy + grid%dtdy5 = dt5*grid%rdy + grid%dydt = (ae*grid%dp) / dt + grid%tdy5 = D0_5/grid%dtdy + + do j=2,jm-1 + grid%dx(j) = grid%dl*ae*grid%cosp(j) + grid%rdx(j) = D1_0 / grid%dx(j) + grid%dtdx(j) = dt /grid% dx(j) + grid%dxdt(j) = grid%dx(j) / dt + grid%dtdx2(j) = D0_5*grid%dtdx(j) + grid%dtdx4(j) = D0_5*grid%dtdx2(j) + grid%dycp(j) = ae*grid%dp/grid%cosp(j) + grid%cy(j) = grid%rdy * grid%acosp(j) + enddo + + do j=2,jm + grid%dxe(j) = ae*grid%dl*grid%cose(j) + grid%rdxe(j) = D1_0 / grid%dxe(j) + grid%dtdxe(j) = dt / grid%dxe(j) + grid%dtxe5(j) = D0_5*grid%dtdxe(j) + grid%txe5(j) = D0_5/grid%dtdxe(j) + grid%cye(j) = D1_0 / (ae*grid%cose(j)*grid%dp) + grid%dyce(j) = ae*grid%dp/grid%cose(j) + enddo + +! C-grid +#ifndef WACCM_MOZART + grid%zt_c = abs(umax*dt5) / (grid%dl*ae) +#else + grid%zt_c = cos( D10_0 * pi / D180_0 ) +#endif + +! D-grid +#ifndef WACCM_MOZART + grid%zt_d = abs(umax*dt) / (grid%dl*ae) +#else + grid%zt_d = cos( D10_0 * pi / D180_0 ) +#endif + + if ( ptopin /= grid%ptop) then + write(iulog,*) 'PTOP as input to cd_core != ptop from T_FVDYCORE_GRID' + stop + endif + + ! + ! damping code + ! + if (div24del2flag == 2) then + ! + ! cam3.5 default damping setting + ! + ldiv2 = .true. + ldiv4 = .false. + ldel2 = .false. + if (masterproc) write(iulog,*) 'Divergence damping: use 2nd order damping' + elseif (div24del2flag == 4) then + ! + ! fourth order divergence damping and no velocity diffusion + ! + ldiv2 = .false. + ldiv4 = .true. + ldel2 = .false. + if (masterproc) write(iulog,*) 'Divergence damping: use 4th order damping' + elseif (div24del2flag == 42) then + ! + ! fourth order divergence damping with velocity diffusion + ! + ldiv2 = .false. + ldiv4 = .true. + ldel2 = .true. + if (masterproc) write(iulog,*) 'Divergence damping: use 4th order damping' + if (masterproc) write(iulog,*) 'Velocity del2 damping with coefficient ', del2coef + else + ldiv2 = .true. + ldiv4 = .false. + ldel2 = .false. + if (masterproc) write(iulog,*) 'Inadmissable velocity smoothing option - div24del2flag = ', div24del2flag + call endrun('Inadmissable value of div24del2flag') + endif + + do k=kfirst,klast + + if (ldel2) then + ! + !*********************************** + ! + ! Laplacian on velocity components + ! + !*********************************** + ! + press = D0_5 * ( grid%ak(k)+grid%ak(k+1) + & + (grid%bk(k)+grid%bk(k+1))*D1E5 ) + tau = D8_0 * (D1_0+ tanh(D1_0*log(grid%ptop/press)) ) + ! + ! tau is strength of damping + ! + if (tau < 0.3_r8) then + ! + ! no del2 damping at lower levels + ! + tau = 0.0_r8 + end if + + do j=js2g0,jn1g1 + ! + ! fac must include dt for the momentum equation + ! i.e. diffusion coefficient is fac/dt + ! + ! del2 diffusion coefficient in spectral core is 2.5e5 + ! + fac = tau * dt * del2coef + ! + ! all these coefficients are necessary because of the staggering of the + ! wind components + ! + grid%cdxde(j,k) = fac/(ae*ae*grid%cose(j)*grid%cose(j)*grid%dl*grid%dl) + grid%cdyde(j,k) = fac/(ae*ae*grid%cose(j)*grid%dp*grid%dp) + end do + do j=js2g0,jn2g1 + fac = tau * dt * del2coef + grid%cdxdp(j,k) = fac/(ae*ae*grid%cosp(j)*grid%cosp(j)*grid%dl*grid%dl) + grid%cdydp(j,k) = fac/(ae*ae*grid%cosp(j)*grid%dp*grid%dp) + end do + end if + + if (ldiv2) then + ! + !*********************************************** + ! + ! cam3 default second-order divergence damping + ! + !*********************************************** + ! + press = D0_5 * ( grid%ak(k)+grid%ak(k+1) + & + (grid%bk(k)+grid%bk(k+1))*D1E5 ) + tau = D8_0 * (D1_0+ tanh(D1_0*log(grid%ptop/press)) ) + + ! DART this change is specific for WACCM. This entire file + ! (cd_core.F90) is not used in the SourceMods when not using WACCM. + ! The DART/CESM setup scripts remove this file when not using WACCM. + ! That ensures the use of the default CESM values. + tau = max(D1_0, tau) / (D64_0*abs(dt)) + + do j=js2g0,jn1g1 + !----------------------------------------- + ! Explanation of divergence damping coeff. + ! ======================================== + ! + ! Divergence damping is added to the momentum + ! equations through a term tau*div where + ! + ! tau = C*L**2/dt + ! + ! where L is the length scale given by + ! + ! L**2 = a**2*dl*dp + ! + ! and divergence is given by + ! + ! div = divx + divy + ! + ! where + ! + ! divx = (1/(a*cos(p)))*du/dl + ! divy = (1/(a*cos(p)))*(d(cos(theta)*v)/dp)) + ! + ! du and (d(cos(theta*v)/dp)) are computed in sw_core + ! + ! The constant terms in divx*tau and divy*tau are + ! + ! cdx = (1/(a*cos(p)))* (1/dl) * C * a**2 * dl * dp / dt = C * (a*dp/(cos(p)))/dt + ! cdy = (1/(a*cos(p)))* (1/dp) * C * a**2 * dl * dp / dt = C * (a*dl/(cos(p)))/dt + ! + !----------------------------------------- + fac = tau * ae / grid%cose(j) !default + grid%cdx(j,k) = fac*grid%dp !default + grid%cdy(j,k) = fac*grid%dl !default + end do + end if + + if (ldiv4) then + ! + ! 4th-order divergence damping + ! + tau4 = 0.01_r8 / (abs(dt)) + ! + !************************************** + ! + ! fourth order divergence damping + ! + !************************************** + ! + do j=1,jm + ! + ! divergence computation coefficients + ! + grid%cdxdiv (j,k) = D1_0/(grid%cose(j)*grid%dl) + grid%cdydiv (j,k) = D1_0/(grid%cose(j)*grid%dp) + end do + do j=js2g0,jn1g1 + ! + ! div4 coefficients + ! + fac = grid%dl*grid%cose(j)!*ae + grid%cdx4 (j,k) = D1_0/(fac*fac) + fac = grid%dp*grid%dp*grid%cose(j)!*ae*ae + grid%cdy4 (j,k) = D1_0/fac + fac = grid%cose(j)*grid%dp*grid%dl + grid%cdtau4(j,k) = -ae*tau4*fac*fac + end do + endif + end do + end if + + + if ( ipe < 0 .or. ns == 1 ) then ! starting cd_core + call FVstartclock(grid,'---C_DELP_LOOP') +!$omp parallel do private(i, j, k, wk, wk2) +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (I, J, K, WK, WK2) +#endif + do k=kfirst,klast + do j=jfirst,jlast + do i=1,im + delpf(i,j,k) = delp(i,j,k) + enddo + enddo + call pft2d( delpf(1,js2g0,k), grid%sc, & + grid%dc, im, jn2g0-js2g0+1, & + wk, wk2 ) + enddo +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + call FVstopclock(grid,'---C_DELP_LOOP') + + endif + +#if defined( SPMD ) + call FVstartclock(grid,'---PRE_C_CORE_COMM') + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_s, u ) + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_s, ng_d, v ) + + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, pt ) + if ( ipe < 0 .or. ns == 1 ) then ! starting cd_core + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, delpf ) + endif ! end if ipe < 0 check + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, pt ) + if ( ipe < 0 .or. ns == 1 ) then ! starting cd_core + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, delpf ) + endif ! end if ipe < 0 check + call FVstopclock(grid,'---PRE_C_CORE_COMM') +#endif + +! +! Get the cell centered winds if needed for the sub-step +! +#if ( defined OFFLINE_DYN ) + if ( ( (ipe < 0) .or. (everytime) ) .and. (.not. met_winds_on_walls()) ) then + call get_met_fields( grid, u_cen, v_cen ) + reset_winds = .true. + else + reset_winds = .false. + endif +#endif + + +! Get D-grid V-wind at the poles and interpolate winds to A- and C-grids; +! This calculation was formerly done in subroutine c_sw but is being done here to +! avoid communication in OpenMP loops + +!$omp parallel do private(k, wk, wk2) + +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (K, WK, WK2) +#endif + do k=kfirst,klast + call d2a2c_winds(grid, u(1,jfirst-ng_d,k), v(1,jfirst-ng_s,k), & + ua(1,jfirst-ng_d,k), va(1,jfirst-ng_s,k), & + uc(1,jfirst-ng_d,k), vc(1,jfirst-2,k), & + u_cen(1,jfirst-ng_d,k), v_cen(1,jfirst-ng_s,k), & + reset_winds, met_rlx(k) ) + +! Optionally filter advecting C-grid winds + if (filtcw .gt. 0) then + call pft2d(uc(1,js2g0,k), grid%sc, grid%dc, im, jn2g0-js2g0+1, wk, wk2 ) + call pft2d(vc(1,js2g0,k), grid%se, grid%de, im, jlast-js2g0+1, wk, wk2 ) + endif + + enddo +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + +! Fill C-grid advecting winds Halo regions +! vc only needs to be ghosted at jlast+1 +#if defined( SPMD ) + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, uc ) + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, 2, 2, vc ) + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, uc ) + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, 2, 2, vc ) +#endif + + call FVstopclock(grid,'---PRE_C_CORE') + + call FVbarrierclock(grid,'sync_c_core', grid%commyz) + call FVstartclock(grid,'---C_CORE') + +#if !defined(INNER_OMP) +!$omp parallel do private(i, j, k, iord, jord) +#endif + +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (K, IORD, JORD) +#endif + + do k=kfirst,klast ! This is the main parallel loop. + + if ( k <= km/8 ) then + iord = 1 + jord = 1 + else + iord = iord_c + jord = jord_c + endif + +!----------------------------------------------------------------- +! Call the vertical independent part of the dynamics on the C-grid +!----------------------------------------------------------------- + + call c_sw( grid, u(1,jfirst-ng_d,k), v(1,jfirst-ng_s,k), & + pt(1,jfirst-ng_d,k), delp(1,jfirst,k), & + ua(1,jfirst-ng_d,k), va(1,jfirst-ng_s,k), & + uc(1,jfirst-ng_d,k), vc(1,jfirst-2,k), & + ptc(1,jfirst,k), delpf(1,jfirst-ng_d,k), & + ptk(1,jfirst,k), tiny, iord, jord) + enddo +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + + call FVstopclock(grid,'---C_CORE') + +! MPI note: uc, vc, ptk, and ptc computed within the above k-look from jfirst to jlast +! Needed by D-core: uc(jfirst-ng_d:jlast+ng_d), vc(jfirst:jlast+1) + + call FVbarrierclock(grid,'sync_c_geop', grid%commyz) + + end if ! (iam .lt. npes_yz) + + if (geopk_cdist) then + + if (iam .lt. npes_yz) then + +! +! Stay in yz space and use z communications +! + + if (grid%geopk16byte) then + call FVstartclock(grid,'---C_GEOP16') + call geopk16(grid, pe, ptk, pkcc, wzc, hs, ptc, & + 0, cp, akap) + else + call FVstartclock(grid,'---C_GEOP_D') + call geopk_d(grid, pe, ptk, pkcc, wzc, hs, ptc, & + 0, cp, akap) + endif + +! +! Geopk does not need j ghost zones of pkc and wz +! + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + pkc(i,j,k) = pkcc(i,j,k) + wz(i,j,k) = wzc(i,j,k) + enddo + enddo + enddo + + if (grid%geopk16byte) then + call FVstopclock(grid,'---C_GEOP16') + else + call FVstopclock(grid,'---C_GEOP_D') + endif + + end if ! (iam .lt. npes_yz) + + else + +! Begin xy geopotential section + + call FVstartclock(grid,'---C_GEOP') + + if (grid%twod_decomp == 1) then + +! +! Transpose to xy decomposition +! + +#if defined( SPMD ) + call FVstartclock(grid,'YZ_TO_XY_C_GEOP') + if (grid%modc_onetwo .eq. 1) then + call mp_sendirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptk, delpxy, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptk, delpxy, & + modc=grid%modc_cdcore ) + call mp_sendirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptc, ptxy, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptc, ptxy, & + modc=grid%modc_cdcore ) + else + call mp_sendirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptk, delpxy, & + ptc, ptxy, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptk, delpxy, & + ptc, ptxy, & + modc=grid%modc_cdcore ) + endif + call FVstopclock(grid,'YZ_TO_XY_C_GEOP') +#endif + + else + +!$omp parallel do private(i, j, k) + do k = kfirst, klast + do j = jfirst, jlast + do i = 1, im + delpxy(i,j,k) = ptk(i,j,k) + ptxy(i,j,k) = ptc(i,j,k) + enddo + enddo + enddo + + endif + + call geopk(grid, pexy, delpxy, pkxy, wzxy, hsxy, ptxy, & + cp, akap, nx) + + if (grid%twod_decomp == 1) then +! +! Transpose back to yz decomposition. +! pexy is not output quantity on this call. +! pkkp and wzkp are holding arrays, whose specific z-dimensions +! are required by Pilgrim. +! Z edge ghost points (klast+1) are automatically filled in +! + +#if defined( SPMD ) + + call FVstartclock(grid,'XY_TO_YZ_C_GEOP') + if (grid%modc_onetwo .eq. 1) then + call mp_sendirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + modc=grid%modc_cdcore ) + call mp_sendirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, wzxy, wzkp, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, wzxy, wzkp, & + modc=grid%modc_cdcore ) + else + call mp_sendirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + wzxy, wzkp, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + wzxy, wzkp, & + modc=grid%modc_cdcore ) + endif + call FVstopclock(grid,'XY_TO_YZ_C_GEOP') + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + pkc(i,j,k) = pkkp(i,j,k) + enddo + enddo + enddo + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + wz(i,j,k) = wzkp(i,j,k) + enddo + enddo + enddo + +#endif + + else + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + pkc(i,j,k) = pkxy(i,j,k) + wz(i,j,k) = wzxy(i,j,k) + enddo + enddo + enddo + + endif + + call FVstopclock(grid,'---C_GEOP') + +! End xy geopotential section + + endif ! geopk_cdist + + if (iam .lt. npes_yz) then + + call FVbarrierclock(grid,'sync_pre_d_core', grid%commyz) + call FVstartclock(grid,'---PRE_D_CORE') + +! Upon exit from geopk, the quantities pe, pkc and wz will have been +! updated at klast+1 + + +#if defined( SPMD ) +! +! pkc & wz need to be ghosted only at jfirst-1 +! + call FVstartclock(grid,'---PRE_D_CORE_COMM') + dest = iam+1 + src = iam-1 + if ( mod(iam+1,npr_y) == 0 ) dest = -1 + if ( mod(iam,npr_y) == 0 ) src = -1 + call mp_send3d_2( grid%commyz, dest, src, im, jm, km+1, & + 1, im, jfirst-1, jlast+1, kfirst, klast+1, & + 1, im, jlast, jlast, kfirst, klast+1, pkc, wz) + call FVstopclock(grid,'---PRE_D_CORE_COMM') +#endif + + + call FVstartclock(grid,'---C_U_LOOP') +! Beware k+1 references directly below (AAM) +! +!$omp parallel do private(i, j, k, p1d, wk, wk2) + +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (I, J, K, P1D, WK, WK2) +#endif + do k=kfirst,klast + do j=js2g0,jn2g0 + do i=1,im + p1d(i) = pkc(i,j,k+1) - pkc(i,j,k) + enddo + + uc(1,j,k) = uc(1,j,k) + grid%dtdx2(j) * ( & + (wz(im,j,k+1)-wz(1,j,k))*(pkc(1,j,k+1)-pkc(im,j,k)) & + + (wz(im,j,k)-wz(1,j,k+1))*(pkc(im,j,k+1)-pkc(1,j,k))) & + / (p1d(1)+p1d(im)) + do i=2,im + uc(i,j,k) = uc(i,j,k) + grid%dtdx2(j) * ( & + (wz(i-1,j,k+1)-wz(i,j,k))*(pkc(i,j,k+1)-pkc(i-1,j,k)) & + + (wz(i-1,j,k)-wz(i,j,k+1))*(pkc(i-1,j,k+1)-pkc(i,j,k))) & + / (p1d(i)+p1d(i-1)) + enddo + +! C.-C. Chen + do i=1,im + cx_om(i,j,k) = grid%dtdx(j)*uc(i,j,k) + enddo + enddo + call pft2d(uc(1,js2g0,k), grid%sc, & + grid%dc, im, jn2g0-js2g0+1, & + wk, wk2 ) + if ( jfirst == 1 ) then ! Clean up + do i=1,im + uc(i,1,k) = D0_0 + cx_om(i,1,k) = D0_0 + enddo + endif + if ( jlast == jm ) then ! Clean up + do i=1,im + uc(i,jm,k) = D0_0 + cx_om(i,jm,k) = D0_0 + enddo + endif + + enddo +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + call FVstopclock(grid,'---C_U_LOOP') + +#if defined( SPMD ) + call FVstartclock(grid,'---PRE_D_CORE_COMM') + call mp_recv3d_2( grid%commyz, src, im, jm, km+1, & + 1, im, jfirst-1, jlast+1, kfirst, klast+1, & + 1, im, jfirst-1, jfirst-1, kfirst, klast+1, pkc, wz) + + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, uc ) + call FVstopclock(grid,'---PRE_D_CORE_COMM') +#endif + + call FVstartclock(grid,'---C_V_PGRAD') +! +! Beware k+1 references directly below (AAM) +! +!$omp parallel do private(i, j, k, wk, wk1 ) + +! pkc and wz need only to be ghosted jfirst-1 + +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (I, J, K, WK, WK1 ) +#endif + do k=kfirst,klast + do j=js1g1,jlast + do i=1,im + wk1(i,j) = pkc(i,j,k+1) - pkc(i,j,k) + enddo + enddo + + do j=js2g0,jlast + do i=1,im + vc(i,j,k) = vc(i,j,k) + grid%dtdy5/(wk1(i,j)+wk1(i,j-1)) * & + ( (wz(i,j-1,k+1)-wz(i,j,k))*(pkc(i,j,k+1)-pkc(i,j-1,k)) & + + (wz(i,j-1,k)-wz(i,j,k+1))*(pkc(i,j-1,k+1)-pkc(i,j,k)) ) + +! C.-C. Chen + cy_om(i,j,k) = grid%dtdy*vc(i,j,k) + enddo + enddo + + call pft2d(vc(1,js2g0,k), grid%se, & + grid%de, im, jlast-js2g0+1, wk, wk1 ) + enddo +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + + call FVstopclock(grid,'---C_V_PGRAD') + +#if defined( SPMD ) + call FVstartclock(grid,'---PRE_D_CORE_COMM') + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, uc ) + +! vc only needs to be ghosted at jlast+1 + dest = iam-1 + src = iam+1 + if ( mod(iam,npr_y) == 0 ) dest = -1 + if ( mod(iam+1,npr_y) == 0 ) src = -1 + call mp_send3d( grid%commyz, dest, src, im, jm, km, & + 1, im, jfirst-2, jlast+2, kfirst, klast, & + 1, im, jfirst, jfirst, kfirst, klast, vc ) + call mp_recv3d( grid%commyz, src, im, jm, km, & + 1, im, jfirst-2, jlast+2, kfirst, klast, & + 1, im, jlast+1, jlast+1, kfirst, klast, vc ) + call FVstopclock(grid,'---PRE_D_CORE_COMM') + +! C.-C. Chen + call mp_send3d( grid%commyz, dest, src, im, jm, km, & + 1, im, jfirst, jlast+1, kfirst, klast, & + 1, im, jfirst, jfirst, kfirst, klast, cy_om ) + call mp_recv3d( grid%commyz, src, im, jm, km, & + 1, im, jfirst, jlast+1, kfirst, klast, & + 1, im, jlast+1, jlast+1, kfirst, klast, cy_om ) +#endif + + call FVstopclock(grid,'---PRE_D_CORE') + + call FVbarrierclock(grid,'sync_d_core', grid%commyz) + call FVstartclock(grid,'---D_CORE') + +#if !defined(INNER_OMP) +!$omp parallel do private(i, j, k, iord, jord) +#endif +#if !defined(USE_OMP) +!CSD$ PARALLEL DO PRIVATE (K, IORD, JORD) +#endif + + do k=kfirst,klast + + if( k <= km/8 ) then + if( k == 1 ) then + iord = 1 + jord = 1 + else + iord = min(2, iord_d) + jord = min(2, jord_d) + endif + else + iord = iord_d + jord = jord_d + endif + +!----------------------------------------------------------------- +! Call the vertical independent part of the dynamics on the D-grid +!----------------------------------------------------------------- + + call d_sw( grid, u(1,jfirst-ng_d,k), v(1,jfirst-ng_s,k), & + uc(1,jfirst-ng_d,k), vc(1,jfirst-2,k), & + pt(1,jfirst-ng_d,k), delp(1,jfirst,k), & + delpf(1,jfirst-ng_d,k), cx3(1,jfirst-ng_d,k), & + cy3(1,jfirst,k), mfx(1,jfirst,k), & + mfy(1,jfirst,k), & + grid%cdx (js2g0:,k),grid%cdy (js2g0:,k), & + grid%cdxde (js2g0:,k),grid%cdxdp (js2g0:,k), & + grid%cdyde(js2g0:,k) ,grid%cdydp(js2g0:,k), & + grid%cdxdiv(:,k),grid%cdydiv(:,k) , & + grid%cdx4 (js2g0:,k),grid%cdy4(js2g0:,k) , & + grid%cdtau4(js2g0:,k), ldiv2, ldiv4, ldel2, & + iord, jord, tiny ) + + enddo +#if !defined(USE_OMP) +!CSD$ END PARALLEL DO +#endif + + call FVstopclock(grid,'---D_CORE') + + call FVbarrierclock(grid,'sync_d_geop', grid%commyz) + +#if defined( SPMD ) + if (s_trac) then +! post sends for ct_overlap or tracer decomposition information + do ml = 1, mlt + call mpiisend(cx3, ncx, mpir8, iremote(ml), cxtag(ml), grid%commnyz, cxreqs(ml)) + call mpiisend(cy3, ncy, mpir8, iremote(ml), cytag(ml), grid%commnyz, cyreqs(ml)) + call mpiisend(mfx, nmfx, mpir8, iremote(ml), mfxtag(ml), grid%commnyz, mfxreqs(ml)) + call mpiisend(mfy, nmfy, mpir8, iremote(ml), mfytag(ml), grid%commnyz, mfyreqs(ml)) + enddo + endif +#endif + + end if ! (iam .lt. npes_yz) + + if (geopk_ddist) then + + if (iam .lt. npes_yz) then + +! +! Stay in yz space and use z communications + + if (grid%geopk16byte) then + call FVstartclock(grid,'---D_GEOP16') + call geopk16(grid, pe, delp, pkcc, wzc, hs, pt, & + ng_d, cp, akap) + else + call FVstartclock(grid,'---D_GEOP_D') + call geopk_d(grid, pe, delp, pkcc, wzc, hs, pt, & + ng_d, cp, akap) + endif + +! +! Geopk does not need j ghost zones of pkc and wz +! + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + pkc(i,j,k) = pkcc(i,j,k) + wz(i,j,k) = wzc(i,j,k) + enddo + enddo + enddo + + if (grid%geopk16byte) then + call FVstopclock(grid,'---D_GEOP16') + else + call FVstopclock(grid,'---D_GEOP_D') + endif + + end if ! (iam .lt. npes_yz) + + else + +! Begin xy geopotential section + + call FVstartclock(grid,'---D_GEOP') + + if (grid%twod_decomp == 1) then +! +! Transpose to xy decomposition +! + +#if defined( SPMD ) + +!$omp parallel do private(i,j,k) + do k=kfirst,klast + do j=jfirst,jlast + do i=1,im + ptc(i,j,k) = pt(i,j,k) + enddo + enddo + enddo + + call FVstartclock(grid,'YZ_TO_XY_D_GEOP') + if (grid%modc_onetwo .eq. 1) then + call mp_sendirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, delp, delpxy, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, delp, delpxy, & + modc=grid%modc_cdcore ) + call mp_sendirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptc, ptxy, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, ptc, ptxy, & + modc=grid%modc_cdcore ) + else + call mp_sendirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, delp, delpxy, & + ptc, ptxy, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%ijk_yz_to_xy%SendDesc, & + grid%ijk_yz_to_xy%RecvDesc, delp, delpxy, & + ptc, ptxy, & + modc=grid%modc_cdcore ) + endif + call FVstopclock(grid,'YZ_TO_XY_D_GEOP') +#endif + + else + +!$omp parallel do private(i,j,k) + do k=kfirst,klast + do j=jfirst,jlast + do i=1,im + delpxy(i,j,k) = delp(i,j,k) + ptxy(i,j,k) = pt(i,j,k) + enddo + enddo + enddo + + endif + + call geopk(grid, pexy, delpxy, pkxy, wzxy, hsxy, ptxy, & + cp, akap, nx) + + if (grid%twod_decomp == 1) then +! +! Transpose back to yz decomposition +! Z edge ghost points (klast+1) are automatically filled in +! pexy is output quantity on last small timestep +! + +#if defined( SPMD ) + + call FVstartclock(grid,'XY_TO_YZ_D_GEOP') + if (grid%modc_onetwo .eq. 1) then + call mp_sendirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + modc=grid%modc_cdcore ) + call mp_sendirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, wzxy, wzkp, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, wzxy, wzkp, & + modc=grid%modc_cdcore ) + else + call mp_sendirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + wzxy, wzkp, & + modc=grid%modc_cdcore ) + call mp_recvirr( grid%commxy, grid%pkxy_to_pkc%SendDesc, & + grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & + wzxy, wzkp, & + modc=grid%modc_cdcore ) + endif + call FVstopclock(grid,'XY_TO_YZ_D_GEOP') + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + pkc(i,j,k) = pkkp(i,j,k) + enddo + enddo + enddo + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + wz(i,j,k) = wzkp(i,j,k) + enddo + enddo + enddo +#endif + + else + +!$omp parallel do private(i, j, k) + do k = kfirst, klast+1 + do j = jfirst, jlast + do i = 1, im + pkc(i,j,k) = pkxy(i,j,k) + wz(i,j,k) = wzxy(i,j,k) + enddo + enddo + enddo + + endif + + call FVstopclock(grid,'---D_GEOP') + +! End xy geopotential section + + endif ! geopk_ddist + + if (iam .lt. npes_yz) then + + call FVbarrierclock(grid,'sync_pre_d_pgrad', grid%commyz) + +! +! Upon exit from geopk, the quantities pe, pkc and wz will have been +! updated at klast+1 + + call FVstartclock(grid,'---PRE_D_PGRAD') + +#if defined( SPMD ) + call FVstartclock(grid,'---PRE_D_PGRAD_COMM_1') +! Exchange boundary regions on north and south for pkc and wz + call mp_send2_ns( grid%commyz, im, jm, km+1, jfirst, jlast, & + kfirst, klast+1, 1, pkc, wz) + call FVstopclock(grid,'---PRE_D_PGRAD_COMM_1') +#endif + + if ( ipe /= 1 ) then ! not the last call +! +! Perform some work while sending data on the way +! + + call FVstartclock(grid,'---D_DELP_LOOP') + +!$omp parallel do private(i, j, k, wk, wk2) + +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (I, J, K, WK, WK2) +#endif + do k=kfirst,klast + do j=jfirst,jlast + do i=1,im + delpf(i,j,k) = delp(i,j,k) + enddo + enddo + call pft2d( delpf(1,js2g0,k), grid%sc, & + grid%dc, im, jn2g0-js2g0+1, & + wk, wk2 ) + enddo +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + call FVstopclock(grid,'---D_DELP_LOOP') + + else +! Last call +!$omp parallel do private(i, j, k) + do k=kfirst,klast+1 + do j=jfirst,jlast + do i=1,im + pk(i,j,k) = pkc(i,j,k) + enddo + enddo + enddo + endif + +#if defined( SPMD ) + call FVstartclock(grid,'---PRE_D_PGRAD_COMM_1') + call mp_recv2_ns( grid%commyz, im, jm, km+1, jfirst, jlast, & + kfirst, klast+1, 1, pkc, wz) + if ( ipe /= 1 ) then ! not the last call + call mp_send4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, delpf ) + endif + call FVstopclock(grid,'---PRE_D_PGRAD_COMM_1') +#endif + + +! +! Beware k+1 references directly below (AAM) +! +!$omp parallel do private(i, j, k) + + do k=kfirst,klast + do j=js1g1,jn1g1 ! dpt needed NS + do i=1,im ! wz, pkc ghosted NS + dpt(i,j,k)=(wz(i,j,k+1)+wz(i,j,k))*(pkc(i,j,k+1)-pkc(i,j,k)) + enddo + enddo + enddo + +! GHOSTING: wz (input) NS ; pkc (input) NS + + call FVstopclock(grid,'---PRE_D_PGRAD') + call FVstartclock(grid,'---D_PGRAD_1') + +!$omp parallel do private(i, j, k, wk3, wk1) +#if !defined(USE_OMP) +!CSD$ PARALLEL DO PRIVATE (I, J, K, WK3, WK1) +#endif + do k=kfirst,klast+1 + + if (k == 1) then + do j=js2g0,jlast + do i=1,im + wz3(i,j,1) = D0_0 + wz(i,j,1) = D0_0 + enddo + enddo + pk4 = D4_0*grid%ptop**akap + do j=js2g0,jn1g1 + do i=1,im + pkc(i,j,1) = pk4 + enddo + enddo + go to 4500 + endif + + do j=js2g1,jn2g0 ! wk3 needed S + wk3(1,j) = (wz(1,j,k)+wz(im,j,k)) * & + (pkc(1,j,k)-pkc(im,j,k)) + do i=2,im + wk3(i,j) = (wz(i,j,k)+wz(i-1,j,k)) * & + (pkc(i,j,k)-pkc(i-1,j,k)) + enddo + enddo + + do j=js2g1,jn2g0 + do i=1,im-1 + wk1(i,j) = wk3(i,j) + wk3(i+1,j) + enddo + wk1(im,j) = wk3(im,j) + wk3(1,j) ! wk3 ghosted S + enddo + + if ( jfirst == 1 ) then + do i=1,im + wk1(i, 1) = D0_0 + enddo + endif + + if ( jlast == jm ) then + do i=1,im + wk1(i,jm) = D0_0 + enddo + endif + + do j=js2g0,jlast ! wk1 ghosted S + do i=1,im + wz3(i,j,k) = wk1(i,j) + wk1(i,j-1) + enddo + enddo + +! N-S walls + + do j=js2g0,jn1g1 ! wk1 needed N + do i=1,im ! wz, pkc ghosted NS + wk1(i,j) = (wz(i,j,k)+wz(i,j-1,k))*(pkc(i,j,k)-pkc(i,j-1,k)) + enddo + enddo + + do j=js2g0,jn1g1 ! wk3 needed N + wk3(1,j) = wk1(1,j) + wk1(im,j) ! wk1 ghosted N + do i=2,im + wk3(i,j) = wk1(i,j) + wk1(i-1,j) ! wk1 ghosted N + enddo + enddo + + do j=js2g0,jn2g0 + do i=1,im + wz(i,j,k) = wk3(i,j) + wk3(i,j+1) ! wk3 ghosted N + enddo + enddo + + do j=js1g1,jn1g1 + wk1(1,j) = pkc(1,j,k) + pkc(im,j,k) + do i=2,im + wk1(i,j) = pkc(i,j,k) + pkc(i-1,j,k) + enddo + enddo + + do j=js2g0,jn1g1 + do i=1,im + pkc(i,j,k) = wk1(i,j) + wk1(i,j-1) + enddo + enddo + +4500 continue + enddo + +#if !defined(USE_OMP) +!CSD$ END PARALLEL DO +#endif + call FVstopclock(grid,'---D_PGRAD_1') + call FVstartclock(grid,'---D_PGRAD_2') + +! GHOSTING: dpt (loop 4000) NS ; pkc (loop 4500) N +! +! Beware k+1 references directly below (AAM) +! +!$omp parallel do private(i, j, k, wk, wk1, wk2, wk3) +#if (!defined USE_OMP) +!CSD$ PARALLEL DO PRIVATE (i, j, k, wk, wk1, wk2, wk3) +#endif + do 6000 k=kfirst,klast + + do j=js1g1,jn1g1 + wk1(1,j) = dpt(1,j,k) + dpt(im,j,k) + do i=2,im + wk1(i,j) = dpt(i,j,k) + dpt(i-1,j,k) + enddo + enddo + + do j=js2g0,jn1g1 + do i=1,im + wk2(i,j) = wk1(i,j) + wk1(i,j-1) + wk(i,j) = pkc(i,j,k+1) - pkc(i,j,k) + enddo + enddo + + do j=js2g0,jlast + do i=1,im-1 + wk3(i,j) = uc(i,j,k) + grid%dtdxe(j)/(wk(i,j) + wk(i+1,j)) & + * (wk2(i,j)-wk2(i+1,j)+wz3(i,j,k+1)-wz3(i,j,k)) + enddo + wk3(im,j) = uc(im,j,k) + grid%dtdxe(j)/(wk(im,j) + wk(1,j)) & + * (wk2(im,j)-wk2(1,j)+wz3(im,j,k+1)-wz3(im,j,k)) + enddo + + do j=js2g0,jn2g0 ! Assumes wk2 ghosted on N + do i=1,im + wk1(i,j) = vc(i,j,k) + grid%dtdy/(wk(i,j)+wk(i,j+1)) * & + (wk2(i,j)-wk2(i,j+1)+wz(i,j,k+1)-wz(i,j,k)) + enddo + enddo + + call pft2d( wk3(1,js2g0), grid%se, & + grid%de, im, jlast-js2g0+1, & + wk, wk2 ) + call pft2d( wk1(1,js2g0), grid%sc, & + grid%dc, im, jn2g0-js2g0+1, & + wk, wk2 ) + + do j=js2g0,jn2g0 + do i=1,im + v(i,j,k) = v(i,j,k) + wk1(i,j) + u(i,j,k) = u(i,j,k) + wk3(i,j) + enddo + enddo + + if ( jlast == jm ) then + do i=1,im + u(i,jlast,k) = u(i,jlast,k) + wk3(i,jlast) + enddo + endif + +6000 continue +#if (!defined USE_OMP) +!CSD$ END PARALLEL DO +#endif + call FVstopclock(grid,'---D_PGRAD_2') + +#if defined( SPMD ) + if ( ipe /= 1 ) then + call FVstartclock(grid,'---PRE_D_PGRAD_COMM_2') + call mp_recv4d_ns( grid%commyz, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, delpf ) + call FVstopclock(grid,'---PRE_D_PGRAD_COMM_2') + endif +#endif + + end if ! (iam .lt. npes_yz) + + return +!EOC + end subroutine cd_core +!----------------------------------------------------------------------- diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/src/dynamics/se/interp_mod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/src/dynamics/se/interp_mod.F90 new file mode 100644 index 0000000000..9c973e572e --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cam/src/dynamics/se/interp_mod.F90 @@ -0,0 +1,508 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_2_1/models/atm/cam/src/dynamics/se/interp_mod.F90 + +module interp_mod + use cam_logfile, only : iulog + use shr_kind_mod, only : r8 => shr_kind_r8 + use dimensions_mod, only : nelemd, np + use interpolate_mod, only : interpolate_scalar, setup_latlon_interp, set_interp_parameter, get_interp_lat, get_interp_lon, & + var_is_vector_uvar, var_is_vector_vvar, interpolate_vector, interpdata_t, get_interp_gweight + use dyn_grid, only : elem, w + use spmd_utils, only : masterproc, iam + use cam_pio_utils, only: phys_decomp, fillvalue + use hybrid_mod, only : hybrid_t, hybrid_create + use abortutils, only: endrun + + implicit none + private + type(interpdata_t), pointer :: cam_interpolate(:) + + public get_interp_lat, get_interp_lon, setup_history_interpolation, write_interpolated + public var_is_vector_uvar, var_is_vector_vvar, latlon_interpolation, add_interp_attributes + + interface write_interpolated + module procedure write_interpolated_scalar + module procedure write_interpolated_vector + end interface + type(hybrid_t) :: hybrid + +contains + + subroutine add_interp_attributes(file) + use pio, only : file_desc_t, pio_put_att, pio_global + use interpolate_mod, only : get_interp_parameter + type(file_desc_t) :: file + + integer :: ierr + integer :: itmp + + itmp = get_interp_parameter('itype') + if(itmp == 0) then + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_type', 'se basis functions') + else if(itmp == 1) then + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_type', 'bilinear') + else + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_type', itmp) + end if + + itmp = get_interp_parameter('gridtype') + select case(itmp) + case(1) + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_outputgridtype', 'equally spaced with poles') + case(2) + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_outputgridtype', 'Gauss') + case(3) + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_outputgridtype', 'equally spaced no poles') + case default + ierr = pio_put_att(file, PIO_GLOBAL, 'interp_outputgridtype', itmp) + end select + + + end subroutine add_interp_attributes + + subroutine setup_history_interpolation(mtapes) + + use dyn_comp, only : dom_mt + use parallel_mod, only: par + use thread_mod, only: omp_get_thread_num + use interpolate_mod, only : interpolate_analysis, get_interp_parameter + implicit none + + integer, intent(in) :: mtapes + integer :: ithr, nthreads + + if(iam>= par%nprocs) return + + ithr=omp_get_thread_num() + hybrid = hybrid_create(par,ithr,1) + + if(any(interpolate_analysis(1:mtapes))) then + allocate(cam_interpolate(nelemd)) + call setup_latlon_interp(elem, cam_interpolate, par) + allocate(w(get_interp_parameter('nlat'))) + w = get_interp_gweight() + end if + + end subroutine setup_history_interpolation + + function latlon_interpolation(t) + use interpolate_mod, only : interpolate_analysis + integer, intent(in) :: t + + logical :: latlon_interpolation + + latlon_interpolation = interpolate_analysis(t) + end function latlon_interpolation + + + + subroutine write_interpolated_scalar(File, varid, fld, numlev, data_type, decomp_type) + use pio, only : file_desc_t, io_desc_t, var_desc_t, pio_write_darray, iosystem_desc_t, & + pio_initdecomp, pio_freedecomp, pio_setdebuglevel + use spmd_dyn, only: local_dp_map, block_buf_nrecs, chunk_buf_nrecs + use ppgrid, only : begchunk, endchunk, pcols, pver + use phys_grid, only : get_gcol_all_p, get_ncols_p, chunk_to_block_send_pters, chunk_to_block_recv_pters, & + transpose_chunk_to_block + use dyn_grid, only: get_gcol_block_d + use dimensions_mod, only: npsq + use element_mod, only : element_t + use dof_mod, only : PutUniquePoints + use interpolate_mod, only : get_interp_parameter + use shr_pio_mod, only : shr_pio_getiosys + use edge_mod, only : edgebuffer_t, edgevpack, edgevunpack, initedgebuffer, freeedgebuffer + use bndry_mod, only : bndry_exchangeV + use parallel_mod, only: par + use abortutils, only : endrun + + ! KDR BUGFIX: allow write_interpolated_YYY to call shr_pio_getiosys with + ! 'ATM####' instead of 'ATM'. #### is the instance number. + use cam_instance, only: atm_id + + implicit none + type(file_desc_t), intent(inout) :: File + type(var_desc_t), intent(inout) :: varid + real(r8), intent(in) :: fld(:,:,:) + integer, intent(in) :: numlev, data_type, decomp_type + + type(io_desc_t) :: iodesc + + integer :: lchnk, i, j, m, icol, ncols, pgcols(pcols), ierr + integer :: idmb1(1), idmb2(1), idmb3(1) + integer :: bpter(npsq,0:pver) ! offsets into block buffer for packing data + integer :: cpter(pcols,0:pver) ! offsets into chunk buffer for unpacking data + + real(r8), pointer :: dest(:,:,:,:) + real(r8), pointer :: bbuffer(:), cbuffer(:), fldout(:,:) + real(r8) :: fld_dyn(npsq,numlev,nelemd) + integer :: st, en, ie, ioff, ncnt_out, k + integer, pointer :: idof(:) + integer :: nlon, nlat, ncol + logical :: usefillvalues=.false. + type(iosystem_desc_t), pointer :: pio_subsystem + type (EdgeBuffer_t) :: edgebuf ! edge buffer + + + + nlon=get_interp_parameter('nlon') + nlat=get_interp_parameter('nlat') + ! KDR 'ATM' doesn't work for multi-instance runs. + ! pio_subsystem => shr_pio_getiosys('ATM') + pio_subsystem => shr_pio_getiosys(atm_id) + + if(decomp_type==phys_decomp) then + fld_dyn = -999_R8 + if(local_dp_map) then + !$omp parallel do private (lchnk, ncols, pgcols, icol, idmb1, idmb2, idmb3, ie, ioff, m) + do lchnk=begchunk,endchunk + ncols=get_ncols_p(lchnk) + call get_gcol_all_p(lchnk,pcols,pgcols) + do icol=1,ncols + call get_gcol_block_d(pgcols(icol),1,idmb1,idmb2,idmb3) + ie = idmb3(1) + ioff=idmb2(1) + do k=1,numlev + fld_dyn(ioff,k,ie) = fld(icol, k, lchnk-begchunk+1) + end do + end do + + end do + else + + allocate( bbuffer(block_buf_nrecs*numlev) ) + allocate( cbuffer(chunk_buf_nrecs*numlev) ) + + !$omp parallel do private (lchnk, ncols, cpter, i, icol) + do lchnk = begchunk,endchunk + ncols = get_ncols_p(lchnk) + + call chunk_to_block_send_pters(lchnk,pcols,pver+1,1,cpter) + + do i=1,ncols + cbuffer(cpter(i,1):cpter(i,1)) = 0.0_r8 + end do + + do icol=1,ncols + + cbuffer (cpter(icol,:)) = fld(icol,:,lchnk-begchunk+1) + end do + + end do + + call transpose_chunk_to_block(1, cbuffer, bbuffer) + if(iam < par%nprocs) then +!$omp parallel do private (ie, bpter, icol) + do ie=1,nelemd + + call chunk_to_block_recv_pters(elem(ie)%GlobalID,npsq,pver+1,1,bpter) + ncols = elem(ie)%idxp%NumUniquePts + do icol=1,ncols + fld_dyn (icol,:,ie) = bbuffer(bpter(icol,:)) + end do + + end do + end if + deallocate( bbuffer ) + deallocate( cbuffer ) + + end if + allocate(dest(np,np,numlev,nelemd)) + call initEdgeBuffer(edgebuf, numlev) + + do ie=1,nelemd + ncols = elem(ie)%idxp%NumUniquePts + call putUniquePoints(elem(ie)%idxP, numlev, fld_dyn(1:ncols,:,ie), dest(:,:,:,ie)) + call edgeVpack(edgebuf, dest(:,:,:,ie), numlev, 0, elem(ie)%desc) + enddo + if(iam < par%nprocs) then + call bndry_exchangeV(par, edgebuf) + end if + do ie=1,nelemd + call edgeVunpack(edgebuf, dest(:,:,:,ie), numlev, 0, elem(ie)%desc) + end do + call freeEdgeBuffer(edgebuf) + usefillvalues = any(dest == fillvalue) + else + usefillvalues=any(fld==fillvalue) + allocate(dest(np,np,numlev,1)) + end if + + ncnt_out = sum(cam_interpolate(1:nelemd)%n_interp) + allocate(fldout(ncnt_out,numlev)) + allocate(idof(ncnt_out*numlev)) + fldout = -999_r8 + idof = 0 + st = 1 + + + + do ie=1,nelemd + ncol = cam_interpolate(ie)%n_interp + do k=0,numlev-1 + do i=1,ncol + idof(st+i-1+k*ncnt_out)=cam_interpolate(ie)%ilon(i)+nlon*(cam_interpolate(ie)%ilat(i)-1)+nlon*nlat*k + enddo + enddo + + ! Now that we have the field on the dyn grid we need to interpolate + en = st+cam_interpolate(ie)%n_interp-1 + if(decomp_type==phys_decomp) then + if(usefillvalues) then + call interpolate_scalar(cam_interpolate(ie),dest(:,:,:,ie), np, numlev, fldout(st:en,:), fillvalue) + else + call interpolate_scalar(cam_interpolate(ie),dest(:,:,:,ie), np, numlev, fldout(st:en,:)) + end if + else + do j=1,np + do i=1,np + dest(i,j,:,1) = fld(i+(j-1)*np,:,ie) + end do + end do + if(usefillvalues) then + call interpolate_scalar(cam_interpolate(ie),dest(:,:,:,1), & + np, numlev, fldout(st:en,:), fillvalue) + else + call interpolate_scalar(cam_interpolate(ie),dest(:,:,:,1), & + np, numlev, fldout(st:en,:)) + end if + end if + + + st = en+1 + end do + + + if(numlev==1) then + call pio_initdecomp(pio_subsystem, data_type, (/nlon,nlat/), idof, iodesc) + else + call pio_initdecomp(pio_subsystem, data_type, (/nlon,nlat,numlev/), idof, iodesc) + end if + call pio_write_darray(File, varid, iodesc, fldout, ierr) + + deallocate(dest) + + deallocate(fldout) + deallocate(idof) + call pio_freedecomp(file,iodesc) + + end subroutine write_interpolated_scalar + + + + + subroutine write_interpolated_vector(File, varidu, varidv, fldu, fldv, numlev, data_type, decomp_type) + use pio, only : file_desc_t, io_desc_t, var_desc_t, pio_write_darray, iosystem_desc_t, & + pio_initdecomp, pio_freedecomp, pio_setdebuglevel + use spmd_dyn, only: local_dp_map, block_buf_nrecs, chunk_buf_nrecs + use ppgrid, only : begchunk, endchunk, pcols, pver + use phys_grid, only : get_gcol_all_p, get_ncols_p, chunk_to_block_send_pters, chunk_to_block_recv_pters, & + transpose_chunk_to_block + use dyn_grid, only: get_gcol_block_d + use dimensions_mod, only: npsq + use element_mod, only : element_t + use dof_mod, only : PutUniquePoints + use interpolate_mod, only : get_interp_parameter + use shr_pio_mod, only : shr_pio_getiosys + use edge_mod, only : edgebuffer_t, edgevpack, edgevunpack, initedgebuffer, freeedgebuffer + use bndry_mod, only : bndry_exchangeV + use parallel_mod, only: par + + ! KDR BUGFIX: allow write_interpolated_YYY to call shr_pio_getiosys with + ! 'ATM####' instead of 'ATM'. #### is the instance number. + use cam_instance, only: atm_id + + implicit none + type(file_desc_t), intent(inout) :: File + type(var_desc_t), intent(inout) :: varidu, varidv + real(r8), intent(in) :: fldu(:,:,:), fldv(:,:,:) + integer, intent(in) :: numlev, data_type, decomp_type + + type(io_desc_t) :: iodesc + + integer :: lchnk, i, j, m, icol, ncols, pgcols(pcols), ierr + integer :: idmb1(1), idmb2(1), idmb3(1) + integer :: bpter(npsq,0:pver) ! offsets into block buffer for packing data + integer :: cpter(pcols,0:pver) ! offsets into chunk buffer for unpacking data + + real(r8), allocatable :: dest(:,:,:,:,:) + real(r8), pointer :: bbuffer(:), cbuffer(:), fldout(:,:,:) + real(r8) :: fld_dyn(npsq,2,numlev,nelemd) + integer :: st, en, ie, ioff, ncnt_out, k + integer, pointer :: idof(:) + integer :: nlon, nlat, ncol + logical :: usefillvalues=.false. + + type(iosystem_desc_t), pointer :: pio_subsystem + type (EdgeBuffer_t) :: edgebuf ! edge buffer + + + + nlon=get_interp_parameter('nlon') + nlat=get_interp_parameter('nlat') + ! KDR 'ATM' doesn't work for multi-instance runs. + ! pio_subsystem => shr_pio_getiosys('ATM') + pio_subsystem => shr_pio_getiosys(atm_id) + + fld_dyn = -999_R8 + if(decomp_type==phys_decomp) then + allocate(dest(np,np,2,numlev,nelemd)) + if(local_dp_map) then + !$omp parallel do private (lchnk, ncols, pgcols, icol, idmb1, idmb2, idmb3, ie, ioff, m) + do lchnk=begchunk,endchunk + ncols=get_ncols_p(lchnk) + call get_gcol_all_p(lchnk,pcols,pgcols) + + do icol=1,ncols + call get_gcol_block_d(pgcols(icol),1,idmb1,idmb2,idmb3) + ie = idmb3(1) + ioff=idmb2(1) + do k=1,numlev + fld_dyn(ioff,1,k,ie) = fldu(icol, k, lchnk-begchunk+1) + fld_dyn(ioff,2,k,ie) = fldv(icol, k, lchnk-begchunk+1) + end do + end do + + end do + else + + allocate( bbuffer(2*block_buf_nrecs*numlev) ) + allocate( cbuffer(2*chunk_buf_nrecs*numlev) ) + + !$omp parallel do private (lchnk, ncols, cpter, i, icol) + do lchnk = begchunk,endchunk + ncols = get_ncols_p(lchnk) + + call chunk_to_block_send_pters(lchnk,pcols,pver+1,2,cpter) + + do i=1,ncols + cbuffer(cpter(i,1):cpter(i,1)) = 0.0_r8 + end do + + do icol=1,ncols + do k=1,numlev + cbuffer (cpter(icol,k)) = fldu(icol,k,lchnk-begchunk+1) + cbuffer (cpter(icol,k)+1) = fldv(icol,k,lchnk-begchunk+1) + end do + end do + + end do + + call transpose_chunk_to_block(2, cbuffer, bbuffer) + if(iam < par%nprocs) then + !$omp parallel do private (ie, bpter, icol) + do ie=1,nelemd + + call chunk_to_block_recv_pters(elem(ie)%GlobalID,npsq,pver+1,2,bpter) + ncols = elem(ie)%idxp%NumUniquePts + do icol=1,ncols + do k=1,numlev + fld_dyn (icol,1,k,ie) = bbuffer(bpter(icol,k)) + fld_dyn (icol,2,k,ie) = bbuffer(bpter(icol,k)+1) + enddo + end do + + end do + end if + deallocate( bbuffer ) + deallocate( cbuffer ) + + end if + call initEdgeBuffer(edgebuf, 2*numlev) + + do ie=1,nelemd + ncols = elem(ie)%idxp%NumUniquePts + call putUniquePoints(elem(ie)%idxP, 2, numlev, fld_dyn(1:ncols,:,:,ie), dest(:,:,:,:,ie)) + + call edgeVpack(edgebuf, dest(:,:,:,:,ie), 2*numlev, 0, elem(ie)%desc) + enddo + if(iam < par%nprocs) then + call bndry_exchangeV(par, edgebuf) + end if + + do ie=1,nelemd + call edgeVunpack(edgebuf, dest(:,:,:,:,ie), 2*numlev, 0, elem(ie)%desc) + enddo + call freeEdgeBuffer(edgebuf) + usefillvalues = any(dest==fillvalue) + else + usefillvalues = (any(fldu==fillvalue) .or. any(fldv==fillvalue)) + allocate(dest(np,np,2,numlev,1)) + endif + ncnt_out = sum(cam_interpolate(1:nelemd)%n_interp) + allocate(fldout(ncnt_out,numlev,2)) + allocate(idof(ncnt_out*numlev)) + + fldout = -999_r8 + idof = 0 + st = 1 + do ie=1,nelemd + ncol = cam_interpolate(ie)%n_interp + do k=0,numlev-1 + do i=1,ncol + idof(st+i-1+k*ncnt_out)=cam_interpolate(ie)%ilon(i)+nlon*(cam_interpolate(ie)%ilat(i)-1)+nlon*nlat*k + enddo + enddo + + + ! Now that we have the field on the dyn grid we need to interpolate + en = st+cam_interpolate(ie)%n_interp-1 + if(decomp_type==phys_decomp) then + if(usefillvalues) then + call interpolate_vector(cam_interpolate(ie),elem(ie), & + dest(:,:,:,:,ie), np, numlev, fldout(st:en,:,:), 0, fillvalue) + else + call interpolate_vector(cam_interpolate(ie),elem(ie),& + dest(:,:,:,:,ie), np, numlev, fldout(st:en,:,:), 0) + endif + else + do k=1,numlev + do j=1,np + do i=1,np + dest(i,j,1,k,1) = fldu(i+(j-1)*np,k,ie) + dest(i,j,1,k,1) = fldv(i+(j-1)*np,k,ie) + end do + end do + end do + if(usefillvalues) then + call interpolate_vector(cam_interpolate(ie),elem(ie),& + dest(:,:,:,:,1), np, numlev, fldout(st:en,:,:), 0, fillvalue) + else + call interpolate_vector(cam_interpolate(ie),elem(ie),& + dest(:,:,:,:,1), np, numlev, fldout(st:en,:,:), 0) + end if + end if + + st = en+1 + end do + + if(numlev==1) then + call pio_initdecomp(pio_subsystem, data_type, (/nlon,nlat/), idof, iodesc) + else + call pio_initdecomp(pio_subsystem, data_type, (/nlon,nlat,numlev/), idof, iodesc) + end if + + call pio_write_darray(File, varidu, iodesc, fldout(:,:,1), ierr) + + call pio_write_darray(File, varidv, iodesc, fldout(:,:,2), ierr) + + + deallocate(fldout) + deallocate(idof) + deallocate(dest) + call pio_freedecomp(file,iodesc) + + end subroutine write_interpolated_vector + + + + + + + + + + + + +end module interp_mod + diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cice/ice_aerosol.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cice/ice_aerosol.F90 new file mode 100644 index 0000000000..6a6f3bd511 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cice/ice_aerosol.F90 @@ -0,0 +1,779 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_2_1/models/ice/cice/src/source/ice_aerosol.F90 + +!======================================================================= +! +!BOP +! +! !MODULE: ice_aerosol - Aerosol tracer within sea ice +! +! !DESCRIPTION: +! +! !REVISION HISTORY: +! SVN:$$ +! +! authors Marika Holland, NCAR +! David Bailey, NCAR +! +! !INTERFACE: +! + module ice_aerosol +! +! !USES: +! + use ice_kinds_mod + use ice_constants + use ice_fileunits + use ice_restart, only: lenstr, restart_dir, restart_file, & + pointer_file, runtype + use ice_communicate, only: my_task, master_task + use ice_exit, only: abort_ice +! +!EOP +! + implicit none + + logical (kind=log_kind) :: & + restart_aero ! if .true., read aerosol tracer restart file + +!======================================================================= + + contains + +!======================================================================= +!BOP +! +! !ROUTINE: init_aerosol +! +! !DESCRIPTION: +! +! Initialize ice aerosol tracer (call prior to reading restart data) +! +! !REVISION HISTORY: same as module +! +! !INTERFACE: +! + subroutine init_aerosol +! +! !USES: +! + use ice_state, only: filename_aero +! +!EOP +! + + if (trim(filename_aero) /= 'none') restart_aero = .true. + + if (restart_aero) then + if (trim(runtype) == 'continue') then + call read_restart_aero + else + call read_restart_aero(filename_aero) + endif + endif + + end subroutine init_aerosol + +!======================================================================= + +!BOP +! +! !ROUTINE: update_aerosol +! +! !DESCRIPTION: +! +! Increase aerosol in ice or snow surface due to deposition +! +! !REVISION HISTORY: same as module +! +! !INTERFACE: +! + subroutine update_aerosol (nx_block, ny_block, & + dt, icells, & + indxi, indxj, & + meltt, melts, & + meltb, congel, & + snoice, & + fsnow, & + trcrn, & + aice_old, & + vice_old, vsno_old, & + vicen, vsnon, aicen, & + faero, fsoot) +! +! !USES: +! + use ice_domain_size, only: max_ntrcr, nilyr, nslyr, n_aero, n_aeromx + use ice_state, only: nt_aero +! +! !INPUT/OUTPUT PARAMETERS: +! + integer (kind=int_kind), intent(in) :: & + nx_block, ny_block, & ! block dimensions + icells ! number of cells with ice present + + integer (kind=int_kind), dimension (nx_block*ny_block), & + intent(in) :: & + indxi, indxj ! compressed indices for cells with ice + + real (kind=dbl_kind), intent(in) :: & + dt ! time step + + real (kind=dbl_kind), dimension(nx_block,ny_block), & + intent(in) :: & + meltt, & + melts, & + meltb, & + congel, & + snoice, & + fsnow, & + vicen, & + vsnon, & + aicen, & + aice_old, & + vice_old, & + vsno_old + + real (kind=dbl_kind), dimension(nx_block,ny_block,n_aeromx), & + intent(in) :: & + faero + + real (kind=dbl_kind), dimension(nx_block,ny_block,n_aeromx), & + intent(inout) :: & + fsoot + + real (kind=dbl_kind), dimension(nx_block,ny_block,max_ntrcr), & + intent(inout) :: & + trcrn + +! +! local variables +! + integer (kind=int_kind) :: i, j, ij, k + integer (kind=int_kind) :: n ! print_points +! + real (kind=dbl_kind), dimension(icells) :: & + dzssl, & + dzint, & + dzssli, & + dzinti + + real (kind=dbl_kind), dimension(icells) :: & + dhs_evap, dhi_evap, & + dhs_melts, dhs_snoice, dhi_meltt, dhi_snoice, & + dhi_congel, dhi_meltb + real (kind=dbl_kind), dimension(icells,n_aeromx) :: & + aerotot, aerotot0 ! for diagnostics + + real (kind=dbl_kind) :: & + dzssl_new, & + dzint_new, & + dzssli_new, & + dzinti_new, & + dznew + + real (kind=dbl_kind), dimension(nx_block,ny_block,n_aeromx,2) :: & + aerosno, aeroice, & + aerosno0, aeroice0 ! for diagnostic prints + + real (kind=dbl_kind), dimension(nx_block,ny_block,n_aeromx) :: & + fsoot_old + + real (kind=dbl_kind) :: & + hs_old, hi_old, hslyr_old, hilyr_old, dhs, dhi, hs, hi, & + hslyr, hilyr, sloss1, sloss2 + real (kind=dbl_kind), dimension(n_aeromx) :: & + kscav, kscavsi + +!MH These need to be the same as in the DE code. Put in a common place? + real (kind=dbl_kind) :: & + hi_ssl, hs_ssl + + data hs_ssl / .040_dbl_kind / + data hi_ssl / .050_dbl_kind / + data kscav / .03_dbl_kind, .20_dbl_kind,& + .02_dbl_kind,.02_dbl_kind,.01_dbl_kind,.01_dbl_kind / + data kscavsi / .03_dbl_kind, .20_dbl_kind,& + .02_dbl_kind,.02_dbl_kind,.01_dbl_kind,.01_dbl_kind / + + aerosno(:,:,:,:) = c0 + aeroice(:,:,:,:) = c0 + aerosno0(:,:,:,:) = c0 + aeroice0(:,:,:,:) = c0 + fsoot_old(:,:,:) = fsoot(:,:,:) + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + + hs_old=vsno_old(i,j)/aice_old(i,j) + hi_old=vice_old(i,j)/aice_old(i,j) + hslyr_old=hs_old/real(nslyr,kind=dbl_kind) + hilyr_old=hi_old/real(nilyr,kind=dbl_kind) + + dzssl(ij)=min(hslyr_old/c2,hs_ssl) + dzint(ij)=hs_old-dzssl(ij) + dzssli(ij)=min(hilyr_old/c2,hi_ssl) + dzinti(ij)=hi_old-dzssli(ij) + + if (aicen(i,j) > c0) then + hs = vsnon(i,j)/aicen(i,j) + hi = vicen(i,j)/aicen(i,j) + dhs_melts(ij)=-melts(i,j)/aicen(i,j) + dhi_snoice(ij)=snoice(i,j)/aicen(i,j) + dhs_snoice(ij)=dhi_snoice(ij)*rhoi/rhos + dhi_meltt(ij)=-meltt(i,j)/aicen(i,j) + dhi_meltb(ij)=-meltb(i,j)/aicen(i,j) + dhi_congel(ij)=congel(i,j)/aicen(i,j) + else + hs = vsnon(i,j)/aice_old(i,j) + hi = vicen(i,j)/aice_old(i,j) + dhs_melts(ij)=-melts(i,j)/aice_old(i,j) + dhi_snoice(ij)=snoice(i,j)/aice_old(i,j) + dhs_snoice(ij)=dhi_snoice(ij)*rhoi/rhos + dhi_meltt(ij)=-meltt(i,j)/aice_old(i,j) + dhi_meltb(ij)=-meltb(i,j)/aice_old(i,j) + dhi_congel(ij)=congel(i,j)/aice_old(i,j) + endif + + dhs_evap(ij)=hs-(hs_old+dhs_melts(ij)-dhs_snoice(ij)+& + fsnow(i,j)/rhos*dt) + dhi_evap(ij)=hi-(hi_old+dhi_meltt(ij)+dhi_meltb(ij)+ & + dhi_congel(ij)+dhi_snoice(ij)) + enddo + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + do k=1,n_aero + aerosno(i,j,k,:)=& + trcrn(i,j,nt_aero+(k-1)*4 :nt_aero+(k-1)*4+1)*vsno_old(i,j) ! aerosol in snow + aeroice(i,j,k,:)=& + trcrn(i,j,nt_aero+(k-1)*4+2:nt_aero+(k-1)*4+3)*vice_old(i,j) ! aerosol in ice + aerosno0(i,j,k,:)=aerosno(i,j,k,:) + aeroice0(i,j,k,:)=aeroice(i,j,k,:) + aerotot0(ij,k)=aerosno(i,j,k,2)+aerosno(i,j,k,1) & + +aeroice(i,j,k,2)+aeroice(i,j,k,1) + enddo + enddo + +! apply evaporation + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + dzint(ij)=dzint(ij) + min(dzssl(ij)+dhs_evap(ij),c0) + dzssl(ij)=max(dzssl(ij)+dhs_evap(ij),c0) + dzinti(ij)=dzinti(ij) + min(dzssli(ij)+dhi_evap(ij),c0) + dzssli(ij)=max(dzssli(ij)+dhi_evap(ij),c0) + enddo + +! basal ice growth + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + dzinti(ij)=dzinti(ij)+dhi_congel(ij) + enddo + +! surface snow melt + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (-dhs_melts(ij) > puny) then + do k=1,n_aero + sloss1=c0 + sloss2=c0 + if (dzssl(ij) > puny) & + sloss1=kscav(k)*aerosno(i,j,k,1) & + *min(-dhs_melts(ij),dzssl(ij))/dzssl(ij) + aerosno(i,j,k,1)=aerosno(i,j,k,1)-sloss1 + if (dzint(ij) > puny) & + sloss2=kscav(k)*aerosno(i,j,k,2) & + *max(-dhs_melts(ij)-dzssl(ij),c0)/dzint(ij) + aerosno(i,j,k,2)=aerosno(i,j,k,2)-sloss2 + fsoot(i,j,k)=fsoot(i,j,k)+(sloss1+sloss2)/dt + enddo ! n_aero + +! update snow thickness + dzint(ij)=dzint(ij)+min(dzssl(ij)+dhs_melts(ij),c0) + dzssl(ij)=max(dzssl(ij)+dhs_melts(ij),c0) + + if ( dzssl(ij) <= puny ) then ! ssl melts away + aerosno(i,j,:,2)=aerosno(i,j,:,1)+aerosno(i,j,:,2) + aerosno(i,j,:,1)=c0 + dzssl(ij)=max(dzssl(ij),c0) + endif + if (dzint(ij) <= puny ) then ! all snow melts away + aeroice(i,j,:,1)=& + aeroice(i,j,:,1)+aerosno(i,j,:,1)+aerosno(i,j,:,2) + aerosno(i,j,:,:)=c0 + dzint(ij)=max(dzint(ij),c0) + endif + endif + enddo + +! surface ice melt + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (-dhi_meltt(ij) > puny) then + do k=1,n_aero + sloss1=c0 + sloss2=c0 + if (dzssli(ij) > puny) & + sloss1=kscav(k)*aeroice(i,j,k,1) & + *min(-dhi_meltt(ij),dzssli(ij))/dzssli(ij) + aeroice(i,j,k,1)=aeroice(i,j,k,1)-sloss1 + if (dzinti(ij) > puny) & + sloss2=kscav(k)*aeroice(i,j,k,2) & + *max(-dhi_meltt(ij)-dzssli(ij),c0)/dzinti(ij) + aeroice(i,j,k,2)=aeroice(i,j,k,2)-sloss2 + fsoot(i,j,k)=fsoot(i,j,k)+(sloss1+sloss2)/dt + enddo + + dzinti(ij)=dzinti(ij)+min(dzssli(ij)+dhi_meltt(ij),c0) + dzssli(ij)=max(dzssli(ij)+dhi_meltt(ij),c0) + if (dzssli(ij) <= puny) then ! ssl ice melts away + do k=1,n_aero + aeroice(i,j,k,2)=aeroice(i,j,k,1)+aeroice(i,j,k,2) + aeroice(i,j,k,1)=c0 + enddo + dzssli(ij)=max(dzssli(ij),c0) + endif + if (dzinti(ij) <= puny) then ! all ice melts away + do k=1,n_aero + fsoot(i,j,k)=fsoot(i,j,k) & + +(aeroice(i,j,k,1)+aeroice(i,j,k,2))/dt + aeroice(i,j,k,:)=c0 + enddo + dzinti(ij)=max(dzinti(ij),c0) + endif + endif + enddo + +! basal ice melt. Assume all soot lost in basal melt + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (-dhi_meltb(ij) > puny) then + do k=1,n_aero + sloss1=c0 + sloss2=c0 + if (dzssli(ij) > puny) & + sloss1=max(-dhi_meltb(ij)-dzinti(ij),c0) & + *aeroice(i,j,k,1)/dzssli(ij) + aeroice(i,j,k,1)=aeroice(i,j,k,1)-sloss1 + if (dzinti(ij) > puny) & + sloss2=min(-dhi_meltb(ij),dzinti(ij)) & + *aeroice(i,j,k,2)/dzinti(ij) + aeroice(i,j,k,2)=aeroice(i,j,k,2)-sloss2 + fsoot(i,j,k)=fsoot(i,j,k)+(sloss1+sloss2)/dt + enddo + + dzssli(ij) = dzssli(ij)+min(dzinti(ij)+dhi_meltb(ij), c0) + dzinti(ij) = max(dzinti(ij)+dhi_meltb(ij), c0) + endif + enddo + +! snowfall + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (fsnow(i,j) > c0) & + dzssl(ij)=dzssl(ij)+fsnow(i,j)/rhos*dt + enddo + +! snoice formation + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (dhs_snoice(ij) > puny) then + do k=1,n_aero + sloss1=c0 + sloss2=c0 + if (dzint(ij) > puny) & + sloss2 = min(dhs_snoice(ij),dzint(ij)) & + *aerosno(i,j,k,2)/dzint(ij) + aerosno(i,j,k,2) = aerosno(i,j,k,2) - sloss2 + if (dzssl(ij) > puny) & + sloss1 = max(dhs_snoice(ij)-dzint(ij),c0) & + *aerosno(i,j,k,1)/dzssl(ij) + aerosno(i,j,k,1) = aerosno(i,j,k,1) - sloss1 + aeroice(i,j,k,1) = aeroice(i,j,k,1) & + + (c1-kscavsi(k))*(sloss2+sloss1) + fsoot(i,j,k)=fsoot(i,j,k)+kscavsi(k)*(sloss2+sloss1)/dt + enddo + dzssl(ij)=dzssl(ij)-max(dhs_snoice(ij)-dzint(ij),c0) + dzint(ij)=max(dzint(ij)-dhs_snoice(ij),c0) + dzssli(ij)=dzssli(ij)+dhi_snoice(ij) + endif + enddo + +! aerosol deposition + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (aicen(i,j) > c0) then + hs = vsnon(i,j) / aicen(i,j) + else + hs = c0 + endif + if (hs > hsmin) then ! should this really be hsmin or 0? + ! should use same hsmin value as in radiation + do k=1,n_aero + aerosno(i,j,k,1)=aerosno(i,j,k,1) & + + faero(i,j,k)*dt*aicen(i,j) + enddo + else + do k=1,n_aero + aeroice(i,j,k,1)=aeroice(i,j,k,1) & + + faero(i,j,k)*dt*aicen(i,j) + enddo + endif + enddo + +! redistribute aerosol within vertical layers + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (aicen(i,j) > c0) then + hs = vsnon(i,j) / aicen(i,j) ! new snow thickness + hi = vicen(i,j) / aicen(i,j) ! new ice thickness + else + hs = c0 + hi = c0 + endif + if (dzssl(ij) <= puny) then ! nothing in SSL + do k=1,n_aero + aerosno(i,j,k,2)=aerosno(i,j,k,2)+aerosno(i,j,k,1) + aerosno(i,j,k,1)=c0 + enddo + endif + if (dzint(ij) <= puny) then ! nothing in Snow Int + do k=1,n_aero + aeroice(i,j,k,1)=aeroice(i,j,k,1)+aerosno(i,j,k,2) + aerosno(i,j,k,2)=c0 + enddo + endif + if (dzssli(ij) <= puny) then ! nothing in Ice SSL + do k=1,n_aero + aeroice(i,j,k,2)=aeroice(i,j,k,2)+aeroice(i,j,k,1) + aeroice(i,j,k,1)=c0 + enddo + endif + + if (dzinti(ij) <= puny) then ! nothing in Ice INT + do k=1,n_aero + fsoot(i,j,k)=fsoot(i,j,k)+& + (aeroice(i,j,k,1)+aeroice(i,j,k,2))/dt + aeroice(i,j,k,:)=c0 + enddo + endif + + hslyr=hs/real(nslyr,kind=dbl_kind) + hilyr=hi/real(nilyr,kind=dbl_kind) + dzssl_new=min(hslyr/c2,hs_ssl) ! ssl for snow + dzint_new=hs-dzssl_new + dzssli_new=min(hilyr/c2,hi_ssl) ! ssl for ice + dzinti_new=hi-dzssli_new + + if (hs > hsmin) then + do k=1,n_aero + dznew=min(dzssl_new-dzssl(ij),c0) + sloss1=c0 + if (dzssl(ij) > puny) & + sloss1=dznew*aerosno(i,j,k,1)/dzssl(ij) ! not neccesarily a loss term + dznew=max(dzssl_new-dzssl(ij),c0) + if (dzint(ij) > puny) & + sloss1=sloss1+aerosno(i,j,k,2)*dznew/dzint(ij) ! not really a loss term + aerosno(i,j,k,1) =aerosno(i,j,k,1)+sloss1 + aerosno(i,j,k,2) =aerosno(i,j,k,2)-sloss1 + enddo + else + aeroice(i,j,:,1)=aeroice(i,j,:,1) & + +aerosno(i,j,:,1)+aerosno(i,j,:,2) + aerosno(i,j,:,:) = c0 + endif + + if (vicen(i,j) > puny) then ! may want a limit on hi instead? + do k=1,n_aero + sloss2=c0 + dznew=min(dzssli_new-dzssli(ij),c0) + if (dzssli(ij) > puny) & + sloss2=dznew*aeroice(i,j,k,1)/dzssli(ij) + dznew=max(dzssli_new-dzssli(ij),c0) + if (dzinti(ij) > puny) & + sloss2=sloss2+aeroice(i,j,k,2)*dznew/dzinti(ij) ! not really a loss term + aeroice(i,j,k,1) =aeroice(i,j,k,1)+sloss2 + aeroice(i,j,k,2) =aeroice(i,j,k,2)-sloss2 + enddo + else + fsoot(i,j,:)=fsoot(i,j,:)+(aeroice(i,j,:,1)+aeroice(i,j,:,2))/dt + aeroice(i,j,:,:) = c0 + endif + + do k=1,n_aero + aerotot(ij,k)=aerosno(i,j,k,2)+aerosno(i,j,k,1) & + +aeroice(i,j,k,2)+aeroice(i,j,k,1) + if ( ( (aerotot(ij,k)-aerotot0(ij,k)) & + - ( faero(i,j,k)*aicen(i,j) & + - (fsoot(i,j,k)-fsoot_old(i,j,k)) )*dt ) > 0.00001) then +!AK write(nu_diag,*) 'aerosol tracer: ',k +!AK write(nu_diag,*) 'aerotot-aerotot0 ',aerotot(ij,k)-aerotot0(ij,k) +!AK write(nu_diag,*) 'faero-fsoot ',faero(i,j,k)*aicen(i,j)*dt & +!AK -(fsoot(i,j,k)-fsoot_old(i,j,k))*dt + endif + enddo + enddo + +! reload tracers + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (vicen(i,j) > puny) & + aeroice(i,j,:,:)=aeroice(i,j,:,:)/vicen(i,j) + if (vsnon(i,j) > puny) & + aerosno(i,j,:,:)=aerosno(i,j,:,:)/vsnon(i,j) + do k=1,n_aero + do n=1,2 + trcrn(i,j,nt_aero+(k-1)*4+n-1)=aerosno(i,j,k,n) + trcrn(i,j,nt_aero+(k-1)*4+n+1)=aeroice(i,j,k,n) + enddo +! do n=1,4 +! if (trcrn(i,j,nt_aero+(k-1)*4+n-1) < puny) then +! fsoot(i,j,k)=fsoot(i,j,k)+ & +! trcrn(i,j,nt_aero+(k-1)*4+n-1)/dt +! trcrn(i,j,nt_aero+(k-1)*4+n-1)=c0 +! endif +! enddo + enddo + enddo + + do ij = 1, icells + i = indxi(ij) + j = indxj(ij) + if (trcrn(i,j,nt_aero) < -puny .or. trcrn(i,j,nt_aero+1) < -puny & + .or. trcrn(i,j,nt_aero+2) < -puny .or. trcrn(i,j,nt_aero+3) < -puny) then + if (my_task == master_task) then !AK + write(nu_diag,*) 'MH aerosol negative in aerosol code' + write(nu_diag,*) 'MH INT neg in aerosol my_task = ',& + my_task & + ,' printing point = ',n & + ,' i and j = ',i,j +!AK write(nu_diag,*) 'MH Int Neg aero snowssl= ',aerosno0(i,j,1,1) +!AK write(nu_diag,*) 'MH Int Neg aero new snowssl= ',aerosno(i,j,1,1) +!AK write(nu_diag,*) 'MH Int Neg aero snowint= ',aerosno0(i,j,1,2) +!AK write(nu_diag,*) 'MH Int Neg aero new snowint= ',aerosno(i,j,1,2) +!AK write(nu_diag,*) 'MH Int Neg aero ice_ssl= ',aeroice0(i,j,1,1) +!AK write(nu_diag,*) 'MH Int Neg aero new ice_ssl= ',aeroice(i,j,1,1) +!AK write(nu_diag,*) 'MH Int Neg aero ice_int= ',aeroice0(i,j,1,2) +!AK write(nu_diag,*) 'MH Int Neg aero new ice_int= ',aeroice(i,j,1,2) +!AK write(nu_diag,*) 'MH Int Neg aero aicen= ',aicen(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero vicen= ',vicen(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero vsnon= ',vsnon(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero viceold= ',vice_old(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero vsnoold= ',vsno_old(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero melts= ',melts(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero meltt= ',meltt(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero meltb= ',meltb(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero congel= ',congel(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero snoice= ',snoice(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero evap sno?= ',dhs_evap(ij) +!AK write(nu_diag,*) 'MH Int Neg aero evap ice?= ',dhi_evap(ij) +!AK write(nu_diag,*) 'MH Int Neg aero fsnow= ',fsnow(i,j) +!AK write(nu_diag,*) 'MH Int Neg aero faero= ',faero(i,j,1) +!AK write(nu_diag,*) 'MH Int Neg aero fsoot= ',fsoot(i,j,1) + end if ! + trcrn(i,j,nt_aero)=max(trcrn(i,j,nt_aero),c0) + trcrn(i,j,nt_aero+1)=max(trcrn(i,j,nt_aero+1),c0) + trcrn(i,j,nt_aero+2)=max(trcrn(i,j,nt_aero+2),c0) + trcrn(i,j,nt_aero+3)=max(trcrn(i,j,nt_aero+3),c0) + endif + enddo + + end subroutine update_aerosol + + + +!======================================================================= +!---! these subroutines write/read Fortran unformatted data files .. +!======================================================================= +! +!BOP +! +! !IROUTINE: write_restart_aero - dumps all fields required for restart +! +! !INTERFACE: +! + subroutine write_restart_aero(filename_spec) +! +! !DESCRIPTION: +! +! Dumps all values needed for restarting +! +! !REVISION HISTORY: +! +! authors Elizabeth Hunke, LANL (original version) +! David Bailey, NCAR +! Marika Holland, NCAR +! +! !USES: +! + use ice_domain_size + use ice_calendar, only: sec, month, mday, nyr, istep1, & + time, time_forc, idate, year_init + use ice_state + use ice_read_write + use ice_restart, only: lenstr, restart_dir, restart_file, pointer_file +! +! !INPUT/OUTPUT PARAMETERS: +! + character(len=char_len_long), intent(in), optional :: filename_spec + +!EOP +! + integer (kind=int_kind) :: & + i, j, k, n, it, iblk, & ! counting indices + iyear, imonth, iday ! year, month, day + + character(len=char_len_long) :: filename + + logical (kind=log_kind) :: diag + + ! construct path/file + if (present(filename_spec)) then + filename = trim(filename_spec) + else + iyear = nyr + year_init - 1 + imonth = month + iday = mday + + write(filename,'(a,a,a,i4.4,a,i2.2,a,i2.2,a,i5.5)') & + restart_dir(1:lenstr(restart_dir)), & + restart_file(1:lenstr(restart_file)),'.aero.', & + iyear,'-',month,'-',mday,'-',sec + end if + + ! begin writing restart data + call ice_open(nu_dump_aero,filename,0) + + if (my_task == master_task) then + write(nu_dump_aero) istep1,time,time_forc + write(nu_diag,*) 'Writing ',filename(1:lenstr(filename)) + endif + + diag = .true. + + !----------------------------------------------------------------- + + do k = 1, n_aero + do n = 1, ncat + call ice_write(nu_dump_aero,0,trcrn(:,:,nt_aero +(k-1)*4,n,:),'ruf8',diag) + call ice_write(nu_dump_aero,0,trcrn(:,:,nt_aero+1+(k-1)*4,n,:),'ruf8',diag) + call ice_write(nu_dump_aero,0,trcrn(:,:,nt_aero+2+(k-1)*4,n,:),'ruf8',diag) + call ice_write(nu_dump_aero,0,trcrn(:,:,nt_aero+3+(k-1)*4,n,:),'ruf8',diag) + enddo + enddo + + if (my_task == master_task) close(nu_dump_aero) + + end subroutine write_restart_aero + +!======================================================================= +!BOP +! +! !IROUTINE: read_restart_aero - reads all fields required for restart +! +! !INTERFACE: +! + subroutine read_restart_aero(filename_spec) +! +! !DESCRIPTION: +! +! Reads all values needed for an ice aerosol restart +! +! !REVISION HISTORY: +! +! authors Elizabeth Hunke, LANL (original version) +! David Bailey, NCAR +! Marika Holland, NCAR +! +! !USES: +! + use ice_domain_size + use ice_calendar, only: sec, month, mday, nyr, istep1, & + time, time_forc, idate, year_init + use ice_state + use ice_read_write + use ice_restart, only: lenstr, restart_dir, restart_file, pointer_file +! +! !INPUT/OUTPUT PARAMETERS: +! + character(len=char_len_long), intent(in), optional :: filename_spec + +!EOP +! + integer (kind=int_kind) :: & + i, j, k, n, it, iblk, & ! counting indices + iyear, imonth, iday ! year, month, day + + character(len=char_len_long) :: & + filename, filename0, string1, string2 + + logical (kind=log_kind) :: & + diag + + if (my_task == master_task) then + ! reconstruct path/file + if (present(filename_spec)) then + filename = filename_spec + else + open(nu_rst_pointer,file=pointer_file) + read(nu_rst_pointer,'(a)') filename0 + filename = trim(filename0) + close(nu_rst_pointer) + + n = index(filename0,trim(restart_file)) + if (n == 0) call abort_ice('soot restart: filename discrepancy') + string1 = trim(filename0(1:n-1)) + string2 = trim(filename0(n+lenstr(restart_file):lenstr(filename0))) + write(filename,'(a,a,a,a)') & + string1(1:lenstr(string1)), & + restart_file(1:lenstr(restart_file)),'.aero', & + string2(1:lenstr(string2)) + endif + endif ! master_task + + call ice_open(nu_restart_aero,filename,0) + + if (my_task == master_task) then + read(nu_restart_aero) istep1,time,time_forc + write(nu_diag,*) 'Reading ',filename(1:lenstr(filename)) + endif + + diag = .true. + + !----------------------------------------------------------------- + + do k = 1, n_aero + do n = 1, ncat + call ice_read(nu_restart_aero,0,trcrn(:,:,nt_aero +(k-1)*4,n,:),'ruf8',& + diag,field_type=field_type_scalar,field_loc=field_loc_center) + call ice_read(nu_restart_aero,0,trcrn(:,:,nt_aero+1+(k-1)*4,n,:),'ruf8',& + diag,field_type=field_type_scalar,field_loc=field_loc_center) + call ice_read(nu_restart_aero,0,trcrn(:,:,nt_aero+2+(k-1)*4,n,:),'ruf8',& + diag,field_type=field_type_scalar,field_loc=field_loc_center) + call ice_read(nu_restart_aero,0,trcrn(:,:,nt_aero+3+(k-1)*4,n,:),'ruf8',& + diag,field_type=field_type_scalar,field_loc=field_loc_center) + enddo + enddo + + if (my_task == master_task) close(nu_restart_aero) + + end subroutine read_restart_aero + +!======================================================================= + + end module ice_aerosol + +!======================================================================= diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cice/ice_diagnostics.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cice/ice_diagnostics.F90 new file mode 100644 index 0000000000..e0a446ce6b --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.cice/ice_diagnostics.F90 @@ -0,0 +1,1382 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_2_1/models/ice/cice/src/source/ice_diagnostics.F90 + +!======================================================================= +!BOP +! +! !MODULE: ice_diagnostics - diagnostic information output during run +! +! !DESCRIPTION: +! +! Diagnostic information output during run +! +! !REVISION HISTORY: +! SVN:$Id: ice_diagnostics.F90 52 2007-01-30 18:04:24Z eclare $ +! +! authors: Elizabeth C. Hunke, LANL +! Bruce P. Briegleb, NCAR +! +! 2004: Block structure added by William Lipscomb +! 2006: Converted to free source form (F90) by Elizabeth Hunke +! +! !INTERFACE: +! + module ice_diagnostics +! +! !USES: +! + use ice_kinds_mod + use ice_communicate, only: my_task, master_task + use ice_constants + use ice_calendar, only: diagfreq, istep1, istep + use ice_fileunits + use ice_domain_size +! +!EOP +! + implicit none + save + + ! diagnostic output file + character (len=char_len) :: diag_file + + ! point print data + + logical (kind=log_kind) :: & + print_points , & ! if true, print point data + print_global ! if true, print global data + + integer (kind=int_kind), parameter :: & + npnt = 2 ! total number of points to be printed + + ! Set to true to identify unstable fast-moving ice. + logical (kind=log_kind), parameter :: & + check_umax = .false. ! if true, check for speed > umax_stab + + real (kind=dbl_kind), parameter :: & + umax_stab = 1.0_dbl_kind , & ! ice speed threshold for instability (m/s) + aice_extmin = 0.15_dbl_kind ! min aice value for ice extent calc + + real (kind=dbl_kind), dimension(npnt) :: & + latpnt , & ! latitude of diagnostic points + lonpnt ! longitude of diagnostic points + + integer (kind=int_kind) :: & + iindx , & ! i index for points + jindx , & ! j index for points + bindx ! block index for points + + ! for water and heat budgets + real (kind=dbl_kind), dimension(npnt) :: & + pdhi , & ! change in mean ice thickness (m) + pdhs , & ! change in mean snow thickness (m) + pde , & ! change in ice and snow energy (J m-2) + plat, plon ! latitude, longitude of points + + integer (kind=int_kind), dimension(npnt) :: & + piloc, pjloc, pbloc, pmloc ! location of diagnostic points + + ! for hemispheric water and heat budgets + real (kind=dbl_kind) :: & + totmn , & ! total ice/snow water mass (nh) + totms , & ! total ice/snow water mass (sh) + totmin , & ! total ice water mass (nh) + totmis , & ! total ice water mass (sh) + toten , & ! total ice/snow energy (J) + totes ! total ice/snow energy (J) + real (kind=dbl_kind), dimension(n_aeromx) :: & + totaeron , & ! total aerosol mass + totaeros ! total aerosol mass + + ! printing info for routine print_state + ! iblkp, ip, jp, mtask identify the grid cell to print + character (char_len) :: plabel + integer (kind=int_kind), parameter :: & + check_step = 999999999, & ! begin printing at istep1=check_step + iblkp = 1, & ! block number + ip = 3, & ! i index + jp = 5, & ! j index + mtask = 0 ! my_task + +!======================================================================= + + contains + +!======================================================================= +!BOP +! +! !IROUTINE: runtime_diags - writes max,min,global sums to standard out +! +! !INTERFACE: +! + subroutine runtime_diags (dt) +! +! !DESCRIPTION: +! +! Writes diagnostic info (max, min, global sums, etc) to standard out +! +! !REVISION HISTORY: +! +! authors: Elizabeth C. Hunke, LANL +! Bruce P. Briegleb, NCAR +! Cecilia M. Bitz, UW +! +! !USES: +! + use ice_broadcast + use ice_global_reductions + use ice_blocks + use ice_domain +!MH use ice_domain_size + use ice_flux + use ice_state + use ice_grid, only: lmask_n, lmask_s, tarean, tareas, grid_type + use ice_therm_vertical, only: calc_Tsfc + +#ifdef CCSMCOUPLED + use ice_prescribed_mod, only : prescribed_ice +#endif +! +! !INPUT/OUTPUT PARAMETERS: +! + real (kind=dbl_kind), intent(in) :: & + dt ! time step +! +!EOP +! + integer (kind=int_kind) :: & + i, j, k, n, ii,jj, iblk + + ! hemispheric state quantities + real (kind=dbl_kind) :: & + umaxn, hmaxn, shmaxn, arean, snwmxn, extentn, & + umaxs, hmaxs, shmaxs, areas, snwmxs, extents, & + etotn, mtotn, micen, msnwn, pmaxn, ketotn, & + etots, mtots, mices, msnws, pmaxs, ketots, & + urmsn, albtotn, arean_alb, & + urmss, albtots, areas_alb + + ! hemispheric flux quantities + real (kind=dbl_kind) :: & + rnn, snn, frzn, hnetn, fhocnn, fhatmn, fhfrzn, & + rns, sns, frzs, hnets, fhocns, fhatms, fhfrzs, & + sfsaltn, sfreshn, evpn, fluxn , delmxn, delmin, & + sfsalts, sfreshs, evps, fluxs , delmxs, delmis, & + delein, werrn, herrn, msltn, delmsltn, serrn, & + deleis, werrs, herrs, mslts, delmslts, serrs, & + ftmp,faeron,faeros,fsootn,fsoots + +! MH for aerosol diagnostics + integer (kind=int_kind) :: & + kaero, naero + real (kind=dbl_kind) :: & + aeromx1n, aeromx1s, aeromx2n, aeromx2s, & + aeromx3n, aeromx3s, aoermx4, & + aerototn, aerotots !MH + + ! fields at diagnostic points + real (kind=dbl_kind), dimension(npnt) :: & + paice, pTair, pQa, pfsnow, pfrain, pfsw, pflw, & + pTsfc, pevap, pfswabs, pflwout, pflat, pfsens, & + pfsurf, pfcondtop, psst, pTf, hiavg, hsavg, pfhocn, & + pmeltt, pmeltb, pmeltl, psnoice, pfrazil, pcongel + + real (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: & + work1, work2 + + !----------------------------------------------------------------- + ! state of the ice + !----------------------------------------------------------------- + ! hemispheric quantities + + ! total ice area + arean = global_sum(aice, distrb_info, field_loc_center, tarean) + areas = global_sum(aice, distrb_info, field_loc_center, tareas) + arean = arean * m2_to_km2 + areas = areas * m2_to_km2 + + ! ice extent (= area of grid cells with aice > aice_extmin) + work1(:,:,:) = c0 + + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + if (aice(i,j,iblk) >= aice_extmin) work1(i,j,iblk) = c1 + enddo + enddo + enddo + !$OMP END PARALLEL DO + extentn = global_sum(work1, distrb_info, field_loc_center, & + tarean) + extents = global_sum(work1, distrb_info, field_loc_center, & + tareas) + extentn = extentn * m2_to_km2 + extents = extents * m2_to_km2 + + ! total ice volume + shmaxn = global_sum(vice, distrb_info, field_loc_center, tarean) + shmaxs = global_sum(vice, distrb_info, field_loc_center, tareas) + + ! total snow volume + snwmxn = global_sum(vsno, distrb_info, field_loc_center, tarean) + snwmxs = global_sum(vsno, distrb_info, field_loc_center, tareas) + + ! total ice-snow kinetic energy + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = p5 & + * (rhos*vsno(i,j,iblk) + rhoi*vice(i,j,iblk)) & + * (uvel(i,j,iblk)**2 + vvel(i,j,iblk)**2) + enddo + enddo + enddo + !$OMP END PARALLEL DO + ketotn = global_sum(work1, distrb_info, field_loc_center, tarean) + ketots = global_sum(work1, distrb_info, field_loc_center, tareas) + + ! rms ice speed + urmsn = c2*ketotn/(rhoi*shmaxn + rhos*snwmxn + puny) + if (urmsn > puny) then + urmsn = sqrt(urmsn) + else + urmsn = c0 + endif + + urmss = c2*ketots/(rhoi*shmaxs + rhos*snwmxs + puny) + if (urmss > puny) then + urmss = sqrt(urmss) + else + urmss = c0 + endif + + ! average ice albedo + ! mask out cells where sun is below horizon (for delta-Eddington) + + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = alvdr(i,j,iblk)*awtvdr & + + alidr(i,j,iblk)*awtidr & + + alvdf(i,j,iblk)*awtvdf & + + alidf(i,j,iblk)*awtidf + enddo + enddo + enddo + !$OMP END PARALLEL DO + + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + if (coszen(i,j,iblk) > puny) then + work2(i,j,iblk) = tarean(i,j,iblk) + else + work2(i,j,iblk) = c0 + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + + arean_alb = global_sum(aice, distrb_info, field_loc_center, work2) + + albtotn = global_sum_prod(aice, work1, distrb_info, & + field_loc_center, work2) + + if (arean_alb > c0) then + albtotn = albtotn / arean_alb + else + albtotn = c0 + endif + + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + if (coszen(i,j,iblk) > puny) then + work2(i,j,iblk) = tareas(i,j,iblk) + else + work2(i,j,iblk) = c0 + endif + enddo + enddo + enddo + !$OMP END PARALLEL DO + + areas_alb = global_sum(aice, distrb_info, field_loc_center, work2) + + albtots = global_sum_prod(aice, work1, distrb_info, & + field_loc_center, work2) + + if (areas_alb > c0) then + albtots = albtots / areas_alb + else + albtots = c0 + endif + + ! maximum ice volume (= mean thickness including open water) + hmaxn = global_maxval(vice, distrb_info, lmask_n) + hmaxs = global_maxval(vice, distrb_info, lmask_s) + +! MH put in aerosol diagnostics + if (tr_aero) then + ! aerosols + do naero=1,n_aero + faeron = global_sum_prod(faero(:,:,naero,:), aice_init, distrb_info, & + field_loc_center, tarean) + faeros = global_sum_prod(faero(:,:,naero,:), aice_init, distrb_info, & + field_loc_center, tareas) + faeron = faeron*dt + faeros = faeros*dt + + fsootn = global_sum_prod(fsoot(:,:,naero,:), aice, distrb_info, & + field_loc_center, tarean) + fsoots = global_sum_prod(fsoot(:,:,naero,:), aice, distrb_info, & + field_loc_center, tareas) + fsootn = fsootn*dt + fsoots = fsoots*dt + + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = trcr(i,j,nt_aero +4*(naero-1),iblk) *vsno(i,j,iblk) & + + trcr(i,j,nt_aero+1+4*(naero-1),iblk)*vsno(i,j,iblk) & + + trcr(i,j,nt_aero+2+4*(naero-1),iblk)*vice(i,j,iblk) & + + trcr(i,j,nt_aero+3+4*(naero-1),iblk)*vice(i,j,iblk) + enddo + enddo + enddo + aerototn= global_sum(work1, distrb_info, field_loc_center, tarean) + aerotots= global_sum(work1, distrb_info, field_loc_center, tareas) + aeromx1n = global_maxval(work1, distrb_info, lmask_n) + aeromx1s = global_maxval(work1, distrb_info, lmask_s) + if (my_task == master_task) then + write(nu_diag,*) 'aero: ',naero,' faero : ',& + faeron, faeros + write(nu_diag,*) 'aero: ',naero,' fsoot : ',& + fsootn, fsoots + write(nu_diag,*) 'aero: ',naero,' faero-fsoot : ',& + faeron-fsootn, faeros-fsoots + write(nu_diag,*) 'aero: ',naero,' aerotot : ',& + aerototn, aerotots + write(nu_diag,*) 'aero: ',naero,' aerotot change: ',& + aerototn-totaeron(naero), aerotots-totaeros(naero) + write(nu_diag,*) 'aero: ',naero,' aeromax agg: ',& + aeromx1n,aeromx1s + endif + +! do kaero=1,ncat +! do iblk = 1, nblocks +! do j = 1, ny_block +! do i = 1, nx_block +! work1(i,j,iblk) = trcrn(i,j,nt_aero,kaero,iblk) +! enddo +! enddo +! enddo +! aeromx1n = global_maxval(work1, distrb_info, lmask_n) +! aeromx1s = global_maxval(work1, distrb_info, lmask_s) +! if (my_task == master_task) & +! write(nu_diag,*) 'MH aeromx1s: ',aeromx1n,aeromx1s,kaero +! enddo + +! do iblk = 1, nblocks +! do j = 1, ny_block +! do i = 1, nx_block +! work1(i,j,iblk) = trcrn(i,j,nt_aero+1,1,iblk) +! enddo +! enddo +! enddo +! aeromx2n = global_maxval(work1, distrb_info, lmask_n) +! write(nu_diag,*) 'MH aeromx2n: ',aeromx2n +! aeromx2s = global_maxval(work1, distrb_info, lmask_s) +! write(nu_diag,*) 'MH aeromx2s: ',aeromx2s +! +! do iblk = 1, nblocks +! do j = 1, ny_block +! do i = 1, nx_block +! work1(i,j,iblk) = trcrn(i,j,nt_aero+2,1,iblk) +! enddo +! enddo +! enddo +! aeromx3n = global_maxval(work1, distrb_info, lmask_n) +! write(nu_diag,*) 'MH aeromx2n: ',aeromx3n +! aeromx3s = global_maxval(work1, distrb_info, lmask_s) +! write(nu_diag,*) 'MH aeromx2s: ',aeromx3s + enddo ! n_aero + endif ! tr_aero + + ! maximum ice speed + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = sqrt(uvel(i,j,iblk)**2 & + + vvel(i,j,iblk)**2) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + umaxn = global_maxval(work1, distrb_info, lmask_n) + umaxs = global_maxval(work1, distrb_info, lmask_s) + + ! Write warning message if ice speed is too big + ! (Ice speeds of ~1 m/s or more usually indicate instability) + + if (check_umax) then + if (umaxn > umax_stab) then + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + if (abs(work1(i,j,iblk) - umaxn) < puny) then + if (my_task == master_task) then + write(nu_diag,*) ' ' + write(nu_diag,*) 'Warning, large ice speed' + write(nu_diag,*) 'my_task, iblk, i, j, umaxn:', & + my_task, iblk, i, j, umaxn + endif + endif + enddo + enddo + enddo + elseif (umaxs > umax_stab) then + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + if (abs(work1(i,j,iblk) - umaxs) < puny) then + if (my_task == master_task) then + write(nu_diag,*) ' ' + write(nu_diag,*) 'Warning, large ice speed' + write(nu_diag,*) 'my_task, iblk, i, j, umaxs:', & + my_task, iblk, i, j, umaxs + endif + endif + enddo + enddo + enddo + endif ! umax + endif ! check_umax + + ! maximum ice strength + + pmaxn = global_maxval(strength, distrb_info, lmask_n) + pmaxs = global_maxval(strength, distrb_info, lmask_s) + + pmaxn = pmaxn / c1000 ! convert to kN/m + pmaxs = pmaxs / c1000 + + if (print_global) then + + ! total ice/snow internal energy + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = esno(i,j,iblk) + eice(i,j,iblk) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + etotn = global_sum(work1, distrb_info, & + field_loc_center, tarean) + etots = global_sum(work1, distrb_info, & + field_loc_center, tareas) + + !----------------------------------------------------------------- + ! various fluxes + !----------------------------------------------------------------- + ! evap, fsens, and flwout need to be multiplied by aice because + ! regrettably they have been divided by aice for the coupler + !----------------------------------------------------------------- + + ! evaporation + + evpn = global_sum_prod(evap, aice, distrb_info, & + field_loc_center, tarean) + evps = global_sum_prod(evap, aice, distrb_info, & + field_loc_center, tareas) + evpn = evpn*dt + evps = evps*dt + + ! salt flux + sfsaltn = global_sum(fsalt_gbm, distrb_info, & + field_loc_center, tarean) + sfsalts = global_sum(fsalt_gbm, distrb_info, & + field_loc_center, tareas) + sfsaltn = sfsaltn*dt + sfsalts = sfsalts*dt + + ! fresh water flux + sfreshn = global_sum(fresh_gbm, distrb_info, & + field_loc_center, tarean) + sfreshs = global_sum(fresh_gbm, distrb_info, & + field_loc_center, tareas) + sfreshn = sfreshn*dt + sfreshs = sfreshs*dt + + ! ocean heat + ! Note: fswthru not included because it does not heat ice + fhocnn = global_sum(fhocn_gbm, distrb_info, & + field_loc_center, tarean) + fhocns = global_sum(fhocn_gbm, distrb_info, & + field_loc_center, tareas) + + ! latent heat + ! You may be wondering, where is the latent heat flux? + ! It is not included here because it cancels with + ! the evaporative flux times the enthalpy of the + ! ice/snow that evaporated. + + ! atmo heat flux + ! Note: flwout includes the reflected longwave down, needed by the + ! atmosphere as an upwards radiative boundary condition. + ! Also note: fswabs includes solar radiation absorbed in ocean, + ! which must be subtracted here. + + if (calc_Tsfc) then + + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = & + (fswabs(i,j,iblk) - fswthru(i,j,iblk) & + + flwout(i,j,iblk) & + + fsens (i,j,iblk)) * aice(i,j,iblk) & + + flw (i,j,iblk) * aice_init(i,j,iblk) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + else ! fsurf is computed by atmosphere model + + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = & + (fsurf(i,j,iblk) - flat(i,j,iblk)) & + * aice(i,j,iblk) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + endif ! calc_Tsfc + + fhatmn = global_sum(work1, distrb_info, & + field_loc_center, tarean) + fhatms = global_sum(work1, distrb_info, & + field_loc_center, tareas) + + ! freezing potential + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = max(c0,frzmlt(i,j,iblk)) + enddo + enddo + enddo + !$OMP END PARALLEL DO + fhfrzn = global_sum(work1, distrb_info, & + field_loc_center, tarean) + fhfrzs = global_sum(work1, distrb_info, & + field_loc_center, tareas) + + ! rain + rnn = global_sum_prod(frain, aice_init, distrb_info, & + field_loc_center, tarean) + rns = global_sum_prod(frain, aice_init, distrb_info, & + field_loc_center, tareas) + rnn = rnn*dt + rns = rns*dt + + ! snow + snn = global_sum_prod(fsnow, aice_init, distrb_info, & + field_loc_center, tarean) + sns = global_sum_prod(fsnow, aice_init, distrb_info, & + field_loc_center, tareas) + snn = snn*dt + sns = sns*dt + + ! frazil ice growth !! should not be multiplied by aice + ! m/step->kg/m^2/s + work1(:,:,:) = frazil(:,:,:)*rhoi/dt + frzn = global_sum(work1, distrb_info, & + field_loc_center, tarean) + frzs = global_sum(work1, distrb_info, field_loc_center, & + tareas) + frzn = frzn*dt + frzs = frzs*dt + + ! ice and snow mass + micen = rhoi*shmaxn + msnwn = rhos*snwmxn + mices = rhoi*shmaxs + msnws = rhos*snwmxs + + mtotn = micen + msnwn + mtots = mices + msnws + + ! mass change since beginning of time step + delmin = mtotn - totmn + delmis = mtots - totms + + ! ice mass change including frazil ice formation + delmxn = micen - totmin + delmxs = mices - totmis + if (.not. update_ocn_f) then + ! ice mass change excluding frazil ice formation + delmxn = delmxn - frzn + delmxs = delmxs - frzs + endif + + ! total water flux + fluxn = c0 + fluxs = c0 + if( arean > c0) then + ! water associated with frazil ice included in fresh + fluxn = rnn + snn + evpn - sfreshn + if (.not. update_ocn_f) then + fluxn = fluxn + frzn + endif + endif + if( areas > c0) then + ! water associated with frazil ice included in fresh + fluxs = rns + sns + evps - sfreshs + if (.not. update_ocn_f) then + fluxs = fluxs + frzs + endif + endif + + werrn = (fluxn-delmin)/(mtotn+c1) + werrs = (fluxs-delmis)/(mtots+c1) + + ! energy change + delein = etotn - toten + deleis = etots - totes + + fhatmn = fhatmn + ( - snn * Lfresh + evpn * Lvap ) / dt + fhatms = fhatms + ( - sns * Lfresh + evps * Lvap ) / dt + + hnetn = (fhatmn - fhocnn - fhfrzn) * dt + hnets = (fhatms - fhocns - fhfrzs) * dt + + herrn = (hnetn - delein) / (etotn - c1) + herrs = (hnets - deleis) / (etots - c1) + + ! salt mass + msltn = micen*ice_ref_salinity*p001 + mslts = mices*ice_ref_salinity*p001 + + ! change in salt mass + delmsltn = delmxn*ice_ref_salinity*p001 + delmslts = delmxs*ice_ref_salinity*p001 + + ! salt error + serrn = (sfsaltn + delmsltn) / (msltn + c1) + serrs = (sfsalts + delmslts) / (mslts + c1) + + endif ! print_global + + if (print_points) then + + !----------------------------------------------------------------- + ! state of the ice and associated fluxes for 2 defined points + ! NOTE these are computed for the last timestep only (not avg) + !----------------------------------------------------------------- + + do n = 1, npnt + if (my_task == pmloc(n)) then + i = piloc(n) + j = pjloc(n) + iblk = pbloc(n) + + pTair(n) = Tair(i,j,iblk) - Tffresh ! air temperature + pQa(n) = Qa(i,j,iblk) ! specific humidity + pfsnow(n) = fsnow(i,j,iblk)*dt/rhos ! snowfall + pfrain(n) = frain(i,j,iblk)*dt/rhow ! rainfall + pfsw(n) = fsw(i,j,iblk) ! shortwave radiation + pflw(n) = flw(i,j,iblk) ! longwave radiation + paice(n) = aice(i,j,iblk) ! ice area + + hiavg(n) = c0 ! avg snow/ice thickness + hsavg(n) = c0 + if (paice(n) /= c0) then + hiavg(n) = vice(i,j,iblk)/paice(n) + hsavg(n) = vsno(i,j,iblk)/paice(n) + endif + pTsfc(n) = trcr(i,j,nt_Tsfc,iblk) ! ice/snow sfc temperature + pevap(n) = evap(i,j,iblk)*dt/rhoi ! sublimation/condensation + pfswabs(n) = fswabs(i,j,iblk) ! absorbed solar flux + pflwout(n) = flwout(i,j,iblk) ! outward longwave flux + pflat(n) = flat(i,j,iblk) ! latent heat flux + pfsens(n) = fsens(i,j,iblk) ! sensible heat flux + pfsurf(n) = fsurf(i,j,iblk) ! total sfc heat flux + pfcondtop(n) = fcondtop(i,j,iblk) ! top sfc cond flux + pmeltt(n) = meltt(i,j,iblk) ! top melt + pmeltb(n) = meltb(i,j,iblk) ! bottom melt + pmeltl(n) = meltl(i,j,iblk) ! lateral melt + psnoice(n) = snoice(i,j,iblk) ! snow ice + pfrazil(n) = frazil(i,j,iblk) ! frazil ice + pcongel(n) = congel(i,j,iblk) ! congelation ice + pdhi(n) = vice(i,j,iblk) - pdhi(n) ! ice thickness change + pdhs(n) = vsno(i,j,iblk) - pdhs(n) ! snow thickness change + pde(n) = -(eice(i,j,iblk) & ! ice/snow energy change + + esno(i,j,iblk) - pde(n)) / dt + psst(n) = sst(i,j,iblk) ! sea surface temperature + pTf(n) = Tf(i,j,iblk) ! freezing temperature + pfhocn(n) = -fhocn(i,j,iblk) ! ocean heat used by ice + + endif ! my_task = pmloc + + call broadcast_scalar(pTair (n), pmloc(n)) + call broadcast_scalar(pQa (n), pmloc(n)) + call broadcast_scalar(pfsnow (n), pmloc(n)) + call broadcast_scalar(pfrain (n), pmloc(n)) + call broadcast_scalar(pfsw (n), pmloc(n)) + call broadcast_scalar(pflw (n), pmloc(n)) + call broadcast_scalar(paice (n), pmloc(n)) + call broadcast_scalar(hsavg (n), pmloc(n)) + call broadcast_scalar(hiavg (n), pmloc(n)) + call broadcast_scalar(pTsfc (n), pmloc(n)) + call broadcast_scalar(pevap (n), pmloc(n)) + call broadcast_scalar(pfswabs (n), pmloc(n)) + call broadcast_scalar(pflwout (n), pmloc(n)) + call broadcast_scalar(pflat (n), pmloc(n)) + call broadcast_scalar(pfsens (n), pmloc(n)) + call broadcast_scalar(pfsurf (n), pmloc(n)) + call broadcast_scalar(pfcondtop(n), pmloc(n)) + call broadcast_scalar(pmeltt (n), pmloc(n)) + call broadcast_scalar(pmeltb (n), pmloc(n)) + call broadcast_scalar(pmeltl (n), pmloc(n)) + call broadcast_scalar(psnoice (n), pmloc(n)) + call broadcast_scalar(pfrazil (n), pmloc(n)) + call broadcast_scalar(pcongel (n), pmloc(n)) + call broadcast_scalar(pdhi (n), pmloc(n)) + call broadcast_scalar(pdhs (n), pmloc(n)) + call broadcast_scalar(pde (n), pmloc(n)) + call broadcast_scalar(psst (n), pmloc(n)) + call broadcast_scalar(pTf (n), pmloc(n)) + call broadcast_scalar(pfhocn (n), pmloc(n)) + + enddo ! npnt + endif ! print_points + + !----------------------------------------------------------------- + ! start spewing + !----------------------------------------------------------------- + + if (my_task == master_task) then + if (grid_type == 'panarctic') then ! Arctic only + write (nu_diag,799) 'Arctic diagnostics' + write (nu_diag,801) 'total ice area (km^2) = ',arean + write (nu_diag,801) 'total ice extent(km^2) = ',extentn + write (nu_diag,801) 'total ice volume (m^3) = ',shmaxn + write (nu_diag,801) 'total snw volume (m^3) = ',snwmxn + write (nu_diag,801) 'tot kinetic energy (J) = ',ketotn + write (nu_diag,800) 'rms ice speed (m/s) = ',urmsn + write (nu_diag,800) 'average albedo = ',albtotn + write (nu_diag,800) 'max ice volume (m) = ',hmaxn + write (nu_diag,800) 'max ice speed (m/s) = ',umaxn + write (nu_diag,900) 'max strength (kN/m) = ',pmaxn + + if (print_global) then ! global diags for conservations checks + +#ifdef CCSMCOUPLED + if (prescribed_ice) then + write (nu_diag,*) '----------------------------' + write (nu_diag,*) 'This is the prescribed ice option.' + write (nu_diag,*) 'Heat and water will not be conserved.' + else +#endif + + write (nu_diag,*) '----------------------------' + write (nu_diag,801) 'arwt rain h2o kg in dt = ',rnn + write (nu_diag,801) 'arwt snow h2o kg in dt = ',snn + write (nu_diag,801) 'arwt evap h2o kg in dt = ',evpn + write (nu_diag,801) 'arwt frzl h2o kg in dt = ',frzn + write (nu_diag,801) 'arwt frsh h2o kg in dt = ',sfreshn + + write (nu_diag,801) 'arwt ice mass (kg) = ',micen + write (nu_diag,801) 'arwt snw mass (kg) = ',msnwn + + write (nu_diag,801) 'arwt tot mass (kg) = ',mtotn + write (nu_diag,801) 'arwt tot mass chng(kg) = ',delmin + write (nu_diag,801) 'arwt water flux = ',fluxn + if (update_ocn_f) then + write (nu_diag,*) '(=rain+snow+evap-fresh) ' + else + write (nu_diag,*) '(=rain+snow+evap+frzl-fresh) ' + endif + write (nu_diag,801) 'water flux error = ',werrn +#ifdef CCSMCOUPLED + endif ! prescribed_ice +#endif + write (nu_diag,*) '----------------------------' + write (nu_diag,801) 'arwt atm heat flux (W) = ',fhatmn + write (nu_diag,801) 'arwt ocn heat flux (W) = ',fhocnn + write (nu_diag,801) 'arwt frzl heat flux(W) = ',fhfrzn + write (nu_diag,801) 'arwt tot energy (J) = ',etotn + write (nu_diag,801) 'arwt net heat (J) = ',hnetn + write (nu_diag,801) 'arwt tot energy chng(J)= ',delein + write (nu_diag,801) 'arwt heat error = ',herrn + + write (nu_diag,*) '----------------------------' + write (nu_diag,801) 'arwt salt mass (kg) = ',msltn + write (nu_diag,801) 'arwt salt mass chng(kg)= ',delmsltn + write (nu_diag,801) 'arwt salt flx in dt(kg)= ',sfsaltn + write (nu_diag,801) 'arwt salt flx error = ',serrn + write (nu_diag,*) '----------------------------' + + endif ! print_global + + else ! global grid + + write(nu_diag,899) 'Arctic','Antarctic' + + write(nu_diag,901) 'total ice area (km^2) = ',arean, areas + write(nu_diag,901) 'total ice extent(km^2) = ',extentn,extents + write(nu_diag,901) 'total ice volume (m^3) = ',shmaxn, shmaxs + write(nu_diag,901) 'total snw volume (m^3) = ',snwmxn, snwmxs + write(nu_diag,901) 'tot kinetic energy (J) = ',ketotn, ketots + write(nu_diag,900) 'rms ice speed (m/s) = ',urmsn, urmss + write(nu_diag,900) 'average albedo = ',albtotn,albtots + write(nu_diag,900) 'max ice volume (m) = ',hmaxn, hmaxs + write(nu_diag,900) 'max ice speed (m/s) = ',umaxn, umaxs + write(nu_diag,900) 'max strength (kN/m) = ',pmaxn, pmaxs + + if (print_global) then ! global diags for conservations checks + + write(nu_diag,*) '----------------------------' + write(nu_diag,901) 'arwt rain h2o kg in dt = ',rnn,rns + write(nu_diag,901) 'arwt snow h2o kg in dt = ',snn,sns + write(nu_diag,901) 'arwt evap h2o kg in dt = ',evpn,evps + write(nu_diag,901) 'arwt frzl h2o kg in dt = ',frzn,frzs + write(nu_diag,901) 'arwt frsh h2o kg in dt = ',sfreshn,sfreshs + + write(nu_diag,901) 'arwt ice mass (kg) = ',micen,mices + write(nu_diag,901) 'arwt snw mass (kg) = ',msnwn,msnws + + write(nu_diag,901) 'arwt tot mass (kg) = ',mtotn,mtots + write(nu_diag,901) 'arwt tot mass chng(kg) = ',delmin,delmis + write(nu_diag,901) 'arwt water flux = ',fluxn,fluxs + if (update_ocn_f) then + write (nu_diag,*) '(=rain+snow+evap-fresh) ' + else + write (nu_diag,*) '(=rain+snow+evap+frzl-fresh) ' + endif + write(nu_diag,901) 'water flux error = ',werrn,werrs + + write(nu_diag,*) '----------------------------' + write(nu_diag,901) 'arwt atm heat flux (W) = ',fhatmn,fhatms + write(nu_diag,901) 'arwt ocn heat flux (W) = ',fhocnn,fhocns + write(nu_diag,901) 'arwt frzl heat flux(W) = ',fhfrzn,fhfrzs + write(nu_diag,901) 'arwt tot energy (J) = ',etotn,etots + write(nu_diag,901) 'arwt net heat (J) = ',hnetn,hnets + write(nu_diag,901) 'arwt tot energy chng(J)= ',delein,deleis + write(nu_diag,901) 'arwt heat error = ',herrn,herrs + + write(nu_diag,*) '----------------------------' + write(nu_diag,901) 'arwt salt mass (kg) = ',msltn,mslts + write(nu_diag,901) 'arwt salt mass chng(kg)= ',delmsltn, & + delmslts + write(nu_diag,901) 'arwt salt flx in dt(kg)= ',sfsaltn, & + sfsalts + write(nu_diag,901) 'arwt salt flx error = ',serrn,serrs + write(nu_diag,*) '----------------------------' + + endif ! print_global + endif ! grid_type + + call flush_fileunit(nu_diag) + + !----------------------------------------------------------------- + ! diagnostics for Arctic and Antarctic points + !----------------------------------------------------------------- + + if (print_points) then + + write(nu_diag,*) ' ' + write(nu_diag,902) ' Lat, Long ',plat(1),plon(1), & + plat(2),plon(2) + write(nu_diag,903) ' my_task, iblk, i, j ', & + pmloc(1),pbloc(1),piloc(1),pjloc(1), & + pmloc(2),pbloc(2),piloc(2),pjloc(2) + write(nu_diag,*) '----------atm----------' + write(nu_diag,900) 'air temperature (C) = ',pTair(1),pTair(2) + write(nu_diag,900) 'specific humidity = ',pQa(1),pQa(2) + write(nu_diag,900) 'snowfall (m) = ',pfsnow(1), & + pfsnow(2) + write(nu_diag,900) 'rainfall (m) = ',pfrain(1), & + pfrain(2) + if (.not.calc_Tsfc) then + write(nu_diag,900) 'total surface heat flux= ',pfsurf(1),pfsurf(2) + write(nu_diag,900) 'top sfc conductive flux= ',pfcondtop(1), & + pfcondtop(2) + write(nu_diag,900) 'latent heat flx = ',pflat(1),pflat(2) + else + write(nu_diag,900) 'shortwave radiation sum= ',pfsw(1),pfsw(2) + write(nu_diag,900) 'longwave radiation = ',pflw(1),pflw(2) + endif + write(nu_diag,*) '----------ice----------' + write(nu_diag,900) 'area fraction = ',paice(1),paice(2) + write(nu_diag,900) 'avg ice thickness (m) = ',hiavg(1),hiavg(2) + write(nu_diag,900) 'avg snow depth (m) = ',hsavg(1),hsavg(2) + if (calc_Tsfc) then + write(nu_diag,900) 'surface temperature(C) = ',pTsfc(1),pTsfc(2) + write(nu_diag,900) 'absorbed shortwave flx = ',pfswabs(1), & + pfswabs(2) + write(nu_diag,900) 'outward longwave flx = ',pflwout(1), & + pflwout(2) + write(nu_diag,900) 'sensible heat flx = ',pfsens(1), & + pfsens(2) + write(nu_diag,900) 'latent heat flx = ',pflat(1),pflat(2) + endif + write(nu_diag,900) 'subl/cond (m ice) = ',pevap(1),pevap(2) + write(nu_diag,900) 'top melt (m) = ',pmeltt(1) & + ,pmeltt(2) + write(nu_diag,900) 'bottom melt (m) = ',pmeltb(1) & + ,pmeltb(2) + write(nu_diag,900) 'lateral melt (m) = ',pmeltl(1) & + ,pmeltl(2) + write(nu_diag,900) 'new ice (m) = ',pfrazil(1), & + pfrazil(2) + write(nu_diag,900) 'congelation (m) = ',pcongel(1), & + pcongel(2) + write(nu_diag,900) 'snow-ice (m) = ',psnoice(1), & + psnoice(2) + write(nu_diag,900) 'effective dhi (m) = ',pdhi(1),pdhi(2) + write(nu_diag,900) 'effective dhs (m) = ',pdhs(1),pdhs(2) + write(nu_diag,900) 'intnl enrgy chng(W/m^2)= ',pde (1),pde (2) + write(nu_diag,*) '----------ocn----------' + write(nu_diag,900) 'sst (C) = ',psst(1),psst(2) + write(nu_diag,900) 'freezing temp (C) = ',pTf(1),pTf(2) + write(nu_diag,900) 'heat used (W/m^2) = ',pfhocn(1), & + pfhocn(2) + + endif ! print_points + endif ! my_task = master_task + + 799 format (27x,a24) + 800 format (a25,2x,f24.17) + 801 format (a25,2x,1pe24.17) + 899 format (27x,a24,2x,a24) + 900 format (a25,2x,f24.17,2x,f24.17) + 901 format (a25,2x,1pe24.17,2x,1pe24.17) + 902 format (a25,10x,f6.1,1x,f6.1,9x,f6.1,1x,f6.1) + 903 format (a25,5x,i4,1x,i4,1x,i4,1x,i4,7x,i4,1x,i4,1x,i4,1x,i4) + + end subroutine runtime_diags + +!======================================================================= +!BOP +! +! !IROUTINE: init_mass_diags - computes global combined ice and snow mass sum +! +! !INTERFACE: +! + subroutine init_mass_diags +! +! !DESCRIPTION: +! +! Computes global combined ice and snow mass sum +! +! !REVISION HISTORY: +! +! author: Elizabeth C. Hunke, LANL +! +! !USES: +! + use ice_global_reductions + use ice_grid + use ice_state + use ice_broadcast +! +! !INPUT/OUTPUT PARAMETERS: +! +!EOP +! + integer (kind=int_kind) :: n, k, ii, jj, i, j, iblk + integer (kind=int_kind) :: naero + + real (kind=dbl_kind) :: & + shmaxn, snwmxn, shmaxs, snwmxs + + real (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: & + work1, work2 + + + ! total ice volume + shmaxn = global_sum(vice, distrb_info, field_loc_center, tarean) + shmaxs = global_sum(vice, distrb_info, field_loc_center, tareas) + + ! total snow volume + snwmxn = global_sum(vsno, distrb_info, field_loc_center, tarean) + snwmxs = global_sum(vsno, distrb_info, field_loc_center, tareas) + + ! north/south ice mass + totmin = rhoi*shmaxn + totmis = rhoi*shmaxs + + ! north/south ice+snow mass + totmn = totmin + rhos*snwmxn + totms = totmis + rhos*snwmxs + + ! north/south ice+snow energy + ! total ice/snow energy + !$OMP PARALLEL DO PRIVATE(iblk,i,j) + do iblk = 1, nblocks + do j=1,ny_block + do i=1,nx_block + work1(i,j,iblk) = esno(i,j,iblk) + eice(i,j,iblk) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + toten = global_sum(work1, distrb_info, field_loc_center, tarean) + totes = global_sum(work1, distrb_info, field_loc_center, tareas) + + if (tr_aero) then + do naero=1,n_aero + do iblk = 1, nblocks + do j = 1, ny_block + do i = 1, nx_block + work1(i,j,iblk) = trcr(i,j,nt_aero +4*(naero-1),iblk)*vsno(i,j,iblk) & + + trcr(i,j,nt_aero+1+4*(naero-1),iblk)*vsno(i,j,iblk) & + + trcr(i,j,nt_aero+2+4*(naero-1),iblk)*vice(i,j,iblk) & + + trcr(i,j,nt_aero+3+4*(naero-1),iblk)*vice(i,j,iblk) + enddo + enddo + enddo + totaeron(naero)= global_sum(work1, distrb_info, field_loc_center, tarean) + totaeros(naero)= global_sum(work1, distrb_info, field_loc_center, tareas) + enddo + endif + + if (print_points) then + + do n = 1, npnt + + if (my_task == pmloc(n)) then + i = piloc(n) + j = pjloc(n) + iblk = pbloc(n) + + pdhi(n) = vice(i,j,iblk) + pdhs(n) = vsno(i,j,iblk) + pde(n) = esno(i,j,iblk) + eice(i,j,iblk) + endif + + enddo ! npnt + + endif ! print_points + + end subroutine init_mass_diags + +!======================================================================= +!BOP +! +! !IROUTINE: init_diags - find tasks for diagnostic points +! +! !INTERFACE: +! + subroutine init_diags +! +! !DESCRIPTION: +! +! Find tasks for diagnostic points. +! +! +! !REVISION HISTORY: +! +! authors: Elizabeth C. Hunke and William H. Lipscomb, LANL +! +! !USES: + use ice_grid + use ice_blocks + use ice_broadcast + use ice_global_reductions + use ice_gather_scatter +! +! !INPUT/OUTPUT PARAMETERS: +! +!EOP +! + real (kind=dbl_kind) :: & + latdis , & ! latitude distance + londis , & ! longitude distance + totdis , & ! total distance + mindis , & ! minimum distance from desired location + mindis_g ! global minimum distance from desired location + + integer (kind=int_kind) :: & + n , & ! index for point search + i,j , & ! grid indices + iblk , & ! block index + ilo,ihi,jlo,jhi ! beginning and end of physical domain + + character (char_len) :: label(npnt) + + type (block) :: & + this_block ! block information for current block + + if (print_points) then + + if (my_task==master_task) then + write(nu_diag,*) ' ' + write(nu_diag,*) ' Find indices of diagnostic points ' + endif + + ! initialize labels + label(1)(1:40) = 'Near North Pole pack ice ' + label(2)(1:40) = 'Weddell Sea ' + + piloc(:) = 0 + pjloc(:) = 0 + pbloc(:) = 0 + pmloc(:) = -999 + plat(:) = -999._dbl_kind + plon(:) = -999._dbl_kind + + ! find minimum distance to diagnostic points on this processor + do n = 1, npnt + if (lonpnt(n) > c180) lonpnt(n) = lonpnt(n) - c360 + + iindx = 0 + jindx = 0 + bindx = 0 + mindis = 540.0_dbl_kind ! 360. + 180. + + !$OMP PARALLEL DO PRIVATE(iblk,this_block,ilo,ihi,jlo,jhi,j,i, & + !$OMP latdis,londis,totdis,mindis, & + !$OMP jindx,iindx,bindx) + do iblk = 1, nblocks + this_block = get_block(blocks_ice(iblk),iblk) + ilo = this_block%ilo + ihi = this_block%ihi + jlo = this_block%jlo + jhi = this_block%jhi + + do j = jlo, jhi + do i = ilo, ihi + if (hm(i,j,iblk) > p5) then + latdis = abs(latpnt(n)-TLAT(i,j,iblk)*rad_to_deg) + londis = abs(lonpnt(n)-TLON(i,j,iblk)*rad_to_deg) & + * cos(TLAT(i,j,iblk)) + totdis = sqrt(latdis**2 + londis**2) + if (totdis < mindis) then + mindis = totdis + jindx = j + iindx = i + bindx = iblk + endif ! totdis < mindis + endif ! hm > p5 + enddo ! i + enddo ! j + enddo ! iblk + !$OMP END PARALLEL DO + + ! find global minimum distance to diagnostic points + mindis_g = global_minval(mindis, distrb_info) + + ! save indices of minimum-distance grid cell + if (abs(mindis_g - mindis) < puny) then + piloc(n) = iindx + pjloc(n) = jindx + pbloc(n) = bindx + pmloc(n) = my_task + plat(n) = TLAT(iindx,jindx,bindx)*rad_to_deg + plon(n) = TLON(iindx,jindx,bindx)*rad_to_deg + endif + + ! communicate to all processors + piloc(n) = global_maxval(piloc(n), distrb_info) + pjloc(n) = global_maxval(pjloc(n), distrb_info) + pbloc(n) = global_maxval(pbloc(n), distrb_info) + pmloc(n) = global_maxval(pmloc(n), distrb_info) + plat(n) = global_maxval(plat(n), distrb_info) + plon(n) = global_maxval(plon(n), distrb_info) + + ! write to log file + if (my_task==master_task) then + write(nu_diag,*) ' ' + write(nu_diag,100) n,latpnt(n),lonpnt(n),plat(n),plon(n), & + piloc(n), pjloc(n), pbloc(n), pmloc(n) + endif + 100 format(' found point',i4/ & + ' lat lon TLAT TLON i j block task'/ & + 4(f6.1,1x),1x,4(i4,2x) ) + + enddo ! npnt + endif ! print_points + + end subroutine init_diags + +!======================================================================= +!BOP +! +! !IROUTINE: print_state - print ice state for specified grid point +! +! !INTERFACE: +! + subroutine print_state(plabel,i,j,iblk) +! +! !DESCRIPTION: +! +! This routine is useful for debugging. +! Calls to it should be inserted in the form (after thermo, for example) +! do iblk = 1, nblocks +! do j=jlo,jhi +! do i=ilo,ihi +! plabel = 'post thermo' +! if (istep1 >= check_step .and. iblk==iblkp .and i==ip & +! .and. j==jp .and. my_task == mtask) & +! call print_state(plabel,i,j,iblk) +! enddo +! enddo +! enddo +! +! 'use ice_diagnostics' may need to be inserted also +! +! !REVISION HISTORY: +! +! author: Elizabeth C. Hunke, LANL +! +! !USES: +! +!MH use ice_domain_size + use ice_state + use ice_itd + use ice_flux +! +! !INPUT/OUTPUT PARAMETERS: +! + character (len=20), intent(in) :: plabel + + integer (kind=int_kind), intent(in) :: & + i, j , & ! horizontal indices + iblk ! block index +! +!EOP +! + real (kind=dbl_kind) :: & + eidebug, esdebug, & + qi, qs, Tsnow + + integer (kind=int_kind) :: n, k + + write(nu_diag,*) plabel + write(nu_diag,*) 'istep1, my_task, i, j, iblk:', & + istep1, my_task, i, j, iblk + write(nu_diag,*) ' ' + write(nu_diag,*) 'aice0', aice0(i,j,iblk) + do n = 1, ncat + write(nu_diag,*) ' ' + write(nu_diag,*) 'n =',n + write(nu_diag,*) 'aicen', aicen(i,j,n,iblk) + write(nu_diag,*) 'vicen', vicen(i,j,n,iblk) + write(nu_diag,*) 'vsnon', vsnon(i,j,n,iblk) + if (aicen(i,j,n,iblk) > puny) then + write(nu_diag,*) 'hin', vicen(i,j,n,iblk)/aicen(i,j,n,iblk) + write(nu_diag,*) 'hsn', vsnon(i,j,n,iblk)/aicen(i,j,n,iblk) + endif + write(nu_diag,*) 'Tsfcn',trcrn(i,j,nt_Tsfc,n,iblk) + write(nu_diag,*) ' ' + enddo ! n + + eidebug = c0 + do n = 1,ncat + do k = 1,nilyr + write(nu_diag,*) 'eicen, cat ',n,' layer ',k, & + eicen(i,j,ilyr1(n)+k-1,iblk) + eidebug = eidebug + eicen(i,j,ilyr1(n)+k-1,iblk) + if (aicen(i,j,n,iblk) > puny) then + qi = eicen(i,j,ilyr1(n)+k-1,iblk) / & ! qi, eicen < 0 + (vicen(i,j,n,iblk)/real(nilyr,kind=dbl_kind)) + write(nu_diag,*) 'qi/rhoi', qi/rhoi + endif + enddo + write(nu_diag,*) ' ' + enddo + write(nu_diag,*) 'eice(i,j)',eidebug + write(nu_diag,*) ' ' + + esdebug = c0 + do n = 1,ncat + if (vsnon(i,j,n,iblk) > puny) then + do k = 1,nslyr + write(nu_diag,*) 'esnon, cat ',n,' layer ',k, & + esnon(i,j,slyr1(n)+k-1,iblk) + esdebug = esdebug + esnon(i,j,slyr1(n)+k-1,iblk) + qs = esnon(i,j,slyr1(n)+k-1,iblk) / & ! qs, esnon < 0 + (vsnon(i,j,n,iblk)/real(nslyr,kind=dbl_kind)) + Tsnow = (Lfresh + qs/rhos) / cp_ice + write(nu_diag,*) 'qs/rhos', qs/rhos + write(nu_diag,*) 'Tsnow', Tsnow + enddo + write(nu_diag,*) ' ' + endif + enddo + write(nu_diag,*) 'esno(i,j)',esdebug + write(nu_diag,*) ' ' + + write(nu_diag,*) 'uvel(i,j)',uvel(i,j,iblk) + write(nu_diag,*) 'vvel(i,j)',vvel(i,j,iblk) + + write(nu_diag,*) ' ' + write(nu_diag,*) 'atm states and fluxes' + write(nu_diag,*) ' uatm = ',uatm (i,j,iblk) + write(nu_diag,*) ' vatm = ',vatm (i,j,iblk) + write(nu_diag,*) ' potT = ',potT (i,j,iblk) + write(nu_diag,*) ' Tair = ',Tair (i,j,iblk) + write(nu_diag,*) ' Qa = ',Qa (i,j,iblk) + write(nu_diag,*) ' rhoa = ',rhoa (i,j,iblk) + write(nu_diag,*) ' swvdr = ',swvdr(i,j,iblk) + write(nu_diag,*) ' swvdf = ',swvdf(i,j,iblk) + write(nu_diag,*) ' swidr = ',swidr(i,j,iblk) + write(nu_diag,*) ' swidf = ',swidf(i,j,iblk) + write(nu_diag,*) ' flw = ',flw (i,j,iblk) + write(nu_diag,*) ' frain = ',frain(i,j,iblk) + write(nu_diag,*) ' fsnow = ',fsnow(i,j,iblk) + write(nu_diag,*) ' ' + write(nu_diag,*) 'ocn states and fluxes' + write(nu_diag,*) ' frzmlt = ',frzmlt (i,j,iblk) + write(nu_diag,*) ' sst = ',sst (i,j,iblk) + write(nu_diag,*) ' sss = ',sss (i,j,iblk) + write(nu_diag,*) ' Tf = ',Tf (i,j,iblk) + write(nu_diag,*) ' uocn = ',uocn (i,j,iblk) + write(nu_diag,*) ' vocn = ',vocn (i,j,iblk) + write(nu_diag,*) ' strtltx = ',strtltx(i,j,iblk) + write(nu_diag,*) ' strtlty = ',strtlty(i,j,iblk) + write(nu_diag,*) ' ' + write(nu_diag,*) 'srf states and fluxes' + write(nu_diag,*) ' Tref = ',Tref (i,j,iblk) + write(nu_diag,*) ' Qref = ',Qref (i,j,iblk) + write(nu_diag,*) ' fsens = ',fsens (i,j,iblk) + write(nu_diag,*) ' flat = ',flat (i,j,iblk) + write(nu_diag,*) ' evap = ',evap (i,j,iblk) + write(nu_diag,*) ' flwout = ',flwout(i,j,iblk) + write(nu_diag,*) ' ' + + end subroutine print_state + +!======================================================================= + + end module ice_diagnostics + +!======================================================================= + + + + + diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/biogeochem/CNBalanceCheckMod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/biogeochem/CNBalanceCheckMod.F90 new file mode 100644 index 0000000000..e9384a1efc --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/biogeochem/CNBalanceCheckMod.F90 @@ -0,0 +1,400 @@ + +! DART note: this file started life as: +! /glade/p/cesm/releases/cesm1_2_1/models/lnd/clm/src/clm4_0/biogeochem/CNBalanceCheckMod.F90 + +module CNBalanceCheckMod + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: CNBalanceCheckMod +! +! !DESCRIPTION: +! Module for carbon mass balance checking. +! +! !USES: + use abortutils , only: endrun + use shr_kind_mod, only: r8 => shr_kind_r8 + use clm_varctl , only: iulog + implicit none + save + private +! !PUBLIC MEMBER FUNCTIONS: + public :: BeginCBalance + public :: BeginNBalance + public :: CBalanceCheck + public :: NBalanceCheck +! +! !REVISION HISTORY: +! 4/23/2004: Created by Peter Thornton +! +!EOP +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BeginCBalance +! +! !INTERFACE: +subroutine BeginCBalance(lbc, ubc, num_soilc, filter_soilc) +! +! !DESCRIPTION: +! On the radiation time step, calculate the beginning carbon balance for mass +! conservation checks. +! +! !USES: + use clmtype +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_soilc ! number of soil columns filter + integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! 2/4/05: Created by Peter Thornton +! +! !LOCAL VARIABLES: +! local pointers to implicit in arrays + real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool +! +! local pointers to implicit out arrays + real(r8), pointer :: col_begcb(:) ! carbon mass, beginning of time step (gC/m**2) +! +! !OTHER LOCAL VARIABLES: + integer :: c ! indices + integer :: fc ! lake filter indices +! +!EOP +!----------------------------------------------------------------------- + ! assign local pointers at the column level + col_begcb => ccbal%begcb + totcolc => ccs%totcolc + + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! calculate beginning column-level carbon balance, + ! for mass conservation check + + col_begcb(c) = totcolc(c) + + end do ! end of columns loop + + +end subroutine BeginCBalance +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BeginNBalance +! +! !INTERFACE: +subroutine BeginNBalance(lbc, ubc, num_soilc, filter_soilc) +! +! !DESCRIPTION: +! On the radiation time step, calculate the beginning nitrogen balance for mass +! conservation checks. +! +! !USES: + use clmtype +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_soilc ! number of soil columns filter + integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! 2/4/05: Created by Peter Thornton +! +! !LOCAL VARIABLES: +! local pointers to implicit in arrays + real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg +! +! local pointers to implicit out arrays + real(r8), pointer :: col_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2) +! +! !OTHER LOCAL VARIABLES: + integer :: c ! indices + integer :: fc ! lake filter indices +! +!EOP +!----------------------------------------------------------------------- + ! assign local pointers at the column level + col_begnb => cnbal%begnb + totcoln => cns%totcoln + + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! calculate beginning column-level nitrogen balance, + ! for mass conservation check + + col_begnb(c) = totcoln(c) + + end do ! end of columns loop + +end subroutine BeginNBalance +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: CBalanceCheck +! +! !INTERFACE: +subroutine CBalanceCheck(lbc, ubc, num_soilc, filter_soilc) +! +! !DESCRIPTION: +! On the radiation time step, perform carbon mass conservation check for column and pft +! +! !USES: + use clmtype + use clm_time_manager, only: get_step_size, is_first_restart_step +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_soilc ! number of soil columns in filter + integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! 12/9/03: Created by Peter Thornton +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arrays + real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool + real(r8), pointer :: gpp(:) ! (gC/m2/s) gross primary production + real(r8), pointer :: er(:) ! (gC/m2/s) total ecosystem respiration, autotrophic + heterotrophic + real(r8), pointer :: col_fire_closs(:) ! (gC/m2/s) total column-level fire C loss + real(r8), pointer :: col_hrv_xsmrpool_to_atm(:) ! excess MR pool harvest mortality (gC/m2/s) + real(r8), pointer :: dwt_closs(:) ! (gC/m2/s) total carbon loss from product pools and conversion + real(r8), pointer :: product_closs(:) ! (gC/m2/s) total wood product carbon loss +! +! local pointers to implicit out arrays + real(r8), pointer :: col_cinputs(:) ! (gC/m2/s) total column-level carbon inputs (for balance check) + real(r8), pointer :: col_coutputs(:) ! (gC/m2/s) total column-level carbon outputs (for balance check) + real(r8), pointer :: col_begcb(:) ! carbon mass, beginning of time step (gC/m**2) + real(r8), pointer :: col_endcb(:) ! carbon mass, end of time step (gC/m**2) + real(r8), pointer :: col_errcb(:) ! carbon balance error for the timestep (gC/m**2) +! +! !OTHER LOCAL VARIABLES: + integer :: c,err_index ! indices + integer :: fc ! lake filter indices + logical :: err_found ! error flag + real(r8):: dt ! radiation time step (seconds) +!EOP +!----------------------------------------------------------------------- + + ! assign local pointers to column-level arrays + totcolc => ccs%totcolc + gpp => pcf_a%gpp + er => ccf%er + col_fire_closs => ccf%col_fire_closs + col_hrv_xsmrpool_to_atm => pcf_a%hrv_xsmrpool_to_atm + dwt_closs => ccf%dwt_closs + product_closs => ccf%product_closs + + col_cinputs => ccf%col_cinputs + col_coutputs => ccf%col_coutputs + col_begcb => ccbal%begcb + col_endcb => ccbal%endcb + col_errcb => ccbal%errcb + + ! set time steps + dt = real( get_step_size(), r8 ) + + err_found = .false. + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! calculate the total column-level carbon storage, for mass conservation check + + col_endcb(c) = totcolc(c) + + ! calculate total column-level inputs + + col_cinputs(c) = gpp(c) + + ! calculate total column-level outputs + ! er = ar + hr, col_fire_closs includes pft-level fire losses + + col_coutputs(c) = er(c) + col_fire_closs(c) + dwt_closs(c) + product_closs(c) + col_hrv_xsmrpool_to_atm(c) + + ! calculate the total column-level carbon balance error for this time step + + col_errcb(c) = (col_cinputs(c) - col_coutputs(c))*dt - & + (col_endcb(c) - col_begcb(c)) + + ! check for significant errors + if (abs(col_errcb(c)) > 1e-8_r8) then + err_found = .true. + err_index = c + end if + + end do ! end of columns loop + + if ( err_found .and. (.not. is_first_restart_step()) ) then ! TJH + c = err_index + write(iulog,*)'column cbalance error = ', col_errcb(c), c + write(iulog,*)'begcb = ',col_begcb(c) + write(iulog,*)'endcb = ',col_endcb(c) + write(iulog,*)'delta store = ',col_endcb(c)-col_begcb(c) + write(iulog,*)'input mass = ',col_cinputs(c)*dt + write(iulog,*)'output mass = ',col_coutputs(c)*dt + write(iulog,*)'net flux = ',(col_cinputs(c)-col_coutputs(c))*dt + write(iulog,*)'nee = ',ccf%nee(c) * dt + write(iulog,*)'gpp = ',gpp(c) * dt + write(iulog,*)'er = ',er(c) * dt + write(iulog,*)'col_fire_closs = ',col_fire_closs(c) * dt + write(iulog,*)'col_hrv_xsmrpool_to_atm = ',col_hrv_xsmrpool_to_atm(c) * dt + write(iulog,*)'dwt_closs = ',dwt_closs(c) * dt + write(iulog,*)'product_closs = ',product_closs(c) * dt + call endrun('column carbon balance') + end if + + +end subroutine CBalanceCheck +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: NBalanceCheck +! +! !INTERFACE: +subroutine NBalanceCheck(lbc, ubc, num_soilc, filter_soilc) +! +! !DESCRIPTION: +! On the radiation time step, perform nitrogen mass conservation check +! for column and pft +! +! !USES: + use clmtype + use clm_time_manager, only: get_step_size, is_first_restart_step +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_soilc ! number of soil columns in filter + integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! 12/9/03: Created by Peter Thornton +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arrays + real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg + real(r8), pointer :: ndep_to_sminn(:) ! atmospheric N deposition to soil mineral N (gN/m2/s) + real(r8), pointer :: nfix_to_sminn(:) ! symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s) + real(r8), pointer :: supplement_to_sminn(:) ! supplemental N supply (gN/m2/s) + real(r8), pointer :: denit(:) ! total rate of denitrification (gN/m2/s) + real(r8), pointer :: sminn_leached(:) ! soil mineral N pool loss to leaching (gN/m2/s) + real(r8), pointer :: col_fire_nloss(:) ! total column-level fire N loss (gN/m2/s) + real(r8), pointer :: dwt_nloss(:) ! (gN/m2/s) total nitrogen loss from product pools and conversion + real(r8), pointer :: product_nloss(:) ! (gN/m2/s) total wood product nitrogen loss +! +! local pointers to implicit in/out arrays +! +! local pointers to implicit out arrays + real(r8), pointer :: col_ninputs(:) ! column-level N inputs (gN/m2/s) + real(r8), pointer :: col_noutputs(:) ! column-level N outputs (gN/m2/s) + real(r8), pointer :: col_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2) + real(r8), pointer :: col_endnb(:) ! nitrogen mass, end of time step (gN/m**2) + real(r8), pointer :: col_errnb(:) ! nitrogen balance error for the timestep (gN/m**2) +! +! !OTHER LOCAL VARIABLES: + integer :: c,err_index ! indices + integer :: fc ! lake filter indices + logical :: err_found ! error flag + real(r8):: dt ! radiation time step (seconds) +!EOP +!----------------------------------------------------------------------- + ! assign local pointers to column-level arrays + + totcoln => cns%totcoln + ndep_to_sminn => cnf%ndep_to_sminn + nfix_to_sminn => cnf%nfix_to_sminn + supplement_to_sminn => cnf%supplement_to_sminn + denit => cnf%denit + sminn_leached => cnf%sminn_leached + col_fire_nloss => cnf%col_fire_nloss + dwt_nloss => cnf%dwt_nloss + product_nloss => cnf%product_nloss + + col_ninputs => cnf%col_ninputs + col_noutputs => cnf%col_noutputs + col_begnb => cnbal%begnb + col_endnb => cnbal%endnb + col_errnb => cnbal%errnb + + ! set time steps + dt = real( get_step_size(), r8 ) + + err_found = .false. + ! column loop + do fc = 1,num_soilc + c=filter_soilc(fc) + + ! calculate the total column-level nitrogen storage, for mass conservation check + + col_endnb(c) = totcoln(c) + + ! calculate total column-level inputs + + col_ninputs(c) = ndep_to_sminn(c) + nfix_to_sminn(c) + supplement_to_sminn(c) + + ! calculate total column-level outputs + + col_noutputs(c) = denit(c) + sminn_leached(c) + col_fire_nloss(c) + dwt_nloss(c) + product_nloss(c) + + ! calculate the total column-level nitrogen balance error for this time step + + col_errnb(c) = (col_ninputs(c) - col_noutputs(c))*dt - & + (col_endnb(c) - col_begnb(c)) + + if (abs(col_errnb(c)) > 1e-8_r8) then + err_found = .true. + err_index = c + end if + + end do ! end of columns loop + + if ( err_found .and. (.not. is_first_restart_step()) ) then ! TJH + c = err_index + write(iulog,*)'column nbalance error = ', col_errnb(c), c + write(iulog,*)'begnb = ',col_begnb(c) + write(iulog,*)'endnb = ',col_endnb(c) + write(iulog,*)'delta store = ',col_endnb(c)-col_begnb(c) + write(iulog,*)'input mass = ',col_ninputs(c)*dt + write(iulog,*)'output mass = ',col_noutputs(c)*dt + write(iulog,*)'net flux = ',(col_ninputs(c)-col_noutputs(c))*dt + call endrun('column nitrogen balance error') + end if + +end subroutine NBalanceCheck +!----------------------------------------------------------------------- + +end module CNBalanceCheckMod diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/biogeophys/BalanceCheckMod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/biogeophys/BalanceCheckMod.F90 new file mode 100644 index 0000000000..f6cb230a81 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/biogeophys/BalanceCheckMod.F90 @@ -0,0 +1,739 @@ + +! DART note: this file started life as: +! /glade/p/cesm/releases/cesm1_2_1/models/lnd/clm/src/clm4_0/biogeophys/BalanceCheckMod.F90 + +module BalanceCheckMod + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: BalanceCheckMod +! +! !DESCRIPTION: +! Water and energy balance check. +! +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use abortutils, only: endrun + use clm_varctl, only: iulog +! +! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + public :: BeginWaterBalance ! Initialize water balance check + public :: BalanceCheck ! Water and energy balance check +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +!EOP +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BeginWaterBalance +! +! !INTERFACE: + subroutine BeginWaterBalance(lbc, ubc, lbp, ubp, & + num_nolakec, filter_nolakec, num_lakec, filter_lakec, & + num_hydrologyc, filter_hydrologyc) +! +! !DESCRIPTION: +! Initialize column-level water balance at beginning of time step +! +! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use clmtype + use clm_varpar , only : nlevgrnd, nlevsoi + use subgridAveMod, only : p2c + use clm_varcon , only : icol_roof, icol_sunwall, icol_shadewall, icol_road_perv, & + icol_road_imperv +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column-index bounds + integer, intent(in) :: lbp, ubp ! pft-index bounds + integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points + integer, intent(in) :: num_lakec ! number of column non-lake points in column filter + integer, intent(in) :: filter_lakec(ubc-lbc+1) ! column filter for non-lake points + integer , intent(in) :: num_hydrologyc ! number of column soil points in column filter + integer , intent(in) :: filter_hydrologyc(ubc-lbc+1) ! column filter for soil points +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! Created by Peter Thornton +! +!EOP +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in variables +! + real(r8), pointer :: h2osno(:) ! snow water (mm H2O) + real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) + real(r8), pointer :: h2ocan_pft(:) ! canopy water (mm H2O) (pft-level) + real(r8), pointer :: wa(:) ! water in the unconfined aquifer (mm) + integer , pointer :: ctype(:) ! column type + real(r8), pointer :: zwt(:) ! water table depth (m) + real(r8), pointer :: zi(:,:) ! interface level below a "z" level (m) +! +! local pointers to original implicit out variables +! + real(r8), pointer :: h2ocan_col(:) ! canopy water (mm H2O) (column level) + real(r8), pointer :: begwb(:) ! water mass begining of the time step +! +! !OTHER LOCAL VARIABLES: +! + integer :: c, p, f, j, fc ! indices +!----------------------------------------------------------------------- + + ! Assign local pointers to derived type members (column-level) + + h2osno => cws%h2osno + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + begwb => cwbal%begwb + h2ocan_col => pws_a%h2ocan + wa => cws%wa + ctype => col%itype + zwt => cws%zwt + zi => cps%zi + + ! Assign local pointers to derived type members (pft-level) + + h2ocan_pft => pws%h2ocan + + ! Determine beginning water balance for time step + ! pft-level canopy water averaged to column + call p2c(num_nolakec, filter_nolakec, h2ocan_pft, h2ocan_col) + + do f = 1, num_hydrologyc + c = filter_hydrologyc(f) + if(zwt(c) <= zi(c,nlevsoi)) then + wa(c) = 5000._r8 + end if + end do + + do f = 1, num_nolakec + c = filter_nolakec(f) + if (ctype(c) == icol_roof .or. ctype(c) == icol_sunwall & + .or. ctype(c) == icol_shadewall .or. ctype(c) == icol_road_imperv) then + begwb(c) = h2ocan_col(c) + h2osno(c) + else + begwb(c) = h2ocan_col(c) + h2osno(c) + wa(c) + end if + end do + do j = 1, nlevgrnd + do f = 1, num_nolakec + c = filter_nolakec(f) + begwb(c) = begwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + end do + end do + + do f = 1, num_lakec + c = filter_lakec(f) + begwb(c) = h2osno(c) + end do + + end subroutine BeginWaterBalance +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BalanceCheck +! +! !INTERFACE: + subroutine BalanceCheck(lbp, ubp, lbc, ubc, lbl, ubl, lbg, ubg) +! +! !DESCRIPTION: +! This subroutine accumulates the numerical truncation errors of the water +! and energy balance calculation. It is helpful to see the performance of +! the process of integration. +! +! The error for energy balance: +! +! error = abs(Net radiation - change of internal energy - Sensible heat +! - Latent heat) +! +! The error for water balance: +! +! error = abs(precipitation - change of water storage - evaporation - runoff) +! +! !USES: + use clmtype + use clm_atmlnd , only : clm_a2l + use subgridAveMod + use clm_time_manager , only : get_step_size, get_nstep, is_first_restart_step + use clm_varcon , only : isturb, icol_roof, icol_sunwall, icol_shadewall, & + spval, icol_road_perv, icol_road_imperv, istice_mec, & + istdlak, istslak, istwet, istcrop, istsoil + use clm_varctl , only : glc_dyntopo +! +! !ARGUMENTS: + implicit none + integer :: lbp, ubp ! pft-index bounds + integer :: lbc, ubc ! column-index bounds + integer :: lbl, ubl ! landunit-index bounds + integer :: lbg, ubg ! grid-index bounds +! +! !CALLED FROM: +! subroutine clm_driver +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 10 November 2000: Mariana Vertenstein +! Migrated to new data structures by Mariana Vertenstein and +! Peter Thornton +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in arguments +! + logical , pointer :: do_capsnow(:) ! true => do snow capping + real(r8), pointer :: qflx_floodc(:) ! total runoff due to flooding + real(r8), pointer :: qflx_snow_melt(:) ! snow melt (net) + real(r8), pointer :: qflx_rain_grnd_col(:) ! rain on ground after interception (mm H2O/s) [+] + real(r8), pointer :: qflx_snow_grnd_col(:) ! snow on ground after interception (mm H2O/s) [+] + integer , pointer :: pgridcell(:) ! pft's gridcell index + integer , pointer :: plandunit(:) ! pft's landunit index + integer , pointer :: cgridcell(:) ! column's gridcell index + integer , pointer :: clandunit(:) ! column's landunit index + integer , pointer :: ltype(:) ! landunit type + integer , pointer :: ctype(:) ! column type + real(r8), pointer :: pwtgcell(:) ! pft's weight relative to corresponding gridcell + real(r8), pointer :: cwtgcell(:) ! column's weight relative to corresponding gridcell + real(r8), pointer :: forc_rain(:) ! rain rate [mm/s] + real(r8), pointer :: forc_snow(:) ! snow rate [mm/s] + real(r8), pointer :: forc_lwrad(:) ! downward infrared (longwave) radiation (W/m**2) + real(r8), pointer :: endwb(:) ! water mass end of the time step + real(r8), pointer :: begwb(:) ! water mass begining of the time step + real(r8), pointer :: fsa(:) ! solar radiation absorbed (total) (W/m**2) + real(r8), pointer :: fsr(:) ! solar radiation reflected (W/m**2) + real(r8), pointer :: eflx_lwrad_out(:) ! emitted infrared (longwave) radiation (W/m**2) + real(r8), pointer :: eflx_lwrad_net(:) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(r8), pointer :: sabv(:) ! solar radiation absorbed by vegetation (W/m**2) + real(r8), pointer :: sabg(:) ! solar radiation absorbed by ground (W/m**2) + real(r8), pointer :: eflx_sh_tot(:) ! total sensible heat flux (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_totg(:) ! total sensible heat flux at grid level (W/m**2) [+ to atm] + real(r8), pointer :: eflx_dynbal(:) ! energy conversion flux due to dynamic land cover change(W/m**2) [+ to atm] + real(r8), pointer :: eflx_lh_tot(:) ! total latent heat flux (W/m8*2) [+ to atm] + real(r8), pointer :: eflx_soil_grnd(:) ! soil heat flux (W/m**2) [+ = into soil] + real(r8), pointer :: qflx_evap_tot(:) ! qflx_evap_soi + qflx_evap_can + qflx_tran_veg + real(r8), pointer :: qflx_irrig(:) ! irrigation flux (mm H2O /s) + real(r8), pointer :: qflx_surf(:) ! surface runoff (mm H2O /s) + real(r8), pointer :: qflx_qrgwl(:) ! qflx_surf at glaciers, wetlands, lakes + real(r8), pointer :: qflx_drain(:) ! sub-surface runoff (mm H2O /s) + real(r8), pointer :: qflx_runoff(:) ! total runoff (mm H2O /s) + real(r8), pointer :: qflx_runoffg(:) ! total runoff at gridcell level inc land cover change flux (mm H2O /s) + real(r8), pointer :: qflx_liq_dynbal(:) ! liq runoff due to dynamic land cover change (mm H2O /s) + real(r8), pointer :: qflx_snwcp_ice(:) ! excess snowfall due to snow capping (mm H2O /s) [+]` + real(r8), pointer :: qflx_glcice(:) ! flux of new glacier ice (mm H2O /s) [+ if ice grows] + real(r8), pointer :: qflx_glcice_frz(:) ! ice growth (mm H2O/s) [+] + real(r8), pointer :: qflx_snwcp_iceg(:) ! excess snowfall due to snow cap inc land cover change flux (mm H20/s) + real(r8), pointer :: qflx_ice_dynbal(:) ! ice runoff due to dynamic land cover change (mm H2O /s) + real(r8), pointer :: forc_solad(:,:) ! direct beam radiation (vis=forc_sols , nir=forc_soll ) + real(r8), pointer :: forc_solai(:,:) ! diffuse radiation (vis=forc_solsd, nir=forc_solld) + real(r8), pointer :: eflx_traffic_pft(:) ! traffic sensible heat flux (W/m**2) + real(r8), pointer :: eflx_wasteheat_pft(:) ! sensible heat flux from urban heating/cooling sources of waste heat (W/m**2) + real(r8), pointer :: canyon_hwr(:) ! ratio of building height to street width + real(r8), pointer :: eflx_heat_from_ac_pft(:) !sensible heat flux put back into canyon due to removal by AC (W/m**2) + real(r8), pointer :: h2osno(:) ! snow water (mm H2O) + real(r8), pointer :: h2osno_old(:) ! snow water (mm H2O) at previous time step + real(r8), pointer :: qflx_dew_snow(:) ! surface dew added to snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_sub_snow(:) ! sublimation rate from snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_top_soil(:) ! net water input into soil from top (mm/s) + real(r8), pointer :: qflx_dew_grnd(:) ! ground surface dew formation (mm H2O /s) [+] + real(r8), pointer :: qflx_evap_grnd(:) ! ground surface evaporation rate (mm H2O/s) [+] + real(r8), pointer :: qflx_prec_grnd(:) ! water onto ground including canopy runoff [kg/(m2 s)] + real(r8), pointer :: qflx_snwcp_liq(:) ! excess liquid water due to snow capping (mm H2O /s) [+]` + real(r8), pointer :: qflx_sl_top_soil(:) ! liquid water + ice from layer above soil to top soil layer or sent to qflx_qrgwl (mm H2O/s) + integer , pointer :: snl(:) ! number of snow layers +! +! local pointers to original implicit out arguments +! + real(r8), pointer :: errh2o(:) ! water conservation error (mm H2O) + real(r8), pointer :: errsol(:) ! solar radiation conservation error (W/m**2) + real(r8), pointer :: errlon(:) ! longwave radiation conservation error (W/m**2) + real(r8), pointer :: errseb(:) ! surface energy conservation error (W/m**2) + real(r8), pointer :: netrad(:) ! net radiation (positive downward) (W/m**2) + real(r8), pointer :: errsoi_col(:) ! column-level soil/lake energy conservation error (W/m**2) + real(r8), pointer :: snow_sources(:) ! snow sources (mm H2O /s) + real(r8), pointer :: snow_sinks(:) ! snow sinks (mm H2O /s) + real(r8), pointer :: errh2osno(:) ! error in h2osno (kg m-2) +! +!EOP +! +! !OTHER LOCAL VARIABLES: + integer :: p,c,l,g ! indices + real(r8) :: dtime ! land model time step (sec) + integer :: nstep ! time step number + logical :: found ! flag in search loop + integer :: indexp,indexc,indexl,indexg ! index of first found in search loop + real(r8) :: forc_rain_col(lbc:ubc) ! column level rain rate [mm/s] + real(r8) :: forc_snow_col(lbc:ubc) ! column level snow rate [mm/s] + +!----------------------------------------------------------------------- + + ! Assign local pointers to derived type scalar members (gridcell-level) + + do_capsnow => cps%do_capsnow + qflx_floodc => cwf%qflx_floodc + qflx_snow_melt => cwf%qflx_snow_melt + qflx_rain_grnd_col => pwf_a%qflx_rain_grnd + qflx_snow_grnd_col => pwf_a%qflx_snow_grnd + clandunit => col%landunit + forc_rain => clm_a2l%forc_rain + forc_snow => clm_a2l%forc_snow + forc_lwrad => clm_a2l%forc_lwrad + forc_solad => clm_a2l%forc_solad + forc_solai => clm_a2l%forc_solai + + ! Assign local pointers to derived type scalar members (landunit-level) + + ltype => lun%itype + canyon_hwr => lun%canyon_hwr + + ! Assign local pointers to derived type scalar members (column-level) + + ctype => col%itype + cgridcell => col%gridcell + cwtgcell => col%wtgcell + endwb => cwbal%endwb + begwb => cwbal%begwb + qflx_irrig => cwf%qflx_irrig + qflx_surf => cwf%qflx_surf + qflx_qrgwl => cwf%qflx_qrgwl + qflx_drain => cwf%qflx_drain + qflx_runoff => cwf%qflx_runoff + qflx_snwcp_ice => pwf_a%qflx_snwcp_ice + qflx_evap_tot => pwf_a%qflx_evap_tot + qflx_glcice => cwf%qflx_glcice + qflx_glcice_frz => cwf%qflx_glcice_frz + errh2o => cwbal%errh2o + errsoi_col => cebal%errsoi + h2osno => cws%h2osno + h2osno_old => cws%h2osno_old + qflx_dew_snow => pwf_a%qflx_dew_snow + qflx_sub_snow => pwf_a%qflx_sub_snow + qflx_top_soil => cwf%qflx_top_soil + qflx_evap_grnd => pwf_a%qflx_evap_grnd + qflx_dew_grnd => pwf_a%qflx_dew_grnd + qflx_prec_grnd => pwf_a%qflx_prec_grnd + qflx_snwcp_liq => pwf_a%qflx_snwcp_liq + qflx_sl_top_soil => cwf%qflx_sl_top_soil + snow_sources => cws%snow_sources + snow_sinks => cws%snow_sinks + errh2osno => cws%errh2osno + snl => cps%snl + + ! Assign local pointers to derived type scalar members (pft-level) + + pgridcell => pft%gridcell + plandunit => pft%landunit + pwtgcell => pft%wtgcell + fsa => pef%fsa + fsr => pef%fsr + eflx_lwrad_out => pef%eflx_lwrad_out + eflx_lwrad_net => pef%eflx_lwrad_net + sabv => pef%sabv + sabg => pef%sabg + eflx_sh_tot => pef%eflx_sh_tot + eflx_lh_tot => pef%eflx_lh_tot + eflx_soil_grnd => pef%eflx_soil_grnd + errsol => pebal%errsol + errseb => pebal%errseb + errlon => pebal%errlon + netrad => pef%netrad + eflx_wasteheat_pft => pef%eflx_wasteheat_pft + eflx_heat_from_ac_pft => pef%eflx_heat_from_ac_pft + eflx_traffic_pft => pef%eflx_traffic_pft + + ! Assign local pointers to derived type scalar members (gridcell-level) + + qflx_runoffg => gwf%qflx_runoffg + qflx_liq_dynbal => gwf%qflx_liq_dynbal + qflx_snwcp_iceg => gwf%qflx_snwcp_iceg + qflx_ice_dynbal => gwf%qflx_ice_dynbal + eflx_sh_totg => gef%eflx_sh_totg + eflx_dynbal => gef%eflx_dynbal + + ! Get step size and time step + + nstep = get_nstep() + dtime = get_step_size() + + ! Determine column level incoming snow and rain + ! Assume no incident precipitation on urban wall columns (as in Hydrology1Mod.F90). + + do c = lbc,ubc + g = cgridcell(c) + if (ctype(c) == icol_sunwall .or. ctype(c) == icol_shadewall) then + forc_rain_col(c) = 0. + forc_snow_col(c) = 0. + else + forc_rain_col(c) = forc_rain(g) + forc_snow_col(c) = forc_snow(g) + end if + end do + + ! Water balance check + + do c = lbc, ubc + g = cgridcell(c) + l = clandunit(c) + + ! Note: Some glacier_mec cols may have zero weight + if (cwtgcell(c) > 0._r8 .or. ltype(l)==istice_mec)then + errh2o(c) = endwb(c) - begwb(c) & + - (forc_rain_col(c) + forc_snow_col(c) + qflx_irrig(c) + qflx_floodc(c) & + - qflx_evap_tot(c) - qflx_surf(c) & + - qflx_qrgwl(c) - qflx_drain(c) - qflx_snwcp_ice(c)) * dtime + + ! Suppose glc_dyntopo = T: + ! (1) We have qflx_snwcp_ice = 0, and excess snow has been incorporated in qflx_glcice. + ! This flux must be included here to complete the water balance. + ! (2) Meltwater from ice is allowed to run off and is included in qflx_qrgwl, + ! but the water content of the ice column has not changed (at least for now) because + ! an equivalent ice mass has been "borrowed" from the base of the column. That + ! meltwater is included in qflx_glcice. + ! + ! Note that qflx_glcice is only valid over ice_mec landunits; elsewhere it is spval + + if (glc_dyntopo .and. ltype(l)==istice_mec) then + errh2o(c) = errh2o(c) + qflx_glcice(c)*dtime + end if + + else + + errh2o(c) = 0.0_r8 + + end if + + end do + + found = .false. + do c = lbc, ubc + if (abs(errh2o(c)) > 1e-7_r8) then + found = .true. + indexc = c + end if + end do + if ( found .and. (.not. is_first_restart_step()) ) then ! TJH + write(iulog,*)'WARNING: water balance error ',& + ' nstep = ',nstep,' indexc= ',indexc,' errh2o= ',errh2o(indexc),' landunit type= ',ltype(clandunit(indexc)) + if ((ctype(indexc) .eq. icol_roof .or. ctype(indexc) .eq. icol_road_imperv .or. & + ctype(indexc) .eq. icol_road_perv) .and. abs(errh2o(indexc)) > 1.e-1 .and. (nstep > 2) ) then + write(iulog,*)'clm urban model is stopping - error is greater than 1.e-1' + write(iulog,*)'nstep = ',nstep,' indexc= ',indexc,' errh2o= ',errh2o(indexc) + write(iulog,*)'ctype(indexc): ',ctype(indexc) + write(iulog,*)'forc_rain = ',forc_rain_col(indexc) + write(iulog,*)'forc_snow = ',forc_snow_col(indexc) + write(iulog,*)'endwb = ',endwb(indexc) + write(iulog,*)'begwb = ',begwb(indexc) + write(iulog,*)'qflx_evap_tot= ',qflx_evap_tot(indexc) + write(iulog,*)'qflx_irrig = ',qflx_irrig(indexc) + write(iulog,*)'qflx_surf = ',qflx_surf(indexc) + write(iulog,*)'qflx_qrgwl = ',qflx_qrgwl(indexc) + write(iulog,*)'qflx_drain = ',qflx_drain(indexc) + write(iulog,*)'qflx_flood = ',qflx_floodc(indexc) + write(iulog,*)'qflx_snwcp_ice = ',qflx_snwcp_ice(indexc) + write(iulog,*)'clm model is stopping' + call endrun('clm urban model is stopping - water balance error is greater than 1.e-1') + else if (abs(errh2o(indexc)) > .10_r8 .and. (nstep > 2) ) then + write(iulog,*)'clm model is stopping - error is greater than .10' + write(iulog,*)'nstep = ',nstep,' indexc= ',indexc,' errh2o= ',errh2o(indexc) + write(iulog,*)'ctype(indexc): ',ctype(indexc) + write(iulog,*)'forc_rain = ',forc_rain_col(indexc) + write(iulog,*)'forc_snow = ',forc_snow_col(indexc) + write(iulog,*)'endwb = ',endwb(indexc) + write(iulog,*)'begwb = ',begwb(indexc) + write(iulog,*)'qflx_evap_tot= ',qflx_evap_tot(indexc) + write(iulog,*)'qflx_irrig = ',qflx_irrig(indexc) + write(iulog,*)'qflx_surf = ',qflx_surf(indexc) + write(iulog,*)'qflx_qrgwl = ',qflx_qrgwl(indexc) + write(iulog,*)'qflx_drain = ',qflx_drain(indexc) + write(iulog,*)'qflx_flood = ',qflx_floodc(indexc) + write(iulog,*)'qflx_snwcp_ice = ',qflx_snwcp_ice(indexc) + write(iulog,*)'clm model is stopping' + call endrun('clm model is stopping - water balance error is greater than .10') + end if + end if + + ! Snow balance check + do c = lbc, ubc + g = cgridcell(c) + l = clandunit(c) + ! As defined here, snow_sources - snow_sinks will equal the change in h2osno at + ! any given time step but only if there is at least one snow layer. h2osno + ! also includes snow that is part of the soil column (an initial snow layer is + ! only created if h2osno > 10mm). + + ! --------------------------------------------------------------------- ! + ! SPM - brought in qflx_snow_melt to get snow + ! balance working after the flooding modifications were in place. + ! This new check is based on a perfrostsims branch of S. Swenson. + ! --------------------------------------------------------------------- ! + + if (snl(c) .lt. 0) then + snow_sources(c) = qflx_prec_grnd(c) + qflx_dew_snow(c) + qflx_dew_grnd(c) + snow_sinks(c) = qflx_sub_snow(c) + qflx_evap_grnd(c) + qflx_snow_melt(c) & + + qflx_snwcp_ice(c) + qflx_snwcp_liq(c) + qflx_sl_top_soil(c) + + if (ltype(l) == istdlak) then + if ( do_capsnow(c) ) then + snow_sources(c) = qflx_snow_grnd_col(c) & + + qflx_dew_snow(c) + qflx_dew_grnd(c) + + snow_sinks(c) = qflx_sub_snow(c) + qflx_evap_grnd(c) & + + (qflx_snwcp_ice(c) + qflx_snwcp_liq(c) - qflx_prec_grnd(c)) & + + qflx_snow_melt(c) + qflx_sl_top_soil(c) + else + snow_sources(c) = qflx_snow_grnd_col(c) & + + qflx_rain_grnd_col(c) & + + qflx_dew_snow(c) + qflx_dew_grnd(c) + + snow_sinks(c) = qflx_sub_snow(c) + qflx_evap_grnd(c) & + + qflx_snow_melt(c) + qflx_sl_top_soil(c) + endif + endif + + if (ltype(l) == istsoil .or. ltype(l) == istcrop .or. ltype(l) == istwet ) then + if ( do_capsnow(c) ) then + snow_sources(c) = qflx_dew_snow(c) + qflx_dew_grnd(c) & + + qflx_prec_grnd(c) + + snow_sinks(c) = qflx_sub_snow(c) + qflx_evap_grnd(c) & + + qflx_snwcp_ice(c) + qflx_snwcp_liq(c) & + + qflx_snow_melt(c) + qflx_sl_top_soil(c) + else + snow_sources(c) = qflx_snow_grnd_col(c) & + + qflx_rain_grnd_col(c) & + + qflx_dew_snow(c) + qflx_dew_grnd(c) + + snow_sinks(c) = qflx_sub_snow(c) + qflx_evap_grnd(c) & + + qflx_snow_melt(c) + qflx_sl_top_soil(c) + endif + endif + + if (ltype(l) == istice_mec .and. glc_dyntopo) then + snow_sinks(c) = snow_sinks(c) + qflx_glcice_frz(c) + end if + + errh2osno(c) = (h2osno(c) - h2osno_old(c)) - (snow_sources(c) - snow_sinks(c)) * dtime + else + snow_sources(c) = 0._r8 + snow_sinks(c) = 0._r8 + errh2osno(c) = 0._r8 + end if + end do + + found = .false. + do c = lbc, ubc + if (cwtgcell(c) > 0._r8 .and. abs(errh2osno(c)) > 1.0e-7_r8) then + found = .true. + indexc = c + end if + end do + + if ( found .and. (.not. is_first_restart_step()) ) then ! TJH + write(iulog,*)'WARNING: snow balance error ',& + ' nstep = ',nstep,' indexc= ',indexc,' errh2osno= ',errh2osno(indexc) + if (abs(errh2osno(indexc)) > 0.1_r8 .and. (nstep > 2) ) then + write(iulog,*)'clm model is stopping - error is greater than .10' + write(iulog,*)'nstep = ',nstep,' indexc= ',indexc,' errh2osno= ',errh2osno(indexc) + write(iulog,*)'ltype: ', ltype(clandunit(indexc)) + write(iulog,*)'ctype(indexc): ',ctype(indexc) + write(iulog,*)'snl: ',snl(indexc) + write(iulog,*)'h2osno: ',h2osno(indexc) + write(iulog,*)'h2osno_old: ',h2osno_old(indexc) + write(iulog,*)'snow_sources: ', snow_sources(indexc) + write(iulog,*)'snow_sinks: ', snow_sinks(indexc) + write(iulog,*)'qflx_prec_grnd: ',qflx_prec_grnd(indexc)*dtime + write(iulog,*)'qflx_sub_snow: ',qflx_sub_snow(indexc)*dtime + write(iulog,*)'qflx_evap_grnd: ',qflx_evap_grnd(indexc)*dtime + write(iulog,*)'qflx_top_soil: ',qflx_top_soil(indexc)*dtime + write(iulog,*)'qflx_dew_snow: ',qflx_dew_snow(indexc)*dtime + write(iulog,*)'qflx_dew_grnd: ',qflx_dew_grnd(indexc)*dtime + write(iulog,*)'qflx_snwcp_ice: ',qflx_snwcp_ice(indexc)*dtime + write(iulog,*)'qflx_snow_melt: ',qflx_snow_melt(indexc)*dtime + write(iulog,*)'qflx_snwcp_liq: ',qflx_snwcp_liq(indexc)*dtime + write(iulog,*)'qflx_sl_top_soil: ',qflx_sl_top_soil(indexc)*dtime + write(iulog,*)'qflx_glcice_frz: ',qflx_glcice_frz(indexc)*dtime + write(iulog,*)'clm model is stopping' + call endrun('clm model is stopping - snow balance error is greater than .10') + end if + end if + + ! Energy balance checks + + do p = lbp, ubp + l = plandunit(p) + ! Note: Some glacier_mec pfts may have zero weight + if (pwtgcell(p)>0._r8 .or. ltype(l)==istice_mec) then + g = pgridcell(p) + + ! Solar radiation energy balance + ! Do not do this check for an urban pft since it will not balance on a per-column + ! level because of interactions between columns and since a separate check is done + ! in the urban radiation module + if (ltype(l) /= isturb) then + errsol(p) = fsa(p) + fsr(p) & + - (forc_solad(g,1) + forc_solad(g,2) + forc_solai(g,1) + forc_solai(g,2)) + else + errsol(p) = spval + end if + + ! Longwave radiation energy balance + ! Do not do this check for an urban pft since it will not balance on a per-column + ! level because of interactions between columns and since a separate check is done + ! in the urban radiation module + if (ltype(l) /= isturb) then + errlon(p) = eflx_lwrad_out(p) - eflx_lwrad_net(p) - forc_lwrad(g) + else + errlon(p) = spval + end if + + ! Surface energy balance + ! Changed to using (eflx_lwrad_net) here instead of (forc_lwrad - eflx_lwrad_out) because + ! there are longwave interactions between urban columns (and therefore pfts). + ! For surfaces other than urban, (eflx_lwrad_net) equals (forc_lwrad - eflx_lwrad_out), + ! and a separate check is done above for these terms. + + if (ltype(l) /= isturb) then + errseb(p) = sabv(p) + sabg(p) + forc_lwrad(g) - eflx_lwrad_out(p) & + - eflx_sh_tot(p) - eflx_lh_tot(p) - eflx_soil_grnd(p) + else + errseb(p) = sabv(p) + sabg(p) & + - eflx_lwrad_net(p) & + - eflx_sh_tot(p) - eflx_lh_tot(p) - eflx_soil_grnd(p) & + + eflx_wasteheat_pft(p) + eflx_heat_from_ac_pft(p) + eflx_traffic_pft(p) + end if + netrad(p) = fsa(p) - eflx_lwrad_net(p) + end if + end do + + ! Solar radiation energy balance check + + found = .false. + do p = lbp, ubp + l = plandunit(p) + if (pwtgcell(p)>0._r8 .or. ltype(l)==istice_mec) then + if ( (errsol(p) /= spval) .and. (abs(errsol(p)) > .10_r8) ) then + found = .true. + indexp = p + indexg = pgridcell(p) + end if + end if + end do + if ( found .and. (nstep > 2) .and. (.not. is_first_restart_step() ) ) then ! TJH + write(iulog,100)'BalanceCheck: solar radiation balance error', nstep, indexp, errsol(indexp) + write(iulog,*)'fsa = ',fsa(indexp) + write(iulog,*)'fsr = ',fsr(indexp) + write(iulog,*)'forc_solad(1)= ',forc_solad(indexg,1) + write(iulog,*)'forc_solad(2)= ',forc_solad(indexg,2) + write(iulog,*)'forc_solai(1)= ',forc_solai(indexg,1) + write(iulog,*)'forc_solai(2)= ',forc_solai(indexg,2) + write(iulog,*)'forc_tot = ',forc_solad(indexg,1)+forc_solad(indexg,2)& + +forc_solai(indexg,1)+forc_solai(indexg,2) + write(iulog,*)'clm model is stopping' + call endrun('BalanceCheck: solar radiation balance error') + end if + + ! Longwave radiation energy balance check + + found = .false. + do p = lbp, ubp + l = plandunit(p) + if (pwtgcell(p)>0._r8 .or. ltype(l)==istice_mec) then + if ( (errlon(p) /= spval) .and. (abs(errlon(p)) > .10_r8) ) then + found = .true. + indexp = p + end if + end if + end do + if ( found .and. (nstep > 2) .and. (.not. is_first_restart_step() ) ) then ! TJH + write(iulog,100)'BalanceCheck: longwave energy balance error',nstep,indexp,errlon(indexp) + write(iulog,*)'clm model is stopping' + call endrun('BalanceCheck: longwave energy balance error') + end if + + ! Surface energy balance check + + found = .false. + do p = lbp, ubp + l = plandunit(p) + if (pwtgcell(p)>0._r8 .or. ltype(l)==istice_mec) then + if (abs(errseb(p)) > .10_r8 ) then + found = .true. + indexp = p + end if + end if + end do + if ( found .and. (nstep > 2) .and. (.not. is_first_restart_step() ) ) then ! TJH + write(iulog,100)'BalanceCheck: surface flux energy balance error',nstep,indexp,errseb(indexp) + write(iulog,*)' sabv = ',sabv(indexp) + write(iulog,*)' sabg = ',sabg(indexp) + write(iulog,*)' eflx_lwrad_net = ',eflx_lwrad_net(indexp) + write(iulog,*)' eflx_sh_tot = ',eflx_sh_tot(indexp) + write(iulog,*)' eflx_lh_tot = ',eflx_lh_tot(indexp) + write(iulog,*)' eflx_soil_grnd = ',eflx_soil_grnd(indexp) + write(iulog,*)'clm model is stopping' + call endrun('BalanceCheck: surface flux energy balance error') + end if + + ! Soil energy balance check + + found = .false. + do c = lbc, ubc + if (abs(errsoi_col(c)) > 1.0e-7_r8 ) then + found = .true. + indexc = c + end if + end do + if ( found .and. (.not. is_first_restart_step() ) ) then ! TJH + write(iulog,100)'BalanceCheck: soil balance error',nstep,indexc,errsoi_col(indexc) + if (abs(errsoi_col(indexc)) > .10_r8 .and. (nstep > 2) ) then + write(iulog,*)'clm model is stopping' + call endrun('BalanceCheck: soil balance error') + end if + end if + + ! Update SH and RUNOFF for dynamic land cover change energy and water fluxes + call c2g( lbc, ubc, lbl, ubl, lbg, ubg, & + qflx_runoff(lbc:ubc), qflx_runoffg(lbg:ubg), & + c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) + do g = lbg, ubg + qflx_runoffg(g) = qflx_runoffg(g) - qflx_liq_dynbal(g) + enddo + + call c2g( lbc, ubc, lbl, ubl, lbg, ubg, & + qflx_snwcp_ice(lbc:ubc), qflx_snwcp_iceg(lbg:ubg), & + c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) + do g = lbg, ubg + qflx_snwcp_iceg(g) = qflx_snwcp_iceg(g) - qflx_ice_dynbal(g) + enddo + + call p2g( lbp, ubp, lbc, ubc, lbl, ubl, lbg, ubg, & + eflx_sh_tot(lbp:ubp), eflx_sh_totg(lbg:ubg), & + p2c_scale_type='unity',c2l_scale_type='urbanf',l2g_scale_type='unity') + do g = lbg, ubg + eflx_sh_totg(g) = eflx_sh_totg(g) - eflx_dynbal(g) + enddo + +100 format (1x,a,' nstep =',i10,' point =',i6,' imbalance =',f12.6,' W/m2') +200 format (1x,a,' nstep =',i10,' point =',i6,' imbalance =',f12.6,' mm') + + end subroutine BalanceCheck + +end module BalanceCheckMod diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/biogeophys/SnowHydrologyMod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/biogeophys/SnowHydrologyMod.F90 new file mode 100644 index 0000000000..a6268878f4 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/biogeophys/SnowHydrologyMod.F90 @@ -0,0 +1,1675 @@ + +! DART note: this file started life as: +! /glade/p/cesmdata/releases/cesm1_2_1/models/lnd/clm/src/clm4_0/biogeophys/SnowHydrologyMod.F90 +! +! NOTE: It includes a modified snow grain radius computation documented in bugzilla +! report 1934. + +module SnowHydrologyMod + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: SnowHydrologyMod +! +! !DESCRIPTION: +! Calculate snow hydrology. +! +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use clm_varpar , only : nlevsno +! +! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + public :: SnowWater ! Change of snow mass and the snow water onto soil + public :: SnowCompaction ! Change in snow layer thickness due to compaction + public :: CombineSnowLayers ! Combine snow layers less than a min thickness + public :: DivideSnowLayers ! Subdivide snow layers if they exceed maximum thickness + public :: BuildSnowFilter ! Construct snow/no-snow filters +! +! !PRIVATE MEMBER FUNCTIONS: + private :: Combo ! Returns the combined variables: dz, t, wliq, wice. +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +!EOP +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: SnowWater +! +! !INTERFACE: + subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & + num_nosnowc, filter_nosnowc) +! +! !DESCRIPTION: +! Evaluate the change of snow mass and the snow water onto soil. +! Water flow within snow is computed by an explicit and non-physical +! based scheme, which permits a part of liquid water over the holding +! capacity (a tentative value is used, i.e. equal to 0.033*porosity) to +! percolate into the underlying layer. Except for cases where the +! porosity of one of the two neighboring layers is less than 0.05, zero +! flow is assumed. The water flow out of the bottom of the snow pack will +! participate as the input of the soil water and runoff. This subroutine +! uses a filter for columns containing snow which must be constructed prior +! to being called. +! +! !USES: + use clmtype + use clm_varcon , only : denh2o, denice, wimp, ssi + use clm_time_manager, only : get_step_size + use clm_atmlnd , only : clm_a2l + use SNICARMod , only : scvng_fct_mlt_bcphi, scvng_fct_mlt_bcpho, & + scvng_fct_mlt_ocphi, scvng_fct_mlt_ocpho, & + scvng_fct_mlt_dst1, scvng_fct_mlt_dst2, & + scvng_fct_mlt_dst3, scvng_fct_mlt_dst4 +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_snowc ! number of snow points in column filter + integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer, intent(in) :: num_nosnowc ! number of non-snow points in column filter + integer, intent(in) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points +! +! !CALLED FROM: +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 15 November 2000: Mariana Vertenstein +! 2/26/02, Peter Thornton: Migrated to new data structures. +! 03/28/08, Mark Flanner: Added aerosol deposition and flushing with meltwater +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arguments +! + integer , pointer :: snl(:) !number of snow layers + logical , pointer :: do_capsnow(:) !true => do snow capping + real(r8), pointer :: qflx_snow_melt(:) !net snow melt + real(r8), pointer :: qflx_snomelt(:) !snow melt (mm H2O /s) + real(r8), pointer :: qflx_rain_grnd(:) !rain on ground after interception (mm H2O/s) [+] + real(r8), pointer :: qflx_sub_snow(:) !sublimation rate from snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_evap_grnd(:) !ground surface evaporation rate (mm H2O/s) [+] + real(r8), pointer :: qflx_dew_snow(:) !surface dew added to snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_dew_grnd(:) !ground surface dew formation (mm H2O /s) [+] + real(r8), pointer :: dz(:,:) !layer depth (m) +! +! local pointers to implicit out arguments +! + real(r8), pointer :: qflx_top_soil(:) !net water input into soil from top (mm/s) +! +! local pointers to implicit inout arguments +! + real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) + integer , pointer :: cgridcell(:) ! columns's gridcell (col) + real(r8), pointer :: mss_bcphi(:,:) ! hydrophillic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_bcpho(:,:) ! hydrophobic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocphi(:,:) ! hydrophillic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocpho(:,:) ! hydrophobic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst1(:,:) ! mass of dust species 1 in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst2(:,:) ! mass of dust species 2 in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst3(:,:) ! mass of dust species 3 in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst4(:,:) ! mass of dust species 4 in snow (col,lyr) [kg] + real(r8), pointer :: flx_bc_dep_dry(:) ! dry BC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_bc_dep_wet(:) ! wet BC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_bc_dep(:) ! total BC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_bc_dep_pho(:) ! hydrophobic BC deposition (col) [kg m-1 s-1] + real(r8), pointer :: flx_bc_dep_phi(:) ! hydrophillic BC deposition (col) [kg m-1 s-1] + real(r8), pointer :: flx_oc_dep_dry(:) ! dry OC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_oc_dep_wet(:) ! wet OC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_oc_dep(:) ! total OC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_oc_dep_pho(:) ! hydrophobic OC deposition (col) [kg m-1 s-1] + real(r8), pointer :: flx_oc_dep_phi(:) ! hydrophillic OC deposition (col) [kg m-1 s-1] + real(r8), pointer :: flx_dst_dep_dry1(:) ! dry dust (species 1) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_wet1(:) ! wet dust (species 1) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_dry2(:) ! dry dust (species 2) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_wet2(:) ! wet dust (species 2) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_dry3(:) ! dry dust (species 3) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_wet3(:) ! wet dust (species 3) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_dry4(:) ! dry dust (species 4) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_wet4(:) ! wet dust (species 4) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep(:) ! total dust deposition (col) [kg m-2 s-1] + real(r8), pointer :: forc_aer(:,:) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] +! +! +! !OTHER LOCAL VARIABLES: +!EOP +! + integer :: c, j, fc !do loop/array indices + real(r8) :: dtime !land model time step (sec) + real(r8) :: qin(lbc:ubc) !water flow into the elmement (mm/s) + real(r8) :: qout(lbc:ubc) !water flow out of the elmement (mm/s) + real(r8) :: wgdif !ice mass after minus sublimation + real(r8) :: vol_liq(lbc:ubc,-nlevsno+1:0) !partial volume of liquid water in layer + real(r8) :: vol_ice(lbc:ubc,-nlevsno+1:0) !partial volume of ice lens in layer + real(r8) :: eff_porosity(lbc:ubc,-nlevsno+1:0) !effective porosity = porosity - vol_ice + integer :: g ! gridcell loop index + real(r8) :: qin_bc_phi(lbc:ubc) ! flux of hydrophilic BC into layer [kg] + real(r8) :: qout_bc_phi(lbc:ubc) ! flux of hydrophilic BC out of layer [kg] + real(r8) :: qin_bc_pho(lbc:ubc) ! flux of hydrophobic BC into layer [kg] + real(r8) :: qout_bc_pho(lbc:ubc) ! flux of hydrophobic BC out of layer [kg] + real(r8) :: qin_oc_phi(lbc:ubc) ! flux of hydrophilic OC into layer [kg] + real(r8) :: qout_oc_phi(lbc:ubc) ! flux of hydrophilic OC out of layer [kg] + real(r8) :: qin_oc_pho(lbc:ubc) ! flux of hydrophobic OC into layer [kg] + real(r8) :: qout_oc_pho(lbc:ubc) ! flux of hydrophobic OC out of layer [kg] + real(r8) :: qin_dst1(lbc:ubc) ! flux of dust species 1 into layer [kg] + real(r8) :: qout_dst1(lbc:ubc) ! flux of dust species 1 out of layer [kg] + real(r8) :: qin_dst2(lbc:ubc) ! flux of dust species 2 into layer [kg] + real(r8) :: qout_dst2(lbc:ubc) ! flux of dust species 2 out of layer [kg] + real(r8) :: qin_dst3(lbc:ubc) ! flux of dust species 3 into layer [kg] + real(r8) :: qout_dst3(lbc:ubc) ! flux of dust species 3 out of layer [kg] + real(r8) :: qin_dst4(lbc:ubc) ! flux of dust species 4 into layer [kg] + real(r8) :: qout_dst4(lbc:ubc) ! flux of dust species 4 out of layer [kg] + real(r8) :: mss_liqice ! mass of liquid+ice in a layer + +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtype components (column-level) + + snl => cps%snl + do_capsnow => cps%do_capsnow + qflx_snow_melt => cwf%qflx_snow_melt + qflx_snomelt => cwf%qflx_snomelt + qflx_rain_grnd => pwf_a%qflx_rain_grnd + qflx_sub_snow => pwf_a%qflx_sub_snow + qflx_evap_grnd => pwf_a%qflx_evap_grnd + qflx_dew_snow => pwf_a%qflx_dew_snow + qflx_dew_grnd => pwf_a%qflx_dew_grnd + qflx_top_soil => cwf%qflx_top_soil + dz => cps%dz + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + cgridcell => col%gridcell + mss_bcphi => cps%mss_bcphi + mss_bcpho => cps%mss_bcpho + mss_ocphi => cps%mss_ocphi + mss_ocpho => cps%mss_ocpho + mss_dst1 => cps%mss_dst1 + mss_dst2 => cps%mss_dst2 + mss_dst3 => cps%mss_dst3 + mss_dst4 => cps%mss_dst4 + flx_bc_dep => cwf%flx_bc_dep + flx_bc_dep_wet => cwf%flx_bc_dep_wet + flx_bc_dep_dry => cwf%flx_bc_dep_dry + flx_bc_dep_phi => cwf%flx_bc_dep_phi + flx_bc_dep_pho => cwf%flx_bc_dep_pho + flx_oc_dep => cwf%flx_oc_dep + flx_oc_dep_wet => cwf%flx_oc_dep_wet + flx_oc_dep_dry => cwf%flx_oc_dep_dry + flx_oc_dep_phi => cwf%flx_oc_dep_phi + flx_oc_dep_pho => cwf%flx_oc_dep_pho + flx_dst_dep => cwf%flx_dst_dep + flx_dst_dep_wet1 => cwf%flx_dst_dep_wet1 + flx_dst_dep_dry1 => cwf%flx_dst_dep_dry1 + flx_dst_dep_wet2 => cwf%flx_dst_dep_wet2 + flx_dst_dep_dry2 => cwf%flx_dst_dep_dry2 + flx_dst_dep_wet3 => cwf%flx_dst_dep_wet3 + flx_dst_dep_dry3 => cwf%flx_dst_dep_dry3 + flx_dst_dep_wet4 => cwf%flx_dst_dep_wet4 + flx_dst_dep_dry4 => cwf%flx_dst_dep_dry4 + forc_aer => clm_a2l%forc_aer + + ! Determine model time step + + dtime = get_step_size() + + ! Renew the mass of ice lens (h2osoi_ice) and liquid (h2osoi_liq) in the + ! surface snow layer resulting from sublimation (frost) / evaporation (condense) + + do fc = 1,num_snowc + c = filter_snowc(fc) + if (do_capsnow(c)) then + wgdif = h2osoi_ice(c,snl(c)+1) - qflx_sub_snow(c)*dtime + h2osoi_ice(c,snl(c)+1) = wgdif + if (wgdif < 0._r8) then + h2osoi_ice(c,snl(c)+1) = 0._r8 + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif + end if + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) - qflx_evap_grnd(c) * dtime + else + wgdif = h2osoi_ice(c,snl(c)+1) + (qflx_dew_snow(c) - qflx_sub_snow(c)) * dtime + h2osoi_ice(c,snl(c)+1) = wgdif + if (wgdif < 0._r8) then + h2osoi_ice(c,snl(c)+1) = 0._r8 + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif + end if + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + & + (qflx_rain_grnd(c) + qflx_dew_grnd(c) - qflx_evap_grnd(c)) * dtime + end if + h2osoi_liq(c,snl(c)+1) = max(0._r8, h2osoi_liq(c,snl(c)+1)) + end do + + ! Porosity and partial volume + + do j = -nlevsno+1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + vol_ice(c,j) = min(1._r8, h2osoi_ice(c,j)/(dz(c,j)*denice)) + eff_porosity(c,j) = 1._r8 - vol_ice(c,j) + vol_liq(c,j) = min(eff_porosity(c,j),h2osoi_liq(c,j)/(dz(c,j)*denh2o)) + end if + end do + end do + + ! Capillary forces within snow are usually two or more orders of magnitude + ! less than those of gravity. Only gravity terms are considered. + ! the genernal expression for water flow is "K * ss**3", however, + ! no effective parameterization for "K". Thus, a very simple consideration + ! (not physically based) is introduced: + ! when the liquid water of layer exceeds the layer's holding + ! capacity, the excess meltwater adds to the underlying neighbor layer. + + ! Also compute aerosol fluxes through snowpack in this loop: + ! 1) compute aerosol mass in each layer + ! 2) add aerosol mass flux from above layer to mass of this layer + ! 3) qout_xxx is mass flux of aerosol species xxx out bottom of + ! layer in water flow, proportional to (current) concentration + ! of aerosol in layer multiplied by a scavenging ratio. + ! 4) update mass of aerosol in top layer, accordingly + ! 5) update mass concentration of aerosol accordingly + + qin(:) = 0._r8 + qin_bc_phi(:) = 0._r8 + qin_bc_pho(:) = 0._r8 + qin_oc_phi(:) = 0._r8 + qin_oc_pho(:) = 0._r8 + qin_dst1(:) = 0._r8 + qin_dst2(:) = 0._r8 + qin_dst3(:) = 0._r8 + qin_dst4(:) = 0._r8 + + do j = -nlevsno+1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + h2osoi_liq(c,j) = h2osoi_liq(c,j) + qin(c) + + mss_bcphi(c,j) = mss_bcphi(c,j) + qin_bc_phi(c) + mss_bcpho(c,j) = mss_bcpho(c,j) + qin_bc_pho(c) + mss_ocphi(c,j) = mss_ocphi(c,j) + qin_oc_phi(c) + mss_ocpho(c,j) = mss_ocpho(c,j) + qin_oc_pho(c) + mss_dst1(c,j) = mss_dst1(c,j) + qin_dst1(c) + mss_dst2(c,j) = mss_dst2(c,j) + qin_dst2(c) + mss_dst3(c,j) = mss_dst3(c,j) + qin_dst3(c) + mss_dst4(c,j) = mss_dst4(c,j) + qin_dst4(c) + + if (j <= -1) then + ! No runoff over snow surface, just ponding on surface + if (eff_porosity(c,j) < wimp .OR. eff_porosity(c,j+1) < wimp) then + qout(c) = 0._r8 + else + qout(c) = max(0._r8,(vol_liq(c,j)-ssi*eff_porosity(c,j))*dz(c,j)) + qout(c) = min(qout(c),(1._r8-vol_ice(c,j+1)-vol_liq(c,j+1))*dz(c,j+1)) + end if + else + qout(c) = max(0._r8,(vol_liq(c,j) - ssi*eff_porosity(c,j))*dz(c,j)) + end if + qout(c) = qout(c)*1000._r8 + h2osoi_liq(c,j) = h2osoi_liq(c,j) - qout(c) + qin(c) = qout(c) + + ! mass of ice+water: in extremely rare circumstances, this can + ! be zero, even though there is a snow layer defined. In + ! this case, set the mass to a very small value to + ! prevent division by zero. + mss_liqice = h2osoi_liq(c,j)+h2osoi_ice(c,j) + if (mss_liqice < 1E-30_r8) then + mss_liqice = 1E-30_r8 + endif + + ! BCPHI: + ! 1. flux with meltwater: + qout_bc_phi(c) = qout(c)*scvng_fct_mlt_bcphi*(mss_bcphi(c,j)/mss_liqice) + if (qout_bc_phi(c) > mss_bcphi(c,j)) then + qout_bc_phi(c) = mss_bcphi(c,j) + endif + mss_bcphi(c,j) = mss_bcphi(c,j) - qout_bc_phi(c) + qin_bc_phi(c) = qout_bc_phi(c) + + ! BCPHO: + ! 1. flux with meltwater: + qout_bc_pho(c) = qout(c)*scvng_fct_mlt_bcpho*(mss_bcpho(c,j)/mss_liqice) + if (qout_bc_pho(c) > mss_bcpho(c,j)) then + qout_bc_pho(c) = mss_bcpho(c,j) + endif + mss_bcpho(c,j) = mss_bcpho(c,j) - qout_bc_pho(c) + qin_bc_pho(c) = qout_bc_pho(c) + + ! OCPHI: + ! 1. flux with meltwater: + qout_oc_phi(c) = qout(c)*scvng_fct_mlt_ocphi*(mss_ocphi(c,j)/mss_liqice) + if (qout_oc_phi(c) > mss_ocphi(c,j)) then + qout_oc_phi(c) = mss_ocphi(c,j) + endif + mss_ocphi(c,j) = mss_ocphi(c,j) - qout_oc_phi(c) + qin_oc_phi(c) = qout_oc_phi(c) + + ! OCPHO: + ! 1. flux with meltwater: + qout_oc_pho(c) = qout(c)*scvng_fct_mlt_ocpho*(mss_ocpho(c,j)/mss_liqice) + if (qout_oc_pho(c) > mss_ocpho(c,j)) then + qout_oc_pho(c) = mss_ocpho(c,j) + endif + mss_ocpho(c,j) = mss_ocpho(c,j) - qout_oc_pho(c) + qin_oc_pho(c) = qout_oc_pho(c) + + ! DUST 1: + ! 1. flux with meltwater: + qout_dst1(c) = qout(c)*scvng_fct_mlt_dst1*(mss_dst1(c,j)/mss_liqice) + if (qout_dst1(c) > mss_dst1(c,j)) then + qout_dst1(c) = mss_dst1(c,j) + endif + mss_dst1(c,j) = mss_dst1(c,j) - qout_dst1(c) + qin_dst1(c) = qout_dst1(c) + + ! DUST 2: + ! 1. flux with meltwater: + qout_dst2(c) = qout(c)*scvng_fct_mlt_dst2*(mss_dst2(c,j)/mss_liqice) + if (qout_dst2(c) > mss_dst2(c,j)) then + qout_dst2(c) = mss_dst2(c,j) + endif + mss_dst2(c,j) = mss_dst2(c,j) - qout_dst2(c) + qin_dst2(c) = qout_dst2(c) + + ! DUST 3: + ! 1. flux with meltwater: + qout_dst3(c) = qout(c)*scvng_fct_mlt_dst3*(mss_dst3(c,j)/mss_liqice) + if (qout_dst3(c) > mss_dst3(c,j)) then + qout_dst3(c) = mss_dst3(c,j) + endif + mss_dst3(c,j) = mss_dst3(c,j) - qout_dst3(c) + qin_dst3(c) = qout_dst3(c) + + ! DUST 4: + ! 1. flux with meltwater: + qout_dst4(c) = qout(c)*scvng_fct_mlt_dst4*(mss_dst4(c,j)/mss_liqice) + if (qout_dst4(c) > mss_dst4(c,j)) then + qout_dst4(c) = mss_dst4(c,j) + endif + mss_dst4(c,j) = mss_dst4(c,j) - qout_dst4(c) + qin_dst4(c) = qout_dst4(c) + + end if + end do + end do + + ! Adjust layer thickness for any water+ice content changes in excess of previous + ! layer thickness. Strictly speaking, only necessary for top snow layer, but doing + ! it for all snow layers will catch problems with older initial files. + ! Layer interfaces (zi) and node depths (z) do not need adjustment here because they + ! are adjusted in CombineSnowLayers and are not used up to that point. + + do j = -nlevsno+1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + dz(c,j) = max(dz(c,j),h2osoi_liq(c,j)/denh2o + h2osoi_ice(c,j)/denice) + end if + end do + end do + + do fc = 1, num_snowc + c = filter_snowc(fc) + ! Qout from snow bottom + qflx_top_soil(c) = qout(c) / dtime + qflx_snow_melt(c) = qflx_snow_melt(c) + (qout(c) / dtime) + end do + + do fc = 1, num_nosnowc + c = filter_nosnowc(fc) + qflx_top_soil(c) = qflx_rain_grnd(c) + qflx_snomelt(c) + qflx_snow_melt(c) = qflx_snomelt(c) + end do + + ! set aerosol deposition fluxes from forcing array + ! The forcing array is either set from an external file + ! or from fluxes received from the atmosphere model + do c = lbc,ubc + g = cgridcell(c) + + flx_bc_dep_dry(c) = forc_aer(g,1) + forc_aer(g,2) + flx_bc_dep_wet(c) = forc_aer(g,3) + flx_bc_dep_phi(c) = forc_aer(g,1) + forc_aer(g,3) + flx_bc_dep_pho(c) = forc_aer(g,2) + flx_bc_dep(c) = forc_aer(g,1) + forc_aer(g,2) + forc_aer(g,3) + + flx_oc_dep_dry(c) = forc_aer(g,4) + forc_aer(g,5) + flx_oc_dep_wet(c) = forc_aer(g,6) + flx_oc_dep_phi(c) = forc_aer(g,4) + forc_aer(g,6) + flx_oc_dep_pho(c) = forc_aer(g,5) + flx_oc_dep(c) = forc_aer(g,4) + forc_aer(g,5) + forc_aer(g,6) + + flx_dst_dep_wet1(c) = forc_aer(g,7) + flx_dst_dep_dry1(c) = forc_aer(g,8) + flx_dst_dep_wet2(c) = forc_aer(g,9) + flx_dst_dep_dry2(c) = forc_aer(g,10) + flx_dst_dep_wet3(c) = forc_aer(g,11) + flx_dst_dep_dry3(c) = forc_aer(g,12) + flx_dst_dep_wet4(c) = forc_aer(g,13) + flx_dst_dep_dry4(c) = forc_aer(g,14) + flx_dst_dep(c) = forc_aer(g,7) + forc_aer(g,8) + forc_aer(g,9) + & + forc_aer(g,10) + forc_aer(g,11) + forc_aer(g,12) + & + forc_aer(g,13) + forc_aer(g,14) + + end do + + ! aerosol deposition fluxes into top layer + ! This is done after the inter-layer fluxes so that some aerosol + ! is in the top layer after deposition, and is not immediately + ! washed out before radiative calculations are done + do fc = 1, num_snowc + c = filter_snowc(fc) + mss_bcphi(c,snl(c)+1) = mss_bcphi(c,snl(c)+1) + (flx_bc_dep_phi(c)*dtime) + mss_bcpho(c,snl(c)+1) = mss_bcpho(c,snl(c)+1) + (flx_bc_dep_pho(c)*dtime) + mss_ocphi(c,snl(c)+1) = mss_ocphi(c,snl(c)+1) + (flx_oc_dep_phi(c)*dtime) + mss_ocpho(c,snl(c)+1) = mss_ocpho(c,snl(c)+1) + (flx_oc_dep_pho(c)*dtime) + + mss_dst1(c,snl(c)+1) = mss_dst1(c,snl(c)+1) + (flx_dst_dep_dry1(c) + flx_dst_dep_wet1(c))*dtime + mss_dst2(c,snl(c)+1) = mss_dst2(c,snl(c)+1) + (flx_dst_dep_dry2(c) + flx_dst_dep_wet2(c))*dtime + mss_dst3(c,snl(c)+1) = mss_dst3(c,snl(c)+1) + (flx_dst_dep_dry3(c) + flx_dst_dep_wet3(c))*dtime + mss_dst4(c,snl(c)+1) = mss_dst4(c,snl(c)+1) + (flx_dst_dep_dry4(c) + flx_dst_dep_wet4(c))*dtime + end do + + end subroutine SnowWater + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: SnowCompaction +! +! !INTERFACE: + subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc) +! +! !DESCRIPTION: +! Determine the change in snow layer thickness due to compaction and +! settling. +! Three metamorphisms of changing snow characteristics are implemented, +! i.e., destructive, overburden, and melt. The treatments of the former +! two are from SNTHERM.89 and SNTHERM.99 (1991, 1999). The contribution +! due to melt metamorphism is simply taken as a ratio of snow ice +! fraction after the melting versus before the melting. +! +! !USES: + use clmtype + use clm_time_manager, only : get_step_size + use clm_varcon , only : denice, denh2o, tfrz, istice_mec +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_snowc ! number of column snow points in column filter + integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in module Hydrology2Mod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/28/02, Peter Thornton: Migrated to new data structures +! 2/29/08, David Lawrence: Revised snow overburden to be include 0.5 weight of current layer +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in scalars +! + integer, pointer :: snl(:) !number of snow layers +! +! local pointers to implicit in arguments +! + integer, pointer :: imelt(:,:) !flag for melting (=1), freezing (=2), Not=0 + real(r8), pointer :: frac_iceold(:,:) !fraction of ice relative to the tot water + real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin) + real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) +! +! local pointers to implicit inout arguments +! + real(r8), pointer :: dz(:,:) !layer depth (m) +! +! +! !OTHER LOCAL VARIABLES: +!EOP +! + integer :: j, l, c, fc ! indices + real(r8):: dtime ! land model time step (sec) + real(r8), parameter :: c2 = 23.e-3_r8 ! [m3/kg] + real(r8), parameter :: c3 = 2.777e-6_r8 ! [1/s] + real(r8), parameter :: c4 = 0.04_r8 ! [1/K] + real(r8), parameter :: c5 = 2.0_r8 ! + real(r8), parameter :: dm = 100.0_r8 ! Upper Limit on Destructive Metamorphism Compaction [kg/m3] + real(r8), parameter :: eta0 = 9.e+5_r8 ! The Viscosity Coefficient Eta0 [kg-s/m2] + real(r8) :: burden(lbc:ubc) ! pressure of overlying snow [kg/m2] + real(r8) :: ddz1 ! Rate of settling of snowpack due to destructive metamorphism. + real(r8) :: ddz2 ! Rate of compaction of snowpack due to overburden. + real(r8) :: ddz3 ! Rate of compaction of snowpack due to melt [1/s] + real(r8) :: dexpf ! expf=exp(-c4*(273.15-t_soisno)). + real(r8) :: fi ! Fraction of ice relative to the total water content at current time step + real(r8) :: td ! t_soisno - tfrz [K] + real(r8) :: pdzdtc ! Nodal rate of change in fractional-thickness due to compaction [fraction/s] + real(r8) :: void ! void (1 - vol_ice - vol_liq) + real(r8) :: wx ! water mass (ice+liquid) [kg/m2] + real(r8) :: bi ! partial density of ice [kg/m3] + + integer, pointer :: clandunit(:) !landunit index for each column + integer, pointer :: ltype(:) !landunit type + +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtypes (column-level) + + snl => cps%snl + dz => cps%dz + imelt => cps%imelt + frac_iceold => cps%frac_iceold + t_soisno => ces%t_soisno + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + clandunit => col%landunit + ltype => lun%itype + + ! Get time step + + dtime = get_step_size() + + ! Begin calculation - note that the following column loops are only invoked if snl(c) < 0 + + burden(:) = 0._r8 + + do j = -nlevsno+1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + + wx = h2osoi_ice(c,j) + h2osoi_liq(c,j) + void = 1._r8 - (h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o) / dz(c,j) + + ! If void is negative, then increase dz such that void = 0. + ! This should be done for any landunit, but for now is done only for glacier_mec 1andunits. + l = clandunit(c) + if (ltype(l)==istice_mec .and. void < 0._r8) then + dz(c,j) = h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o + void = 0._r8 + endif + + ! Allow compaction only for non-saturated node and higher ice lens node. + if (void > 0.001_r8 .and. h2osoi_ice(c,j) > .1_r8) then + bi = h2osoi_ice(c,j) / dz(c,j) + fi = h2osoi_ice(c,j) / wx + td = tfrz-t_soisno(c,j) + dexpf = exp(-c4*td) + + ! Settling as a result of destructive metamorphism + + ddz1 = -c3*dexpf + if (bi > dm) ddz1 = ddz1*exp(-46.0e-3_r8*(bi-dm)) + + ! Liquid water term + + if (h2osoi_liq(c,j) > 0.01_r8*dz(c,j)) ddz1=ddz1*c5 + + ! Compaction due to overburden + + ddz2 = -(burden(c)+wx/2._r8)*exp(-0.08_r8*td - c2*bi)/eta0 + + ! Compaction occurring during melt + + if (imelt(c,j) == 1) then + ddz3 = - 1._r8/dtime * max(0._r8,(frac_iceold(c,j) - fi)/frac_iceold(c,j)) + else + ddz3 = 0._r8 + end if + + ! Time rate of fractional change in dz (units of s-1) + + pdzdtc = ddz1 + ddz2 + ddz3 + + ! The change in dz due to compaction + ! Limit compaction to no less than fully saturated layer thickness + + dz(c,j) = max(dz(c,j) * (1._r8+pdzdtc*dtime),h2osoi_ice(c,j)/denice & + + h2osoi_liq(c,j)/denh2o) + + end if + + ! Pressure of overlying snow + + burden(c) = burden(c) + wx + + end if + end do + end do + + end subroutine SnowCompaction + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: CombineSnowLayers +! +! !INTERFACE: + subroutine CombineSnowLayers(lbc, ubc, num_snowc, filter_snowc) +! +! !DESCRIPTION: +! Combine snow layers that are less than a minimum thickness or mass +! If the snow element thickness or mass is less than a prescribed minimum, +! then it is combined with a neighboring element. The subroutine +! clm\_combo.f90 then executes the combination of mass and energy. +! +! !USES: + use clmtype + use clm_varcon, only : istsoil, isturb + use clm_varcon, only : istcrop + use clm_time_manager, only : get_step_size +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(inout) :: num_snowc ! number of column snow points in column filter + integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in module Hydrology2Mod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/28/02, Peter Thornton: Migrated to new data structures. +! 03/28/08, Mark Flanner: Added aerosol masses and snow grain radius +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arguments +! + integer, pointer :: clandunit(:) !landunit index for each column + integer, pointer :: ltype(:) !landunit type +! +! local pointers to implicit inout arguments +! + integer , pointer :: snl(:) !number of snow layers + real(r8), pointer :: h2osno(:) !snow water (mm H2O) + real(r8), pointer :: snowdp(:) !snow height (m) + real(r8), pointer :: dz(:,:) !layer depth (m) + real(r8), pointer :: zi(:,:) !interface level below a "z" level (m) + real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin) + real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) +! +! local pointers to implicit out arguments +! + real(r8), pointer :: z(:,:) ! layer thickness (m) + real(r8), pointer :: mss_bcphi(:,:) ! hydrophilic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_bcpho(:,:) ! hydrophobic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocphi(:,:) ! hydrophilic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocpho(:,:) ! hydrophobic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst1(:,:) ! dust species 1 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst2(:,:) ! dust species 2 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst3(:,:) ! dust species 3 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst4(:,:) ! dust species 4 mass in snow (col,lyr) [kg] + real(r8), pointer :: snw_rds(:,:) ! effective snow grain radius (col,lyr) [microns, m^-6] + real(r8), pointer :: qflx_sl_top_soil(:) ! liquid water + ice from layer above soil to top soil layer or sent to qflx_qrgwl (mm H2O/s) +! +! +! !OTHER LOCAL VARIABLES: +!EOP +! + integer :: c, fc ! column indices + integer :: i,k ! loop indices + integer :: j,l ! node indices + integer :: msn_old(lbc:ubc) ! number of top snow layer + integer :: mssi(lbc:ubc) ! node index + integer :: neibor ! adjacent node selected for combination + real(r8):: zwice(lbc:ubc) ! total ice mass in snow + real(r8):: zwliq (lbc:ubc) ! total liquid water in snow + real(r8):: dzmin(5) ! minimum of top snow layer + real(r8) :: dtime !land model time step (sec) + + data dzmin /0.010_r8, 0.015_r8, 0.025_r8, 0.055_r8, 0.115_r8/ +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtypes (landunit-level) + + ltype => lun%itype + + ! Assign local pointers to derived subtypes (column-level) + + clandunit => col%landunit + snl => cps%snl + snowdp => cps%snowdp + h2osno => cws%h2osno + dz => cps%dz + zi => cps%zi + z => cps%z + t_soisno => ces%t_soisno + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + mss_bcphi => cps%mss_bcphi + mss_bcpho => cps%mss_bcpho + mss_ocphi => cps%mss_ocphi + mss_ocpho => cps%mss_ocpho + mss_dst1 => cps%mss_dst1 + mss_dst2 => cps%mss_dst2 + mss_dst3 => cps%mss_dst3 + mss_dst4 => cps%mss_dst4 + snw_rds => cps%snw_rds + qflx_sl_top_soil => cwf%qflx_sl_top_soil + + ! Determine model time step + + dtime = get_step_size() + + + ! Check the mass of ice lens of snow, when the total is less than a small value, + ! combine it with the underlying neighbor. + + do fc = 1, num_snowc + c = filter_snowc(fc) + msn_old(c) = snl(c) + qflx_sl_top_soil(c) = 0._r8 + end do + + ! The following loop is NOT VECTORIZED + + do fc = 1, num_snowc + c = filter_snowc(fc) + l = clandunit(c) + do j = msn_old(c)+1,0 + if (h2osoi_ice(c,j) <= .1_r8) then + if (ltype(l) == istsoil .or. ltype(l)==isturb .or. ltype(l) == istcrop) then + h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j) + h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j) + + if (j == 0) then + qflx_sl_top_soil(c) = (h2osoi_liq(c,j) + h2osoi_ice(c,j))/dtime + end if + + if (j /= 0) dz(c,j+1) = dz(c,j+1) + dz(c,j) + + ! NOTE: Temperature, and similarly snw_rds, of the + ! underlying snow layer are NOT adjusted in this case. + ! Because the layer being eliminated has a small mass, + ! this should not make a large difference, but it + ! would be more thorough to do so. + if (j /= 0) then + mss_bcphi(c,j+1) = mss_bcphi(c,j+1) + mss_bcphi(c,j) + mss_bcpho(c,j+1) = mss_bcpho(c,j+1) + mss_bcpho(c,j) + mss_ocphi(c,j+1) = mss_ocphi(c,j+1) + mss_ocphi(c,j) + mss_ocpho(c,j+1) = mss_ocpho(c,j+1) + mss_ocpho(c,j) + mss_dst1(c,j+1) = mss_dst1(c,j+1) + mss_dst1(c,j) + mss_dst2(c,j+1) = mss_dst2(c,j+1) + mss_dst2(c,j) + mss_dst3(c,j+1) = mss_dst3(c,j+1) + mss_dst3(c,j) + mss_dst4(c,j+1) = mss_dst4(c,j+1) + mss_dst4(c,j) + end if + + else if (ltype(l) /= istsoil .and. ltype(l) /= isturb .and. ltype(l) /= istcrop .and. j /= 0) then + h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j) + h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j) + dz(c,j+1) = dz(c,j+1) + dz(c,j) + + mss_bcphi(c,j+1) = mss_bcphi(c,j+1) + mss_bcphi(c,j) + mss_bcpho(c,j+1) = mss_bcpho(c,j+1) + mss_bcpho(c,j) + mss_ocphi(c,j+1) = mss_ocphi(c,j+1) + mss_ocphi(c,j) + mss_ocpho(c,j+1) = mss_ocpho(c,j+1) + mss_ocpho(c,j) + mss_dst1(c,j+1) = mss_dst1(c,j+1) + mss_dst1(c,j) + mss_dst2(c,j+1) = mss_dst2(c,j+1) + mss_dst2(c,j) + mss_dst3(c,j+1) = mss_dst3(c,j+1) + mss_dst3(c,j) + mss_dst4(c,j+1) = mss_dst4(c,j+1) + mss_dst4(c,j) + + end if + + ! shift all elements above this down one. + if (j > snl(c)+1 .and. snl(c) < -1) then + do i = j, snl(c)+2, -1 + ! If the layer closest to the surface is less than 0.1 mm and the ltype is not + ! urban, soil or crop, the h2osoi_liq and h2osoi_ice associated with this layer is sent + ! to qflx_qrgwl later on in the code. To keep track of this for the snow balance + ! error check, we add this to qflx_sl_top_soil here + if (ltype(l) /= istsoil .and. ltype(l) /= istcrop .and. ltype(l) /= isturb .and. i == 0) then + qflx_sl_top_soil(c) = (h2osoi_liq(c,i) + h2osoi_ice(c,i))/dtime + end if + + t_soisno(c,i) = t_soisno(c,i-1) + h2osoi_liq(c,i) = h2osoi_liq(c,i-1) + h2osoi_ice(c,i) = h2osoi_ice(c,i-1) + + mss_bcphi(c,i) = mss_bcphi(c,i-1) + mss_bcpho(c,i) = mss_bcpho(c,i-1) + mss_ocphi(c,i) = mss_ocphi(c,i-1) + mss_ocpho(c,i) = mss_ocpho(c,i-1) + mss_dst1(c,i) = mss_dst1(c,i-1) + mss_dst2(c,i) = mss_dst2(c,i-1) + mss_dst3(c,i) = mss_dst3(c,i-1) + mss_dst4(c,i) = mss_dst4(c,i-1) + snw_rds(c,i) = snw_rds(c,i-1) + + dz(c,i) = dz(c,i-1) + end do + end if + snl(c) = snl(c) + 1 + end if + end do + end do + + do fc = 1, num_snowc + c = filter_snowc(fc) + h2osno(c) = 0._r8 + snowdp(c) = 0._r8 + zwice(c) = 0._r8 + zwliq(c) = 0._r8 + end do + + do j = -nlevsno+1,0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + h2osno(c) = h2osno(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + snowdp(c) = snowdp(c) + dz(c,j) + zwice(c) = zwice(c) + h2osoi_ice(c,j) + zwliq(c) = zwliq(c) + h2osoi_liq(c,j) + end if + end do + end do + + ! Check the snow depth - all snow gone + ! The liquid water assumes ponding on soil surface. + + do fc = 1, num_snowc + c = filter_snowc(fc) + l = clandunit(c) + if (snowdp(c) < 0.01_r8 .and. snowdp(c) > 0._r8) then + snl(c) = 0 + h2osno(c) = zwice(c) + + mss_bcphi(c,:) = 0._r8 + mss_bcpho(c,:) = 0._r8 + mss_ocphi(c,:) = 0._r8 + mss_ocpho(c,:) = 0._r8 + mss_dst1(c,:) = 0._r8 + mss_dst2(c,:) = 0._r8 + mss_dst3(c,:) = 0._r8 + mss_dst4(c,:) = 0._r8 + + if (h2osno(c) <= 0._r8) snowdp(c) = 0._r8 + if (ltype(l) == istsoil .or. ltype(l) == isturb .or. ltype(l) == istcrop) then + h2osoi_liq(c,1) = h2osoi_liq(c,1) + zwliq(c) + end if + end if + end do + + ! Check the snow depth - snow layers combined + ! The following loop IS NOT VECTORIZED + + do fc = 1, num_snowc + c = filter_snowc(fc) + + ! Two or more layers + + if (snl(c) < -1) then + + msn_old(c) = snl(c) + mssi(c) = 1 + + do i = msn_old(c)+1,0 + if (dz(c,i) < dzmin(mssi(c))) then + + if (i == snl(c)+1) then + ! If top node is removed, combine with bottom neighbor. + neibor = i + 1 + else if (i == 0) then + ! If the bottom neighbor is not snow, combine with the top neighbor. + neibor = i - 1 + else + ! If none of the above special cases apply, combine with the thinnest neighbor + neibor = i + 1 + if ((dz(c,i-1)+dz(c,i)) < (dz(c,i+1)+dz(c,i))) neibor = i-1 + end if + + ! Node l and j are combined and stored as node j. + if (neibor > i) then + j = neibor + l = i + else + j = i + l = neibor + end if + + ! this should be included in 'Combo' for consistency, + ! but functionally it is the same to do it here + mss_bcphi(c,j)=mss_bcphi(c,j)+mss_bcphi(c,l) + mss_bcpho(c,j)=mss_bcpho(c,j)+mss_bcpho(c,l) + mss_ocphi(c,j)=mss_ocphi(c,j)+mss_ocphi(c,l) + mss_ocpho(c,j)=mss_ocpho(c,j)+mss_ocpho(c,l) + mss_dst1(c,j)=mss_dst1(c,j)+mss_dst1(c,l) + mss_dst2(c,j)=mss_dst2(c,j)+mss_dst2(c,l) + mss_dst3(c,j)=mss_dst3(c,j)+mss_dst3(c,l) + mss_dst4(c,j)=mss_dst4(c,j)+mss_dst4(c,l) + ! mass-weighted combination of effective grain size: + snw_rds(c,j) = (snw_rds(c,j)*(h2osoi_liq(c,j)+h2osoi_ice(c,j)) + & + snw_rds(c,l)*(h2osoi_liq(c,l)+h2osoi_ice(c,l))) / & + (h2osoi_liq(c,j)+h2osoi_ice(c,j)+h2osoi_liq(c,l)+h2osoi_ice(c,l)) + + call Combo (dz(c,j), h2osoi_liq(c,j), h2osoi_ice(c,j), & + t_soisno(c,j), dz(c,l), h2osoi_liq(c,l), h2osoi_ice(c,l), t_soisno(c,l) ) + + ! Now shift all elements above this down one. + if (j-1 > snl(c)+1) then + do k = j-1, snl(c)+2, -1 + t_soisno(c,k) = t_soisno(c,k-1) + h2osoi_ice(c,k) = h2osoi_ice(c,k-1) + h2osoi_liq(c,k) = h2osoi_liq(c,k-1) + + mss_bcphi(c,k) = mss_bcphi(c,k-1) + mss_bcpho(c,k) = mss_bcpho(c,k-1) + mss_ocphi(c,k) = mss_ocphi(c,k-1) + mss_ocpho(c,k) = mss_ocpho(c,k-1) + mss_dst1(c,k) = mss_dst1(c,k-1) + mss_dst2(c,k) = mss_dst2(c,k-1) + mss_dst3(c,k) = mss_dst3(c,k-1) + mss_dst4(c,k) = mss_dst4(c,k-1) + snw_rds(c,k) = snw_rds(c,k-1) + + dz(c,k) = dz(c,k-1) + end do + end if + + ! Decrease the number of snow layers + snl(c) = snl(c) + 1 + if (snl(c) >= -1) EXIT + + else + + ! The layer thickness is greater than the prescribed minimum value + mssi(c) = mssi(c) + 1 + + end if + end do + + end if + + end do + + ! Reset the node depth and the depth of layer interface + + do j = 0, -nlevsno+1, -1 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c) + 1) then + z(c,j) = zi(c,j) - 0.5_r8*dz(c,j) + zi(c,j-1) = zi(c,j) - dz(c,j) + end if + end do + end do + + end subroutine CombineSnowLayers + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: DivideSnowLayers +! +! !INTERFACE: + subroutine DivideSnowLayers(lbc, ubc, num_snowc, filter_snowc) +! +! !DESCRIPTION: +! Subdivides snow layers if they exceed their prescribed maximum thickness. +! +! !USES: + use clmtype + use clm_varcon, only : tfrz +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(inout) :: num_snowc ! number of column snow points in column filter + integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in module Hydrology2Mod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/28/02, Peter Thornton: Migrated to new data structures. +! 2/29/08, David Lawrence: Snowpack T profile maintained during layer splitting +! 03/28/08, Mark Flanner: Added aerosol masses and snow grain radius +! +! !LOCAL VARIABLES: +! +! local pointers to implicit inout arguments +! + integer , pointer :: snl(:) !number of snow layers + real(r8), pointer :: dz(:,:) !layer depth (m) + real(r8), pointer :: zi(:,:) !interface level below a "z" level (m) + real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin) + real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) +! +! local pointers to implicit out arguments +! + real(r8), pointer :: z(:,:) ! layer thickness (m) + real(r8), pointer :: mss_bcphi(:,:) ! hydrophilic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_bcpho(:,:) ! hydrophobic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocphi(:,:) ! hydrophilic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocpho(:,:) ! hydrophobic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst1(:,:) ! dust species 1 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst2(:,:) ! dust species 2 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst3(:,:) ! dust species 3 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst4(:,:) ! dust species 4 mass in snow (col,lyr) [kg] + real(r8), pointer :: snw_rds(:,:) ! effective snow grain radius (col,lyr) [microns, m^-6] +! +! +! !OTHER LOCAL VARIABLES: +!EOP +! + integer :: j, c, fc ! indices + real(r8) :: drr ! thickness of the combined [m] + integer :: msno ! number of snow layer 1 (top) to msno (bottom) + real(r8) :: dzsno(lbc:ubc,nlevsno) ! Snow layer thickness [m] + real(r8) :: swice(lbc:ubc,nlevsno) ! Partial volume of ice [m3/m3] + real(r8) :: swliq(lbc:ubc,nlevsno) ! Partial volume of liquid water [m3/m3] + real(r8) :: tsno(lbc:ubc ,nlevsno) ! Nodel temperature [K] + real(r8) :: zwice ! temporary + real(r8) :: zwliq ! temporary + real(r8) :: propor ! temporary + real(r8) :: dtdz ! temporary + + ! temporary variables mimicking the structure of other layer division variables + real(r8) :: mbc_phi(lbc:ubc,nlevsno) ! mass of BC in each snow layer + real(r8) :: zmbc_phi ! temporary + real(r8) :: mbc_pho(lbc:ubc,nlevsno) ! mass of BC in each snow layer + real(r8) :: zmbc_pho ! temporary + real(r8) :: moc_phi(lbc:ubc,nlevsno) ! mass of OC in each snow layer + real(r8) :: zmoc_phi ! temporary + real(r8) :: moc_pho(lbc:ubc,nlevsno) ! mass of OC in each snow layer + real(r8) :: zmoc_pho ! temporary + real(r8) :: mdst1(lbc:ubc,nlevsno) ! mass of dust 1 in each snow layer + real(r8) :: zmdst1 ! temporary + real(r8) :: mdst2(lbc:ubc,nlevsno) ! mass of dust 2 in each snow layer + real(r8) :: zmdst2 ! temporary + real(r8) :: mdst3(lbc:ubc,nlevsno) ! mass of dust 3 in each snow layer + real(r8) :: zmdst3 ! temporary + real(r8) :: mdst4(lbc:ubc,nlevsno) ! mass of dust 4 in each snow layer + real(r8) :: zmdst4 ! temporary + real(r8) :: rds(lbc:ubc,nlevsno) + +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtype components (column-level) + + snl => cps%snl + dz => cps%dz + zi => cps%zi + z => cps%z + t_soisno => ces%t_soisno + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + mss_bcphi => cps%mss_bcphi + mss_bcpho => cps%mss_bcpho + mss_ocphi => cps%mss_ocphi + mss_ocpho => cps%mss_ocpho + mss_dst1 => cps%mss_dst1 + mss_dst2 => cps%mss_dst2 + mss_dst3 => cps%mss_dst3 + mss_dst4 => cps%mss_dst4 + snw_rds => cps%snw_rds + + + ! Begin calculation - note that the following column loops are only invoked + ! for snow-covered columns + + do j = 1,nlevsno + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j <= abs(snl(c))) then + dzsno(c,j) = dz(c,j+snl(c)) + swice(c,j) = h2osoi_ice(c,j+snl(c)) + swliq(c,j) = h2osoi_liq(c,j+snl(c)) + tsno(c,j) = t_soisno(c,j+snl(c)) + + mbc_phi(c,j) = mss_bcphi(c,j+snl(c)) + mbc_pho(c,j) = mss_bcpho(c,j+snl(c)) + moc_phi(c,j) = mss_ocphi(c,j+snl(c)) + moc_pho(c,j) = mss_ocpho(c,j+snl(c)) + mdst1(c,j) = mss_dst1(c,j+snl(c)) + mdst2(c,j) = mss_dst2(c,j+snl(c)) + mdst3(c,j) = mss_dst3(c,j+snl(c)) + mdst4(c,j) = mss_dst4(c,j+snl(c)) + rds(c,j) = snw_rds(c,j+snl(c)) + + end if + end do + end do + + do fc = 1, num_snowc + c = filter_snowc(fc) + + msno = abs(snl(c)) + + if (msno == 1) then + ! Specify a new snow layer + if (dzsno(c,1) > 0.03_r8) then + msno = 2 + dzsno(c,1) = dzsno(c,1)/2._r8 + swice(c,1) = swice(c,1)/2._r8 + swliq(c,1) = swliq(c,1)/2._r8 + dzsno(c,2) = dzsno(c,1) + swice(c,2) = swice(c,1) + swliq(c,2) = swliq(c,1) + tsno(c,2) = tsno(c,1) + + mbc_phi(c,1) = mbc_phi(c,1)/2._r8 + mbc_phi(c,2) = mbc_phi(c,1) + mbc_pho(c,1) = mbc_pho(c,1)/2._r8 + mbc_pho(c,2) = mbc_pho(c,1) + moc_phi(c,1) = moc_phi(c,1)/2._r8 + moc_phi(c,2) = moc_phi(c,1) + moc_pho(c,1) = moc_pho(c,1)/2._r8 + moc_pho(c,2) = moc_pho(c,1) + mdst1(c,1) = mdst1(c,1)/2._r8 + mdst1(c,2) = mdst1(c,1) + mdst2(c,1) = mdst2(c,1)/2._r8 + mdst2(c,2) = mdst2(c,1) + mdst3(c,1) = mdst3(c,1)/2._r8 + mdst3(c,2) = mdst3(c,1) + mdst4(c,1) = mdst4(c,1)/2._r8 + mdst4(c,2) = mdst4(c,1) + rds(c,2) = rds(c,1) + + end if + end if + + if (msno > 1) then + if (dzsno(c,1) > 0.02_r8) then + drr = dzsno(c,1) - 0.02_r8 + propor = drr/dzsno(c,1) + zwice = propor*swice(c,1) + zwliq = propor*swliq(c,1) + + zmbc_phi = propor*mbc_phi(c,1) + zmbc_pho = propor*mbc_pho(c,1) + zmoc_phi = propor*moc_phi(c,1) + zmoc_pho = propor*moc_pho(c,1) + zmdst1 = propor*mdst1(c,1) + zmdst2 = propor*mdst2(c,1) + zmdst3 = propor*mdst3(c,1) + zmdst4 = propor*mdst4(c,1) + + propor = 0.02_r8/dzsno(c,1) + swice(c,1) = propor*swice(c,1) + swliq(c,1) = propor*swliq(c,1) + + mbc_phi(c,1) = propor*mbc_phi(c,1) + mbc_pho(c,1) = propor*mbc_pho(c,1) + moc_phi(c,1) = propor*moc_phi(c,1) + moc_pho(c,1) = propor*moc_pho(c,1) + mdst1(c,1) = propor*mdst1(c,1) + mdst2(c,1) = propor*mdst2(c,1) + mdst3(c,1) = propor*mdst3(c,1) + mdst4(c,1) = propor*mdst4(c,1) + + dzsno(c,1) = 0.02_r8 + + mbc_phi(c,2) = mbc_phi(c,2)+zmbc_phi ! (combo) + mbc_pho(c,2) = mbc_pho(c,2)+zmbc_pho ! (combo) + moc_phi(c,2) = moc_phi(c,2)+zmoc_phi ! (combo) + moc_pho(c,2) = moc_pho(c,2)+zmoc_pho ! (combo) + mdst1(c,2) = mdst1(c,2)+zmdst1 ! (combo) + mdst2(c,2) = mdst2(c,2)+zmdst2 ! (combo) + mdst3(c,2) = mdst3(c,2)+zmdst3 ! (combo) + mdst4(c,2) = mdst4(c,2)+zmdst4 ! (combo) + !mgf++ 20140225: Mass-weighted combination of radius ... bugzilla 1934 + !rds(c,2) = rds(c,1) ! (combo) + rds(c,2) = (rds(c,2)*(swliq(c,2)+swice(c,2)) + & + rds(c,1)*(zwliq+zwice))/(swliq(c,2)+swice(c,2)+zwliq+zwice) + !mgf-- bugzilla 1934 + + call Combo (dzsno(c,2), swliq(c,2), swice(c,2), tsno(c,2), drr, & + zwliq, zwice, tsno(c,1)) + + ! Subdivide a new layer + if (msno <= 2 .and. dzsno(c,2) > 0.07_r8) then + msno = 3 + dtdz = (tsno(c,1) - tsno(c,2))/((dzsno(c,1)+dzsno(c,2))/2._r8) + dzsno(c,2) = dzsno(c,2)/2._r8 + swice(c,2) = swice(c,2)/2._r8 + swliq(c,2) = swliq(c,2)/2._r8 + dzsno(c,3) = dzsno(c,2) + swice(c,3) = swice(c,2) + swliq(c,3) = swliq(c,2) + tsno(c,3) = tsno(c,2) - dtdz*dzsno(c,2)/2._r8 + if (tsno(c,3) >= tfrz) then + tsno(c,3) = tsno(c,2) + else + tsno(c,2) = tsno(c,2) + dtdz*dzsno(c,2)/2._r8 + endif + + mbc_phi(c,2) = mbc_phi(c,2)/2._r8 + mbc_phi(c,3) = mbc_phi(c,2) + mbc_pho(c,2) = mbc_pho(c,2)/2._r8 + mbc_pho(c,3) = mbc_pho(c,2) + moc_phi(c,2) = moc_phi(c,2)/2._r8 + moc_phi(c,3) = moc_phi(c,2) + moc_pho(c,2) = moc_pho(c,2)/2._r8 + moc_pho(c,3) = moc_pho(c,2) + mdst1(c,2) = mdst1(c,2)/2._r8 + mdst1(c,3) = mdst1(c,2) + mdst2(c,2) = mdst2(c,2)/2._r8 + mdst2(c,3) = mdst2(c,2) + mdst3(c,2) = mdst3(c,2)/2._r8 + mdst3(c,3) = mdst3(c,2) + mdst4(c,2) = mdst4(c,2)/2._r8 + mdst4(c,3) = mdst4(c,2) + rds(c,3) = rds(c,2) + + end if + end if + end if + + if (msno > 2) then + if (dzsno(c,2) > 0.05_r8) then + drr = dzsno(c,2) - 0.05_r8 + propor = drr/dzsno(c,2) + zwice = propor*swice(c,2) + zwliq = propor*swliq(c,2) + + zmbc_phi = propor*mbc_phi(c,2) + zmbc_pho = propor*mbc_pho(c,2) + zmoc_phi = propor*moc_phi(c,2) + zmoc_pho = propor*moc_pho(c,2) + zmdst1 = propor*mdst1(c,2) + zmdst2 = propor*mdst2(c,2) + zmdst3 = propor*mdst3(c,2) + zmdst4 = propor*mdst4(c,2) + + propor = 0.05_r8/dzsno(c,2) + swice(c,2) = propor*swice(c,2) + swliq(c,2) = propor*swliq(c,2) + + mbc_phi(c,2) = propor*mbc_phi(c,2) + mbc_pho(c,2) = propor*mbc_pho(c,2) + moc_phi(c,2) = propor*moc_phi(c,2) + moc_pho(c,2) = propor*moc_pho(c,2) + mdst1(c,2) = propor*mdst1(c,2) + mdst2(c,2) = propor*mdst2(c,2) + mdst3(c,2) = propor*mdst3(c,2) + mdst4(c,2) = propor*mdst4(c,2) + + dzsno(c,2) = 0.05_r8 + + mbc_phi(c,3) = mbc_phi(c,3)+zmbc_phi ! (combo) + mbc_pho(c,3) = mbc_pho(c,3)+zmbc_pho ! (combo) + moc_phi(c,3) = moc_phi(c,3)+zmoc_phi ! (combo) + moc_pho(c,3) = moc_pho(c,3)+zmoc_pho ! (combo) + mdst1(c,3) = mdst1(c,3)+zmdst1 ! (combo) + mdst2(c,3) = mdst2(c,3)+zmdst2 ! (combo) + mdst3(c,3) = mdst3(c,3)+zmdst3 ! (combo) + mdst4(c,3) = mdst4(c,3)+zmdst4 ! (combo) + !mgf++ 20140225: Mass-weighted combination of radius ... bugzilla 1934 + !rds(c,3) = rds(c,2) ! (combo) + rds(c,3) = (rds(c,3)*(swliq(c,3)+swice(c,3)) + & + rds(c,2)*(zwliq+zwice))/(swliq(c,3)+swice(c,3)+zwliq+zwice) + !mgf-- bugzilla 1934 + + + call Combo (dzsno(c,3), swliq(c,3), swice(c,3), tsno(c,3), drr, & + zwliq, zwice, tsno(c,2)) + + ! Subdivided a new layer + if (msno <= 3 .and. dzsno(c,3) > 0.18_r8) then + msno = 4 + dtdz = (tsno(c,2) - tsno(c,3))/((dzsno(c,2)+dzsno(c,3))/2._r8) + dzsno(c,3) = dzsno(c,3)/2._r8 + swice(c,3) = swice(c,3)/2._r8 + swliq(c,3) = swliq(c,3)/2._r8 + dzsno(c,4) = dzsno(c,3) + swice(c,4) = swice(c,3) + swliq(c,4) = swliq(c,3) + tsno(c,4) = tsno(c,3) - dtdz*dzsno(c,3)/2._r8 + if (tsno(c,4) >= tfrz) then + tsno(c,4) = tsno(c,3) + else + tsno(c,3) = tsno(c,3) + dtdz*dzsno(c,3)/2._r8 + endif + + mbc_phi(c,3) = mbc_phi(c,3)/2._r8 + mbc_phi(c,4) = mbc_phi(c,3) + mbc_pho(c,3) = mbc_pho(c,3)/2._r8 + mbc_pho(c,4) = mbc_pho(c,3) + moc_phi(c,3) = moc_phi(c,3)/2._r8 + moc_phi(c,4) = moc_phi(c,3) + moc_pho(c,3) = moc_pho(c,3)/2._r8 + moc_pho(c,4) = moc_pho(c,3) + mdst1(c,3) = mdst1(c,3)/2._r8 + mdst1(c,4) = mdst1(c,3) + mdst2(c,3) = mdst2(c,3)/2._r8 + mdst2(c,4) = mdst2(c,3) + mdst3(c,3) = mdst3(c,3)/2._r8 + mdst3(c,4) = mdst3(c,3) + mdst4(c,3) = mdst4(c,3)/2._r8 + mdst4(c,4) = mdst4(c,3) + rds(c,4) = rds(c,3) + + end if + end if + end if + + if (msno > 3) then + if (dzsno(c,3) > 0.11_r8) then + drr = dzsno(c,3) - 0.11_r8 + propor = drr/dzsno(c,3) + zwice = propor*swice(c,3) + zwliq = propor*swliq(c,3) + + zmbc_phi = propor*mbc_phi(c,3) + zmbc_pho = propor*mbc_pho(c,3) + zmoc_phi = propor*moc_phi(c,3) + zmoc_pho = propor*moc_pho(c,3) + zmdst1 = propor*mdst1(c,3) + zmdst2 = propor*mdst2(c,3) + zmdst3 = propor*mdst3(c,3) + zmdst4 = propor*mdst4(c,3) + + propor = 0.11_r8/dzsno(c,3) + swice(c,3) = propor*swice(c,3) + swliq(c,3) = propor*swliq(c,3) + + mbc_phi(c,3) = propor*mbc_phi(c,3) + mbc_pho(c,3) = propor*mbc_pho(c,3) + moc_phi(c,3) = propor*moc_phi(c,3) + moc_pho(c,3) = propor*moc_pho(c,3) + mdst1(c,3) = propor*mdst1(c,3) + mdst2(c,3) = propor*mdst2(c,3) + mdst3(c,3) = propor*mdst3(c,3) + mdst4(c,3) = propor*mdst4(c,3) + + dzsno(c,3) = 0.11_r8 + + mbc_phi(c,4) = mbc_phi(c,4)+zmbc_phi ! (combo) + mbc_pho(c,4) = mbc_pho(c,4)+zmbc_pho ! (combo) + moc_phi(c,4) = moc_phi(c,4)+zmoc_phi ! (combo) + moc_pho(c,4) = moc_pho(c,4)+zmoc_pho ! (combo) + mdst1(c,4) = mdst1(c,4)+zmdst1 ! (combo) + mdst2(c,4) = mdst2(c,4)+zmdst2 ! (combo) + mdst3(c,4) = mdst3(c,4)+zmdst3 ! (combo) + mdst4(c,4) = mdst4(c,4)+zmdst4 ! (combo) + !mgf++ 20140225: Mass-weighted combination of radius ... bugzilla 1934 + !rds(c,4) = rds(c,3) ! (combo) + rds(c,4) = (rds(c,4)*(swliq(c,4)+swice(c,4)) + & + rds(c,3)*(zwliq+zwice))/(swliq(c,4)+swice(c,4)+zwliq+zwice) + !mgf-- bugzilla 1934 + + + call Combo (dzsno(c,4), swliq(c,4), swice(c,4), tsno(c,4), drr, & + zwliq, zwice, tsno(c,3)) + + ! Subdivided a new layer + if (msno <= 4 .and. dzsno(c,4) > 0.41_r8) then + msno = 5 + dtdz = (tsno(c,3) - tsno(c,4))/((dzsno(c,3)+dzsno(c,4))/2._r8) + dzsno(c,4) = dzsno(c,4)/2._r8 + swice(c,4) = swice(c,4)/2._r8 + swliq(c,4) = swliq(c,4)/2._r8 + dzsno(c,5) = dzsno(c,4) + swice(c,5) = swice(c,4) + swliq(c,5) = swliq(c,4) + tsno(c,5) = tsno(c,4) - dtdz*dzsno(c,4)/2._r8 + if (tsno(c,5) >= tfrz) then + tsno(c,5) = tsno(c,4) + else + tsno(c,4) = tsno(c,4) + dtdz*dzsno(c,4)/2._r8 + endif + + mbc_phi(c,4) = mbc_phi(c,4)/2._r8 + mbc_phi(c,5) = mbc_phi(c,4) + mbc_pho(c,4) = mbc_pho(c,4)/2._r8 + mbc_pho(c,5) = mbc_pho(c,4) + moc_phi(c,4) = moc_phi(c,4)/2._r8 + moc_phi(c,5) = moc_phi(c,4) + moc_pho(c,4) = moc_pho(c,4)/2._r8 + moc_pho(c,5) = moc_pho(c,4) + mdst1(c,4) = mdst1(c,4)/2._r8 + mdst1(c,5) = mdst1(c,4) + mdst2(c,4) = mdst2(c,4)/2._r8 + mdst2(c,5) = mdst2(c,4) + mdst3(c,4) = mdst3(c,4)/2._r8 + mdst3(c,5) = mdst3(c,4) + mdst4(c,4) = mdst4(c,4)/2._r8 + mdst4(c,5) = mdst4(c,4) + rds(c,5) = rds(c,4) + + end if + end if + end if + + if (msno > 4) then + if (dzsno(c,4) > 0.23_r8) then + drr = dzsno(c,4) - 0.23_r8 + propor = drr/dzsno(c,4) + zwice = propor*swice(c,4) + zwliq = propor*swliq(c,4) + + zmbc_phi = propor*mbc_phi(c,4) + zmbc_pho = propor*mbc_pho(c,4) + zmoc_phi = propor*moc_phi(c,4) + zmoc_pho = propor*moc_pho(c,4) + zmdst1 = propor*mdst1(c,4) + zmdst2 = propor*mdst2(c,4) + zmdst3 = propor*mdst3(c,4) + zmdst4 = propor*mdst4(c,4) + + propor = 0.23_r8/dzsno(c,4) + swice(c,4) = propor*swice(c,4) + swliq(c,4) = propor*swliq(c,4) + + mbc_phi(c,4) = propor*mbc_phi(c,4) + mbc_pho(c,4) = propor*mbc_pho(c,4) + moc_phi(c,4) = propor*moc_phi(c,4) + moc_pho(c,4) = propor*moc_pho(c,4) + mdst1(c,4) = propor*mdst1(c,4) + mdst2(c,4) = propor*mdst2(c,4) + mdst3(c,4) = propor*mdst3(c,4) + mdst4(c,4) = propor*mdst4(c,4) + + dzsno(c,4) = 0.23_r8 + + mbc_phi(c,5) = mbc_phi(c,5)+zmbc_phi ! (combo) + mbc_pho(c,5) = mbc_pho(c,5)+zmbc_pho ! (combo) + moc_phi(c,5) = moc_phi(c,5)+zmoc_phi ! (combo) + moc_pho(c,5) = moc_pho(c,5)+zmoc_pho ! (combo) + mdst1(c,5) = mdst1(c,5)+zmdst1 ! (combo) + mdst2(c,5) = mdst2(c,5)+zmdst2 ! (combo) + mdst3(c,5) = mdst3(c,5)+zmdst3 ! (combo) + mdst4(c,5) = mdst4(c,5)+zmdst4 ! (combo) + !mgf++ 20140225: Mass-weighted combination of radius ... bugzilla 1934 + !rds(c,5) = rds(c,4) ! (combo) + rds(c,5) = (rds(c,5)*(swliq(c,5)+swice(c,5)) + & + rds(c,4)*(zwliq+zwice))/(swliq(c,5)+swice(c,5)+zwliq+zwice) + !mgf-- bugzilla 1934 + + call Combo (dzsno(c,5), swliq(c,5), swice(c,5), tsno(c,5), drr, & + zwliq, zwice, tsno(c,4)) + end if + end if + + snl(c) = -msno + + end do + + do j = -nlevsno+1,0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + dz(c,j) = dzsno(c,j-snl(c)) + h2osoi_ice(c,j) = swice(c,j-snl(c)) + h2osoi_liq(c,j) = swliq(c,j-snl(c)) + t_soisno(c,j) = tsno(c,j-snl(c)) + + mss_bcphi(c,j) = mbc_phi(c,j-snl(c)) + mss_bcpho(c,j) = mbc_pho(c,j-snl(c)) + mss_ocphi(c,j) = moc_phi(c,j-snl(c)) + mss_ocpho(c,j) = moc_pho(c,j-snl(c)) + mss_dst1(c,j) = mdst1(c,j-snl(c)) + mss_dst2(c,j) = mdst2(c,j-snl(c)) + mss_dst3(c,j) = mdst3(c,j-snl(c)) + mss_dst4(c,j) = mdst4(c,j-snl(c)) + snw_rds(c,j) = rds(c,j-snl(c)) + + end if + end do + end do + + do j = 0, -nlevsno+1, -1 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + z(c,j) = zi(c,j) - 0.5_r8*dz(c,j) + zi(c,j-1) = zi(c,j) - dz(c,j) + end if + end do + end do + + end subroutine DivideSnowLayers + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: Combo +! +! !INTERFACE: + subroutine Combo(dz, wliq, wice, t, dz2, wliq2, wice2, t2) +! +! !DESCRIPTION: +! Combines two elements and returns the following combined +! variables: dz, t, wliq, wice. +! The combined temperature is based on the equation: +! the sum of the enthalpies of the two elements = +! that of the combined element. +! +! !USES: + use clm_varcon, only : cpice, cpliq, tfrz, hfus +! +! !ARGUMENTS: + implicit none + real(r8), intent(in) :: dz2 ! nodal thickness of 2 elements being combined [m] + real(r8), intent(in) :: wliq2 ! liquid water of element 2 [kg/m2] + real(r8), intent(in) :: wice2 ! ice of element 2 [kg/m2] + real(r8), intent(in) :: t2 ! nodal temperature of element 2 [K] + real(r8), intent(inout) :: dz ! nodal thickness of 1 elements being combined [m] + real(r8), intent(inout) :: wliq ! liquid water of element 1 + real(r8), intent(inout) :: wice ! ice of element 1 [kg/m2] + real(r8), intent(inout) :: t ! nodel temperature of elment 1 [K] +! +! !CALLED FROM: +! subroutine CombineSnowLayers in this module +! subroutine DivideSnowLayers in this module +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! +! +! !LOCAL VARIABLES: +!EOP +! + real(r8) :: dzc ! Total thickness of nodes 1 and 2 (dzc=dz+dz2). + real(r8) :: wliqc ! Combined liquid water [kg/m2] + real(r8) :: wicec ! Combined ice [kg/m2] + real(r8) :: tc ! Combined node temperature [K] + real(r8) :: h ! enthalpy of element 1 [J/m2] + real(r8) :: h2 ! enthalpy of element 2 [J/m2] + real(r8) :: hc ! temporary +!----------------------------------------------------------------------- + + dzc = dz+dz2 + wicec = (wice+wice2) + wliqc = (wliq+wliq2) + h = (cpice*wice+cpliq*wliq) * (t-tfrz)+hfus*wliq + h2= (cpice*wice2+cpliq*wliq2) * (t2-tfrz)+hfus*wliq2 + + hc = h + h2 + tc = tfrz + (hc - hfus*wliqc) / (cpice*wicec + cpliq*wliqc) + + dz = dzc + wice = wicec + wliq = wliqc + t = tc + + end subroutine Combo + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BuildSnowFilter +! +! !INTERFACE: + subroutine BuildSnowFilter(lbc, ubc, num_nolakec, filter_nolakec, & + num_snowc, filter_snowc, & + num_nosnowc, filter_nosnowc) +! +! !DESCRIPTION: +! Constructs snow filter for use in vectorized loops for snow hydrology. +! +! !USES: + use clmtype +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points + integer, intent(out) :: num_snowc ! number of column snow points in column filter + integer, intent(out) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer, intent(out) :: num_nosnowc ! number of column non-snow points in column filter + integer, intent(out) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in Hydrology2Mod +! subroutine CombineSnowLayers in this module +! +! !REVISION HISTORY: +! 2003 July 31: Forrest Hoffman +! +! !LOCAL VARIABLES: +! local pointers to implicit in arguments + integer , pointer :: snl(:) ! number of snow layers +! +! +! !OTHER LOCAL VARIABLES: +!EOP + integer :: fc, c +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtype components (column-level) + + snl => cps%snl + + ! Build snow/no-snow filters for other subroutines + + num_snowc = 0 + num_nosnowc = 0 + do fc = 1, num_nolakec + c = filter_nolakec(fc) + if (snl(c) < 0) then + num_snowc = num_snowc + 1 + filter_snowc(num_snowc) = c + else + num_nosnowc = num_nosnowc + 1 + filter_nosnowc(num_nosnowc) = c + end if + end do + + end subroutine BuildSnowFilter + +end module SnowHydrologyMod diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/biogeophys/UrbanMod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/biogeophys/UrbanMod.F90 new file mode 100644 index 0000000000..c97451d2a8 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/biogeophys/UrbanMod.F90 @@ -0,0 +1,3473 @@ + +! DART note: this file started life as: +! /glade/p/cesm/releases/cesm1_2_1/models/lnd/clm/src/clm4_0/biogeophys/UrbanMod.F90 + +module UrbanMod + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: UrbanMod +! +! !DESCRIPTION: +! Calculate solar and longwave radiation, and turbulent fluxes for urban landunit +! +! !USES: + use shr_kind_mod, only : r8 => shr_kind_r8 + use clm_varpar , only : numrad + use clm_varcon , only : isecspday, degpsec + use clm_varctl , only : iulog + use abortutils , only : endrun + use shr_sys_mod , only : shr_sys_flush +! +! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + public :: UrbanClumpInit ! Initialization of urban clump data structure + public :: UrbanRadiation ! Urban radiative fluxes + public :: UrbanAlbedo ! Urban albedos + public :: UrbanSnowAlbedo ! Urban snow albedos + public :: UrbanFluxes ! Urban turbulent fluxes + +! !Urban control variables + character(len= *), parameter, public :: urban_hac_off = 'OFF' ! + character(len= *), parameter, public :: urban_hac_on = 'ON' ! + character(len= *), parameter, public :: urban_wasteheat_on = 'ON_WASTEHEAT' ! + character(len= 16), public :: urban_hac = urban_hac_off + logical, public :: urban_traffic = .false. ! urban traffic fluxes +! +! !REVISION HISTORY: +! Created by Gordon Bonan and Mariana Vertenstein and Keith Oleson 04/2003 +! +!EOP +! +! PRIVATE MEMBER FUNCTIONS + private :: view_factor ! View factors for road and one wall + private :: incident_direct ! Direct beam solar rad incident on walls and road in urban canyon + private :: incident_diffuse ! Diffuse solar rad incident on walls and road in urban canyon + private :: net_solar ! Solar radiation absorbed by road and both walls in urban canyon + private :: net_longwave ! Net longwave radiation for road and both walls in urban canyon + +! PRIVATE TYPES + private + type urban_clump_t + real(r8), pointer :: canyon_hwr(:) ! ratio of building height to street width + real(r8), pointer :: wtroad_perv(:) ! weight of pervious road wrt total road + real(r8), pointer :: ht_roof(:) ! height of urban roof (m) + real(r8), pointer :: wtlunit_roof(:) ! weight of roof with respect to landunit + real(r8), pointer :: wind_hgt_canyon(:) ! height above road at which wind in canyon is to be computed (m) + real(r8), pointer :: em_roof(:) ! roof emissivity + real(r8), pointer :: em_improad(:) ! impervious road emissivity + real(r8), pointer :: em_perroad(:) ! pervious road emissivity + real(r8), pointer :: em_wall(:) ! wall emissivity + real(r8), pointer :: alb_roof_dir(:,:) ! direct roof albedo + real(r8), pointer :: alb_roof_dif(:,:) ! diffuse roof albedo + real(r8), pointer :: alb_improad_dir(:,:) ! direct impervious road albedo + real(r8), pointer :: alb_improad_dif(:,:) ! diffuse impervious road albedo + real(r8), pointer :: alb_perroad_dir(:,:) ! direct pervious road albedo + real(r8), pointer :: alb_perroad_dif(:,:) ! diffuse pervious road albedo + real(r8), pointer :: alb_wall_dir(:,:) ! direct wall albedo + real(r8), pointer :: alb_wall_dif(:,:) ! diffuse wall albedo + end type urban_clump_t + + type (urban_clump_t), private, pointer :: urban_clump(:) ! array of urban clumps for this processor + + integer, private, parameter :: noonsec = isecspday / 2 ! seconds at local noon +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: UrbanAlbedo +! +! !INTERFACE: + subroutine UrbanAlbedo (nc, lbl, ubl, lbc, ubc, lbp, ubp, & + num_urbanl, filter_urbanl, & + num_urbanc, filter_urbanc, & + num_urbanp, filter_urbanp) +! +! !DESCRIPTION: +! Determine urban landunit component albedos +! +! !USES: + use clmtype + use shr_orb_mod , only : shr_orb_decl, shr_orb_cosz + use clm_varcon , only : icol_roof, icol_sunwall, icol_shadewall, icol_road_perv, icol_road_imperv, & + sb +! +! !ARGUMENTS: + implicit none + integer , intent(in) :: nc ! clump index + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer, intent(in) :: lbc, ubc ! column-index bounds + integer, intent(in) :: lbp, ubp ! pft-index bounds + integer , intent(in) :: num_urbanl ! number of urban landunits in clump + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + integer , intent(in) :: num_urbanc ! number of urban columns in clump + integer , intent(in) :: filter_urbanc(ubc-lbc+1) ! urban column filter + integer , intent(in) :: num_urbanp ! number of urban pfts in clump + integer , intent(in) :: filter_urbanp(ubp-lbp+1) ! urban pft filter +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! 03/2003, Mariana Vertenstein: Migrated to clm2.2 +! 01/2008, Erik Kluzek: Migrated to clm3.5.15 +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in arguments +! + integer , pointer :: pgridcell(:) ! gridcell of corresponding pft + integer , pointer :: lgridcell(:) ! gridcell of corresponding landunit + integer , pointer :: clandunit(:) ! column's landunit + integer , pointer :: cgridcell(:) ! gridcell of corresponding column + integer , pointer :: coli(:) ! beginning column index for landunit + integer , pointer :: colf(:) ! ending column index for landunit + integer , pointer :: ctype(:) ! column type + integer , pointer :: pcolumn(:) ! column of corresponding pft + real(r8), pointer :: czen(:) ! cosine of solar zenith angle for each column + real(r8), pointer :: lat(:) ! latitude (radians) + real(r8), pointer :: lon(:) ! longitude (radians) + real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1) +! +! local pointers to original implicit out arguments +! + real(r8), pointer :: albgrd(:,:) ! ground albedo (direct) + real(r8), pointer :: albgri(:,:) ! ground albedo (diffuse) + real(r8), pointer :: albd(:,:) ! surface albedo (direct) + real(r8), pointer :: albi(:,:) ! surface albedo (diffuse) + real(r8), pointer :: fabd(:,:) ! flux absorbed by veg per unit direct flux + real(r8), pointer :: fabi(:,:) ! flux absorbed by veg per unit diffuse flux + real(r8), pointer :: ftdd(:,:) ! down direct flux below veg per unit dir flx + real(r8), pointer :: ftid(:,:) ! down diffuse flux below veg per unit dir flx + real(r8), pointer :: ftii(:,:) ! down diffuse flux below veg per unit dif flx + real(r8), pointer :: fsun(:) ! sunlit fraction of canopy + real(r8), pointer :: gdir(:) ! leaf projection in solar direction (0 to 1) + real(r8), pointer :: omega(:,:) ! fraction of intercepted radiation that is scattered (0 to 1) + real(r8), pointer :: vf_sr(:) ! view factor of sky for road + real(r8), pointer :: vf_wr(:) ! view factor of one wall for road + real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall + real(r8), pointer :: vf_rw(:) ! view factor of road for one wall + real(r8), pointer :: vf_ww(:) ! view factor of opposing wall for one wall + real(r8), pointer :: sabs_roof_dir(:,:) ! direct solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_roof_dif(:,:) ! diffuse solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_sunwall_dir(:,:) ! direct solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_sunwall_dif(:,:) ! diffuse solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dir(:,:) ! direct solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dif(:,:) ! diffuse solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_improad_dir(:,:) ! direct solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_improad_dif(:,:) ! diffuse solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dir(:,:) ! direct solar absorbed by pervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dif(:,:) ! diffuse solar absorbed by pervious road per unit ground area per unit incident flux +! +! +! !OTHER LOCAL VARIABLES +!EOP +! + real(r8) :: coszen(num_urbanl) ! cosine solar zenith angle + real(r8) :: coszen_pft(num_urbanp) ! cosine solar zenith angle for next time step (pft level) + real(r8) :: zen(num_urbanl) ! solar zenith angle (radians) + real(r8) :: sdir(num_urbanl, numrad) ! direct beam solar radiation on horizontal surface + real(r8) :: sdif(num_urbanl, numrad) ! diffuse solar radiation on horizontal surface + + real(r8) :: sdir_road(num_urbanl, numrad) ! direct beam solar radiation incident on road + real(r8) :: sdif_road(num_urbanl, numrad) ! diffuse solar radiation incident on road + real(r8) :: sdir_sunwall(num_urbanl, numrad) ! direct beam solar radiation (per unit wall area) incident on sunlit wall per unit incident flux + real(r8) :: sdif_sunwall(num_urbanl, numrad) ! diffuse solar radiation (per unit wall area) incident on sunlit wall per unit incident flux + real(r8) :: sdir_shadewall(num_urbanl, numrad) ! direct beam solar radiation (per unit wall area) incident on shaded wall per unit incident flux + real(r8) :: sdif_shadewall(num_urbanl, numrad) ! diffuse solar radiation (per unit wall area) incident on shaded wall per unit incident flux + real(r8) :: albsnd_roof(num_urbanl,numrad) ! snow albedo for roof (direct) + real(r8) :: albsni_roof(num_urbanl,numrad) ! snow albedo for roof (diffuse) + real(r8) :: albsnd_improad(num_urbanl,numrad) ! snow albedo for impervious road (direct) + real(r8) :: albsni_improad(num_urbanl,numrad) ! snow albedo for impervious road (diffuse) + real(r8) :: albsnd_perroad(num_urbanl,numrad) ! snow albedo for pervious road (direct) + real(r8) :: albsni_perroad(num_urbanl,numrad) ! snow albedo for pervious road (diffuse) + + integer :: fl,fp,fc,g,l,p,c,ib ! indices + integer :: ic ! 0=unit incoming direct; 1=unit incoming diffuse + integer :: num_solar ! counter + real(r8) :: alb_roof_dir_s(num_urbanl,numrad) ! direct roof albedo with snow effects + real(r8) :: alb_roof_dif_s(num_urbanl,numrad) ! diffuse roof albedo with snow effects + real(r8) :: alb_improad_dir_s(num_urbanl,numrad) ! direct impervious road albedo with snow effects + real(r8) :: alb_perroad_dir_s(num_urbanl,numrad) ! direct pervious road albedo with snow effects + real(r8) :: alb_improad_dif_s(num_urbanl,numrad) ! diffuse impervious road albedo with snow effects + real(r8) :: alb_perroad_dif_s(num_urbanl,numrad) ! diffuse pervious road albedo with snow effects + real(r8) :: sref_roof_dir(num_urbanl,numrad) ! direct solar reflected by roof per unit ground area per unit incident flux + real(r8) :: sref_roof_dif(num_urbanl,numrad) ! diffuse solar reflected by roof per unit ground area per unit incident flux + real(r8) :: sref_sunwall_dir(num_urbanl,numrad) ! direct solar reflected by sunwall per unit wall area per unit incident flux + real(r8) :: sref_sunwall_dif(num_urbanl,numrad) ! diffuse solar reflected by sunwall per unit wall area per unit incident flux + real(r8) :: sref_shadewall_dir(num_urbanl,numrad) ! direct solar reflected by shadewall per unit wall area per unit incident flux + real(r8) :: sref_shadewall_dif(num_urbanl,numrad) ! diffuse solar reflected by shadewall per unit wall area per unit incident flux + real(r8) :: sref_improad_dir(num_urbanl,numrad) ! direct solar reflected by impervious road per unit ground area per unit incident flux + real(r8) :: sref_improad_dif(num_urbanl,numrad) ! diffuse solar reflected by impervious road per unit ground area per unit incident flux + real(r8) :: sref_perroad_dir(num_urbanl,numrad) ! direct solar reflected by pervious road per unit ground area per unit incident flux + real(r8) :: sref_perroad_dif(num_urbanl,numrad) ! diffuse solar reflected by pervious road per unit ground area per unit incident flux + real(r8), pointer :: canyon_hwr(:) ! ratio of building height to street width + real(r8), pointer :: wtroad_perv(:) ! weight of pervious road wrt total road + real(r8), pointer :: alb_roof_dir(:,:) ! direct roof albedo + real(r8), pointer :: alb_roof_dif(:,:) ! diffuse roof albedo + real(r8), pointer :: alb_improad_dir(:,:) ! direct impervious road albedo + real(r8), pointer :: alb_perroad_dir(:,:) ! direct pervious road albedo + real(r8), pointer :: alb_improad_dif(:,:) ! diffuse imprevious road albedo + real(r8), pointer :: alb_perroad_dif(:,:) ! diffuse pervious road albedo + real(r8), pointer :: alb_wall_dir(:,:) ! direct wall albedo + real(r8), pointer :: alb_wall_dif(:,:) ! diffuse wall albedo +!----------------------------------------------------------------------- + + ! Assign pointers into module urban clumps + + canyon_hwr => urban_clump(nc)%canyon_hwr + wtroad_perv => urban_clump(nc)%wtroad_perv + alb_roof_dir => urban_clump(nc)%alb_roof_dir + alb_roof_dif => urban_clump(nc)%alb_roof_dif + alb_improad_dir => urban_clump(nc)%alb_improad_dir + alb_improad_dif => urban_clump(nc)%alb_improad_dif + alb_perroad_dir => urban_clump(nc)%alb_perroad_dir + alb_perroad_dif => urban_clump(nc)%alb_perroad_dif + alb_wall_dir => urban_clump(nc)%alb_wall_dir + alb_wall_dif => urban_clump(nc)%alb_wall_dif + + ! Assign gridcell level pointers + + lat => grc%lat + lon => grc%lon + + ! Assign landunit level pointer + + lgridcell => lun%gridcell + coli => lun%coli + colf => lun%colf + vf_sr => lps%vf_sr + vf_wr => lps%vf_wr + vf_sw => lps%vf_sw + vf_rw => lps%vf_rw + vf_ww => lps%vf_ww + sabs_roof_dir => lps%sabs_roof_dir + sabs_roof_dif => lps%sabs_roof_dif + sabs_sunwall_dir => lps%sabs_sunwall_dir + sabs_sunwall_dif => lps%sabs_sunwall_dif + sabs_shadewall_dir => lps%sabs_shadewall_dir + sabs_shadewall_dif => lps%sabs_shadewall_dif + sabs_improad_dir => lps%sabs_improad_dir + sabs_improad_dif => lps%sabs_improad_dif + sabs_perroad_dir => lps%sabs_perroad_dir + sabs_perroad_dif => lps%sabs_perroad_dif + + ! Assign column level pointers + + ctype => col%itype + albgrd => cps%albgrd + albgri => cps%albgri + frac_sno => cps%frac_sno + clandunit => col%landunit + cgridcell => col%gridcell + czen => cps%coszen + + ! Assign pft level pointers + + pgridcell => pft%gridcell + pcolumn => pft%column + albd => pps%albd + albi => pps%albi + fabd => pps%fabd + fabi => pps%fabi + ftdd => pps%ftdd + ftid => pps%ftid + ftii => pps%ftii + fsun => pps%fsun + gdir => pps%gdir + omega => pps%omega + + ! ---------------------------------------------------------------------------- + ! Solar declination and cosine solar zenith angle and zenith angle for + ! next time step + ! ---------------------------------------------------------------------------- + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + coszen(fl) = czen(coli(l)) ! Assumes coszen for each column are the same + zen(fl) = acos(coszen(fl)) + end do + + do fp = 1,num_urbanp + p = filter_urbanp(fp) + g = pgridcell(p) + c = pcolumn(p) + coszen_pft(fp) = czen(c) + end do + + ! ---------------------------------------------------------------------------- + ! Initialize clmtype output since solar radiation is only done if coszen > 0 + ! ---------------------------------------------------------------------------- + + do ib = 1,numrad + do fc = 1,num_urbanc + c = filter_urbanc(fc) + + albgrd(c,ib) = 0._r8 + albgri(c,ib) = 0._r8 + end do + + do fp = 1,num_urbanp + p = filter_urbanp(fp) + g = pgridcell(p) + albd(p,ib) = 1._r8 + albi(p,ib) = 1._r8 + fabd(p,ib) = 0._r8 + fabi(p,ib) = 0._r8 + if (coszen_pft(fp) > 0._r8) then + ftdd(p,ib) = 1._r8 + else + ftdd(p,ib) = 0._r8 + end if + ftid(p,ib) = 0._r8 + if (coszen_pft(fp) > 0._r8) then + ftii(p,ib) = 1._r8 + else + ftii(p,ib) = 0._r8 + end if + omega(p,ib) = 0._r8 + if (ib == 1) then + gdir(p) = 0._r8 + fsun(p) = 0._r8 + end if + end do + end do + + ! ---------------------------------------------------------------------------- + ! Urban Code + ! ---------------------------------------------------------------------------- + + num_solar = 0 + do fl = 1,num_urbanl + if (coszen(fl) > 0._r8) num_solar = num_solar + 1 + end do + + ! Initialize urban clump components + + do ib = 1,numrad + do fl = 1,num_urbanl + l = filter_urbanl(fl) + sabs_roof_dir(l,ib) = 0._r8 + sabs_roof_dif(l,ib) = 0._r8 + sabs_sunwall_dir(l,ib) = 0._r8 + sabs_sunwall_dif(l,ib) = 0._r8 + sabs_shadewall_dir(l,ib) = 0._r8 + sabs_shadewall_dif(l,ib) = 0._r8 + sabs_improad_dir(l,ib) = 0._r8 + sabs_improad_dif(l,ib) = 0._r8 + sabs_perroad_dir(l,ib) = 0._r8 + sabs_perroad_dif(l,ib) = 0._r8 + sref_roof_dir(fl,ib) = 1._r8 + sref_roof_dif(fl,ib) = 1._r8 + sref_sunwall_dir(fl,ib) = 1._r8 + sref_sunwall_dif(fl,ib) = 1._r8 + sref_shadewall_dir(fl,ib) = 1._r8 + sref_shadewall_dif(fl,ib) = 1._r8 + sref_improad_dir(fl,ib) = 1._r8 + sref_improad_dif(fl,ib) = 1._r8 + sref_perroad_dir(fl,ib) = 1._r8 + sref_perroad_dif(fl,ib) = 1._r8 + end do + end do + + ! View factors for road and one wall in urban canyon (depends only on canyon_hwr) + + if (num_urbanl .gt. 0) then + call view_factor (lbl, ubl, num_urbanl, filter_urbanl, canyon_hwr) + end if + + ! ---------------------------------------------------------------------------- + ! Only do the rest if all coszen are positive + ! ---------------------------------------------------------------------------- + + if (num_solar > 0)then + + ! Set constants - solar fluxes are per unit incoming flux + + do ib = 1,numrad + do fl = 1,num_urbanl + sdir(fl,ib) = 1._r8 + sdif(fl,ib) = 1._r8 + end do + end do + + ! Incident direct beam radiation for + ! (a) roof and (b) road and both walls in urban canyon + + if (num_urbanl .gt. 0) then + call incident_direct (lbl, ubl, num_urbanl, canyon_hwr, coszen, zen, sdir, sdir_road, sdir_sunwall, sdir_shadewall) + end if + + ! Incident diffuse radiation for + ! (a) roof and (b) road and both walls in urban canyon. + + if (num_urbanl .gt. 0) then + call incident_diffuse (lbl, ubl, num_urbanl, filter_urbanl, canyon_hwr, sdif, sdif_road, & + sdif_sunwall, sdif_shadewall) + end if + + ! Get snow albedos for roof and impervious and pervious road + if (num_urbanl .gt. 0) then + ic = 0; call UrbanSnowAlbedo(lbl, ubl, num_urbanl, filter_urbanl, coszen, ic, albsnd_roof, albsnd_improad, albsnd_perroad) + ic = 1; call UrbanSnowAlbedo(lbl, ubl, num_urbanl, filter_urbanl, coszen, ic, albsni_roof, albsni_improad, albsni_perroad) + end if + + ! Combine snow-free and snow albedos + do ib = 1,numrad + do fl = 1,num_urbanl + l = filter_urbanl(fl) + do c = coli(l),colf(l) + if (ctype(c) == icol_roof) then + alb_roof_dir_s(fl,ib) = alb_roof_dir(fl,ib)*(1._r8-frac_sno(c)) & + + albsnd_roof(fl,ib)*frac_sno(c) + alb_roof_dif_s(fl,ib) = alb_roof_dif(fl,ib)*(1._r8-frac_sno(c)) & + + albsni_roof(fl,ib)*frac_sno(c) + else if (ctype(c) == icol_road_imperv) then + alb_improad_dir_s(fl,ib) = alb_improad_dir(fl,ib)*(1._r8-frac_sno(c)) & + + albsnd_improad(fl,ib)*frac_sno(c) + alb_improad_dif_s(fl,ib) = alb_improad_dif(fl,ib)*(1._r8-frac_sno(c)) & + + albsni_improad(fl,ib)*frac_sno(c) + else if (ctype(c) == icol_road_perv) then + alb_perroad_dir_s(fl,ib) = alb_perroad_dir(fl,ib)*(1._r8-frac_sno(c)) & + + albsnd_perroad(fl,ib)*frac_sno(c) + alb_perroad_dif_s(fl,ib) = alb_perroad_dif(fl,ib)*(1._r8-frac_sno(c)) & + + albsni_perroad(fl,ib)*frac_sno(c) + end if + end do + end do + end do + + ! Reflected and absorbed solar radiation per unit incident radiation + ! for road and both walls in urban canyon allowing for multiple reflection + ! Reflected and absorbed solar radiation per unit incident radiation for roof + + if (num_urbanl .gt. 0) then + call net_solar (lbl, ubl, num_urbanl, filter_urbanl, coszen, canyon_hwr, wtroad_perv, sdir, sdif, & + alb_improad_dir_s, alb_perroad_dir_s, alb_wall_dir, alb_roof_dir_s, & + alb_improad_dif_s, alb_perroad_dif_s, alb_wall_dif, alb_roof_dif_s, & + sdir_road, sdir_sunwall, sdir_shadewall, & + sdif_road, sdif_sunwall, sdif_shadewall, & + sref_improad_dir, sref_perroad_dir, sref_sunwall_dir, sref_shadewall_dir, sref_roof_dir, & + sref_improad_dif, sref_perroad_dif, sref_sunwall_dif, sref_shadewall_dif, sref_roof_dif) + end if + + ! ---------------------------------------------------------------------------- + ! Map urban output to clmtype components + ! ---------------------------------------------------------------------------- + + ! Set albgrd and albgri (ground albedos) and albd and albi (surface albedos) + + do ib = 1,numrad + do fl = 1,num_urbanl + l = filter_urbanl(fl) + do c = coli(l),colf(l) + if (ctype(c) == icol_roof) then + albgrd(c,ib) = sref_roof_dir(fl,ib) + albgri(c,ib) = sref_roof_dif(fl,ib) + else if (ctype(c) == icol_sunwall) then + albgrd(c,ib) = sref_sunwall_dir(fl,ib) + albgri(c,ib) = sref_sunwall_dif(fl,ib) + else if (ctype(c) == icol_shadewall) then + albgrd(c,ib) = sref_shadewall_dir(fl,ib) + albgri(c,ib) = sref_shadewall_dif(fl,ib) + else if (ctype(c) == icol_road_perv) then + albgrd(c,ib) = sref_perroad_dir(fl,ib) + albgri(c,ib) = sref_perroad_dif(fl,ib) + else if (ctype(c) == icol_road_imperv) then + albgrd(c,ib) = sref_improad_dir(fl,ib) + albgri(c,ib) = sref_improad_dif(fl,ib) + endif + end do + end do + do fp = 1,num_urbanp + p = filter_urbanp(fp) + c = pcolumn(p) + albd(p,ib) = albgrd(c,ib) + albi(p,ib) = albgri(c,ib) + end do + end do + end if + + end subroutine UrbanAlbedo + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: UrbanSnowAlbedo +! +! !INTERFACE: + subroutine UrbanSnowAlbedo (lbl, ubl, num_urbanl, filter_urbanl, coszen, ind, & + albsn_roof, albsn_improad, albsn_perroad) +! +! !DESCRIPTION: +! Determine urban snow albedos +! +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use clmtype + use clm_varcon , only : icol_roof, icol_road_perv, icol_road_imperv +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer , intent(in) :: num_urbanl ! number of urban landunits in clump + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + integer , intent(in) :: ind ! 0=direct beam, 1=diffuse radiation + real(r8), intent(in) :: coszen(num_urbanl) ! cosine solar zenith angle + real(r8), intent(out):: albsn_roof(num_urbanl,2) ! roof snow albedo by waveband (assume 2 wavebands) + real(r8), intent(out):: albsn_improad(num_urbanl,2) ! impervious road snow albedo by waveband (assume 2 wavebands) + real(r8), intent(out):: albsn_perroad(num_urbanl,2) ! pervious road snow albedo by waveband (assume 2 wavebands) +! +! !CALLED FROM: +! subroutine UrbanAlbedo in this module +! +! !REVISION HISTORY: +! Author: Keith Oleson 9/2005 +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arguments + integer , pointer :: coli(:) ! beginning column index for landunit + integer , pointer :: colf(:) ! ending column index for landunit + real(r8), pointer :: h2osno(:) ! snow water (mm H2O) + integer , pointer :: ctype(:) ! column type +! +! +! !OTHER LOCAL VARIABLES: +!EOP + integer :: fl,c,l ! indices +! +! variables and constants for snow albedo calculation +! +! These values are derived from Marshall (1989) assuming soot content of 1.5e-5 +! (three times what LSM uses globally). Note that snow age effects are ignored here. + real(r8), parameter :: snal0 = 0.66_r8 ! vis albedo of urban snow + real(r8), parameter :: snal1 = 0.56_r8 ! nir albedo of urban snow +!----------------------------------------------------------------------- + + ! Assign local pointers to derived type members (landunit level) + + coli => lun%coli + colf => lun%colf + + ! Assign local pointers to derived subtypes components (column-level) + + ctype => col%itype + h2osno => cws%h2osno + + ! this code assumes that numrad = 2 , with the following + ! index values: 1 = visible, 2 = NIR + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + do c = coli(l),colf(l) + if (coszen(fl) > 0._r8 .and. h2osno(c) > 0._r8) then + if (ctype(c) == icol_roof) then + albsn_roof(fl,1) = snal0 + albsn_roof(fl,2) = snal1 + else if (ctype(c) == icol_road_imperv) then + albsn_improad(fl,1) = snal0 + albsn_improad(fl,2) = snal1 + else if (ctype(c) == icol_road_perv) then + albsn_perroad(fl,1) = snal0 + albsn_perroad(fl,2) = snal1 + end if + else + if (ctype(c) == icol_roof) then + albsn_roof(fl,1) = 0._r8 + albsn_roof(fl,2) = 0._r8 + else if (ctype(c) == icol_road_imperv) then + albsn_improad(fl,1) = 0._r8 + albsn_improad(fl,2) = 0._r8 + else if (ctype(c) == icol_road_perv) then + albsn_perroad(fl,1) = 0._r8 + albsn_perroad(fl,2) = 0._r8 + end if + end if + end do + end do + + end subroutine UrbanSnowAlbedo + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: UrbanRadiation +! +! !INTERFACE: + subroutine UrbanRadiation (nc, lbl, ubl, lbc, ubc, lbp, ubp, & + num_nourbanl, filter_nourbanl, & + num_urbanl, filter_urbanl, & + num_urbanc, filter_urbanc, & + num_urbanp, filter_urbanp) +! +! !DESCRIPTION: +! Solar fluxes absorbed and reflected by roof and canyon (walls, road). +! Also net and upward longwave fluxes. + +! !USES: + use clmtype + use clm_varcon , only : spval, icol_roof, icol_sunwall, icol_shadewall, & + icol_road_perv, icol_road_imperv, sb + use clm_varcon , only : tfrz ! To use new constant.. + use clm_time_manager , only : get_curr_date, get_step_size + use clm_atmlnd , only : clm_a2l +! +! !ARGUMENTS: + implicit none + integer , intent(in) :: nc ! clump index + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer, intent(in) :: lbc, ubc ! column-index bounds + integer, intent(in) :: lbp, ubp ! pft-index bounds + integer , intent(in) :: num_nourbanl ! number of non-urban landunits in clump + integer , intent(in) :: filter_nourbanl(ubl-lbl+1) ! non-urban landunit filter + integer , intent(in) :: num_urbanl ! number of urban landunits in clump + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + integer , intent(in) :: num_urbanc ! number of urban columns in clump + integer , intent(in) :: filter_urbanc(ubc-lbc+1) ! urban column filter + integer , intent(in) :: num_urbanp ! number of urban pfts in clump + integer , intent(in) :: filter_urbanp(ubp-lbp+1) ! urban pft filter +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! 03/2003, Mariana Vertenstein: Migrated to clm2.2 +! 07/2004, Mariana Vertenstein: Migrated to clm3.0 +! 01/2008, Erik Kluzek: Migrated to clm3.5.15 +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in arguments (urban clump) +! + real(r8), pointer :: canyon_hwr(:) ! ratio of building height to street width + real(r8), pointer :: wtroad_perv(:) ! weight of pervious road wrt total road + real(r8), pointer :: em_roof(:) ! roof emissivity + real(r8), pointer :: em_improad(:) ! impervious road emissivity + real(r8), pointer :: em_perroad(:) ! pervious road emissivity + real(r8), pointer :: em_wall(:) ! wall emissivity +! +! local pointers to original implicit in arguments (clmtype) +! + integer , pointer :: pgridcell(:) ! gridcell of corresponding pft + integer , pointer :: pcolumn(:) ! column of corresponding pft + integer , pointer :: lgridcell(:) ! gridcell of corresponding landunit + integer , pointer :: ctype(:) ! column type + integer , pointer :: coli(:) ! beginning column index for landunit + integer , pointer :: colf(:) ! ending column index for landunit + integer , pointer :: pfti(:) ! beginning pfti index for landunit + integer , pointer :: pftf(:) ! ending pftf index for landunit + real(r8), pointer :: londeg(:) ! longitude (degrees) + real(r8), pointer :: forc_lwrad(:) ! downward infrared (longwave) radiation (W/m**2) + real(r8), pointer :: forc_solad(:,:) ! direct beam radiation (vis=forc_sols , nir=forc_soll ) (W/m**2) + real(r8), pointer :: forc_solai(:,:) ! diffuse beam radiation (vis=forc_sols , nir=forc_soll ) (W/m**2) + real(r8), pointer :: forc_solar(:) ! incident solar radiation (W/m**2) + real(r8), pointer :: albd(:,:) ! surface albedo (direct) + real(r8), pointer :: albi(:,:) ! surface albedo (diffuse) + real(r8), pointer :: t_grnd(:) ! ground temperature (K) + real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1) + real(r8), pointer :: t_ref2m(:) ! 2 m height surface air temperature (K) + real(r8), pointer :: vf_sr(:) ! view factor of sky for road + real(r8), pointer :: vf_wr(:) ! view factor of one wall for road + real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall + real(r8), pointer :: vf_rw(:) ! view factor of road for one wall + real(r8), pointer :: vf_ww(:) ! view factor of opposing wall for one wall + real(r8), pointer :: sabs_roof_dir(:,:) ! direct solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_roof_dif(:,:) ! diffuse solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_sunwall_dir(:,:) ! direct solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_sunwall_dif(:,:) ! diffuse solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dir(:,:) ! direct solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dif(:,:) ! diffuse solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_improad_dir(:,:) ! direct solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_improad_dif(:,:) ! diffuse solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dir(:,:) ! direct solar absorbed by pervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dif(:,:) ! diffuse solar absorbed by pervious road per unit ground area per unit incident flux +! +! local pointers to original implicit out arguments (clmtype) +! + real(r8), pointer :: parsun(:) ! average absorbed PAR for sunlit leaves (W/m**2) + real(r8), pointer :: parsha(:) ! average absorbed PAR for shaded leaves (W/m**2) + real(r8), pointer :: sabg(:) ! solar radiation absorbed by ground (W/m**2) + real(r8), pointer :: sabv(:) ! solar radiation absorbed by vegetation (W/m**2) + real(r8), pointer :: fsa(:) ! solar radiation absorbed (total) (W/m**2) + real(r8), pointer :: fsa_u(:) ! urban solar radiation absorbed (total) (W/m**2) + real(r8), pointer :: fsr(:) ! solar radiation reflected (total) (W/m**2) + real(r8), pointer :: fsds_vis_d(:) ! incident direct beam vis solar radiation (W/m**2) + real(r8), pointer :: fsds_nir_d(:) ! incident direct beam nir solar radiation (W/m**2) + real(r8), pointer :: fsds_vis_i(:) ! incident diffuse vis solar radiation (W/m**2) + real(r8), pointer :: fsds_nir_i(:) ! incident diffuse nir solar radiation (W/m**2) + real(r8), pointer :: fsr_vis_d(:) ! reflected direct beam vis solar radiation (W/m**2) + real(r8), pointer :: fsr_nir_d(:) ! reflected direct beam nir solar radiation (W/m**2) + real(r8), pointer :: fsr_vis_i(:) ! reflected diffuse vis solar radiation (W/m**2) + real(r8), pointer :: fsr_nir_i(:) ! reflected diffuse nir solar radiation (W/m**2) + real(r8), pointer :: fsds_vis_d_ln(:) ! incident direct beam vis solar rad at local noon (W/m**2) + real(r8), pointer :: fsds_nir_d_ln(:) ! incident direct beam nir solar rad at local noon (W/m**2) + real(r8), pointer :: fsr_vis_d_ln(:) ! reflected direct beam vis solar rad at local noon (W/m**2) + real(r8), pointer :: fsr_nir_d_ln(:) ! reflected direct beam nir solar rad at local noon (W/m**2) + real(r8), pointer :: eflx_lwrad_out(:) ! emitted infrared (longwave) radiation (W/m**2) + real(r8), pointer :: eflx_lwrad_net(:) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(r8), pointer :: eflx_lwrad_net_u(:) ! urban net infrared (longwave) rad (W/m**2) [+ = to atm] +! +! +! !OTHER LOCAL VARIABLES +!EOP +! + integer :: fp,fl,p,c,l,g ! indices + integer :: local_secp1 ! seconds into current date in local time + real(r8) :: dtime ! land model time step (sec) + integer :: year,month,day ! temporaries (not used) + integer :: secs ! seconds into current date + + real(r8), parameter :: mpe = 1.e-06_r8 ! prevents overflow for division by zero + real(r8), parameter :: snoem = 0.97_r8 ! snow emissivity (should use value from Biogeophysics1) + + real(r8) :: lwnet_roof(num_urbanl) ! net (outgoing-incoming) longwave radiation (per unit ground area), roof (W/m**2) + real(r8) :: lwnet_improad(num_urbanl) ! net (outgoing-incoming) longwave radiation (per unit ground area), impervious road (W/m**2) + real(r8) :: lwnet_perroad(num_urbanl) ! net (outgoing-incoming) longwave radiation (per unit ground area), pervious road (W/m**2) + real(r8) :: lwnet_sunwall(num_urbanl) ! net (outgoing-incoming) longwave radiation (per unit wall area), sunlit wall (W/m**2) + real(r8) :: lwnet_shadewall(num_urbanl)! net (outgoing-incoming) longwave radiation (per unit wall area), shaded wall (W/m**2) + real(r8) :: lwnet_canyon(num_urbanl) ! net (outgoing-incoming) longwave radiation for canyon, per unit ground area (W/m**2) + real(r8) :: lwup_roof(num_urbanl) ! upward longwave radiation (per unit ground area), roof (W/m**2) + real(r8) :: lwup_improad(num_urbanl) ! upward longwave radiation (per unit ground area), impervious road (W/m**2) + real(r8) :: lwup_perroad(num_urbanl) ! upward longwave radiation (per unit ground area), pervious road (W/m**2) + real(r8) :: lwup_sunwall(num_urbanl) ! upward longwave radiation, (per unit wall area), sunlit wall (W/m**2) + real(r8) :: lwup_shadewall(num_urbanl) ! upward longwave radiation, (per unit wall area), shaded wall (W/m**2) + real(r8) :: lwup_canyon(num_urbanl) ! upward longwave radiation for canyon, per unit ground area (W/m**2) + real(r8) :: t_roof(num_urbanl) ! roof temperature (K) + real(r8) :: t_improad(num_urbanl) ! imppervious road temperature (K) + real(r8) :: t_perroad(num_urbanl) ! pervious road temperature (K) + real(r8) :: t_sunwall(num_urbanl) ! sunlit wall temperature (K) + real(r8) :: t_shadewall(num_urbanl) ! shaded wall temperature (K) + real(r8) :: lwdown(num_urbanl) ! atmospheric downward longwave radiation (W/m**2) + real(r8) :: em_roof_s(num_urbanl) ! roof emissivity with snow effects + real(r8) :: em_improad_s(num_urbanl) ! impervious road emissivity with snow effects + real(r8) :: em_perroad_s(num_urbanl) ! pervious road emissivity with snow effects +!----------------------------------------------------------------------- + + ! Assign pointers into module urban clumps + + if( num_urbanl > 0 )then + canyon_hwr => urban_clump(nc)%canyon_hwr + wtroad_perv => urban_clump(nc)%wtroad_perv + em_roof => urban_clump(nc)%em_roof + em_improad => urban_clump(nc)%em_improad + em_perroad => urban_clump(nc)%em_perroad + em_wall => urban_clump(nc)%em_wall + end if + + ! Assign local pointers to multi-level derived type members (gridcell level) + + londeg => grc%londeg + forc_solad => clm_a2l%forc_solad + forc_solai => clm_a2l%forc_solai + forc_solar => clm_a2l%forc_solar + forc_lwrad => clm_a2l%forc_lwrad + + ! Assign local pointers to derived type members (landunit level) + + pfti => lun%pfti + pftf => lun%pftf + coli => lun%coli + colf => lun%colf + lgridcell => lun%gridcell + vf_sr => lps%vf_sr + vf_wr => lps%vf_wr + vf_sw => lps%vf_sw + vf_rw => lps%vf_rw + vf_ww => lps%vf_ww + sabs_roof_dir => lps%sabs_roof_dir + sabs_roof_dif => lps%sabs_roof_dif + sabs_sunwall_dir => lps%sabs_sunwall_dir + sabs_sunwall_dif => lps%sabs_sunwall_dif + sabs_shadewall_dir => lps%sabs_shadewall_dir + sabs_shadewall_dif => lps%sabs_shadewall_dif + sabs_improad_dir => lps%sabs_improad_dir + sabs_improad_dif => lps%sabs_improad_dif + sabs_perroad_dir => lps%sabs_perroad_dir + sabs_perroad_dif => lps%sabs_perroad_dif + + ! Assign local pointers to derived type members (column level) + + ctype => col%itype + t_grnd => ces%t_grnd + frac_sno => cps%frac_sno + + ! Assign local pointers to derived type members (pft level) + + pgridcell => pft%gridcell + pcolumn => pft%column + albd => pps%albd + albi => pps%albi + sabg => pef%sabg + sabv => pef%sabv + fsa => pef%fsa + fsa_u => pef%fsa_u + fsr => pef%fsr + fsds_vis_d => pef%fsds_vis_d + fsds_nir_d => pef%fsds_nir_d + fsds_vis_i => pef%fsds_vis_i + fsds_nir_i => pef%fsds_nir_i + fsr_vis_d => pef%fsr_vis_d + fsr_nir_d => pef%fsr_nir_d + fsr_vis_i => pef%fsr_vis_i + fsr_nir_i => pef%fsr_nir_i + fsds_vis_d_ln => pef%fsds_vis_d_ln + fsds_nir_d_ln => pef%fsds_nir_d_ln + fsr_vis_d_ln => pef%fsr_vis_d_ln + fsr_nir_d_ln => pef%fsr_nir_d_ln + eflx_lwrad_out => pef%eflx_lwrad_out + eflx_lwrad_net => pef%eflx_lwrad_net + eflx_lwrad_net_u => pef%eflx_lwrad_net_u + parsun => pef%parsun + parsha => pef%parsha + t_ref2m => pes%t_ref2m + + ! Define fields that appear on the restart file for non-urban landunits + + do fl = 1,num_nourbanl + l = filter_nourbanl(fl) + sabs_roof_dir(l,:) = spval + sabs_roof_dif(l,:) = spval + sabs_sunwall_dir(l,:) = spval + sabs_sunwall_dif(l,:) = spval + sabs_shadewall_dir(l,:) = spval + sabs_shadewall_dif(l,:) = spval + sabs_improad_dir(l,:) = spval + sabs_improad_dif(l,:) = spval + sabs_perroad_dir(l,:) = spval + sabs_perroad_dif(l,:) = spval + vf_sr(l) = spval + vf_wr(l) = spval + vf_sw(l) = spval + vf_rw(l) = spval + vf_ww(l) = spval + end do + + ! Set input forcing fields + do fl = 1,num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + ! Need to set the following temperatures to some defined value even if it + ! does not appear in the urban landunit for the net_longwave computation + + t_roof(fl) = 19._r8 + tfrz + t_sunwall(fl) = 19._r8 + tfrz + t_shadewall(fl) = 19._r8 + tfrz + t_improad(fl) = 19._r8 + tfrz + t_perroad(fl) = 19._r8 + tfrz + + ! Initial assignment of emissivity + em_roof_s(fl) = em_roof(fl) + em_improad_s(fl) = em_improad(fl) + em_perroad_s(fl) = em_perroad(fl) + + ! Set urban temperatures and emissivity including snow effects. + do c = coli(l),colf(l) + if (ctype(c) == icol_roof ) then + t_roof(fl) = t_grnd(c) + em_roof_s(fl) = em_roof(fl)*(1._r8-frac_sno(c)) + snoem*frac_sno(c) + else if (ctype(c) == icol_road_imperv) then + t_improad(fl) = t_grnd(c) + em_improad_s(fl) = em_improad(fl)*(1._r8-frac_sno(c)) + snoem*frac_sno(c) + else if (ctype(c) == icol_road_perv ) then + t_perroad(fl) = t_grnd(c) + em_perroad_s(fl) = em_perroad(fl)*(1._r8-frac_sno(c)) + snoem*frac_sno(c) + else if (ctype(c) == icol_sunwall ) then + t_sunwall(fl) = t_grnd(c) + else if (ctype(c) == icol_shadewall ) then + t_shadewall(fl) = t_grnd(c) + end if + end do + lwdown(fl) = forc_lwrad(g) + end do + + ! Net longwave radiation for road and both walls in urban canyon allowing for multiple re-emission + + if (num_urbanl .gt. 0) then + call net_longwave (lbl, ubl, num_urbanl, filter_urbanl, canyon_hwr, wtroad_perv, & + lwdown, em_roof_s, em_improad_s, em_perroad_s, em_wall, & + t_roof, t_improad, t_perroad, t_sunwall, t_shadewall, & + lwnet_roof, lwnet_improad, lwnet_perroad, lwnet_sunwall, lwnet_shadewall, lwnet_canyon, & + lwup_roof, lwup_improad, lwup_perroad, lwup_sunwall, lwup_shadewall, lwup_canyon) + end if + + dtime = get_step_size() + call get_curr_date (year, month, day, secs) + + ! Determine clmtype variables needed for history output and communication with atm + ! Loop over urban pfts in clump + + do fp = 1,num_urbanp + p = filter_urbanp(fp) + g = pgridcell(p) + + local_secp1 = secs + nint((londeg(g)/degpsec)/dtime)*dtime + local_secp1 = mod(local_secp1,isecspday) + + ! Solar incident + + fsds_vis_d(p) = forc_solad(g,1) + fsds_nir_d(p) = forc_solad(g,2) + fsds_vis_i(p) = forc_solai(g,1) + fsds_nir_i(p) = forc_solai(g,2) + ! Determine local noon incident solar + if (local_secp1 == noonsec) then + fsds_vis_d_ln(p) = forc_solad(g,1) + fsds_nir_d_ln(p) = forc_solad(g,2) + else + fsds_vis_d_ln(p) = spval + fsds_nir_d_ln(p) = spval + endif + + ! Solar reflected + ! per unit ground area (roof, road) and per unit wall area (sunwall, shadewall) + + fsr_vis_d(p) = albd(p,1) * forc_solad(g,1) + fsr_nir_d(p) = albd(p,2) * forc_solad(g,2) + fsr_vis_i(p) = albi(p,1) * forc_solai(g,1) + fsr_nir_i(p) = albi(p,2) * forc_solai(g,2) + + ! Determine local noon reflected solar + if (local_secp1 == noonsec) then + fsr_vis_d_ln(p) = fsr_vis_d(p) + fsr_nir_d_ln(p) = fsr_nir_d(p) + else + fsr_vis_d_ln(p) = spval + fsr_nir_d_ln(p) = spval + endif + fsr(p) = fsr_vis_d(p) + fsr_nir_d(p) + fsr_vis_i(p) + fsr_nir_i(p) + + end do + + ! Loop over urban landunits in clump + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + ! Solar absorbed and longwave out and net + ! per unit ground area (roof, road) and per unit wall area (sunwall, shadewall) + ! Each urban pft has its own column - this is used in the logic below + + do p = pfti(l), pftf(l) + c = pcolumn(p) + if (ctype(c) == icol_roof) then + eflx_lwrad_out(p) = lwup_roof(fl) + eflx_lwrad_net(p) = lwnet_roof(fl) + eflx_lwrad_net_u(p) = lwnet_roof(fl) + sabg(p) = sabs_roof_dir(l,1)*forc_solad(g,1) + & + sabs_roof_dif(l,1)*forc_solai(g,1) + & + sabs_roof_dir(l,2)*forc_solad(g,2) + & + sabs_roof_dif(l,2)*forc_solai(g,2) + else if (ctype(c) == icol_sunwall) then + eflx_lwrad_out(p) = lwup_sunwall(fl) + eflx_lwrad_net(p) = lwnet_sunwall(fl) + eflx_lwrad_net_u(p) = lwnet_sunwall(fl) + sabg(p) = sabs_sunwall_dir(l,1)*forc_solad(g,1) + & + sabs_sunwall_dif(l,1)*forc_solai(g,1) + & + sabs_sunwall_dir(l,2)*forc_solad(g,2) + & + sabs_sunwall_dif(l,2)*forc_solai(g,2) + else if (ctype(c) == icol_shadewall) then + eflx_lwrad_out(p) = lwup_shadewall(fl) + eflx_lwrad_net(p) = lwnet_shadewall(fl) + eflx_lwrad_net_u(p) = lwnet_shadewall(fl) + sabg(p) = sabs_shadewall_dir(l,1)*forc_solad(g,1) + & + sabs_shadewall_dif(l,1)*forc_solai(g,1) + & + sabs_shadewall_dir(l,2)*forc_solad(g,2) + & + sabs_shadewall_dif(l,2)*forc_solai(g,2) + else if (ctype(c) == icol_road_perv) then + eflx_lwrad_out(p) = lwup_perroad(fl) + eflx_lwrad_net(p) = lwnet_perroad(fl) + eflx_lwrad_net_u(p) = lwnet_perroad(fl) + sabg(p) = sabs_perroad_dir(l,1)*forc_solad(g,1) + & + sabs_perroad_dif(l,1)*forc_solai(g,1) + & + sabs_perroad_dir(l,2)*forc_solad(g,2) + & + sabs_perroad_dif(l,2)*forc_solai(g,2) + else if (ctype(c) == icol_road_imperv) then + eflx_lwrad_out(p) = lwup_improad(fl) + eflx_lwrad_net(p) = lwnet_improad(fl) + eflx_lwrad_net_u(p) = lwnet_improad(fl) + sabg(p) = sabs_improad_dir(l,1)*forc_solad(g,1) + & + sabs_improad_dif(l,1)*forc_solai(g,1) + & + sabs_improad_dir(l,2)*forc_solad(g,2) + & + sabs_improad_dif(l,2)*forc_solai(g,2) + end if + sabv(p) = 0._r8 + fsa(p) = sabv(p) + sabg(p) + fsa_u(p) = fsa(p) + parsun(p) = 0._r8 + parsha(p) = 0._r8 + + end do ! end loop over urban pfts + + end do ! end loop over urban landunits + + end subroutine UrbanRadiation + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: view_factor +! +! !INTERFACE: + subroutine view_factor (lbl, ubl, num_urbanl, filter_urbanl, canyon_hwr) + +! +! !DESCRIPTION: +! View factors for road and one wall +! WALL | +! ROAD | +! wall | +! -----\ /----- - - |\----------/ +! | \ vsr / | | r | | \ vww / s +! | \ / | h o w | \ / k +! wall | \ / | wall | a | | \ / y +! |vwr \ / vwr| | d | |vrw \ / vsw +! ------\/------ - - |-----\/----- +! road wall | +! <----- w ----> | +! <---- h --->| +! +! vsr = view factor of sky for road vrw = view factor of road for wall +! vwr = view factor of one wall for road vww = view factor of opposing wall for wall +! vsw = view factor of sky for wall +! vsr + vwr + vwr = 1 vrw + vww + vsw = 1 +! +! Source: Masson, V. (2000) A physically-based scheme for the urban energy budget in +! atmospheric models. Boundary-Layer Meteorology 94:357-397 +! +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use clmtype +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer , intent(in) :: num_urbanl ! number of urban landunits + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + real(r8), intent(in) :: canyon_hwr(num_urbanl) ! ratio of building height to street width +! +! local pointers to original implicit out arguments (clmtype) +! + real(r8), pointer :: vf_sr(:) ! view factor of sky for road + real(r8), pointer :: vf_wr(:) ! view factor of one wall for road + real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall + real(r8), pointer :: vf_rw(:) ! view factor of road for one wall + real(r8), pointer :: vf_ww(:) ! view factor of opposing wall for one wall +! +! !CALLED FROM: +! subroutine UrbanAlbedo in this module +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! 03/2003, Mariana Vertenstein: Migrated to clm2.2 +! 01/2008, Erik Kluzek: Migrated to clm3.5.15 +! +! +! !LOCAL VARIABLES: +!EOP + integer :: l, fl ! indices + real(r8) :: sum ! sum of view factors for wall or road +!----------------------------------------------------------------------- + + ! Assign landunit level pointer + + vf_sr => lps%vf_sr + vf_wr => lps%vf_wr + vf_sw => lps%vf_sw + vf_rw => lps%vf_rw + vf_ww => lps%vf_ww + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + + ! road -- sky view factor -> 1 as building height -> 0 + ! and -> 0 as building height -> infinity + + vf_sr(l) = sqrt(canyon_hwr(fl)**2 + 1._r8) - canyon_hwr(fl) + vf_wr(l) = 0.5_r8 * (1._r8 - vf_sr(l)) + + ! one wall -- sky view factor -> 0.5 as building height -> 0 + ! and -> 0 as building height -> infinity + + vf_sw(l) = 0.5_r8 * (canyon_hwr(fl) + 1._r8 - sqrt(canyon_hwr(fl)**2+1._r8)) / canyon_hwr(fl) + vf_rw(l) = vf_sw(l) + vf_ww(l) = 1._r8 - vf_sw(l) - vf_rw(l) + + end do + + + ! error check -- make sure view factor sums to one for road and wall + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + + sum = vf_sr(l) + 2._r8*vf_wr(l) + if (abs(sum-1._r8) > 1.e-06_r8 ) then + write (iulog,*) 'urban road view factor error',sum + write (iulog,*) 'clm model is stopping' + call endrun() + endif + sum = vf_sw(l) + vf_rw(l) + vf_ww(l) + if (abs(sum-1._r8) > 1.e-06_r8 ) then + write (iulog,*) 'urban wall view factor error',sum + write (iulog,*) 'clm model is stopping' + call endrun() + endif + + end do + + end subroutine view_factor + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: incident_direct +! +! !INTERFACE: + subroutine incident_direct (lbl, ubl, num_urbanl, canyon_hwr, coszen, zen, sdir, sdir_road, sdir_sunwall, sdir_shadewall) +! +! !DESCRIPTION: +! Direct beam solar radiation incident on walls and road in urban canyon +! +! Sun +! / +! roof / +! ------ /--- - +! | / | | +! sunlit wall | / | shaded wall h +! | / | | +! -----/----- - +! road +! <--- w ---> +! +! Method: +! Road = Horizontal surface. Account for shading by wall. Integrate over all canyon orientations +! Wall (sunlit) = Adjust horizontal radiation for 90 degree surface. Account for shading by opposing wall. +! Integrate over all canyon orientations +! Wall (shaded) = 0 +! +! Conservation check: Total incoming direct beam (sdir) = sdir_road + (sdir_shadewall + sdir_sunwall)*canyon_hwr +! Multiplication by canyon_hwr scales wall fluxes (per unit wall area) to per unit ground area +! +! Source: Masson, V. (2000) A physically-based scheme for the urban energy budget in +! atmospheric models. Boundary-Layer Meteorology 94:357-397 +! +! This analytical solution from Masson (2000) agrees with the numerical solution to +! within 0.6 W/m**2 for sdir = 1000 W/m**2 and for all H/W from 0.1 to 10 by 0.1 +! and all solar zenith angles from 1 to 90 deg by 1 +! +! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_varcon , only : rpi + implicit none +! +! !ARGUMENTS: + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer , intent(in) :: num_urbanl ! number of urban landunits + real(r8), intent(in) :: canyon_hwr(num_urbanl) ! ratio of building height to street width + real(r8), intent(in) :: coszen(num_urbanl) ! cosine solar zenith angle + real(r8), intent(in) :: zen(num_urbanl) ! solar zenith angle (radians) + real(r8), intent(in) :: sdir(num_urbanl, numrad) ! direct beam solar radiation incident on horizontal surface + real(r8), intent(out) :: sdir_road(num_urbanl, numrad) ! direct beam solar radiation incident on road per unit incident flux + real(r8), intent(out) :: sdir_sunwall(num_urbanl, numrad) ! direct beam solar radiation (per unit wall area) incident on sunlit wall per unit incident flux + real(r8), intent(out) :: sdir_shadewall(num_urbanl, numrad) ! direct beam solar radiation (per unit wall area) incident on shaded wall per unit incident flux +! +! !CALLED FROM: +! subroutine UrbanAlbedo in this module +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! +! +! !LOCAL VARIABLES: +!EOP + integer :: l,i,ib ! indices +!KO logical :: numchk = .true. ! true => perform numerical check of analytical solution + logical :: numchk = .false. ! true => perform numerical check of analytical solution + real(r8) :: theta0(num_urbanl) ! critical canyon orientation for which road is no longer illuminated + real(r8) :: tanzen(num_urbanl) ! tan(zenith angle) + real(r8) :: swall_projected ! direct beam solar radiation (per unit ground area) incident on wall + real(r8) :: err1(num_urbanl) ! energy conservation error + real(r8) :: err2(num_urbanl) ! energy conservation error + real(r8) :: err3(num_urbanl) ! energy conservation error + real(r8) :: sumr ! sum of sroad for each orientation (0 <= theta <= pi/2) + real(r8) :: sumw ! sum of swall for each orientation (0 <= theta <= pi/2) + real(r8) :: num ! number of orientations + real(r8) :: theta ! canyon orientation relative to sun (0 <= theta <= pi/2) + real(r8) :: zen0 ! critical solar zenith angle for which sun begins to illuminate road +!----------------------------------------------------------------------- + + do l = 1,num_urbanl + if (coszen(l) > 0._r8) then + theta0(l) = asin(min( (1._r8/(canyon_hwr(l)*tan(max(zen(l),0.000001_r8)))), 1._r8 )) + tanzen(l) = tan(zen(l)) + end if + end do + + do ib = 1,numrad + + do l = 1,num_urbanl + if (coszen(l) > 0._r8) then + sdir_shadewall(l,ib) = 0._r8 + + ! incident solar radiation on wall and road integrated over all canyon orientations (0 <= theta <= pi/2) + + sdir_road(l,ib) = sdir(l,ib) * & + (2._r8*theta0(l)/rpi - 2./rpi*canyon_hwr(l)*tanzen(l)*(1._r8-cos(theta0(l)))) + sdir_sunwall(l,ib) = 2._r8 * sdir(l,ib) * ((1._r8/canyon_hwr(l))* & + (0.5_r8-theta0(l)/rpi) + (1._r8/rpi)*tanzen(l)*(1._r8-cos(theta0(l)))) + + ! conservation check for road and wall. need to use wall fluxes converted to ground area + + swall_projected = (sdir_shadewall(l,ib) + sdir_sunwall(l,ib)) * canyon_hwr(l) + err1(l) = sdir(l,ib) - (sdir_road(l,ib) + swall_projected) + else + sdir_road(l,ib) = 0._r8 + sdir_sunwall(l,ib) = 0._r8 + sdir_shadewall(l,ib) = 0._r8 + endif + end do + + do l = 1,num_urbanl + if (coszen(l) > 0._r8) then + if (abs(err1(l)) > 0.001_r8) then + write (iulog,*) 'urban direct beam solar radiation balance error',err1(l) + write (iulog,*) 'clm model is stopping' + call endrun() + endif + endif + end do + + ! numerical check of analytical solution + ! sum sroad and swall over all canyon orientations (0 <= theta <= pi/2) + + if (numchk) then + do l = 1,num_urbanl + if (coszen(l) > 0._r8) then + sumr = 0._r8 + sumw = 0._r8 + num = 0._r8 + do i = 1, 9000 + theta = i/100._r8 * rpi/180._r8 + zen0 = atan(1._r8/(canyon_hwr(l)*sin(theta))) + if (zen(l) >= zen0) then + sumr = sumr + 0._r8 + sumw = sumw + sdir(l,ib) / canyon_hwr(l) + else + sumr = sumr + sdir(l,ib) * (1._r8-canyon_hwr(l)*sin(theta)*tanzen(l)) + sumw = sumw + sdir(l,ib) * sin(theta)*tanzen(l) + end if + num = num + 1._r8 + end do + err2(l) = sumr/num - sdir_road(l,ib) + err3(l) = sumw/num - sdir_sunwall(l,ib) + endif + end do + do l = 1,num_urbanl + if (coszen(l) > 0._r8) then + if (abs(err2(l)) > 0.0006_r8 ) then + write (iulog,*) 'urban road incident direct beam solar radiation error',err2(l) + write (iulog,*) 'clm model is stopping' + call endrun + endif + if (abs(err3(l)) > 0.0006_r8 ) then + write (iulog,*) 'urban wall incident direct beam solar radiation error',err3(l) + write (iulog,*) 'clm model is stopping' + call endrun + end if + end if + end do + end if + + end do + + end subroutine incident_direct + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: incident_diffuse +! +! !INTERFACE: + subroutine incident_diffuse (lbl, ubl, num_urbanl, filter_urbanl, canyon_hwr, sdif, sdif_road, sdif_sunwall, sdif_shadewall) +! +! !DESCRIPTION: +! Diffuse solar radiation incident on walls and road in urban canyon +! Conservation check: Total incoming diffuse +! (sdif) = sdif_road + (sdif_shadewall + sdif_sunwall)*canyon_hwr +! Multiplication by canyon_hwr scales wall fluxes (per unit wall area) to per unit ground area +! +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use clmtype +! +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer , intent(in) :: num_urbanl ! number of urban landunits + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + real(r8), intent(in) :: canyon_hwr(num_urbanl) ! ratio of building height to street width + real(r8), intent(in) :: sdif(num_urbanl, numrad) ! diffuse solar radiation incident on horizontal surface + real(r8), intent(out) :: sdif_road(num_urbanl, numrad) ! diffuse solar radiation incident on road + real(r8), intent(out) :: sdif_sunwall(num_urbanl, numrad) ! diffuse solar radiation (per unit wall area) incident on sunlit wall + real(r8), intent(out) :: sdif_shadewall(num_urbanl, numrad) ! diffuse solar radiation (per unit wall area) incident on shaded wall +! +! local pointers to original implicit in arguments (clmtype) +! + real(r8), pointer :: vf_sr(:) ! view factor of sky for road + real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall +! +! !CALLED FROM: +! subroutine UrbanAlbedo in this module +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! +! +! !LOCAL VARIABLES: +!EOP + integer :: l, fl, ib ! indices + real(r8) :: err(num_urbanl) ! energy conservation error (W/m**2) + real(r8) :: swall_projected ! diffuse solar radiation (per unit ground area) incident on wall (W/m**2) +!----------------------------------------------------------------------- + + ! Assign landunit level pointer + + vf_sr => lps%vf_sr + vf_sw => lps%vf_sw + + do ib = 1, numrad + + ! diffuse solar and conservation check. need to convert wall fluxes to ground area + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + sdif_road(fl,ib) = sdif(fl,ib) * vf_sr(l) + sdif_sunwall(fl,ib) = sdif(fl,ib) * vf_sw(l) + sdif_shadewall(fl,ib) = sdif(fl,ib) * vf_sw(l) + + swall_projected = (sdif_shadewall(fl,ib) + sdif_sunwall(fl,ib)) * canyon_hwr(fl) + err(fl) = sdif(fl,ib) - (sdif_road(fl,ib) + swall_projected) + end do + + ! error check + + do l = 1, num_urbanl + if (abs(err(l)) > 0.001_r8) then + write (iulog,*) 'urban diffuse solar radiation balance error',err(l) + write (iulog,*) 'clm model is stopping' + call endrun + endif + end do + + end do + + end subroutine incident_diffuse + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: net_solar +! +! !INTERFACE: + subroutine net_solar (lbl, ubl, num_urbanl, filter_urbanl, coszen, canyon_hwr, wtroad_perv, sdir, sdif, & + alb_improad_dir, alb_perroad_dir, alb_wall_dir, alb_roof_dir, & + alb_improad_dif, alb_perroad_dif, alb_wall_dif, alb_roof_dif, & + sdir_road, sdir_sunwall, sdir_shadewall, & + sdif_road, sdif_sunwall, sdif_shadewall, & + sref_improad_dir, sref_perroad_dir, sref_sunwall_dir, sref_shadewall_dir, sref_roof_dir, & + sref_improad_dif, sref_perroad_dif, sref_sunwall_dif, sref_shadewall_dif, sref_roof_dif) +! +! !DESCRIPTION: +! Solar radiation absorbed by road and both walls in urban canyon allowing +! for multiple reflection. +! +! !USES: + use shr_kind_mod, only : r8 => shr_kind_r8 + use clmtype +! +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer , intent(in) :: num_urbanl ! number of urban landunits + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + real(r8), intent(in) :: coszen(num_urbanl) ! cosine solar zenith angle + real(r8), intent(in) :: canyon_hwr(num_urbanl) ! ratio of building height to street width + real(r8), intent(in) :: wtroad_perv(num_urbanl) ! weight of pervious road wrt total road + real(r8), intent(in) :: sdir(num_urbanl, numrad) ! direct beam solar radiation incident on horizontal surface + real(r8), intent(in) :: sdif(num_urbanl, numrad) ! diffuse solar radiation on horizontal surface + real(r8), intent(in) :: alb_improad_dir(num_urbanl, numrad) ! direct impervious road albedo + real(r8), intent(in) :: alb_perroad_dir(num_urbanl, numrad) ! direct pervious road albedo + real(r8), intent(in) :: alb_wall_dir(num_urbanl, numrad) ! direct wall albedo + real(r8), intent(in) :: alb_roof_dir(num_urbanl, numrad) ! direct roof albedo + real(r8), intent(in) :: alb_improad_dif(num_urbanl, numrad) ! diffuse impervious road albedo + real(r8), intent(in) :: alb_perroad_dif(num_urbanl, numrad) ! diffuse pervious road albedo + real(r8), intent(in) :: alb_wall_dif(num_urbanl, numrad) ! diffuse wall albedo + real(r8), intent(in) :: alb_roof_dif(num_urbanl, numrad) ! diffuse roof albedo + real(r8), intent(in) :: sdir_road(num_urbanl, numrad) ! direct beam solar radiation incident on road per unit incident flux + real(r8), intent(in) :: sdir_sunwall(num_urbanl, numrad) ! direct beam solar radiation (per unit wall area) incident on sunlit wall per unit incident flux + real(r8), intent(in) :: sdir_shadewall(num_urbanl, numrad) ! direct beam solar radiation (per unit wall area) incident on shaded wall per unit incident flux + real(r8), intent(in) :: sdif_road(num_urbanl, numrad) ! diffuse solar radiation incident on road per unit incident flux + real(r8), intent(in) :: sdif_sunwall(num_urbanl, numrad) ! diffuse solar radiation (per unit wall area) incident on sunlit wall per unit incident flux + real(r8), intent(in) :: sdif_shadewall(num_urbanl, numrad) ! diffuse solar radiation (per unit wall area) incident on shaded wall per unit incident flux + real(r8), intent(inout) :: sref_improad_dir(num_urbanl, numrad) ! direct solar rad reflected by impervious road (per unit ground area) per unit incident flux + real(r8), intent(inout) :: sref_perroad_dir(num_urbanl, numrad) ! direct solar rad reflected by pervious road (per unit ground area) per unit incident flux + real(r8), intent(inout) :: sref_improad_dif(num_urbanl, numrad) ! diffuse solar rad reflected by impervious road (per unit ground area) per unit incident flux + real(r8), intent(inout) :: sref_perroad_dif(num_urbanl, numrad) ! diffuse solar rad reflected by pervious road (per unit ground area) per unit incident flux + real(r8), intent(inout) :: sref_sunwall_dir(num_urbanl, numrad) ! direct solar rad reflected by sunwall (per unit wall area) per unit incident flux + real(r8), intent(inout) :: sref_sunwall_dif(num_urbanl, numrad) ! diffuse solar rad reflected by sunwall (per unit wall area) per unit incident flux + real(r8), intent(inout) :: sref_shadewall_dir(num_urbanl, numrad) ! direct solar rad reflected by shadewall (per unit wall area) per unit incident flux + real(r8), intent(inout) :: sref_shadewall_dif(num_urbanl, numrad) ! diffuse solar rad reflected by shadewall (per unit wall area) per unit incident flux + real(r8), intent(inout) :: sref_roof_dir(num_urbanl, numrad) ! direct solar rad reflected by roof (per unit ground area) per unit incident flux + real(r8), intent(inout) :: sref_roof_dif(num_urbanl, numrad) ! diffuse solar rad reflected by roof (per unit ground area) per unit incident flux +! +! local pointers to original implicit in arguments (clmtype) +! + real(r8), pointer :: vf_sr(:) ! view factor of sky for road + real(r8), pointer :: vf_wr(:) ! view factor of one wall for road + real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall + real(r8), pointer :: vf_rw(:) ! view factor of road for one wall + real(r8), pointer :: vf_ww(:) ! view factor of opposing wall for one wall + real(r8), pointer :: sabs_roof_dir(:,:) ! direct solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_roof_dif(:,:) ! diffuse solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_sunwall_dir(:,:) ! direct solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_sunwall_dif(:,:) ! diffuse solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dir(:,:) ! direct solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dif(:,:) ! diffuse solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_improad_dir(:,:) ! direct solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_improad_dif(:,:) ! diffuse solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dir(:,:) ! direct solar absorbed by pervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dif(:,:) ! diffuse solar absorbed by pervious road per unit ground area per unit incident flux +! +! !CALLED FROM: +! subroutine UrbanAlbedo in this module +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! +! +! !LOCAL VARIABLES +!EOP +! + real(r8) :: wtroad_imperv(num_urbanl) ! weight of impervious road wrt total road + real(r8) :: sabs_canyon_dir(num_urbanl) ! direct solar rad absorbed by canyon per unit incident flux + real(r8) :: sabs_canyon_dif(num_urbanl) ! diffuse solar rad absorbed by canyon per unit incident flux + real(r8) :: sref_canyon_dir(num_urbanl) ! direct solar reflected by canyon per unit incident flux + real(r8) :: sref_canyon_dif(num_urbanl) ! diffuse solar reflected by canyon per unit incident flux + + real(r8) :: improad_a_dir(num_urbanl) ! absorbed direct solar for impervious road after "n" reflections per unit incident flux + real(r8) :: improad_a_dif(num_urbanl) ! absorbed diffuse solar for impervious road after "n" reflections per unit incident flux + real(r8) :: improad_r_dir(num_urbanl) ! reflected direct solar for impervious road after "n" reflections per unit incident flux + real(r8) :: improad_r_dif(num_urbanl) ! reflected diffuse solar for impervious road after "n" reflections per unit incident flux + real(r8) :: improad_r_sky_dir(num_urbanl) ! improad_r_dir to sky per unit incident flux + real(r8) :: improad_r_sunwall_dir(num_urbanl) ! improad_r_dir to sunlit wall per unit incident flux + real(r8) :: improad_r_shadewall_dir(num_urbanl) ! improad_r_dir to shaded wall per unit incident flux + real(r8) :: improad_r_sky_dif(num_urbanl) ! improad_r_dif to sky per unit incident flux + real(r8) :: improad_r_sunwall_dif(num_urbanl) ! improad_r_dif to sunlit wall per unit incident flux + real(r8) :: improad_r_shadewall_dif(num_urbanl) ! improad_r_dif to shaded wall per unit incident flux + + real(r8) :: perroad_a_dir(num_urbanl) ! absorbed direct solar for pervious road after "n" reflections per unit incident flux + real(r8) :: perroad_a_dif(num_urbanl) ! absorbed diffuse solar for pervious road after "n" reflections per unit incident flux + real(r8) :: perroad_r_dir(num_urbanl) ! reflected direct solar for pervious road after "n" reflections per unit incident flux + real(r8) :: perroad_r_dif(num_urbanl) ! reflected diffuse solar for pervious road after "n" reflections per unit incident flux + real(r8) :: perroad_r_sky_dir(num_urbanl) ! perroad_r_dir to sky per unit incident flux + real(r8) :: perroad_r_sunwall_dir(num_urbanl) ! perroad_r_dir to sunlit wall per unit incident flux + real(r8) :: perroad_r_shadewall_dir(num_urbanl) ! perroad_r_dir to shaded wall per unit incident flux + real(r8) :: perroad_r_sky_dif(num_urbanl) ! perroad_r_dif to sky per unit incident flux + real(r8) :: perroad_r_sunwall_dif(num_urbanl) ! perroad_r_dif to sunlit wall per unit incident flux + real(r8) :: perroad_r_shadewall_dif(num_urbanl) ! perroad_r_dif to shaded wall per unit incident flux + + real(r8) :: road_a_dir(num_urbanl) ! absorbed direct solar for total road after "n" reflections per unit incident flux + real(r8) :: road_a_dif(num_urbanl) ! absorbed diffuse solar for total road after "n" reflections per unit incident flux + real(r8) :: road_r_dir(num_urbanl) ! reflected direct solar for total road after "n" reflections per unit incident flux + real(r8) :: road_r_dif(num_urbanl) ! reflected diffuse solar for total road after "n" reflections per unit incident flux + real(r8) :: road_r_sky_dir(num_urbanl) ! road_r_dir to sky per unit incident flux + real(r8) :: road_r_sunwall_dir(num_urbanl) ! road_r_dir to sunlit wall per unit incident flux + real(r8) :: road_r_shadewall_dir(num_urbanl) ! road_r_dir to shaded wall per unit incident flux + real(r8) :: road_r_sky_dif(num_urbanl) ! road_r_dif to sky per unit incident flux + real(r8) :: road_r_sunwall_dif(num_urbanl) ! road_r_dif to sunlit wall per unit incident flux + real(r8) :: road_r_shadewall_dif(num_urbanl) ! road_r_dif to shaded wall per unit incident flux + + real(r8) :: sunwall_a_dir(num_urbanl) ! absorbed direct solar for sunlit wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: sunwall_a_dif(num_urbanl) ! absorbed diffuse solar for sunlit wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: sunwall_r_dir(num_urbanl) ! reflected direct solar for sunlit wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: sunwall_r_dif(num_urbanl) ! reflected diffuse solar for sunlit wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: sunwall_r_sky_dir(num_urbanl) ! sunwall_r_dir to sky per unit incident flux + real(r8) :: sunwall_r_road_dir(num_urbanl) ! sunwall_r_dir to road per unit incident flux + real(r8) :: sunwall_r_shadewall_dir(num_urbanl) ! sunwall_r_dir to opposing (shaded) wall per unit incident flux + real(r8) :: sunwall_r_sky_dif(num_urbanl) ! sunwall_r_dif to sky per unit incident flux + real(r8) :: sunwall_r_road_dif(num_urbanl) ! sunwall_r_dif to road per unit incident flux + real(r8) :: sunwall_r_shadewall_dif(num_urbanl) ! sunwall_r_dif to opposing (shaded) wall per unit incident flux + + real(r8) :: shadewall_a_dir(num_urbanl) ! absorbed direct solar for shaded wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: shadewall_a_dif(num_urbanl) ! absorbed diffuse solar for shaded wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: shadewall_r_dir(num_urbanl) ! reflected direct solar for shaded wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: shadewall_r_dif(num_urbanl) ! reflected diffuse solar for shaded wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: shadewall_r_sky_dir(num_urbanl) ! shadewall_r_dir to sky per unit incident flux + real(r8) :: shadewall_r_road_dir(num_urbanl) ! shadewall_r_dir to road per unit incident flux + real(r8) :: shadewall_r_sunwall_dir(num_urbanl) ! shadewall_r_dir to opposing (sunlit) wall per unit incident flux + real(r8) :: shadewall_r_sky_dif(num_urbanl) ! shadewall_r_dif to sky per unit incident flux + real(r8) :: shadewall_r_road_dif(num_urbanl) ! shadewall_r_dif to road per unit incident flux + real(r8) :: shadewall_r_sunwall_dif(num_urbanl) ! shadewall_r_dif to opposing (sunlit) wall per unit incident flux + + real(r8) :: canyon_alb_dir(num_urbanl) ! direct canyon albedo + real(r8) :: canyon_alb_dif(num_urbanl) ! diffuse canyon albedo + + real(r8) :: stot(num_urbanl) ! sum of radiative terms + real(r8) :: stot_dir(num_urbanl) ! sum of direct radiative terms + real(r8) :: stot_dif(num_urbanl) ! sum of diffuse radiative terms + + integer :: l,fl,ib ! indices + integer :: iter_dir,iter_dif ! iteration counter + real(r8) :: crit ! convergence criterion + real(r8) :: err ! energy conservation error + integer :: pass + integer, parameter :: n = 50 ! number of interations + real(r8) :: sabs_road ! temporary for absorption over road + real(r8) :: sref_road ! temporary for reflected over road + real(r8), parameter :: errcrit = .00001_r8 ! error criteria +!----------------------------------------------------------------------- + + ! Assign landunit level pointer + + vf_sr => lps%vf_sr + vf_wr => lps%vf_wr + vf_sw => lps%vf_sw + vf_rw => lps%vf_rw + vf_ww => lps%vf_ww + sabs_roof_dir => lps%sabs_roof_dir + sabs_roof_dif => lps%sabs_roof_dif + sabs_sunwall_dir => lps%sabs_sunwall_dir + sabs_sunwall_dif => lps%sabs_sunwall_dif + sabs_shadewall_dir => lps%sabs_shadewall_dir + sabs_shadewall_dif => lps%sabs_shadewall_dif + sabs_improad_dir => lps%sabs_improad_dir + sabs_improad_dif => lps%sabs_improad_dif + sabs_perroad_dir => lps%sabs_perroad_dir + sabs_perroad_dif => lps%sabs_perroad_dif + + ! Calculate impervious road + + do l = 1,num_urbanl + wtroad_imperv(l) = 1._r8 - wtroad_perv(l) + end do + + do ib = 1,numrad + do fl = 1,num_urbanl + if (coszen(fl) .gt. 0._r8) then + l = filter_urbanl(fl) + + ! initial absorption and reflection for road and both walls. + ! distribute reflected radiation to sky, road, and walls + ! according to appropriate view factor. radiation reflected to + ! road and walls will undergo multiple reflections within the canyon. + ! do separately for direct beam and diffuse radiation. + + ! direct beam + + road_a_dir(fl) = 0.0_r8 + road_r_dir(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_a_dir(fl) = (1._r8-alb_improad_dir(fl,ib)) * sdir_road(fl,ib) + improad_r_dir(fl) = alb_improad_dir(fl,ib) * sdir_road(fl,ib) + improad_r_sky_dir(fl) = improad_r_dir(fl) * vf_sr(l) + improad_r_sunwall_dir(fl) = improad_r_dir(fl) * vf_wr(l) + improad_r_shadewall_dir(fl) = improad_r_dir(fl) * vf_wr(l) + road_a_dir(fl) = road_a_dir(fl) + improad_a_dir(fl)*wtroad_imperv(fl) + road_r_dir(fl) = road_r_dir(fl) + improad_r_dir(fl)*wtroad_imperv(fl) + end if + + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_a_dir(fl) = (1._r8-alb_perroad_dir(fl,ib)) * sdir_road(fl,ib) + perroad_r_dir(fl) = alb_perroad_dir(fl,ib) * sdir_road(fl,ib) + perroad_r_sky_dir(fl) = perroad_r_dir(fl) * vf_sr(l) + perroad_r_sunwall_dir(fl) = perroad_r_dir(fl) * vf_wr(l) + perroad_r_shadewall_dir(fl) = perroad_r_dir(fl) * vf_wr(l) + road_a_dir(fl) = road_a_dir(fl) + perroad_a_dir(fl)*wtroad_perv(fl) + road_r_dir(fl) = road_r_dir(fl) + perroad_r_dir(fl)*wtroad_perv(fl) + end if + + road_r_sky_dir(fl) = road_r_dir(fl) * vf_sr(l) + road_r_sunwall_dir(fl) = road_r_dir(fl) * vf_wr(l) + road_r_shadewall_dir(fl) = road_r_dir(fl) * vf_wr(l) + + sunwall_a_dir(fl) = (1._r8-alb_wall_dir(fl,ib)) * sdir_sunwall(fl,ib) + sunwall_r_dir(fl) = alb_wall_dir(fl,ib) * sdir_sunwall(fl,ib) + sunwall_r_sky_dir(fl) = sunwall_r_dir(fl) * vf_sw(l) + sunwall_r_road_dir(fl) = sunwall_r_dir(fl) * vf_rw(l) + sunwall_r_shadewall_dir(fl) = sunwall_r_dir(fl) * vf_ww(l) + + shadewall_a_dir(fl) = (1._r8-alb_wall_dir(fl,ib)) * sdir_shadewall(fl,ib) + shadewall_r_dir(fl) = alb_wall_dir(fl,ib) * sdir_shadewall(fl,ib) + shadewall_r_sky_dir(fl) = shadewall_r_dir(fl) * vf_sw(l) + shadewall_r_road_dir(fl) = shadewall_r_dir(fl) * vf_rw(l) + shadewall_r_sunwall_dir(fl) = shadewall_r_dir(fl) * vf_ww(l) + + ! diffuse + + road_a_dif(fl) = 0.0_r8 + road_r_dif(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_a_dif(fl) = (1._r8-alb_improad_dif(fl,ib)) * sdif_road(fl,ib) + improad_r_dif(fl) = alb_improad_dif(fl,ib) * sdif_road(fl,ib) + improad_r_sky_dif(fl) = improad_r_dif(fl) * vf_sr(l) + improad_r_sunwall_dif(fl) = improad_r_dif(fl) * vf_wr(l) + improad_r_shadewall_dif(fl) = improad_r_dif(fl) * vf_wr(l) + road_a_dif(fl) = road_a_dif(fl) + improad_a_dif(fl)*wtroad_imperv(fl) + road_r_dif(fl) = road_r_dif(fl) + improad_r_dif(fl)*wtroad_imperv(fl) + end if + + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_a_dif(fl) = (1._r8-alb_perroad_dif(fl,ib)) * sdif_road(fl,ib) + perroad_r_dif(fl) = alb_perroad_dif(fl,ib) * sdif_road(fl,ib) + perroad_r_sky_dif(fl) = perroad_r_dif(fl) * vf_sr(l) + perroad_r_sunwall_dif(fl) = perroad_r_dif(fl) * vf_wr(l) + perroad_r_shadewall_dif(fl) = perroad_r_dif(fl) * vf_wr(l) + road_a_dif(fl) = road_a_dif(fl) + perroad_a_dif(fl)*wtroad_perv(fl) + road_r_dif(fl) = road_r_dif(fl) + perroad_r_dif(fl)*wtroad_perv(fl) + end if + + road_r_sky_dif(fl) = road_r_dif(fl) * vf_sr(l) + road_r_sunwall_dif(fl) = road_r_dif(fl) * vf_wr(l) + road_r_shadewall_dif(fl) = road_r_dif(fl) * vf_wr(l) + + sunwall_a_dif(fl) = (1._r8-alb_wall_dif(fl,ib)) * sdif_sunwall(fl,ib) + sunwall_r_dif(fl) = alb_wall_dif(fl,ib) * sdif_sunwall(fl,ib) + sunwall_r_sky_dif(fl) = sunwall_r_dif(fl) * vf_sw(l) + sunwall_r_road_dif(fl) = sunwall_r_dif(fl) * vf_rw(l) + sunwall_r_shadewall_dif(fl) = sunwall_r_dif(fl) * vf_ww(l) + + shadewall_a_dif(fl) = (1._r8-alb_wall_dif(fl,ib)) * sdif_shadewall(fl,ib) + shadewall_r_dif(fl) = alb_wall_dif(fl,ib) * sdif_shadewall(fl,ib) + shadewall_r_sky_dif(fl) = shadewall_r_dif(fl) * vf_sw(l) + shadewall_r_road_dif(fl) = shadewall_r_dif(fl) * vf_rw(l) + shadewall_r_sunwall_dif(fl) = shadewall_r_dif(fl) * vf_ww(l) + + ! initialize sum of direct and diffuse solar absorption and reflection for road and both walls + + if ( wtroad_imperv(fl) > 0.0_r8 ) sabs_improad_dir(l,ib) = improad_a_dir(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sabs_perroad_dir(l,ib) = perroad_a_dir(fl) + sabs_sunwall_dir(l,ib) = sunwall_a_dir(fl) + sabs_shadewall_dir(l,ib) = shadewall_a_dir(fl) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sabs_improad_dif(l,ib) = improad_a_dif(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sabs_perroad_dif(l,ib) = perroad_a_dif(fl) + sabs_sunwall_dif(l,ib) = sunwall_a_dif(fl) + sabs_shadewall_dif(l,ib) = shadewall_a_dif(fl) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sref_improad_dir(fl,ib) = improad_r_sky_dir(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sref_perroad_dir(fl,ib) = perroad_r_sky_dir(fl) + sref_sunwall_dir(fl,ib) = sunwall_r_sky_dir(fl) + sref_shadewall_dir(fl,ib) = shadewall_r_sky_dir(fl) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sref_improad_dif(fl,ib) = improad_r_sky_dif(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sref_perroad_dif(fl,ib) = perroad_r_sky_dif(fl) + sref_sunwall_dif(fl,ib) = sunwall_r_sky_dif(fl) + sref_shadewall_dif(fl,ib) = shadewall_r_sky_dif(fl) + endif + + end do + + ! absorption and reflection for walls and road with multiple reflections + ! (i.e., absorb and reflect initial reflection in canyon and allow for + ! subsequent scattering) + ! + ! (1) absorption and reflection of scattered solar radiation + ! road: reflected fluxes from walls need to be projected to ground area + ! wall: reflected flux from road needs to be projected to wall area + ! + ! (2) add absorbed radiation for ith reflection to total absorbed + ! + ! (3) distribute reflected radiation to sky, road, and walls according to view factors + ! + ! (4) add solar reflection to sky for ith reflection to total reflection + ! + ! (5) stop iteration when absorption for ith reflection is less than some nominal amount. + ! small convergence criteria is required to ensure solar radiation is conserved + ! + ! do separately for direct beam and diffuse + + do fl = 1,num_urbanl + if (coszen(fl) .gt. 0._r8) then + l = filter_urbanl(fl) + + ! reflected direct beam + + do iter_dir = 1, n + ! step (1) + + stot(fl) = (sunwall_r_road_dir(fl) + shadewall_r_road_dir(fl))*canyon_hwr(fl) + + road_a_dir(fl) = 0.0_r8 + road_r_dir(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_a_dir(fl) = (1._r8-alb_improad_dir(fl,ib)) * stot(fl) + improad_r_dir(fl) = alb_improad_dir(fl,ib) * stot(fl) + road_a_dir(fl) = road_a_dir(fl) + improad_a_dir(fl)*wtroad_imperv(fl) + road_r_dir(fl) = road_r_dir(fl) + improad_r_dir(fl)*wtroad_imperv(fl) + end if + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_a_dir(fl) = (1._r8-alb_perroad_dir(fl,ib)) * stot(fl) + perroad_r_dir(fl) = alb_perroad_dir(fl,ib) * stot(fl) + road_a_dir(fl) = road_a_dir(fl) + perroad_a_dir(fl)*wtroad_perv(fl) + road_r_dir(fl) = road_r_dir(fl) + perroad_r_dir(fl)*wtroad_perv(fl) + end if + + stot(fl) = road_r_sunwall_dir(fl)/canyon_hwr(fl) + shadewall_r_sunwall_dir(fl) + sunwall_a_dir(fl) = (1._r8-alb_wall_dir(fl,ib)) * stot(fl) + sunwall_r_dir(fl) = alb_wall_dir(fl,ib) * stot(fl) + + stot(fl) = road_r_shadewall_dir(fl)/canyon_hwr(fl) + sunwall_r_shadewall_dir(fl) + shadewall_a_dir(fl) = (1._r8-alb_wall_dir(fl,ib)) * stot(fl) + shadewall_r_dir(fl) = alb_wall_dir(fl,ib) * stot(fl) + + ! step (2) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sabs_improad_dir(l,ib) = sabs_improad_dir(l,ib) + improad_a_dir(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sabs_perroad_dir(l,ib) = sabs_perroad_dir(l,ib) + perroad_a_dir(fl) + sabs_sunwall_dir(l,ib) = sabs_sunwall_dir(l,ib) + sunwall_a_dir(fl) + sabs_shadewall_dir(l,ib) = sabs_shadewall_dir(l,ib) + shadewall_a_dir(fl) + + ! step (3) + + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_r_sky_dir(fl) = improad_r_dir(fl) * vf_sr(l) + improad_r_sunwall_dir(fl) = improad_r_dir(fl) * vf_wr(l) + improad_r_shadewall_dir(fl) = improad_r_dir(fl) * vf_wr(l) + end if + + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_r_sky_dir(fl) = perroad_r_dir(fl) * vf_sr(l) + perroad_r_sunwall_dir(fl) = perroad_r_dir(fl) * vf_wr(l) + perroad_r_shadewall_dir(fl) = perroad_r_dir(fl) * vf_wr(l) + end if + + road_r_sky_dir(fl) = road_r_dir(fl) * vf_sr(l) + road_r_sunwall_dir(fl) = road_r_dir(fl) * vf_wr(l) + road_r_shadewall_dir(fl) = road_r_dir(fl) * vf_wr(l) + + sunwall_r_sky_dir(fl) = sunwall_r_dir(fl) * vf_sw(l) + sunwall_r_road_dir(fl) = sunwall_r_dir(fl) * vf_rw(l) + sunwall_r_shadewall_dir(fl) = sunwall_r_dir(fl) * vf_ww(l) + + shadewall_r_sky_dir(fl) = shadewall_r_dir(fl) * vf_sw(l) + shadewall_r_road_dir(fl) = shadewall_r_dir(fl) * vf_rw(l) + shadewall_r_sunwall_dir(fl) = shadewall_r_dir(fl) * vf_ww(l) + + ! step (4) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sref_improad_dir(fl,ib) = sref_improad_dir(fl,ib) + improad_r_sky_dir(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sref_perroad_dir(fl,ib) = sref_perroad_dir(fl,ib) + perroad_r_sky_dir(fl) + sref_sunwall_dir(fl,ib) = sref_sunwall_dir(fl,ib) + sunwall_r_sky_dir(fl) + sref_shadewall_dir(fl,ib) = sref_shadewall_dir(fl,ib) + shadewall_r_sky_dir(fl) + + ! step (5) + + crit = max(road_a_dir(fl), sunwall_a_dir(fl), shadewall_a_dir(fl)) + if (crit < errcrit) exit + end do + if (iter_dir >= n) then + write (iulog,*) 'urban net solar radiation error: no convergence, direct beam' + write (iulog,*) 'clm model is stopping' + call endrun + endif + + ! reflected diffuse + + do iter_dif = 1, n + ! step (1) + + stot(fl) = (sunwall_r_road_dif(fl) + shadewall_r_road_dif(fl))*canyon_hwr(fl) + road_a_dif(fl) = 0.0_r8 + road_r_dif(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_a_dif(fl) = (1._r8-alb_improad_dif(fl,ib)) * stot(fl) + improad_r_dif(fl) = alb_improad_dif(fl,ib) * stot(fl) + road_a_dif(fl) = road_a_dif(fl) + improad_a_dif(fl)*wtroad_imperv(fl) + road_r_dif(fl) = road_r_dif(fl) + improad_r_dif(fl)*wtroad_imperv(fl) + end if + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_a_dif(fl) = (1._r8-alb_perroad_dif(fl,ib)) * stot(fl) + perroad_r_dif(fl) = alb_perroad_dif(fl,ib) * stot(fl) + road_a_dif(fl) = road_a_dif(fl) + perroad_a_dif(fl)*wtroad_perv(fl) + road_r_dif(fl) = road_r_dif(fl) + perroad_r_dif(fl)*wtroad_perv(fl) + end if + + stot(fl) = road_r_sunwall_dif(fl)/canyon_hwr(fl) + shadewall_r_sunwall_dif(fl) + sunwall_a_dif(fl) = (1._r8-alb_wall_dif(fl,ib)) * stot(fl) + sunwall_r_dif(fl) = alb_wall_dif(fl,ib) * stot(fl) + + stot(fl) = road_r_shadewall_dif(fl)/canyon_hwr(fl) + sunwall_r_shadewall_dif(fl) + shadewall_a_dif(fl) = (1._r8-alb_wall_dif(fl,ib)) * stot(fl) + shadewall_r_dif(fl) = alb_wall_dif(fl,ib) * stot(fl) + + ! step (2) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sabs_improad_dif(l,ib) = sabs_improad_dif(l,ib) + improad_a_dif(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sabs_perroad_dif(l,ib) = sabs_perroad_dif(l,ib) + perroad_a_dif(fl) + sabs_sunwall_dif(l,ib) = sabs_sunwall_dif(l,ib) + sunwall_a_dif(fl) + sabs_shadewall_dif(l,ib) = sabs_shadewall_dif(l,ib) + shadewall_a_dif(fl) + + ! step (3) + + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_r_sky_dif(fl) = improad_r_dif(fl) * vf_sr(l) + improad_r_sunwall_dif(fl) = improad_r_dif(fl) * vf_wr(l) + improad_r_shadewall_dif(fl) = improad_r_dif(fl) * vf_wr(l) + end if + + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_r_sky_dif(fl) = perroad_r_dif(fl) * vf_sr(l) + perroad_r_sunwall_dif(fl) = perroad_r_dif(fl) * vf_wr(l) + perroad_r_shadewall_dif(fl) = perroad_r_dif(fl) * vf_wr(l) + end if + + road_r_sky_dif(fl) = road_r_dif(fl) * vf_sr(l) + road_r_sunwall_dif(fl) = road_r_dif(fl) * vf_wr(l) + road_r_shadewall_dif(fl) = road_r_dif(fl) * vf_wr(l) + + sunwall_r_sky_dif(fl) = sunwall_r_dif(fl) * vf_sw(l) + sunwall_r_road_dif(fl) = sunwall_r_dif(fl) * vf_rw(l) + sunwall_r_shadewall_dif(fl) = sunwall_r_dif(fl) * vf_ww(l) + + shadewall_r_sky_dif(fl) = shadewall_r_dif(fl) * vf_sw(l) + shadewall_r_road_dif(fl) = shadewall_r_dif(fl) * vf_rw(l) + shadewall_r_sunwall_dif(fl) = shadewall_r_dif(fl) * vf_ww(l) + + ! step (4) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sref_improad_dif(fl,ib) = sref_improad_dif(fl,ib) + improad_r_sky_dif(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sref_perroad_dif(fl,ib) = sref_perroad_dif(fl,ib) + perroad_r_sky_dif(fl) + sref_sunwall_dif(fl,ib) = sref_sunwall_dif(fl,ib) + sunwall_r_sky_dif(fl) + sref_shadewall_dif(fl,ib) = sref_shadewall_dif(fl,ib) + shadewall_r_sky_dif(fl) + + ! step (5) + + crit = max(road_a_dif(fl), sunwall_a_dif(fl), shadewall_a_dif(fl)) + if (crit < errcrit) exit + end do + if (iter_dif >= n) then + write (iulog,*) 'urban net solar radiation error: no convergence, diffuse' + write (iulog,*) 'clm model is stopping' + call endrun() + endif + + ! total reflected by canyon - sum of solar reflection to sky from canyon. + ! project wall fluxes to horizontal surface + + sref_canyon_dir(fl) = 0.0_r8 + sref_canyon_dif(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + sref_canyon_dir(fl) = sref_canyon_dir(fl) + sref_improad_dir(fl,ib)*wtroad_imperv(fl) + sref_canyon_dif(fl) = sref_canyon_dif(fl) + sref_improad_dif(fl,ib)*wtroad_imperv(fl) + end if + if ( wtroad_perv(fl) > 0.0_r8 ) then + sref_canyon_dir(fl) = sref_canyon_dir(fl) + sref_perroad_dir(fl,ib)*wtroad_perv(fl) + sref_canyon_dif(fl) = sref_canyon_dif(fl) + sref_perroad_dif(fl,ib)*wtroad_perv(fl) + end if + sref_canyon_dir(fl) = sref_canyon_dir(fl) + (sref_sunwall_dir(fl,ib) + sref_shadewall_dir(fl,ib))*canyon_hwr(fl) + sref_canyon_dif(fl) = sref_canyon_dif(fl) + (sref_sunwall_dif(fl,ib) + sref_shadewall_dif(fl,ib))*canyon_hwr(fl) + + ! total absorbed by canyon. project wall fluxes to horizontal surface + + sabs_canyon_dir(fl) = 0.0_r8 + sabs_canyon_dif(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + sabs_canyon_dir(fl) = sabs_canyon_dir(fl) + sabs_improad_dir(l,ib)*wtroad_imperv(fl) + sabs_canyon_dif(fl) = sabs_canyon_dif(fl) + sabs_improad_dif(l,ib)*wtroad_imperv(fl) + end if + if ( wtroad_perv(fl) > 0.0_r8 ) then + sabs_canyon_dir(fl) = sabs_canyon_dir(fl) + sabs_perroad_dir(l,ib)*wtroad_perv(fl) + sabs_canyon_dif(fl) = sabs_canyon_dif(fl) + sabs_perroad_dif(l,ib)*wtroad_perv(fl) + end if + sabs_canyon_dir(fl) = sabs_canyon_dir(fl) + (sabs_sunwall_dir(l,ib) + sabs_shadewall_dir(l,ib))*canyon_hwr(fl) + sabs_canyon_dif(fl) = sabs_canyon_dif(fl) + (sabs_sunwall_dif(l,ib) + sabs_shadewall_dif(l,ib))*canyon_hwr(fl) + + ! conservation check. note: previous conservation checks confirm partioning of total direct + ! beam and diffuse radiation from atmosphere to road and walls is conserved as + ! sdir (from atmosphere) = sdir_road + (sdir_sunwall + sdir_shadewall)*canyon_hwr + ! sdif (from atmosphere) = sdif_road + (sdif_sunwall + sdif_shadewall)*canyon_hwr + + stot_dir(fl) = sdir_road(fl,ib) + (sdir_sunwall(fl,ib) + sdir_shadewall(fl,ib))*canyon_hwr(fl) + stot_dif(fl) = sdif_road(fl,ib) + (sdif_sunwall(fl,ib) + sdif_shadewall(fl,ib))*canyon_hwr(fl) + + err = stot_dir(fl) + stot_dif(fl) & + - (sabs_canyon_dir(fl) + sabs_canyon_dif(fl) + sref_canyon_dir(fl) + sref_canyon_dif(fl)) + if (abs(err) > 0.001_r8 ) then + write(iulog,*)'urban net solar radiation balance error for ib=',ib,' err= ',err + write(iulog,*)' l= ',l,' ib= ',ib + write(iulog,*)' stot_dir = ',stot_dir(fl) + write(iulog,*)' stot_dif = ',stot_dif(fl) + write(iulog,*)' sabs_canyon_dir = ',sabs_canyon_dir(fl) + write(iulog,*)' sabs_canyon_dif = ',sabs_canyon_dif(fl) + write(iulog,*)' sref_canyon_dir = ',sref_canyon_dir(fl) + write(iulog,*)' sref_canyon_dif = ',sref_canyon_dir(fl) + write(iulog,*) 'clm model is stopping' + call endrun() + endif + + ! canyon albedo + + canyon_alb_dif(fl) = sref_canyon_dif(fl) / max(stot_dif(fl), 1.e-06_r8) + canyon_alb_dir(fl) = sref_canyon_dir(fl) / max(stot_dir(fl), 1.e-06_r8) + end if + + end do ! end of landunit loop + + ! Refected and absorbed solar radiation per unit incident radiation for roof + + do fl = 1,num_urbanl + if (coszen(fl) .gt. 0._r8) then + l = filter_urbanl(fl) + sref_roof_dir(fl,ib) = alb_roof_dir(fl,ib) * sdir(fl,ib) + sref_roof_dif(fl,ib) = alb_roof_dif(fl,ib) * sdif(fl,ib) + sabs_roof_dir(l,ib) = sdir(fl,ib) - sref_roof_dir(fl,ib) + sabs_roof_dif(l,ib) = sdif(fl,ib) - sref_roof_dif(fl,ib) + end if + end do + + end do ! end of radiation band loop + + end subroutine net_solar + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: net_longwave +! +! !INTERFACE: + subroutine net_longwave (lbl, ubl, num_urbanl, filter_urbanl, canyon_hwr, wtroad_perv, & + lwdown, em_roof, em_improad, em_perroad, em_wall, & + t_roof, t_improad, t_perroad, t_sunwall, t_shadewall, & + lwnet_roof, lwnet_improad, lwnet_perroad, lwnet_sunwall, lwnet_shadewall, lwnet_canyon, & + lwup_roof, lwup_improad, lwup_perroad, lwup_sunwall, lwup_shadewall, lwup_canyon) +! +! !DESCRIPTION: +! Net longwave radiation for road and both walls in urban canyon allowing for +! multiple reflection. Also net longwave radiation for urban roof. +! +! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_varcon , only : sb + use clmtype +! +! !ARGUMENTS: + implicit none + integer , intent(in) :: num_urbanl ! number of urban landunits + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + real(r8), intent(in) :: canyon_hwr(num_urbanl) ! ratio of building height to street width + real(r8), intent(in) :: wtroad_perv(num_urbanl) ! weight of pervious road wrt total road + + real(r8), intent(in) :: lwdown(num_urbanl) ! atmospheric longwave radiation (W/m**2) + real(r8), intent(in) :: em_roof(num_urbanl) ! roof emissivity + real(r8), intent(in) :: em_improad(num_urbanl) ! impervious road emissivity + real(r8), intent(in) :: em_perroad(num_urbanl) ! pervious road emissivity + real(r8), intent(in) :: em_wall(num_urbanl) ! wall emissivity + + real(r8), intent(in) :: t_roof(num_urbanl) ! roof temperature (K) + real(r8), intent(in) :: t_improad(num_urbanl) ! impervious road temperature (K) + real(r8), intent(in) :: t_perroad(num_urbanl) ! ervious road temperature (K) + real(r8), intent(in) :: t_sunwall(num_urbanl) ! sunlit wall temperature (K) + real(r8), intent(in) :: t_shadewall(num_urbanl) ! shaded wall temperature (K) + + real(r8), intent(out) :: lwnet_roof(num_urbanl) ! net (outgoing-incoming) longwave radiation, roof (W/m**2) + real(r8), intent(out) :: lwnet_improad(num_urbanl) ! net (outgoing-incoming) longwave radiation, impervious road (W/m**2) + real(r8), intent(out) :: lwnet_perroad(num_urbanl) ! net (outgoing-incoming) longwave radiation, pervious road (W/m**2) + real(r8), intent(out) :: lwnet_sunwall(num_urbanl) ! net (outgoing-incoming) longwave radiation (per unit wall area), sunlit wall (W/m**2) + real(r8), intent(out) :: lwnet_shadewall(num_urbanl) ! net (outgoing-incoming) longwave radiation (per unit wall area), shaded wall (W/m**2) + real(r8), intent(out) :: lwnet_canyon(num_urbanl) ! net (outgoing-incoming) longwave radiation for canyon, per unit ground area (W/m**2) + + real(r8), intent(out) :: lwup_roof(num_urbanl) ! upward longwave radiation, roof (W/m**2) + real(r8), intent(out) :: lwup_improad(num_urbanl) ! upward longwave radiation, impervious road (W/m**2) + real(r8), intent(out) :: lwup_perroad(num_urbanl) ! upward longwave radiation, pervious road (W/m**2) + real(r8), intent(out) :: lwup_sunwall(num_urbanl) ! upward longwave radiation (per unit wall area), sunlit wall (W/m**2) + real(r8), intent(out) :: lwup_shadewall(num_urbanl) ! upward longwave radiation (per unit wall area), shaded wall (W/m**2) + real(r8), intent(out) :: lwup_canyon(num_urbanl) ! upward longwave radiation for canyon, per unit ground area (W/m**2) +! +! local pointers to original implicit in arguments (clmtype) +! + real(r8), pointer :: vf_sr(:) ! view factor of sky for road + real(r8), pointer :: vf_wr(:) ! view factor of one wall for road + real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall + real(r8), pointer :: vf_rw(:) ! view factor of road for one wall + real(r8), pointer :: vf_ww(:) ! view factor of opposing wall for one wall +! +! !CALLED FROM: +! subroutine UrbanRadiation in this module +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! +! +! !LOCAL VARIABLES: +!EOP + real(r8) :: lwdown_road(num_urbanl) ! atmospheric longwave radiation for total road (W/m**2) + real(r8) :: lwdown_sunwall(num_urbanl) ! atmospheric longwave radiation (per unit wall area) for sunlit wall (W/m**2) + real(r8) :: lwdown_shadewall(num_urbanl) ! atmospheric longwave radiation (per unit wall area) for shaded wall (W/m**2) + real(r8) :: lwtot(num_urbanl) ! incoming longwave radiation (W/m**2) + + real(r8) :: improad_a(num_urbanl) ! absorbed longwave for improad (W/m**2) + real(r8) :: improad_r(num_urbanl) ! reflected longwave for improad (W/m**2) + real(r8) :: improad_r_sky(num_urbanl) ! improad_r to sky (W/m**2) + real(r8) :: improad_r_sunwall(num_urbanl) ! improad_r to sunlit wall (W/m**2) + real(r8) :: improad_r_shadewall(num_urbanl) ! improad_r to shaded wall (W/m**2) + real(r8) :: improad_e(num_urbanl) ! emitted longwave for improad (W/m**2) + real(r8) :: improad_e_sky(num_urbanl) ! improad_e to sky (W/m**2) + real(r8) :: improad_e_sunwall(num_urbanl) ! improad_e to sunlit wall (W/m**2) + real(r8) :: improad_e_shadewall(num_urbanl) ! improad_e to shaded wall (W/m**2) + + real(r8) :: perroad_a(num_urbanl) ! absorbed longwave for perroad (W/m**2) + real(r8) :: perroad_r(num_urbanl) ! reflected longwave for perroad (W/m**2) + real(r8) :: perroad_r_sky(num_urbanl) ! perroad_r to sky (W/m**2) + real(r8) :: perroad_r_sunwall(num_urbanl) ! perroad_r to sunlit wall (W/m**2) + real(r8) :: perroad_r_shadewall(num_urbanl) ! perroad_r to shaded wall (W/m**2) + real(r8) :: perroad_e(num_urbanl) ! emitted longwave for perroad (W/m**2) + real(r8) :: perroad_e_sky(num_urbanl) ! perroad_e to sky (W/m**2) + real(r8) :: perroad_e_sunwall(num_urbanl) ! perroad_e to sunlit wall (W/m**2) + real(r8) :: perroad_e_shadewall(num_urbanl) ! perroad_e to shaded wall (W/m**2) + + real(r8) :: road_a(num_urbanl) ! absorbed longwave for total road (W/m**2) + real(r8) :: road_r(num_urbanl) ! reflected longwave for total road (W/m**2) + real(r8) :: road_r_sky(num_urbanl) ! total road_r to sky (W/m**2) + real(r8) :: road_r_sunwall(num_urbanl) ! total road_r to sunlit wall (W/m**2) + real(r8) :: road_r_shadewall(num_urbanl) ! total road_r to shaded wall (W/m**2) + real(r8) :: road_e(num_urbanl) ! emitted longwave for total road (W/m**2) + real(r8) :: road_e_sky(num_urbanl) ! total road_e to sky (W/m**2) + real(r8) :: road_e_sunwall(num_urbanl) ! total road_e to sunlit wall (W/m**2) + real(r8) :: road_e_shadewall(num_urbanl) ! total road_e to shaded wall (W/m**2) + + real(r8) :: sunwall_a(num_urbanl) ! absorbed longwave (per unit wall area) for sunlit wall (W/m**2) + real(r8) :: sunwall_r(num_urbanl) ! reflected longwave (per unit wall area) for sunlit wall (W/m**2) + real(r8) :: sunwall_r_sky(num_urbanl) ! sunwall_r to sky (W/m**2) + real(r8) :: sunwall_r_road(num_urbanl) ! sunwall_r to road (W/m**2) + real(r8) :: sunwall_r_shadewall(num_urbanl) ! sunwall_r to opposing (shaded) wall (W/m**2) + real(r8) :: sunwall_e(num_urbanl) ! emitted longwave (per unit wall area) for sunlit wall (W/m**2) + real(r8) :: sunwall_e_sky(num_urbanl) ! sunwall_e to sky (W/m**2) + real(r8) :: sunwall_e_road(num_urbanl) ! sunwall_e to road (W/m**2) + real(r8) :: sunwall_e_shadewall(num_urbanl) ! sunwall_e to opposing (shaded) wall (W/m**2) + + real(r8) :: shadewall_a(num_urbanl) ! absorbed longwave (per unit wall area) for shaded wall (W/m**2) + real(r8) :: shadewall_r(num_urbanl) ! reflected longwave (per unit wall area) for shaded wall (W/m**2) + real(r8) :: shadewall_r_sky(num_urbanl) ! shadewall_r to sky (W/m**2) + real(r8) :: shadewall_r_road(num_urbanl) ! shadewall_r to road (W/m**2) + real(r8) :: shadewall_r_sunwall(num_urbanl) ! shadewall_r to opposing (sunlit) wall (W/m**2) + real(r8) :: shadewall_e(num_urbanl) ! emitted longwave (per unit wall area) for shaded wall (W/m**2) + real(r8) :: shadewall_e_sky(num_urbanl) ! shadewall_e to sky (W/m**2) + real(r8) :: shadewall_e_road(num_urbanl) ! shadewall_e to road (W/m**2) + real(r8) :: shadewall_e_sunwall(num_urbanl) ! shadewall_e to opposing (sunlit) wall (W/m**2) + integer :: l,fl,iter ! indices + integer, parameter :: n = 50 ! number of interations + real(r8) :: crit ! convergence criterion (W/m**2) + real(r8) :: err ! energy conservation error (W/m**2) + real(r8) :: wtroad_imperv(num_urbanl) ! weight of impervious road wrt total road +!----------------------------------------------------------------------- + + ! Assign landunit level pointer + + vf_sr => lps%vf_sr + vf_wr => lps%vf_wr + vf_sw => lps%vf_sw + vf_rw => lps%vf_rw + vf_ww => lps%vf_ww + + ! Calculate impervious road + + do l = 1,num_urbanl + wtroad_imperv(l) = 1._r8 - wtroad_perv(l) + end do + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + ! atmospheric longwave radiation incident on walls and road in urban canyon. + ! check for conservation (need to convert wall fluxes to ground area). + ! lwdown (from atmosphere) = lwdown_road + (lwdown_sunwall + lwdown_shadewall)*canyon_hwr + + lwdown_road(fl) = lwdown(fl) * vf_sr(l) + lwdown_sunwall(fl) = lwdown(fl) * vf_sw(l) + lwdown_shadewall(fl) = lwdown(fl) * vf_sw(l) + + err = lwdown(fl) - (lwdown_road(fl) + (lwdown_shadewall(fl) + lwdown_sunwall(fl))*canyon_hwr(fl)) + if (abs(err) > 0.10_r8 ) then + write (iulog,*) 'urban incident atmospheric longwave radiation balance error',err + write (iulog,*) 'clm model is stopping' + call endrun + endif + end do + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + + ! initial absorption, reflection, and emission for road and both walls. + ! distribute reflected and emitted radiation to sky, road, and walls according + ! to appropriate view factor. radiation reflected to road and walls will + ! undergo multiple reflections within the canyon. + + road_a(fl) = 0.0_r8 + road_r(fl) = 0.0_r8 + road_e(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_a(fl) = em_improad(fl) * lwdown_road(fl) + improad_r(fl) = (1._r8-em_improad(fl)) * lwdown_road(fl) + improad_r_sky(fl) = improad_r(fl) * vf_sr(l) + improad_r_sunwall(fl) = improad_r(fl) * vf_wr(l) + improad_r_shadewall(fl) = improad_r(fl) * vf_wr(l) + improad_e(fl) = em_improad(fl) * sb * (t_improad(fl)**4) + improad_e_sky(fl) = improad_e(fl) * vf_sr(l) + improad_e_sunwall(fl) = improad_e(fl) * vf_wr(l) + improad_e_shadewall(fl) = improad_e(fl) * vf_wr(l) + road_a(fl) = road_a(fl) + improad_a(fl)*wtroad_imperv(fl) + road_r(fl) = road_r(fl) + improad_r(fl)*wtroad_imperv(fl) + road_e(fl) = road_e(fl) + improad_e(fl)*wtroad_imperv(fl) + end if + + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_a(fl) = em_perroad(fl) * lwdown_road(fl) + perroad_r(fl) = (1._r8-em_perroad(fl)) * lwdown_road(fl) + perroad_r_sky(fl) = perroad_r(fl) * vf_sr(l) + perroad_r_sunwall(fl) = perroad_r(fl) * vf_wr(l) + perroad_r_shadewall(fl) = perroad_r(fl) * vf_wr(l) + perroad_e(fl) = em_perroad(fl) * sb * (t_perroad(fl)**4) + perroad_e_sky(fl) = perroad_e(fl) * vf_sr(l) + perroad_e_sunwall(fl) = perroad_e(fl) * vf_wr(l) + perroad_e_shadewall(fl) = perroad_e(fl) * vf_wr(l) + road_a(fl) = road_a(fl) + perroad_a(fl)*wtroad_perv(fl) + road_r(fl) = road_r(fl) + perroad_r(fl)*wtroad_perv(fl) + road_e(fl) = road_e(fl) + perroad_e(fl)*wtroad_perv(fl) + end if + + road_r_sky(fl) = road_r(fl) * vf_sr(l) + road_r_sunwall(fl) = road_r(fl) * vf_wr(l) + road_r_shadewall(fl) = road_r(fl) * vf_wr(l) + road_e_sky(fl) = road_e(fl) * vf_sr(l) + road_e_sunwall(fl) = road_e(fl) * vf_wr(l) + road_e_shadewall(fl) = road_e(fl) * vf_wr(l) + + sunwall_a(fl) = em_wall(fl) * lwdown_sunwall(fl) + sunwall_r(fl) = (1._r8-em_wall(fl)) * lwdown_sunwall(fl) + sunwall_r_sky(fl) = sunwall_r(fl) * vf_sw(l) + sunwall_r_road(fl) = sunwall_r(fl) * vf_rw(l) + sunwall_r_shadewall(fl) = sunwall_r(fl) * vf_ww(l) + sunwall_e(fl) = em_wall(fl) * sb * (t_sunwall(fl)**4) + sunwall_e_sky(fl) = sunwall_e(fl) * vf_sw(l) + sunwall_e_road(fl) = sunwall_e(fl) * vf_rw(l) + sunwall_e_shadewall(fl) = sunwall_e(fl) * vf_ww(l) + + shadewall_a(fl) = em_wall(fl) * lwdown_shadewall(fl) + shadewall_r(fl) = (1._r8-em_wall(fl)) * lwdown_shadewall(fl) + shadewall_r_sky(fl) = shadewall_r(fl) * vf_sw(l) + shadewall_r_road(fl) = shadewall_r(fl) * vf_rw(l) + shadewall_r_sunwall(fl) = shadewall_r(fl) * vf_ww(l) + shadewall_e(fl) = em_wall(fl) * sb * (t_shadewall(fl)**4) + shadewall_e_sky(fl) = shadewall_e(fl) * vf_sw(l) + shadewall_e_road(fl) = shadewall_e(fl) * vf_rw(l) + shadewall_e_sunwall(fl) = shadewall_e(fl) * vf_ww(l) + + ! initialize sum of net and upward longwave radiation for road and both walls + + if ( wtroad_imperv(fl) > 0.0_r8 ) lwnet_improad(fl) = improad_e(fl) - improad_a(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) lwnet_perroad(fl) = perroad_e(fl) - perroad_a(fl) + lwnet_sunwall(fl) = sunwall_e(fl) - sunwall_a(fl) + lwnet_shadewall(fl) = shadewall_e(fl) - shadewall_a(fl) + + if ( wtroad_imperv(fl) > 0.0_r8 ) lwup_improad(fl) = improad_r_sky(fl) + improad_e_sky(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) lwup_perroad(fl) = perroad_r_sky(fl) + perroad_e_sky(fl) + lwup_sunwall(fl) = sunwall_r_sky(fl) + sunwall_e_sky(fl) + lwup_shadewall(fl) = shadewall_r_sky(fl) + shadewall_e_sky(fl) + + end do + + ! now account for absorption and reflection within canyon of fluxes from road and walls + ! allowing for multiple reflections + ! + ! (1) absorption and reflection. note: emission from road and walls absorbed by walls and roads + ! only occurs in first iteration. zero out for later iterations. + ! + ! road: fluxes from walls need to be projected to ground area + ! wall: fluxes from road need to be projected to wall area + ! + ! (2) add net longwave for ith reflection to total net longwave + ! + ! (3) distribute reflected radiation to sky, road, and walls according to view factors + ! + ! (4) add upward longwave radiation to sky from road and walls for ith reflection to total + ! + ! (5) stop iteration when absorption for ith reflection is less than some nominal amount. + ! small convergence criteria is required to ensure radiation is conserved + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + + do iter = 1, n + ! step (1) + + lwtot(fl) = (sunwall_r_road(fl) + sunwall_e_road(fl) & + + shadewall_r_road(fl) + shadewall_e_road(fl))*canyon_hwr(fl) + road_a(fl) = 0.0_r8 + road_r(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_r(fl) = (1._r8-em_improad(fl)) * lwtot(fl) + improad_a(fl) = em_improad(fl) * lwtot(fl) + road_a(fl) = road_a(fl) + improad_a(fl)*wtroad_imperv(fl) + road_r(fl) = road_r(fl) + improad_r(fl)*wtroad_imperv(fl) + end if + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_r(fl) = (1._r8-em_perroad(fl)) * lwtot(fl) + perroad_a(fl) = em_perroad(fl) * lwtot(fl) + road_a(fl) = road_a(fl) + perroad_a(fl)*wtroad_perv(fl) + road_r(fl) = road_r(fl) + perroad_r(fl)*wtroad_perv(fl) + end if + + lwtot(fl) = (road_r_sunwall(fl) + road_e_sunwall(fl))/canyon_hwr(fl) & + + (shadewall_r_sunwall(fl) + shadewall_e_sunwall(fl)) + sunwall_a(fl) = em_wall(fl) * lwtot(fl) + sunwall_r(fl) = (1._r8-em_wall(fl)) * lwtot(fl) + + lwtot(fl) = (road_r_shadewall(fl) + road_e_shadewall(fl))/canyon_hwr(fl) & + + (sunwall_r_shadewall(fl) + sunwall_e_shadewall(fl)) + shadewall_a(fl) = em_wall(fl) * lwtot(fl) + shadewall_r(fl) = (1._r8-em_wall(fl)) * lwtot(fl) + + sunwall_e_road(fl) = 0._r8 + shadewall_e_road(fl) = 0._r8 + road_e_sunwall(fl) = 0._r8 + shadewall_e_sunwall(fl) = 0._r8 + road_e_shadewall(fl) = 0._r8 + sunwall_e_shadewall(fl) = 0._r8 + + ! step (2) + + if ( wtroad_imperv(fl) > 0.0_r8 ) lwnet_improad(fl) = lwnet_improad(fl) - improad_a(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) lwnet_perroad(fl) = lwnet_perroad(fl) - perroad_a(fl) + lwnet_sunwall(fl) = lwnet_sunwall(fl) - sunwall_a(fl) + lwnet_shadewall(fl) = lwnet_shadewall(fl) - shadewall_a(fl) + + ! step (3) + + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_r_sky(fl) = improad_r(fl) * vf_sr(l) + improad_r_sunwall(fl) = improad_r(fl) * vf_wr(l) + improad_r_shadewall(fl) = improad_r(fl) * vf_wr(l) + end if + + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_r_sky(fl) = perroad_r(fl) * vf_sr(l) + perroad_r_sunwall(fl) = perroad_r(fl) * vf_wr(l) + perroad_r_shadewall(fl) = perroad_r(fl) * vf_wr(l) + end if + + road_r_sky(fl) = road_r(fl) * vf_sr(l) + road_r_sunwall(fl) = road_r(fl) * vf_wr(l) + road_r_shadewall(fl) = road_r(fl) * vf_wr(l) + + sunwall_r_sky(fl) = sunwall_r(fl) * vf_sw(l) + sunwall_r_road(fl) = sunwall_r(fl) * vf_rw(l) + sunwall_r_shadewall(fl) = sunwall_r(fl) * vf_ww(l) + + shadewall_r_sky(fl) = shadewall_r(fl) * vf_sw(l) + shadewall_r_road(fl) = shadewall_r(fl) * vf_rw(l) + shadewall_r_sunwall(fl) = shadewall_r(fl) * vf_ww(l) + + ! step (4) + + if ( wtroad_imperv(fl) > 0.0_r8 ) lwup_improad(fl) = lwup_improad(fl) + improad_r_sky(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) lwup_perroad(fl) = lwup_perroad(fl) + perroad_r_sky(fl) + lwup_sunwall(fl) = lwup_sunwall(fl) + sunwall_r_sky(fl) + lwup_shadewall(fl) = lwup_shadewall(fl) + shadewall_r_sky(fl) + + ! step (5) + + crit = max(road_a(fl), sunwall_a(fl), shadewall_a(fl)) + if (crit < .001_r8) exit + end do + if (iter >= n) then + write (iulog,*) 'urban net longwave radiation error: no convergence' + write (iulog,*) 'crit is ',crit,' should be < 0.001' + write (iulog,*) 'road_a(fl) is ',road_a(fl) + write (iulog,*) 'sunwall_a(fl) is ',sunwall_a(fl) + write (iulog,*) 'shadewall_a(fl) is ',shadewall_a(fl) + write (iulog,*) 'lwtot(fl) is ',lwtot(fl) + write (iulog,*) 'clm model is stopping' + call endrun + endif + + ! total net longwave radiation for canyon. project wall fluxes to horizontal surface + + lwnet_canyon(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) lwnet_canyon(fl) = lwnet_canyon(fl) + lwnet_improad(fl)*wtroad_imperv(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) lwnet_canyon(fl) = lwnet_canyon(fl) + lwnet_perroad(fl)*wtroad_perv(fl) + lwnet_canyon(fl) = lwnet_canyon(fl) + (lwnet_sunwall(fl) + lwnet_shadewall(fl))*canyon_hwr(fl) + + ! total emitted longwave for canyon. project wall fluxes to horizontal + + lwup_canyon(fl) = 0.0_r8 + if( wtroad_imperv(fl) > 0.0_r8 ) lwup_canyon(fl) = lwup_canyon(fl) + lwup_improad(fl)*wtroad_imperv(fl) + if( wtroad_perv(fl) > 0.0_r8 ) lwup_canyon(fl) = lwup_canyon(fl) + lwup_perroad(fl)*wtroad_perv(fl) + lwup_canyon(fl) = lwup_canyon(fl) + (lwup_sunwall(fl) + lwup_shadewall(fl))*canyon_hwr(fl) + + ! conservation check. note: previous conservation check confirms partioning of incident + ! atmospheric longwave radiation to road and walls is conserved as + ! lwdown (from atmosphere) = lwdown_improad + lwdown_perroad + (lwdown_sunwall + lwdown_shadewall)*canyon_hwr + + err = lwnet_canyon(fl) - (lwup_canyon(fl) - lwdown(fl)) + if (abs(err) > .10_r8 ) then + write (iulog,*) 'urban net longwave radiation balance error',err + write (iulog,*) 'clm model is stopping' + call endrun() + end if + + end do + + ! Net longwave radiation for roof + + do l = 1,num_urbanl + lwup_roof(l) = em_roof(l)*sb*(t_roof(l)**4) + (1._r8-em_roof(l))*lwdown(l) + lwnet_roof(l) = lwup_roof(l) - lwdown(l) + end do + + end subroutine net_longwave + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: UrbanClumpInit +! +! !INTERFACE: + subroutine UrbanClumpInit() +! +! !DESCRIPTION: +! Initialize urban radiation module +! +! !USES: + use clmtype + use clm_varcon , only : spval, icol_roof, icol_sunwall, icol_shadewall, & + icol_road_perv, icol_road_imperv + use decompMod , only : get_proc_clumps, ldecomp + use filterMod , only : filter + use UrbanInputMod, only : urbinp +! +! !ARGUMENTS: + implicit none +! +! !CALLED FROM: +! subroutine initialize +! +! !REVISION HISTORY: +! Author: Mariana Vertenstein 04/2003 +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in arguments +! + integer , pointer :: coli(:) ! beginning column index for landunit + integer , pointer :: colf(:) ! ending column index for landunit + integer , pointer :: lgridcell(:) ! gridcell of corresponding landunit + integer , pointer :: ctype(:) ! column type +! +! +! !OTHER LOCAL VARIABLES +!EOP +! + integer :: nc,fl,ib,l,c,p,g ! indices + integer :: nclumps ! number of clumps on processor + integer :: num_urbanl ! number of per-clump urban landunits + integer :: ier ! error status +!----------------------------------------------------------------------- + + ! Assign local pointers to derived type members (landunit-level) + + coli => lun%coli + colf => lun%colf + lgridcell => lun%gridcell + + ! Assign local pointers to derived type members (column-level) + + ctype => col%itype + + ! Allocate memory + + nclumps = get_proc_clumps() + allocate(urban_clump(nclumps), stat=ier) + if (ier /= 0) then + write (iulog,*) 'UrbanInit: allocation error for urban clumps'; call endrun() + end if + + ! Loop over all clumps on this processor + + do nc = 1, nclumps + + ! Determine number of unrban landunits in clump + + num_urbanl = filter(nc)%num_urbanl + + ! Consistency check for urban columns + + do fl = 1,num_urbanl + l = filter(nc)%urbanl(fl) + do c = coli(l),colf(l) + if ( ctype(c) /= icol_roof .and. & + ctype(c) /= icol_sunwall .and. ctype(c) /= icol_shadewall .and. & + ctype(c) /= icol_road_perv .and. ctype(c) /= icol_road_imperv) then + write(iulog,*)'error in urban column types for landunit = ',l + write(iulog,*)'ctype= ',ctype(c) + call endrun() + endif + end do + end do + + ! Allocate memory for urban clump clumponents + + if (num_urbanl > 0) then + allocate( urban_clump(nc)%canyon_hwr (num_urbanl), & + urban_clump(nc)%wtroad_perv (num_urbanl), & + urban_clump(nc)%ht_roof (num_urbanl), & + urban_clump(nc)%wtlunit_roof (num_urbanl), & + urban_clump(nc)%wind_hgt_canyon (num_urbanl), & + urban_clump(nc)%em_roof (num_urbanl), & + urban_clump(nc)%em_improad (num_urbanl), & + urban_clump(nc)%em_perroad (num_urbanl), & + urban_clump(nc)%em_wall (num_urbanl), & + urban_clump(nc)%alb_roof_dir (num_urbanl,numrad), & + urban_clump(nc)%alb_roof_dif (num_urbanl,numrad), & + urban_clump(nc)%alb_improad_dir (num_urbanl,numrad), & + urban_clump(nc)%alb_perroad_dir (num_urbanl,numrad), & + urban_clump(nc)%alb_improad_dif (num_urbanl,numrad), & + urban_clump(nc)%alb_perroad_dif (num_urbanl,numrad), & + urban_clump(nc)%alb_wall_dir (num_urbanl,numrad), & + urban_clump(nc)%alb_wall_dif (num_urbanl,numrad), stat=ier ) + if (ier /= 0) then + write(iulog,*)'UrbanRadInit: allocation error for urban derived type'; call endrun() + endif + end if + + ! Set constants in derived type values for urban clump + + do fl = 1,num_urbanl + l = filter(nc)%urbanl(fl) + g = lun%gridcell(l) + urban_clump(nc)%canyon_hwr (fl) = urbinp%canyon_hwr (g) + urban_clump(nc)%wtroad_perv (fl) = urbinp%wtroad_perv (g) + urban_clump(nc)%ht_roof (fl) = urbinp%ht_roof (g) + urban_clump(nc)%wtlunit_roof (fl) = urbinp%wtlunit_roof (g) + urban_clump(nc)%wind_hgt_canyon(fl) = urbinp%wind_hgt_canyon(g) + do ib = 1,numrad + urban_clump(nc)%alb_roof_dir (fl,ib) = urbinp%alb_roof_dir (g,ib) + urban_clump(nc)%alb_roof_dif (fl,ib) = urbinp%alb_roof_dif (g,ib) + urban_clump(nc)%alb_improad_dir(fl,ib) = urbinp%alb_improad_dir(g,ib) + urban_clump(nc)%alb_perroad_dir(fl,ib) = urbinp%alb_perroad_dir(g,ib) + urban_clump(nc)%alb_improad_dif(fl,ib) = urbinp%alb_improad_dif(g,ib) + urban_clump(nc)%alb_perroad_dif(fl,ib) = urbinp%alb_perroad_dif(g,ib) + urban_clump(nc)%alb_wall_dir (fl,ib) = urbinp%alb_wall_dir (g,ib) + urban_clump(nc)%alb_wall_dif (fl,ib) = urbinp%alb_wall_dif (g,ib) + end do + urban_clump(nc)%em_roof (fl) = urbinp%em_roof (g) + urban_clump(nc)%em_improad(fl) = urbinp%em_improad(g) + urban_clump(nc)%em_perroad(fl) = urbinp%em_perroad(g) + urban_clump(nc)%em_wall (fl) = urbinp%em_wall (g) +! write(iulog,*)'g: ',g +! write(iulog,*)'l: ',l +! write(iulog,*)'fl: ',fl +! write(iulog,*)'urban_clump(nc)%canyon_hwr: ',urban_clump(nc)%canyon_hwr(fl) +! write(iulog,*)'urban_clump(nc)%wtroad_perv: ',urban_clump(nc)%wtroad_perv(fl) +! write(iulog,*)'urban_clump(nc)%ht_roof: ',urban_clump(nc)%ht_roof(fl) +! write(iulog,*)'urban_clump(nc)%wtlunit_roof: ',urban_clump(nc)%wtlunit_roof(fl) +! write(iulog,*)'urban_clump(nc)%wind_hgt_canyon: ',urban_clump(nc)%wind_hgt_canyon(fl) +! write(iulog,*)'urban_clump(nc)%alb_roof_dir: ',urban_clump(nc)%alb_roof_dir(fl,:) +! write(iulog,*)'urban_clump(nc)%alb_roof_dif: ',urban_clump(nc)%alb_roof_dif(fl,:) +! write(iulog,*)'urban_clump(nc)%alb_improad_dir: ',urban_clump(nc)%alb_improad_dir(fl,:) +! write(iulog,*)'urban_clump(nc)%alb_improad_dif: ',urban_clump(nc)%alb_improad_dif(fl,:) +! write(iulog,*)'urban_clump(nc)%alb_perroad_dir: ',urban_clump(nc)%alb_perroad_dir(fl,:) +! write(iulog,*)'urban_clump(nc)%alb_perroad_dif: ',urban_clump(nc)%alb_perroad_dif(fl,:) +! write(iulog,*)'urban_clump(nc)%alb_wall_dir: ',urban_clump(nc)%alb_wall_dir(fl,:) +! write(iulog,*)'urban_clump(nc)%alb_wall_dif: ',urban_clump(nc)%alb_wall_dif(fl,:) +! write(iulog,*)'urban_clump(nc)%em_roof: ',urban_clump(nc)%em_roof(fl) +! write(iulog,*)'urban_clump(nc)%em_improad: ',urban_clump(nc)%em_improad(fl) +! write(iulog,*)'urban_clump(nc)%em_perroad: ',urban_clump(nc)%em_perroad(fl) +! write(iulog,*)'urban_clump(nc)%em_wall: ',urban_clump(nc)%em_wall(fl) + end do + end do ! end of loop over clumps + + end subroutine UrbanClumpInit + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: UrbanFluxes +! +! !INTERFACE: + subroutine UrbanFluxes (nc, lbp, ubp, lbl, ubl, lbc, ubc, & + num_nourbanl, filter_nourbanl, & + num_urbanl, filter_urbanl, & + num_urbanc, filter_urbanc, & + num_urbanp, filter_urbanp) +! +! !DESCRIPTION: +! Turbulent and momentum fluxes from urban canyon (consisting of roof, sunwall, +! shadewall, pervious and impervious road). + +! !USES: + use clmtype + use clm_varcon , only : cpair, vkc, spval, icol_roof, icol_sunwall, & + icol_shadewall, icol_road_perv, icol_road_imperv, & + grav, pondmx_urban, rpi, rgas, & + ht_wasteheat_factor, ac_wasteheat_factor, & + wasteheat_limit + use filterMod , only : filter + use FrictionVelocityMod, only : FrictionVelocity, MoninObukIni + use QSatMod , only : QSat + use clm_varpar , only : maxpatch_urb, nlevurb + use clm_time_manager , only : get_curr_date, get_step_size, get_nstep + use clm_atmlnd , only : clm_a2l + +! +! !ARGUMENTS: + implicit none + integer , intent(in) :: nc ! clump index + integer, intent(in) :: lbp, ubp ! pft-index bounds + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer, intent(in) :: lbc, ubc ! column-index bounds + integer , intent(in) :: num_nourbanl ! number of non-urban landunits in clump + integer , intent(in) :: filter_nourbanl(ubl-lbl+1) ! non-urban landunit filter + integer , intent(in) :: num_urbanl ! number of urban landunits in clump + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + integer , intent(in) :: num_urbanc ! number of urban columns in clump + integer , intent(in) :: filter_urbanc(ubc-lbc+1) ! urban column filter + integer , intent(in) :: num_urbanp ! number of urban pfts in clump + integer , intent(in) :: filter_urbanp(ubp-lbp+1) ! urban pft filter +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! Author: Keith Oleson 10/2005 +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in arguments (urban clump) +! + real(r8), pointer :: ht_roof(:) ! height of urban roof (m) + real(r8), pointer :: wtlunit_roof(:) ! weight of roof with respect to landunit + real(r8), pointer :: canyon_hwr(:) ! ratio of building height to street width + real(r8), pointer :: wtroad_perv(:) ! weight of pervious road wrt total road + real(r8), pointer :: wind_hgt_canyon(:) ! height above road at which wind in canyon is to be computed (m) +! +! local pointers to original implicit in arguments (clmtype) +! + real(r8), pointer :: forc_u(:) ! atmospheric wind speed in east direction (m/s) + real(r8), pointer :: forc_v(:) ! atmospheric wind speed in north direction (m/s) + real(r8), pointer :: forc_rho(:) ! density (kg/m**3) + real(r8), pointer :: forc_hgt_u_pft(:) ! observational height of wind at pft-level (m) + real(r8), pointer :: forc_hgt_t_pft(:) ! observational height of temperature at pft-level (m) + real(r8), pointer :: forc_q(:) ! atmospheric specific humidity (kg/kg) + real(r8), pointer :: forc_t(:) ! atmospheric temperature (K) + real(r8), pointer :: forc_th(:) ! atmospheric potential temperature (K) + real(r8), pointer :: forc_pbot(:) ! atmospheric pressure (Pa) + + real(r8), pointer :: z_0_town(:) ! momentum roughness length of urban landunit (m) + real(r8), pointer :: z_d_town(:) ! displacement height of urban landunit (m) + + integer , pointer :: pgridcell(:) ! gridcell of corresponding pft + integer , pointer :: pcolumn(:) ! column of corresponding pft + integer , pointer :: lgridcell(:) ! gridcell of corresponding landunit + integer , pointer :: plandunit(:) ! pft's landunit index + integer , pointer :: ctype(:) ! column type + integer , pointer :: coli(:) ! beginning column index for landunit + integer , pointer :: colf(:) ! ending column index for landunit + integer , pointer :: pfti(:) ! beginning pft index for landunit + integer , pointer :: pftf(:) ! ending pft index for landunit + + real(r8), pointer :: taf(:) ! urban canopy air temperature (K) + real(r8), pointer :: qaf(:) ! urban canopy air specific humidity (kg/kg) + integer , pointer :: npfts(:) ! landunit's number of pfts (columns) + real(r8), pointer :: t_grnd(:) ! ground surface temperature (K) + real(r8), pointer :: qg(:) ! specific humidity at ground surface (kg/kg) + real(r8), pointer :: htvp(:) ! latent heat of evaporation (/sublimation) (J/kg) + real(r8), pointer :: dqgdT(:) ! temperature derivative of "qg" + real(r8), pointer :: eflx_traffic(:) ! traffic sensible heat flux (W/m**2) + real(r8), pointer :: eflx_traffic_factor(:) ! multiplicative urban traffic factor for sensible heat flux + real(r8), pointer :: eflx_wasteheat(:) ! sensible heat flux from urban heating/cooling sources of waste heat (W/m**2) + real(r8), pointer :: eflx_heat_from_ac(:) ! sensible heat flux put back into canyon due to removal by AC (W/m**2) + real(r8), pointer :: t_soisno(:,:) ! soil temperature (K) + real(r8), pointer :: eflx_urban_ac(:) ! urban air conditioning flux (W/m**2) + real(r8), pointer :: eflx_urban_heat(:) ! urban heating flux (W/m**2) + real(r8), pointer :: londeg(:) ! longitude (degrees) + real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) + real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1) + real(r8), pointer :: snowdp(:) ! snow height (m) + real(r8), pointer :: h2osno(:) ! snow water (mm H2O) + integer , pointer :: snl(:) ! number of snow layers + real(r8), pointer :: rootr_road_perv(:,:) ! effective fraction of roots in each soil layer for urban pervious road + real(r8), pointer :: soilalpha_u(:) ! Urban factor that reduces ground saturated specific humidity (-) +! +! local pointers to original implicit out arguments +! + real(r8), pointer :: dlrad(:) ! downward longwave radiation below the canopy (W/m**2) + real(r8), pointer :: ulrad(:) ! upward longwave radiation above the canopy (W/m**2) + real(r8), pointer :: cgrnds(:) ! deriv, of soil sensible heat flux wrt soil temp (W/m**2/K) + real(r8), pointer :: cgrndl(:) ! deriv of soil latent heat flux wrt soil temp (W/m**2/K) + real(r8), pointer :: cgrnd(:) ! deriv. of soil energy flux wrt to soil temp (W/m**2/K) + real(r8), pointer :: taux(:) ! wind (shear) stress: e-w (kg/m/s**2) + real(r8), pointer :: tauy(:) ! wind (shear) stress: n-s (kg/m/s**2) + real(r8), pointer :: eflx_sh_grnd(:) ! sensible heat flux from ground (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_tot(:) ! total sensible heat flux (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_tot_u(:) ! urban total sensible heat flux (W/m**2) [+ to atm] + real(r8), pointer :: qflx_evap_soi(:) ! soil evaporation (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_tran_veg(:) ! vegetation transpiration (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_evap_veg(:) ! vegetation evaporation (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_evap_tot(:) ! qflx_evap_soi + qflx_evap_can + qflx_tran_veg + real(r8), pointer :: t_ref2m(:) ! 2 m height surface air temperature (K) + real(r8), pointer :: q_ref2m(:) ! 2 m height surface specific humidity (kg/kg) + real(r8), pointer :: t_ref2m_u(:) ! Urban 2 m height surface air temperature (K) + real(r8), pointer :: t_veg(:) ! vegetation temperature (K) + real(r8), pointer :: ram1(:) ! aerodynamical resistance (s/m) + real(r8), pointer :: rootr(:,:) ! effective fraction of roots in each soil layer + real(r8), pointer :: psnsun(:) ! sunlit leaf photosynthesis (umol CO2 /m**2/ s) + real(r8), pointer :: psnsha(:) ! shaded leaf photosynthesis (umol CO2 /m**2/ s) + real(r8), pointer :: t_building(:) ! internal building temperature (K) + real(r8), pointer :: rh_ref2m(:) ! 2 m height surface relative humidity (%) + real(r8), pointer :: rh_ref2m_u(:) ! Urban 2 m height surface relative humidity (%) +! +! +! !OTHER LOCAL VARIABLES +!EOP +! + character(len=*), parameter :: sub="UrbanFluxes" + integer :: fp,fc,fl,f,p,c,l,g,j,pi,i ! indices + + real(r8) :: canyontop_wind(num_urbanl) ! wind at canyon top (m/s) + real(r8) :: canyon_u_wind(num_urbanl) ! u-component of wind speed inside canyon (m/s) + real(r8) :: canyon_wind(num_urbanl) ! net wind speed inside canyon (m/s) + real(r8) :: canyon_resistance(num_urbanl) ! resistance to heat and moisture transfer from canyon road/walls to canyon air (s/m) + + real(r8) :: ur(lbl:ubl) ! wind speed at reference height (m/s) + real(r8) :: ustar(lbl:ubl) ! friction velocity (m/s) + real(r8) :: ramu(lbl:ubl) ! aerodynamic resistance (s/m) + real(r8) :: rahu(lbl:ubl) ! thermal resistance (s/m) + real(r8) :: rawu(lbl:ubl) ! moisture resistance (s/m) + real(r8) :: temp1(lbl:ubl) ! relation for potential temperature profile + real(r8) :: temp12m(lbl:ubl) ! relation for potential temperature profile applied at 2-m + real(r8) :: temp2(lbl:ubl) ! relation for specific humidity profile + real(r8) :: temp22m(lbl:ubl) ! relation for specific humidity profile applied at 2-m + real(r8) :: thm_g(lbl:ubl) ! intermediate variable (forc_t+0.0098*forc_hgt_t) + real(r8) :: thv_g(lbl:ubl) ! virtual potential temperature (K) + real(r8) :: dth(lbl:ubl) ! diff of virtual temp. between ref. height and surface + real(r8) :: dqh(lbl:ubl) ! diff of humidity between ref. height and surface + real(r8) :: zldis(lbl:ubl) ! reference height "minus" zero displacement height (m) + real(r8) :: um(lbl:ubl) ! wind speed including the stablity effect (m/s) + real(r8) :: obu(lbl:ubl) ! Monin-Obukhov length (m) + real(r8) :: taf_numer(lbl:ubl) ! numerator of taf equation (K m/s) + real(r8) :: taf_denom(lbl:ubl) ! denominator of taf equation (m/s) + real(r8) :: qaf_numer(lbl:ubl) ! numerator of qaf equation (kg m/kg s) + real(r8) :: qaf_denom(lbl:ubl) ! denominator of qaf equation (m/s) + real(r8) :: wtas(lbl:ubl) ! sensible heat conductance for urban air to atmospheric air (m/s) + real(r8) :: wtaq(lbl:ubl) ! latent heat conductance for urban air to atmospheric air (m/s) + real(r8) :: wts_sum(lbl:ubl) ! sum of wtas, wtus_roof, wtus_road_perv, wtus_road_imperv, wtus_sunwall, wtus_shadewall + real(r8) :: wtq_sum(lbl:ubl) ! sum of wtaq, wtuq_roof, wtuq_road_perv, wtuq_road_imperv, wtuq_sunwall, wtuq_shadewall + real(r8) :: beta(lbl:ubl) ! coefficient of convective velocity + real(r8) :: zii(lbl:ubl) ! convective boundary layer height (m) + + real(r8) :: fm(lbl:ubl) ! needed for BGC only to diagnose 10m wind speed + + real(r8) :: wtus(lbc:ubc) ! sensible heat conductance for urban columns (m/s) + real(r8) :: wtuq(lbc:ubc) ! latent heat conductance for urban columns (m/s) + + integer :: iter ! iteration index + real(r8) :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(r8) :: tstar ! temperature scaling parameter + real(r8) :: qstar ! moisture scaling parameter + real(r8) :: thvstar ! virtual potential temperature scaling parameter + real(r8) :: wtus_roof(lbl:ubl) ! sensible heat conductance for roof (not scaled) (m/s) + real(r8) :: wtuq_roof(lbl:ubl) ! latent heat conductance for roof (not scaled) (m/s) + real(r8) :: wtus_road_perv(lbl:ubl) ! sensible heat conductance for pervious road (not scaled) (m/s) + real(r8) :: wtuq_road_perv(lbl:ubl) ! latent heat conductance for pervious road (not scaled) (m/s) + real(r8) :: wtus_road_imperv(lbl:ubl) ! sensible heat conductance for impervious road (not scaled) (m/s) + real(r8) :: wtuq_road_imperv(lbl:ubl) ! latent heat conductance for impervious road (not scaled) (m/s) + real(r8) :: wtus_sunwall(lbl:ubl) ! sensible heat conductance for sunwall (not scaled) (m/s) + real(r8) :: wtuq_sunwall(lbl:ubl) ! latent heat conductance for sunwall (not scaled) (m/s) + real(r8) :: wtus_shadewall(lbl:ubl) ! sensible heat conductance for shadewall (not scaled) (m/s) + real(r8) :: wtuq_shadewall(lbl:ubl) ! latent heat conductance for shadewall (not scaled) (m/s) + real(r8) :: t_sunwall_innerl(lbl:ubl) ! temperature of inner layer of sunwall (K) + real(r8) :: t_shadewall_innerl(lbl:ubl) ! temperature of inner layer of shadewall (K) + real(r8) :: t_roof_innerl(lbl:ubl) ! temperature of inner layer of roof (K) + real(r8) :: lngth_roof ! length of roof (m) + real(r8) :: wc ! convective velocity (m/s) + real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) :: eflx_sh_grnd_scale(lbp:ubp) ! scaled sensible heat flux from ground (W/m**2) [+ to atm] + real(r8) :: qflx_evap_soi_scale(lbp:ubp) ! scaled soil evaporation (mm H2O/s) (+ = to atm) + real(r8) :: eflx_wasteheat_roof(lbl:ubl) ! sensible heat flux from urban heating/cooling sources of waste heat for roof (W/m**2) + real(r8) :: eflx_wasteheat_sunwall(lbl:ubl) ! sensible heat flux from urban heating/cooling sources of waste heat for sunwall (W/m**2) + real(r8) :: eflx_wasteheat_shadewall(lbl:ubl) ! sensible heat flux from urban heating/cooling sources of waste heat for shadewall (W/m**2) + real(r8) :: eflx_heat_from_ac_roof(lbl:ubl) ! sensible heat flux put back into canyon due to heat removal by AC for roof (W/m**2) + real(r8) :: eflx_heat_from_ac_sunwall(lbl:ubl) ! sensible heat flux put back into canyon due to heat removal by AC for sunwall (W/m**2) + real(r8) :: eflx_heat_from_ac_shadewall(lbl:ubl) ! sensible heat flux put back into canyon due to heat removal by AC for shadewall (W/m**2) + real(r8) :: eflx(lbl:ubl) ! total sensible heat flux for error check (W/m**2) + real(r8) :: qflx(lbl:ubl) ! total water vapor flux for error check (kg/m**2/s) + real(r8) :: eflx_scale(lbl:ubl) ! sum of scaled sensible heat fluxes for urban columns for error check (W/m**2) + real(r8) :: qflx_scale(lbl:ubl) ! sum of scaled water vapor fluxes for urban columns for error check (kg/m**2/s) + real(r8) :: eflx_err(lbl:ubl) ! sensible heat flux error (W/m**2) + real(r8) :: qflx_err(lbl:ubl) ! water vapor flux error (kg/m**2/s) + real(r8) :: fwet_roof ! fraction of roof surface that is wet (-) + real(r8) :: fwet_road_imperv ! fraction of impervious road surface that is wet (-) + + integer, parameter :: niters = 3 ! maximum number of iterations for surface temperature + integer :: local_secp1(lbl:ubl) ! seconds into current date in local time (sec) + real(r8) :: dtime ! land model time step (sec) + integer :: year,month,day,secs ! calendar info for current time step + logical :: found ! flag in search loop + integer :: indexl ! index of first found in search loop + integer :: nstep ! time step number + real(r8) :: z_d_town_loc(lbl:ubl) ! temporary copy + real(r8) :: z_0_town_loc(lbl:ubl) ! temporary copy + real(r8), parameter :: lapse_rate = 0.0098_r8 ! Dry adiabatic lapse rate (K/m) + real(r8) :: e_ref2m ! 2 m height surface saturated vapor pressure [Pa] + real(r8) :: de2mdT ! derivative of 2 m height surface saturated vapor pressure on t_ref2m + real(r8) :: qsat_ref2m ! 2 m height surface saturated specific humidity [kg/kg] + real(r8) :: dqsat2mdT ! derivative of 2 m height surface saturated specific humidity on t_ref2m + +!----------------------------------------------------------------------- + + ! Assign pointers into module urban clumps + + if ( num_urbanl > 0 )then + ht_roof => urban_clump(nc)%ht_roof + wtlunit_roof => urban_clump(nc)%wtlunit_roof + canyon_hwr => urban_clump(nc)%canyon_hwr + wtroad_perv => urban_clump(nc)%wtroad_perv + wind_hgt_canyon => urban_clump(nc)%wind_hgt_canyon + end if + + ! Assign local pointers to multi-level derived type members (gridcell level) + + forc_t => clm_a2l%forc_t + forc_th => clm_a2l%forc_th + forc_u => clm_a2l%forc_u + forc_v => clm_a2l%forc_v + forc_rho => clm_a2l%forc_rho + forc_q => clm_a2l%forc_q + forc_pbot => clm_a2l%forc_pbot + londeg => grc%londeg + + ! Assign local pointers to derived type members (landunit level) + + pfti => lun%pfti + pftf => lun%pftf + coli => lun%coli + colf => lun%colf + lgridcell => lun%gridcell + z_0_town => lun%z_0_town + z_d_town => lun%z_d_town + taf => lps%taf + qaf => lps%qaf + npfts => lun%npfts + eflx_traffic => lef%eflx_traffic + eflx_traffic_factor => lef%eflx_traffic_factor + eflx_wasteheat => lef%eflx_wasteheat + eflx_heat_from_ac => lef%eflx_heat_from_ac + t_building => lps%t_building + + ! Assign local pointers to derived type members (column level) + + ctype => col%itype + t_grnd => ces%t_grnd + qg => cws%qg + htvp => cps%htvp + dqgdT => cws%dqgdT + t_soisno => ces%t_soisno + eflx_urban_ac => cef%eflx_urban_ac + eflx_urban_heat => cef%eflx_urban_heat + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + frac_sno => cps%frac_sno + snowdp => cps%snowdp + h2osno => cws%h2osno + snl => cps%snl + rootr_road_perv => cps%rootr_road_perv + soilalpha_u => cws%soilalpha_u + + ! Assign local pointers to derived type members (pft level) + + pgridcell => pft%gridcell + pcolumn => pft%column + plandunit => pft%landunit + ram1 => pps%ram1 + dlrad => pef%dlrad + ulrad => pef%ulrad + cgrnds => pef%cgrnds + cgrndl => pef%cgrndl + cgrnd => pef%cgrnd + taux => pmf%taux + tauy => pmf%tauy + eflx_sh_grnd => pef%eflx_sh_grnd + eflx_sh_tot => pef%eflx_sh_tot + eflx_sh_tot_u => pef%eflx_sh_tot_u + qflx_evap_soi => pwf%qflx_evap_soi + qflx_tran_veg => pwf%qflx_tran_veg + qflx_evap_veg => pwf%qflx_evap_veg + qflx_evap_tot => pwf%qflx_evap_tot + t_ref2m => pes%t_ref2m + q_ref2m => pes%q_ref2m + t_ref2m_u => pes%t_ref2m_u + t_veg => pes%t_veg + rootr => pps%rootr + psnsun => pcf%psnsun + psnsha => pcf%psnsha + forc_hgt_u_pft => pps%forc_hgt_u_pft + forc_hgt_t_pft => pps%forc_hgt_t_pft + forc_hgt_u_pft => pps%forc_hgt_u_pft + forc_hgt_t_pft => pps%forc_hgt_t_pft + rh_ref2m => pes%rh_ref2m + rh_ref2m_u => pes%rh_ref2m_u + + ! Define fields that appear on the restart file for non-urban landunits + + do fl = 1,num_nourbanl + l = filter_nourbanl(fl) + taf(l) = spval + qaf(l) = spval + end do + + ! Get time step + nstep = get_nstep() + + ! Set constants (same as in Biogeophysics1Mod) + beta(:) = 1._r8 ! Should be set to the same values as in Biogeophysics1Mod + zii(:) = 1000._r8 ! Should be set to the same values as in Biogeophysics1Mod + + ! Get current date + dtime = get_step_size() + call get_curr_date (year, month, day, secs) + + ! Compute canyontop wind using Masson (2000) + + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + local_secp1(l) = secs + nint((londeg(g)/degpsec)/dtime)*dtime + local_secp1(l) = mod(local_secp1(l),isecspday) + + ! Error checks + + if (ht_roof(fl) - z_d_town(l) <= z_0_town(l)) then + write (iulog,*) 'aerodynamic parameter error in UrbanFluxes' + write (iulog,*) 'h_r - z_d <= z_0' + write (iulog,*) 'ht_roof, z_d_town, z_0_town: ', ht_roof(fl), z_d_town(l), & + z_0_town(l) + write (iulog,*) 'clm model is stopping' + call endrun() + end if + if (forc_hgt_u_pft(pfti(l)) - z_d_town(l) <= z_0_town(l)) then + write (iulog,*) 'aerodynamic parameter error in UrbanFluxes' + write (iulog,*) 'h_u - z_d <= z_0' + write (iulog,*) 'forc_hgt_u_pft, z_d_town, z_0_town: ', forc_hgt_u_pft(pfti(l)), z_d_town(l), & + z_0_town(l) + write (iulog,*) 'clm model is stopping' + call endrun() + end if + + ! Magnitude of atmospheric wind + + ur(l) = max(1.0_r8,sqrt(forc_u(g)*forc_u(g)+forc_v(g)*forc_v(g))) + + ! Canyon top wind + + canyontop_wind(fl) = ur(l) * & + log( (ht_roof(fl)-z_d_town(l)) / z_0_town(l) ) / & + log( (forc_hgt_u_pft(pfti(l))-z_d_town(l)) / z_0_town(l) ) + + ! U component of canyon wind + + if (canyon_hwr(fl) < 0.5_r8) then ! isolated roughness flow + canyon_u_wind(fl) = canyontop_wind(fl) * exp( -0.5_r8*canyon_hwr(fl)* & + (1._r8-(wind_hgt_canyon(fl)/ht_roof(fl))) ) + else if (canyon_hwr(fl) < 1.0_r8) then ! wake interference flow + canyon_u_wind(fl) = canyontop_wind(fl) * (1._r8+2._r8*(2._r8/rpi - 1._r8)* & + (ht_roof(fl)/(ht_roof(fl)/canyon_hwr(fl)) - 0.5_r8)) * & + exp(-0.5_r8*canyon_hwr(fl)*(1._r8-(wind_hgt_canyon(fl)/ht_roof(fl)))) + else ! skimming flow + canyon_u_wind(fl) = canyontop_wind(fl) * (2._r8/rpi) * & + exp(-0.5_r8*canyon_hwr(fl)*(1._r8-(wind_hgt_canyon(fl)/ht_roof(fl)))) + end if + + end do + +! Compute fluxes - Follows CLM approach for bare soils (Oleson et al 2004) + + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + thm_g(l) = forc_t(g) + lapse_rate*forc_hgt_t_pft(pfti(l)) + thv_g(l) = forc_th(g)*(1._r8+0.61_r8*forc_q(g)) + dth(l) = thm_g(l)-taf(l) + dqh(l) = forc_q(g)-qaf(l) + dthv = dth(l)*(1._r8+0.61_r8*forc_q(g))+0.61_r8*forc_th(g)*dqh(l) + zldis(l) = forc_hgt_u_pft(pfti(l)) - z_d_town(l) + + ! Initialize Monin-Obukhov length and wind speed including convective velocity + + call MoninObukIni(ur(l), thv_g(l), dthv, zldis(l), z_0_town(l), um(l), obu(l)) + + end do + + ! Initialize conductances + wtus_roof(:) = 0._r8 + wtus_road_perv(:) = 0._r8 + wtus_road_imperv(:) = 0._r8 + wtus_sunwall(:) = 0._r8 + wtus_shadewall(:) = 0._r8 + wtuq_roof(:) = 0._r8 + wtuq_road_perv(:) = 0._r8 + wtuq_road_imperv(:) = 0._r8 + wtuq_sunwall(:) = 0._r8 + wtuq_shadewall(:) = 0._r8 + + ! Make copies so that array sections are not passed in function calls to friction velocity + + do fl = 1, num_urbanl + l = filter_urbanl(fl) + z_d_town_loc(l) = z_d_town(l) + z_0_town_loc(l) = z_0_town(l) + end do + + ! Start stability iteration + + do iter = 1,niters + + ! Get friction velocity, relation for potential + ! temperature and humidity profiles of surface boundary layer. + + if (num_urbanl .gt. 0) then + call FrictionVelocity(lbl, ubl, num_urbanl, filter_urbanl, & + z_d_town_loc, z_0_town_loc, z_0_town_loc, z_0_town_loc, & + obu, iter, ur, um, ustar, & + temp1, temp2, temp12m, temp22m, fm, landunit_index=.true.) + end if + + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + ! Determine aerodynamic resistance to fluxes from urban canopy air to + ! atmosphere + + ramu(l) = 1._r8/(ustar(l)*ustar(l)/um(l)) + rahu(l) = 1._r8/(temp1(l)*ustar(l)) + rawu(l) = 1._r8/(temp2(l)*ustar(l)) + + ! Determine magnitude of canyon wind by using horizontal wind determined + ! previously and vertical wind from friction velocity (Masson 2000) + + canyon_wind(fl) = sqrt(canyon_u_wind(fl)**2._r8 + ustar(l)**2._r8) + + ! Determine canyon_resistance (currently this single resistance determines the + ! resistance from urban surfaces (roof, pervious and impervious road, sunlit and + ! shaded walls) to urban canopy air, since it is only dependent on wind speed + ! Also from Masson 2000. + + canyon_resistance(fl) = cpair * forc_rho(g) / (11.8_r8 + 4.2_r8*canyon_wind(fl)) + + end do + + ! This is the first term in the equation solutions for urban canopy air temperature + ! and specific humidity (numerator) and is a landunit quantity + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + taf_numer(l) = thm_g(l)/rahu(l) + taf_denom(l) = 1._r8/rahu(l) + qaf_numer(l) = forc_q(g)/rawu(l) + qaf_denom(l) = 1._r8/rawu(l) + + ! First term needed for derivative of heat fluxes + wtas(l) = 1._r8/rahu(l) + wtaq(l) = 1._r8/rawu(l) + + end do + + + ! Gather other terms for other urban columns for numerator and denominator of + ! equations for urban canopy air temperature and specific humidity + + do pi = 1,maxpatch_urb + do fl = 1,num_urbanl + l = filter_urbanl(fl) + if ( pi <= npfts(l) ) then + c = coli(l) + pi - 1 + + if (ctype(c) == icol_roof) then + + ! scaled sensible heat conductance + wtus(c) = wtlunit_roof(fl)/canyon_resistance(fl) + ! unscaled sensible heat conductance + wtus_roof(l) = 1._r8/canyon_resistance(fl) + + if (snowdp(c) > 0._r8) then + fwet_roof = min(snowdp(c)/0.05_r8, 1._r8) + else + fwet_roof = (max(0._r8, h2osoi_liq(c,1)+h2osoi_ice(c,1))/pondmx_urban)**0.666666666666_r8 + fwet_roof = min(fwet_roof,1._r8) + end if + if (qaf(l) > qg(c)) then + fwet_roof = 1._r8 + end if + ! scaled latent heat conductance + wtuq(c) = fwet_roof*(wtlunit_roof(fl)/canyon_resistance(fl)) + ! unscaled latent heat conductance + wtuq_roof(l) = fwet_roof*(1._r8/canyon_resistance(fl)) + + ! wasteheat from heating/cooling + if (trim(urban_hac) == urban_wasteheat_on) then + eflx_wasteheat_roof(l) = ac_wasteheat_factor * eflx_urban_ac(c) + & + ht_wasteheat_factor * eflx_urban_heat(c) + else + eflx_wasteheat_roof(l) = 0._r8 + end if + + ! If air conditioning on, always replace heat removed with heat into canyon + if (trim(urban_hac) == urban_hac_on .or. trim(urban_hac) == urban_wasteheat_on) then + eflx_heat_from_ac_roof(l) = abs(eflx_urban_ac(c)) + else + eflx_heat_from_ac_roof(l) = 0._r8 + end if + + else if (ctype(c) == icol_road_perv) then + + ! scaled sensible heat conductance + wtus(c) = wtroad_perv(fl)*(1._r8-wtlunit_roof(fl))/canyon_resistance(fl) + ! unscaled sensible heat conductance + if (wtroad_perv(fl) > 0._r8) then + wtus_road_perv(l) = 1._r8/canyon_resistance(fl) + else + wtus_road_perv(l) = 0._r8 + end if + + ! scaled latent heat conductance + wtuq(c) = wtroad_perv(fl)*(1._r8-wtlunit_roof(fl))/canyon_resistance(fl) + ! unscaled latent heat conductance + if (wtroad_perv(fl) > 0._r8) then + wtuq_road_perv(l) = 1._r8/canyon_resistance(fl) + else + wtuq_road_perv(l) = 0._r8 + end if + + else if (ctype(c) == icol_road_imperv) then + + ! scaled sensible heat conductance + wtus(c) = (1._r8-wtroad_perv(fl))*(1._r8-wtlunit_roof(fl))/canyon_resistance(fl) + ! unscaled sensible heat conductance + if ((1._r8-wtroad_perv(fl)) > 0._r8) then + wtus_road_imperv(l) = 1._r8/canyon_resistance(fl) + else + wtus_road_imperv(l) = 0._r8 + end if + + if (snowdp(c) > 0._r8) then + fwet_road_imperv = min(snowdp(c)/0.05_r8, 1._r8) + else + fwet_road_imperv = (max(0._r8, h2osoi_liq(c,1)+h2osoi_ice(c,1))/pondmx_urban)**0.666666666666_r8 + fwet_road_imperv = min(fwet_road_imperv,1._r8) + end if + if (qaf(l) > qg(c)) then + fwet_road_imperv = 1._r8 + end if + ! scaled latent heat conductance + wtuq(c) = fwet_road_imperv*(1._r8-wtroad_perv(fl))*(1._r8-wtlunit_roof(fl))/canyon_resistance(fl) + ! unscaled latent heat conductance + if ((1._r8-wtroad_perv(fl)) > 0._r8) then + wtuq_road_imperv(l) = fwet_road_imperv*(1._r8/canyon_resistance(fl)) + else + wtuq_road_imperv(l) = 0._r8 + end if + + else if (ctype(c) == icol_sunwall) then + + ! scaled sensible heat conductance + wtus(c) = canyon_hwr(fl)*(1._r8-wtlunit_roof(fl))/canyon_resistance(fl) + ! unscaled sensible heat conductance + wtus_sunwall(l) = 1._r8/canyon_resistance(fl) + + ! scaled latent heat conductance + wtuq(c) = 0._r8 + ! unscaled latent heat conductance + wtuq_sunwall(l) = 0._r8 + + ! wasteheat from heating/cooling + if (trim(urban_hac) == urban_wasteheat_on) then + eflx_wasteheat_sunwall(l) = ac_wasteheat_factor * eflx_urban_ac(c) + & + ht_wasteheat_factor * eflx_urban_heat(c) + else + eflx_wasteheat_sunwall(l) = 0._r8 + end if + + ! If air conditioning on, always replace heat removed with heat into canyon + if (trim(urban_hac) == urban_hac_on .or. trim(urban_hac) == urban_wasteheat_on) then + eflx_heat_from_ac_sunwall(l) = abs(eflx_urban_ac(c)) + else + eflx_heat_from_ac_sunwall(l) = 0._r8 + end if + + else if (ctype(c) == icol_shadewall) then + + ! scaled sensible heat conductance + wtus(c) = canyon_hwr(fl)*(1._r8-wtlunit_roof(fl))/canyon_resistance(fl) + ! unscaled sensible heat conductance + wtus_shadewall(l) = 1._r8/canyon_resistance(fl) + + ! scaled latent heat conductance + wtuq(c) = 0._r8 + ! unscaled latent heat conductance + wtuq_shadewall(l) = 0._r8 + + ! wasteheat from heating/cooling + if (trim(urban_hac) == urban_wasteheat_on) then + eflx_wasteheat_shadewall(l) = ac_wasteheat_factor * eflx_urban_ac(c) + & + ht_wasteheat_factor * eflx_urban_heat(c) + else + eflx_wasteheat_shadewall(l) = 0._r8 + end if + + ! If air conditioning on, always replace heat removed with heat into canyon + if (trim(urban_hac) == urban_hac_on .or. trim(urban_hac) == urban_wasteheat_on) then + eflx_heat_from_ac_shadewall(l) = abs(eflx_urban_ac(c)) + else + eflx_heat_from_ac_shadewall(l) = 0._r8 + end if + else + write(iulog,*) 'c, ctype, pi = ', c, ctype(c), pi + write(iulog,*) 'Column indices for: shadewall, sunwall, road_imperv, road_perv, roof: ' + write(iulog,*) icol_shadewall, icol_sunwall, icol_road_imperv, icol_road_perv, icol_roof + call endrun( sub//':: ERROR, ctype out of range' ) + end if + + taf_numer(l) = taf_numer(l) + t_grnd(c)*wtus(c) + taf_denom(l) = taf_denom(l) + wtus(c) + qaf_numer(l) = qaf_numer(l) + qg(c)*wtuq(c) + qaf_denom(l) = qaf_denom(l) + wtuq(c) + + end if + end do + end do + + ! Calculate new urban canopy air temperature and specific humidity + + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + ! Total waste heat and heat from AC is sum of heat for walls and roofs + ! accounting for different surface areas + eflx_wasteheat(l) = wtlunit_roof(fl)*eflx_wasteheat_roof(l) + & + (1._r8-wtlunit_roof(fl))*(canyon_hwr(fl)*(eflx_wasteheat_sunwall(l) + & + eflx_wasteheat_shadewall(l))) + + ! Limit wasteheat to ensure that we don't get any unrealistically strong + ! positive feedbacks due to AC in a warmer climate + eflx_wasteheat(l) = min(eflx_wasteheat(l),wasteheat_limit) + + eflx_heat_from_ac(l) = wtlunit_roof(fl)*eflx_heat_from_ac_roof(l) + & + (1._r8-wtlunit_roof(fl))*(canyon_hwr(fl)*(eflx_heat_from_ac_sunwall(l) + & + eflx_heat_from_ac_shadewall(l))) + + ! Calculate traffic heat flux + ! Only comes from impervious road + eflx_traffic(l) = (1._r8-wtlunit_roof(fl))*(1._r8-wtroad_perv(fl))* & + eflx_traffic_factor(l) + + taf(l) = taf_numer(l)/taf_denom(l) + qaf(l) = qaf_numer(l)/qaf_denom(l) + + wts_sum(l) = wtas(l) + wtus_roof(l) + wtus_road_perv(l) + & + wtus_road_imperv(l) + wtus_sunwall(l) + wtus_shadewall(l) + + wtq_sum(l) = wtaq(l) + wtuq_roof(l) + wtuq_road_perv(l) + & + wtuq_road_imperv(l) + wtuq_sunwall(l) + wtuq_shadewall(l) + + end do + + ! This section of code is not required if niters = 1 + ! Determine stability using new taf and qaf + ! TODO: Some of these constants replicate what is in FrictionVelocity and BareGround fluxes should consildate. EBK + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + dth(l) = thm_g(l)-taf(l) + dqh(l) = forc_q(g)-qaf(l) + tstar = temp1(l)*dth(l) + qstar = temp2(l)*dqh(l) + thvstar = tstar*(1._r8+0.61_r8*forc_q(g)) + 0.61_r8*forc_th(g)*qstar + zeta = zldis(l)*vkc*grav*thvstar/(ustar(l)**2*thv_g(l)) + + if (zeta >= 0._r8) then !stable + zeta = min(2._r8,max(zeta,0.01_r8)) + um(l) = max(ur(l),0.1_r8) + else !unstable + zeta = max(-100._r8,min(zeta,-0.01_r8)) + wc = beta(l)*(-grav*ustar(l)*thvstar*zii(l)/thv_g(l))**0.333_r8 + um(l) = sqrt(ur(l)*ur(l) + wc*wc) + end if + + obu(l) = zldis(l)/zeta + end do + + end do ! end iteration + +! Determine fluxes from canyon surfaces + + do f = 1, num_urbanp + + p = filter_urbanp(f) + c = pcolumn(p) + g = pgridcell(p) + l = plandunit(p) + + ram1(p) = ramu(l) !pass value to global variable + + ! Upward and downward canopy longwave are zero + + ulrad(p) = 0._r8 + dlrad(p) = 0._r8 + + ! Derivative of sensible and latent heat fluxes with respect to + ! ground temperature + + if (ctype(c) == icol_roof) then + cgrnds(p) = forc_rho(g) * cpair * (wtas(l) + wtus_road_perv(l) + & + wtus_road_imperv(l) + wtus_sunwall(l) + wtus_shadewall(l)) * & + (wtus_roof(l)/wts_sum(l)) + cgrndl(p) = forc_rho(g) * (wtaq(l) + wtuq_road_perv(l) + & + wtuq_road_imperv(l) + wtuq_sunwall(l) + wtuq_shadewall(l)) * & + (wtuq_roof(l)/wtq_sum(l))*dqgdT(c) + else if (ctype(c) == icol_road_perv) then + cgrnds(p) = forc_rho(g) * cpair * (wtas(l) + wtus_roof(l) + & + wtus_road_imperv(l) + wtus_sunwall(l) + wtus_shadewall(l)) * & + (wtus_road_perv(l)/wts_sum(l)) + cgrndl(p) = forc_rho(g) * (wtaq(l) + wtuq_roof(l) + & + wtuq_road_imperv(l) + wtuq_sunwall(l) + wtuq_shadewall(l)) * & + (wtuq_road_perv(l)/wtq_sum(l))*dqgdT(c) + else if (ctype(c) == icol_road_imperv) then + cgrnds(p) = forc_rho(g) * cpair * (wtas(l) + wtus_roof(l) + & + wtus_road_perv(l) + wtus_sunwall(l) + wtus_shadewall(l)) * & + (wtus_road_imperv(l)/wts_sum(l)) + cgrndl(p) = forc_rho(g) * (wtaq(l) + wtuq_roof(l) + & + wtuq_road_perv(l) + wtuq_sunwall(l) + wtuq_shadewall(l)) * & + (wtuq_road_imperv(l)/wtq_sum(l))*dqgdT(c) + else if (ctype(c) == icol_sunwall) then + cgrnds(p) = forc_rho(g) * cpair * (wtas(l) + wtus_roof(l) + & + wtus_road_perv(l) + wtus_road_imperv(l) + wtus_shadewall(l)) * & + (wtus_sunwall(l)/wts_sum(l)) + cgrndl(p) = 0._r8 + else if (ctype(c) == icol_shadewall) then + cgrnds(p) = forc_rho(g) * cpair * (wtas(l) + wtus_roof(l) + & + wtus_road_perv(l) + wtus_road_imperv(l) + wtus_sunwall(l)) * & + (wtus_shadewall(l)/wts_sum(l)) + cgrndl(p) = 0._r8 + end if + cgrnd(p) = cgrnds(p) + cgrndl(p)*htvp(c) + + ! Surface fluxes of momentum, sensible and latent heat + + taux(p) = -forc_rho(g)*forc_u(g)/ramu(l) + tauy(p) = -forc_rho(g)*forc_v(g)/ramu(l) + + ! Use new canopy air temperature + dth(l) = taf(l) - t_grnd(c) + + if (ctype(c) == icol_roof) then + eflx_sh_grnd(p) = -forc_rho(g)*cpair*wtus_roof(l)*dth(l) + else if (ctype(c) == icol_road_perv) then + eflx_sh_grnd(p) = -forc_rho(g)*cpair*wtus_road_perv(l)*dth(l) + else if (ctype(c) == icol_road_imperv) then + eflx_sh_grnd(p) = -forc_rho(g)*cpair*wtus_road_imperv(l)*dth(l) + else if (ctype(c) == icol_sunwall) then + eflx_sh_grnd(p) = -forc_rho(g)*cpair*wtus_sunwall(l)*dth(l) + else if (ctype(c) == icol_shadewall) then + eflx_sh_grnd(p) = -forc_rho(g)*cpair*wtus_shadewall(l)*dth(l) + end if + + eflx_sh_tot(p) = eflx_sh_grnd(p) + eflx_sh_tot_u(p) = eflx_sh_tot(p) + + dqh(l) = qaf(l) - qg(c) + + if (ctype(c) == icol_roof) then + qflx_evap_soi(p) = -forc_rho(g)*wtuq_roof(l)*dqh(l) + else if (ctype(c) == icol_road_perv) then + ! Evaporation assigned to soil term if dew or snow + ! or if no liquid water available in soil column + if (dqh(l) > 0._r8 .or. frac_sno(c) > 0._r8 .or. soilalpha_u(c) .le. 0._r8) then + qflx_evap_soi(p) = -forc_rho(g)*wtuq_road_perv(l)*dqh(l) + qflx_tran_veg(p) = 0._r8 + ! Otherwise, evaporation assigned to transpiration term + else + qflx_evap_soi(p) = 0._r8 + qflx_tran_veg(p) = -forc_rho(g)*wtuq_road_perv(l)*dqh(l) + end if + qflx_evap_veg(p) = qflx_tran_veg(p) + else if (ctype(c) == icol_road_imperv) then + qflx_evap_soi(p) = -forc_rho(g)*wtuq_road_imperv(l)*dqh(l) + else if (ctype(c) == icol_sunwall) then + qflx_evap_soi(p) = 0._r8 + else if (ctype(c) == icol_shadewall) then + qflx_evap_soi(p) = 0._r8 + end if + + ! SCALED sensible and latent heat flux for error check + eflx_sh_grnd_scale(p) = -forc_rho(g)*cpair*wtus(c)*dth(l) + qflx_evap_soi_scale(p) = -forc_rho(g)*wtuq(c)*dqh(l) + + end do + + ! Check to see that total sensible and latent heat equal the sum of + ! the scaled heat fluxes above + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + eflx(l) = -(forc_rho(g)*cpair/rahu(l))*(thm_g(l) - taf(l)) + qflx(l) = -(forc_rho(g)/rawu(l))*(forc_q(g) - qaf(l)) + eflx_scale(l) = sum(eflx_sh_grnd_scale(pfti(l):pftf(l))) + qflx_scale(l) = sum(qflx_evap_soi_scale(pfti(l):pftf(l))) + eflx_err(l) = eflx_scale(l) - eflx(l) + qflx_err(l) = qflx_scale(l) - qflx(l) + end do + + found = .false. + do fl = 1, num_urbanl + l = filter_urbanl(fl) + if (abs(eflx_err(l)) > 0.01_r8) then + found = .true. + indexl = l + exit + end if + end do + if ( found ) then + write(iulog,*)'WARNING: Total sensible heat does not equal sum of scaled heat fluxes for urban columns ',& + ' nstep = ',nstep,' indexl= ',indexl,' eflx_err= ',eflx_err(indexl) + if (abs(eflx_err(indexl)) > .01_r8) then + write(iulog,*)'clm model is stopping - error is greater than .01 W/m**2' + write(iulog,*)'eflx_scale = ',eflx_scale(indexl) + write(iulog,*)'eflx_sh_grnd_scale: ',eflx_sh_grnd_scale(pfti(indexl):pftf(indexl)) + write(iulog,*)'eflx = ',eflx(indexl) + call endrun + end if + end if + + found = .false. + do fl = 1, num_urbanl + l = filter_urbanl(fl) + ! 4.e-9 kg/m**2/s = 0.01 W/m**2 + if (abs(qflx_err(l)) > 4.e-9_r8) then + found = .true. + indexl = l + exit + end if + end do + if ( found ) then + write(iulog,*)'WARNING: Total water vapor flux does not equal sum of scaled water vapor fluxes for urban columns ',& + ' nstep = ',nstep,' indexl= ',indexl,' qflx_err= ',qflx_err(indexl) + if (abs(qflx_err(indexl)) > 4.e-9_r8) then + write(iulog,*)'clm model is stopping - error is greater than 4.e-9 kg/m**2/s' + write(iulog,*)'qflx_scale = ',qflx_scale(indexl) + write(iulog,*)'qflx = ',qflx(indexl) + call endrun + end if + end if + + ! Gather terms required to determine internal building temperature + + do pi = 1,maxpatch_urb + do fl = 1,num_urbanl + l = filter_urbanl(fl) + if ( pi <= npfts(l) ) then + c = coli(l) + pi - 1 + + if (ctype(c) == icol_roof) then + t_roof_innerl(l) = t_soisno(c,nlevurb) + else if (ctype(c) == icol_sunwall) then + t_sunwall_innerl(l) = t_soisno(c,nlevurb) + else if (ctype(c) == icol_shadewall) then + t_shadewall_innerl(l) = t_soisno(c,nlevurb) + end if + + end if + end do + end do + + ! Calculate internal building temperature + do fl = 1, num_urbanl + l = filter_urbanl(fl) + + lngth_roof = (ht_roof(fl)/canyon_hwr(fl))*wtlunit_roof(fl)/(1._r8-wtlunit_roof(fl)) + t_building(l) = (ht_roof(fl)*(t_shadewall_innerl(l) + t_sunwall_innerl(l)) & + +lngth_roof*t_roof_innerl(l))/(2._r8*ht_roof(fl)+lngth_roof) + end do + + ! No roots for urban except for pervious road + + do j = 1, nlevurb + do f = 1, num_urbanp + p = filter_urbanp(f) + c = pcolumn(p) + if (ctype(c) == icol_road_perv) then + rootr(p,j) = rootr_road_perv(c,j) + else + rootr(p,j) = 0._r8 + end if + end do + end do + + do f = 1, num_urbanp + + p = filter_urbanp(f) + c = pcolumn(p) + g = pgridcell(p) + l = plandunit(p) + + ! Use urban canopy air temperature and specific humidity to represent + ! 2-m temperature and humidity + + t_ref2m(p) = taf(l) + q_ref2m(p) = qaf(l) + t_ref2m_u(p) = taf(l) + + ! 2 m height relative humidity + + call QSat(t_ref2m(p), forc_pbot(g), e_ref2m, de2mdT, qsat_ref2m, dqsat2mdT) + rh_ref2m(p) = min(100._r8, q_ref2m(p) / qsat_ref2m * 100._r8) + rh_ref2m_u(p) = rh_ref2m(p) + + ! Variables needed by history tape + + t_veg(p) = forc_t(g) + + ! Add the following to avoid NaN + + psnsun(p) = 0._r8 + psnsha(p) = 0._r8 + pps%lncsun(p) = 0._r8 + pps%lncsha(p) = 0._r8 + pps%vcmxsun(p) = 0._r8 + pps%vcmxsha(p) = 0._r8 + + end do + + end subroutine UrbanFluxes + +end module UrbanMod diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/main/histFileMod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/main/histFileMod.F90 new file mode 100644 index 0000000000..d82b639bec --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_0/main/histFileMod.F90 @@ -0,0 +1,4501 @@ + +! DART note: this file started life as: +! /glade/p/cesm/releases/cesm1_2_1/models/lnd/clm/src/clm4_0/main/histFileMod.F90 + +module histFileMod + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: histFileMod +! +! !DESCRIPTION: +! Module containing methods to for CLM history file handling. +! +! !USES: + use shr_kind_mod, only : r8 => shr_kind_r8 + use spmdMod , only : masterproc + use shr_sys_mod , only : shr_sys_flush + use abortutils , only : endrun + use clm_varcon , only : spval,ispval + use clm_varctl , only : iulog + use clmtype + use decompMod , only : get_proc_bounds, get_proc_global + use ncdio_pio + implicit none + save + private + +! +! !PUBLIC TYPES: +! +! Constants +! + integer , public, parameter :: max_tapes = 6 ! max number of history tapes + integer , public, parameter :: max_flds = 1500 ! max number of history fields + integer , public, parameter :: max_namlen = 32 ! maximum number of characters for field name +! +! Counters +! + integer , public :: ntapes = 0 ! index of max history file requested +! +! Namelist +! + integer :: ni ! implicit index below + logical, public :: & + hist_empty_htapes = .false. ! namelist: flag indicates no default history fields + integer, public :: & + hist_ndens(max_tapes) = 2 ! namelist: output density of netcdf history files + integer, public :: & + hist_mfilt(max_tapes) = 30 ! namelist: number of time samples per tape + logical, public :: & + hist_dov2xy(max_tapes) = (/.true.,(.true.,ni=2,max_tapes)/) ! namelist: true=> do grid averaging + integer, public :: & + hist_nhtfrq(max_tapes) = (/0, (-24, ni=2,max_tapes)/) ! namelist: history write freq(0=monthly) + character(len=1), public :: & + hist_avgflag_pertape(max_tapes) = (/(' ',ni=1,max_tapes)/) ! namelist: per tape averaging flag + character(len=max_namlen), public :: & + hist_type1d_pertape(max_tapes) = (/(' ',ni=1,max_tapes)/) ! namelist: per tape type1d + + character(len=max_namlen+2), public :: & + fincl(max_flds,max_tapes) ! namelist-equivalence list of fields to add + + character(len=max_namlen+2), public :: & + hist_fincl1(max_flds) = ' ' ! namelist: list of fields to add + character(len=max_namlen+2), public :: & + hist_fincl2(max_flds) = ' ' ! namelist: list of fields to add + character(len=max_namlen+2), public :: & + hist_fincl3(max_flds) = ' ' ! namelist: list of fields to add + character(len=max_namlen+2), public :: & + hist_fincl4(max_flds) = ' ' ! namelist: list of fields to add + character(len=max_namlen+2), public :: & + hist_fincl5(max_flds) = ' ' ! namelist: list of fields to add + character(len=max_namlen+2), public :: & + hist_fincl6(max_flds) = ' ' ! namelist: list of fields to add + + character(len=max_namlen+2), public :: & + fexcl(max_flds,max_tapes) ! namelist-equivalence list of fields to remove + + character(len=max_namlen+2), public :: & + hist_fexcl1(max_flds) = ' ' ! namelist: list of fields to remove + character(len=max_namlen+2), public :: & + hist_fexcl2(max_flds) = ' ' ! namelist: list of fields to remove + character(len=max_namlen+2), public :: & + hist_fexcl3(max_flds) = ' ' ! namelist: list of fields to remove + character(len=max_namlen+2), public :: & + hist_fexcl4(max_flds) = ' ' ! namelist: list of fields to remove + character(len=max_namlen+2), public :: & + hist_fexcl5(max_flds) = ' ' ! namelist: list of fields to remove + character(len=max_namlen+2), public :: & + hist_fexcl6(max_flds) = ' ' ! namelist: list of fields to remove +! +! Restart +! + logical, private :: if_disphist(max_tapes) ! true => save history file +! +! !PUBLIC MEMBER FUNCTIONS: + public :: hist_addfld1d ! Add a 1d single-level field to the master field list + public :: hist_addfld2d ! Add a 2d multi-level field to the master field list + public :: hist_add_subscript ! Add a 2d subscript dimension + public :: hist_printflds ! Print summary of master field list + public :: hist_htapes_build ! Initialize history file handler for initial or continue run + public :: hist_update_hbuf ! Updates history buffer for all fields and tapes + public :: hist_htapes_wrapup ! Write history tape(s) + public :: hist_restart_ncd ! Read/write history file restart data + public :: htapes_fieldlist ! Define the contents of each history file based on namelist +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !PRIVATE MEMBER FUNCTIONS: + private :: masterlist_make_active ! Add a field to a history file default "on" list + private :: masterlist_addfld ! Add a field to the master field list + private :: masterlist_change_timeavg ! Override default history tape contents for specific tape + private :: htape_addfld ! Add a field to the active list for a history tape + private :: htape_create ! Define contents of history file t + private :: htape_timeconst ! Write time constant values to history tape + private :: htape_timeconst3D ! Write time constant 3D values to primary history tape + private :: hfields_normalize ! Normalize history file fields by number of accumulations + private :: hfields_zero ! Zero out accumulation and hsitory buffers for a tape + private :: hfields_write ! Write a variable to a history tape + private :: hfields_1dinfo ! Define/output 1d subgrid info if appropriate + private :: hist_update_hbuf_field_1d ! Updates history buffer for specific field and tape + private :: hist_update_hbuf_field_2d ! Updates history buffer for specific field and tape + private :: list_index ! Find index of field in exclude list + private :: set_hist_filename ! Determine history dataset filenames + private :: getname ! Retrieve name portion of input "inname" + private :: getflag ! Retrieve flag + private :: pointer_index ! Track data pointer indices + private :: max_nFields ! The max number of fields on any tape + +! !PRIVATE TYPES: +! Constants +! + integer, parameter :: max_chars = 128 ! max chars for char variables +! +! Subscript dimensions +! + integer, parameter :: max_subs = 100 ! max number of subscripts + integer :: num_subs = 0 ! actual number of subscripts + character(len=32) :: subs_name(max_subs) ! name of subscript + integer :: subs_dim(max_subs) ! dimension of subscript +! +! Derived types +! + type field_info + character(len=max_namlen) :: name ! field name + character(len=max_chars) :: long_name ! long name + character(len=max_chars) :: units ! units + character(len=8) :: type1d ! clm pointer first dimension type + ! from clmtype (nameg, etc) + character(len=8) :: type1d_out ! hbuf first dimension type + ! from clmtype (nameg, etc) + character(len=8) :: type2d ! hbuf second dimension type + ! ["levgrnd","levlak","numrad","glc_nec","subname(n)"] + integer :: beg1d ! on-node 1d clm pointer start index + integer :: end1d ! on-node 1d clm pointer end index + integer :: num1d ! size of clm pointer first dimension (all nodes) + integer :: beg1d_out ! on-node 1d hbuf pointer start index + integer :: end1d_out ! on-node 1d hbuf pointer end index + integer :: num1d_out ! size of hbuf first dimension (all nodes) + integer :: num2d ! size of hbuf second dimension (e.g. number of vertical levels) + integer :: hpindex ! history pointer index + character(len=8) :: p2c_scale_type ! scale factor when averaging pft to column + character(len=8) :: c2l_scale_type ! scale factor when averaging column to landunit + character(len=8) :: l2g_scale_type ! scale factor when averaging landunit to gridcell + end type field_info + + type master_entry + type (field_info) :: field ! field information + logical :: actflag(max_tapes) ! active/inactive flag + character(len=1) :: avgflag(max_tapes) ! time averaging flag ("X","A","M" or "I",) + end type master_entry + + type history_entry + type (field_info) :: field ! field information + character(len=1) :: avgflag ! time averaging flag + real(r8), pointer :: hbuf(:,:) ! history buffer (dimensions: dim1d x num2d) + integer , pointer :: nacs(:,:) ! accumulation counter (dimensions: dim1d x num2d) + end type history_entry + + type history_tape + integer :: nflds ! number of active fields on tape + integer :: ntimes ! current number of time samples on tape + integer :: mfilt ! maximum number of time samples per tape + integer :: nhtfrq ! number of time samples per tape + integer :: ncprec ! netcdf output precision + logical :: dov2xy ! true => do xy average for all fields + logical :: is_endhist ! true => current time step is end of history interval + real(r8) :: begtime ! time at beginning of history averaging interval + type (history_entry) :: hlist(max_flds) ! array of active history tape entries + end type history_tape + + type clmpoint_rs ! Pointer to real scalar data (1D) + real(r8), pointer :: ptr(:) + end type clmpoint_rs + type clmpoint_ra ! Pointer to real array data (2D) + real(r8), pointer :: ptr(:,:) + end type clmpoint_ra +!EOP +! +! Pointers into clmtype arrays +! + integer, parameter :: max_mapflds = 1500 ! Maximum number of fields to track + type (clmpoint_rs) :: clmptr_rs(max_mapflds) ! Real scalar data (1D) + type (clmpoint_ra) :: clmptr_ra(max_mapflds) ! Real array data (2D) +! +! Master list: an array of master_entry entities +! + type (master_entry) :: masterlist(max_flds) ! master field list +! +! History tape: an array of history_tape entities (only active fields) +! + type (history_tape) :: tape(max_tapes) ! array history tapes +! +! Namelist input +! +! Counters +! + integer :: nfmaster = 0 ! number of fields in master field list +! +! Other variables +! + character(len=max_chars) :: locfnh(max_tapes) ! local history file names + character(len=max_chars) :: locfnhr(max_tapes) ! local history restart file names + logical :: htapes_defined = .false. ! flag indicates history contents have been defined +! +! NetCDF Id's +! + type(file_desc_t) :: nfid(max_tapes) ! file ids + type(file_desc_t) :: ncid_hist(max_tapes) ! file ids for history restart files + integer :: time_dimid ! time dimension id + integer :: hist_interval_dimid ! time bounds dimension id + integer :: strlen_dimid ! string dimension id + +! +! Time Constant variable names and filename +! + character(len=max_chars) :: TimeConst3DVars_Filename = ' ' + character(len=max_chars) :: TimeConst3DVars = ' ' +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_printflds +! +! !INTERFACE: + subroutine hist_printflds() +! +! !DESCRIPTION: +! Print summary of master field list. +! +! !USES: +! +! !ARGUMENTS: + implicit none +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein 03/2003 +! +! +! !LOCAL VARIABLES: +!EOP + integer nf + character(len=*),parameter :: subname = 'CLM_hist_printflds' +!----------------------------------------------------------------------- + + if (masterproc) then + write(iulog,*) trim(subname),' : number of master fields = ',nfmaster + write(iulog,*)' ******* MASTER FIELD LIST *******' + do nf = 1,nfmaster + write(iulog,9000)nf, masterlist(nf)%field%name, masterlist(nf)%field%units +9000 format (i5,1x,a32,1x,a16) + end do + call shr_sys_flush(iulog) + end if + + end subroutine hist_printflds + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: masterlist_addfld +! +! !INTERFACE: + subroutine masterlist_addfld (fname, type1d, type1d_out, & + type2d, num2d, units, avgflag, long_name, hpindex, & + p2c_scale_type, c2l_scale_type, l2g_scale_type) +! +! !DESCRIPTION: +! Add a field to the master field list. Put input arguments of +! field name, units, number of levels, averaging flag, and long name +! into a type entry in the global master field list (masterlist). +! +! !USES: +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: fname ! field name + character(len=*), intent(in) :: type1d ! 1d data type + character(len=*), intent(in) :: type1d_out ! 1d output type + character(len=*), intent(in) :: type2d ! 2d output type + integer , intent(in) :: num2d ! size of second dimension (e.g. number of vertical levels) + character(len=*), intent(in) :: units ! units of field + character(len=1), intent(in) :: avgflag ! time averaging flag + character(len=*), intent(in) :: long_name ! long name of field + integer , intent(in) :: hpindex ! clmtype index for history buffer output + character(len=*), intent(in) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column + character(len=*), intent(in) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits + character(len=*), intent(in) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: n ! loop index + integer :: f ! masterlist index + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: numa ! total number of atm cells across all processors + integer :: numg ! total number of gridcells across all processors + integer :: numl ! total number of landunits across all processors + integer :: numc ! total number of columns across all processors + integer :: nump ! total number of pfts across all processors + character(len=*),parameter :: subname = 'masterlist_addfld' +!------------------------------------------------------------------------ + + ! Determine bounds + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + call get_proc_global(numg, numl, numc, nump) + ! Ensure that new field is not all blanks + + if (fname == ' ') then + write(iulog,*) trim(subname),' ERROR: blank field name not allowed' + call endrun() + end if + + ! Ensure that new field doesn't already exist + + do n = 1,nfmaster + if (masterlist(n)%field%name == fname) then + write(iulog,*) trim(subname),' ERROR:', fname, ' already on list' + call endrun() + end if + end do + + ! Increase number of fields on master field list + + nfmaster = nfmaster + 1 + f = nfmaster + + ! Check number of fields in master list against maximum number for master list + + if (nfmaster > max_flds) then + write(iulog,*) trim(subname),' ERROR: too many fields for primary history file ', & + '-- max_flds,nfmaster=', max_flds, nfmaster + call endrun() + end if + + ! Add field to master list + + masterlist(f)%field%name = fname + masterlist(f)%field%long_name = long_name + masterlist(f)%field%units = units + masterlist(f)%field%type1d = type1d + masterlist(f)%field%type1d_out = type1d_out + masterlist(f)%field%type2d = type2d + masterlist(f)%field%num2d = num2d + masterlist(f)%field%hpindex = hpindex + masterlist(f)%field%p2c_scale_type = p2c_scale_type + masterlist(f)%field%c2l_scale_type = c2l_scale_type + masterlist(f)%field%l2g_scale_type = l2g_scale_type + + select case (type1d) + case (grlnd) + masterlist(f)%field%beg1d = begg + masterlist(f)%field%end1d = endg + masterlist(f)%field%num1d = numg + case (nameg) + masterlist(f)%field%beg1d = begg + masterlist(f)%field%end1d = endg + masterlist(f)%field%num1d = numg + case (namel) + masterlist(f)%field%beg1d = begl + masterlist(f)%field%end1d = endl + masterlist(f)%field%num1d = numl + case (namec) + masterlist(f)%field%beg1d = begc + masterlist(f)%field%end1d = endc + masterlist(f)%field%num1d = numc + case (namep) + masterlist(f)%field%beg1d = begp + masterlist(f)%field%end1d = endp + masterlist(f)%field%num1d = nump + case default + write(iulog,*) trim(subname),' ERROR: unknown 1d output type= ',type1d + call endrun() + end select + + ! The following two fields are used only in master field list, + ! NOT in the runtime active field list + ! ALL FIELDS IN THE MASTER LIST ARE INITIALIZED WITH THE ACTIVE + ! FLAG SET TO FALSE + + masterlist(f)%avgflag(:) = avgflag + masterlist(f)%actflag(:) = .false. + + end subroutine masterlist_addfld + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_htapes_build +! +! !INTERFACE: + subroutine hist_htapes_build () +! +! !DESCRIPTION: +! Initialize history file for initial or continuation run. For example, +! on an initial run, this routine initializes ``ntapes'' history files. +! On a restart run, this routine only initializes history files declared +! beyond what existed on the previous run. Files which already existed on +! the previous run have already been initialized (i.e. named and opened) +! in routine restart\_history. Loop over tapes and fields per tape setting +! appropriate variables and calling appropriate routines +! +! !USES: + use clm_time_manager, only: get_prev_time + use clm_varcon , only: secspday +! +! !ARGUMENTS: + implicit none +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: i ! index + integer :: ier ! error code + integer :: t, f ! tape, field indices + integer :: day, sec ! day and seconds from base date + character(len=*),parameter :: subname = 'hist_htapes_build' +!----------------------------------------------------------------------- + + if (masterproc) then + write(iulog,*) trim(subname),' Initializing clm2 history files' + write(iulog,'(72a1)') ("-",i=1,60) + call shr_sys_flush(iulog) + endif + + ! Define field list information for all history files. + ! Update ntapes to reflect number of active history files + ! Note - branch runs can have additional auxiliary history files + ! declared). + + call htapes_fieldlist() + + ! Determine if gridcell (xy) averaging is done for all fields on tape + + do t=1,ntapes + tape(t)%dov2xy = hist_dov2xy(t) + write(iulog,*)trim(subname),' hist tape = ',t,& + ' written with dov2xy= ',tape(t)%dov2xy + end do + + ! Set number of time samples in each history file and + ! Note - the following entries will be overwritten by history restart + ! Note - with netcdf, only 1 (ncd_double) and 2 (ncd_float) are allowed + + do t=1,ntapes + tape(t)%ntimes = 0 + tape(t)%dov2xy = hist_dov2xy(t) + tape(t)%nhtfrq = hist_nhtfrq(t) + tape(t)%mfilt = hist_mfilt(t) + if (hist_ndens(t) == 1) then + tape(t)%ncprec = ncd_double + else + tape(t)%ncprec = ncd_float + endif + end do + + ! Set time of beginning of current averaging interval + ! First etermine elapased time since reference date + + call get_prev_time(day, sec) + do t=1,ntapes + tape(t)%begtime = day + sec/secspday + end do + + if (masterproc) then + write(iulog,*) trim(subname),' Successfully initialized clm2 history files' + write(iulog,'(72a1)') ("-",i=1,60) + call shr_sys_flush(iulog) + endif + + end subroutine hist_htapes_build + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: masterlist_make_active +! +! !INTERFACE: + subroutine masterlist_make_active (name, tape_index, avgflag) +! +! !DESCRIPTION: +! Add a field to the default ``on'' list for a given history file. +! Also change the default time averaging flag if requested. +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: name ! field name + integer, intent(in) :: tape_index ! history tape index + character(len=1), intent(in), optional :: avgflag ! time averaging flag +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + logical :: found ! flag indicates field found in masterlist + character(len=*),parameter :: subname = 'masterlist_make_active' +!----------------------------------------------------------------------- + + ! Check validity of input arguments + + if (tape_index > max_tapes) then + write(iulog,*) trim(subname),' ERROR: tape index=', tape_index, ' is too big' + call endrun() + end if + + if (present(avgflag)) then + if ( avgflag /= ' ' .and. & + avgflag /= 'A' .and. avgflag /= 'I' .and. & + avgflag /= 'X' .and. avgflag /= 'M') then + write(iulog,*) trim(subname),' ERROR: unknown averaging flag=', avgflag + call endrun() + endif + end if + + ! Look through master list for input field name. + ! When found, set active flag for that tape to true. + ! Also reset averaging flag if told to use other than default. + + found = .false. + do f = 1,nfmaster + if (trim(name) == trim(masterlist(f)%field%name)) then + masterlist(f)%actflag(tape_index) = .true. + if (present(avgflag)) then + if (avgflag/= ' ') masterlist(f)%avgflag(tape_index) = avgflag + end if + found = .true. + exit + end if + end do + if (.not. found) then + write(iulog,*) trim(subname),' ERROR: field=', name, ' not found' + call endrun() + end if + + end subroutine masterlist_make_active + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: masterlist_change_timeavg +! +! !INTERFACE: + subroutine masterlist_change_timeavg (t) +! +! !DESCRIPTION: +! Override default history tape contents for a specific tape. +! Copy the flag into the master field list. +! +! !USES: +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! history tape index +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + character(len=1) :: avgflag ! lcl equiv of hist_avgflag_pertape(t) + character(len=*),parameter :: subname = 'masterlist_change_timeavg' +!----------------------------------------------------------------------- + + avgflag = hist_avgflag_pertape(t) + + do f = 1,nfmaster + select case (avgflag) + case ('A') + masterlist(f)%avgflag(t) = avgflag + case ('I') + masterlist(f)%avgflag(t) = avgflag + case ('X') + masterlist(f)%avgflag(t) = avgflag + case ('M') + masterlist(f)%avgflag(t) = avgflag + case default + write(iulog,*) trim(subname),' ERROR: unknown avgflag=',avgflag + call endrun () + end select + end do + + end subroutine masterlist_change_timeavg + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: htapes_fieldlist +! +! !INTERFACE: + subroutine htapes_fieldlist() +! +! !DESCRIPTION: +! Define the contents of each history file based on namelist +! input for initial or branch run, and restart data if a restart run. +! Use arrays fincl and fexcl to modify default history tape contents. +! Then sort the result alphanumerically. +! +! !USES: +! +! !ARGUMENTS: + implicit none +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: t, f ! tape, field indices + integer :: ff ! index into include, exclude and fprec list + character(len=max_namlen) :: name ! field name portion of fincl (i.e. no avgflag separator) + character(len=max_namlen) :: mastername ! name from masterlist field + character(len=1) :: avgflag ! averaging flag + character(len=1) :: prec_acc ! history buffer precision flag + character(len=1) :: prec_wrt ! history buffer write precision flag + type (history_entry) :: tmp ! temporary used for swapping + character(len=*),parameter :: subname = 'htapes_fieldlist' +!----------------------------------------------------------------------- + + ! Override averaging flag for all fields on a particular tape + ! if namelist input so specifies + + do t=1,max_tapes + if (hist_avgflag_pertape(t) /= ' ') then + call masterlist_change_timeavg (t) + end if + end do + + fincl(:,1) = hist_fincl1(:) + fincl(:,2) = hist_fincl2(:) + fincl(:,3) = hist_fincl3(:) + fincl(:,4) = hist_fincl4(:) + fincl(:,5) = hist_fincl5(:) + fincl(:,6) = hist_fincl6(:) + + fexcl(:,1) = hist_fexcl1(:) + fexcl(:,2) = hist_fexcl2(:) + fexcl(:,3) = hist_fexcl3(:) + fexcl(:,4) = hist_fexcl4(:) + fexcl(:,5) = hist_fexcl5(:) + fexcl(:,6) = hist_fexcl6(:) + + + ! First ensure contents of fincl and fexcl are valid names + + do t = 1,max_tapes + f = 1 + do while (f < max_flds .and. fincl(f,t) /= ' ') + name = getname (fincl(f,t)) + do ff = 1,nfmaster + mastername = masterlist(ff)%field%name + if (name == mastername) exit + end do + if (name /= mastername) then + write(iulog,*) trim(subname),' ERROR: ', trim(name), ' in fincl(', f, ') ',& + 'for history tape ',t,' not found' + call endrun() + end if + f = f + 1 + end do + + f = 1 + do while (f < max_flds .and. fexcl(f,t) /= ' ') + do ff = 1,nfmaster + mastername = masterlist(ff)%field%name + if (fexcl(f,t) == mastername) exit + end do + if (fexcl(f,t) /= mastername) then + write(iulog,*) trim(subname),' ERROR: ', fexcl(f,t), ' in fexcl(', f, ') ', & + 'for history tape ',t,' not found' + call endrun() + end if + f = f + 1 + end do + end do + + tape(:)%nflds = 0 + do t = 1,max_tapes + + ! Loop through the masterlist set of field names and determine if any of those + ! are in the FINCL or FEXCL arrays + ! The call to list_index determines the index in the FINCL or FEXCL arrays + ! that the masterlist field corresponds to + ! Add the field to the tape if specified via namelist (FINCL[1-max_tapes]), + ! or if it is on by default and was not excluded via namelist (FEXCL[1-max_tapes]). + + do f = 1,nfmaster + mastername = masterlist(f)%field%name + call list_index (fincl(1,t), mastername, ff) + + if (ff > 0) then + + ! if field is in include list, ff > 0 and htape_addfld + ! will not be called for field + + avgflag = getflag (fincl(ff,t)) + call htape_addfld (t, f, avgflag) + + else if (.not. hist_empty_htapes) then + + ! find index of field in exclude list + + call list_index (fexcl(1,t), mastername, ff) + + ! if field is in exclude list, ff > 0 and htape_addfld + ! will not be called for field + ! if field is not in exclude list, ff =0 and htape_addfld + ! will be called for field (note that htape_addfld will be + ! called below only if field is not in exclude list OR in + ! include list + + if (ff == 0 .and. masterlist(f)%actflag(t)) then + call htape_addfld (t, f, ' ') + end if + + end if + end do + + ! Specification of tape contents now complete. + ! Sort each list of active entries + + do f = tape(t)%nflds-1,1,-1 + do ff = 1,f + if (tape(t)%hlist(ff)%field%name > tape(t)%hlist(ff+1)%field%name) then + + tmp = tape(t)%hlist(ff) + tape(t)%hlist(ff ) = tape(t)%hlist(ff+1) + tape(t)%hlist(ff+1) = tmp + + else if (tape(t)%hlist(ff)%field%name == tape(t)%hlist(ff+1)%field%name) then + + write(iulog,*) trim(subname),' ERROR: Duplicate field ', & + tape(t)%hlist(ff)%field%name, & + 't,ff,name=',t,ff,tape(t)%hlist(ff+1)%field%name + call endrun() + + end if + end do + end do + + if (masterproc) then + if (tape(t)%nflds > 0) then + write(iulog,*) trim(subname),' : Included fields tape ',t,'=',tape(t)%nflds + end if + do f = 1,tape(t)%nflds + write(iulog,*) f,' ',tape(t)%hlist(f)%field%name, & + tape(t)%hlist(f)%field%num2d,' ',tape(t)%hlist(f)%avgflag + end do + call shr_sys_flush(iulog) + end if + end do + + ! Determine total number of active history tapes + + ntapes = 0 + do t = max_tapes,1,-1 + if (tape(t)%nflds > 0) then + ntapes = t + exit + end if + end do + + ! Ensure there are no "holes" in tape specification, i.e. empty tapes. + ! Enabling holes should not be difficult if necessary. + + do t = 1,ntapes + if (tape(t)%nflds == 0) then + write(iulog,*) trim(subname),' ERROR: Tape ',t,' is empty' + call endrun() + end if + end do + + ! Check that the number of history files declared does not exceed + ! the maximum allowed. + + if (ntapes > max_tapes) then + write(iulog,*) trim(subname),' ERROR: Too many history files declared, max_tapes=',max_tapes + call endrun() + end if + + ! Change 1d output per tape output flag if requested - only for history + ! tapes where 2d xy averaging is not enabled + + do t = 1,ntapes + if (hist_type1d_pertape(t) /= ' ' .and. (.not. hist_dov2xy(t))) then + select case (trim(hist_type1d_pertape(t))) + case ('PFTS','COLS', 'LAND', 'GRID') + if ( masterproc ) & + write(iulog,*)'history tape ',t,' will have 1d output type of ',hist_type1d_pertape(t) + case default + write(iulog,*) trim(subname),' ERROR: unknown namelist type1d per tape=',hist_type1d_pertape(t) + call endrun() + end select + end if + end do + + if (masterproc) then + write(iulog,*) 'There will be a total of ',ntapes,' history tapes' + do t=1,ntapes + write(iulog,*) + if (hist_nhtfrq(t) == 0) then + write(iulog,*)'History tape ',t,' write frequency is MONTHLY' + else + write(iulog,*)'History tape ',t,' write frequency = ',hist_nhtfrq(t) + endif + if (hist_dov2xy(t)) then + write(iulog,*)'All fields on history tape ',t,' are grid averaged' + else + write(iulog,*)'All fields on history tape ',t,' are not grid averaged' + end if + write(iulog,*)'Number of time samples on history tape ',t,' is ',hist_mfilt(t) + write(iulog,*)'Output precision on history tape ',t,'=',hist_ndens(t) + write(iulog,*) + end do + call shr_sys_flush(iulog) + end if + + ! Set flag indicating h-tape contents are now defined (needed by masterlist_addfld) + + htapes_defined = .true. + + end subroutine htapes_fieldlist + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: htape_addfld +! +! !INTERFACE: + subroutine htape_addfld (t, f, avgflag) +! +! !DESCRIPTION: +! Add a field to the active list for a history tape. Copy the data from +! the master field list to the active list for the tape. +! +! !USES: +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! history tape index + integer, intent(in) :: f ! field index from master field list + character(len=1), intent(in) :: avgflag ! time averaging flag +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: n ! field index on defined tape + character(len=8) :: type1d ! clm pointer 1d type + character(len=8) :: type1d_out ! history buffer 1d type + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: numa ! total number of atm cells across all processors + integer :: numg ! total number of gridcells across all processors + integer :: numl ! total number of landunits across all processors + integer :: numc ! total number of columns across all processors + integer :: nump ! total number of pfts across all processors + integer :: num2d ! size of second dimension (e.g. .number of vertical levels) + integer :: beg1d_out,end1d_out ! history output per-proc 1d beginning and ending indices + integer :: num1d_out ! history output 1d size + character(len=*),parameter :: subname = 'htape_addfld' +!----------------------------------------------------------------------- + + ! Ensure that it is not to late to add a field to the history tape + + if (htapes_defined) then + write(iulog,*) trim(subname),' ERROR: attempt to add field ', & + masterlist(f)%field%name, ' after history files are set' + call endrun() + end if + + tape(t)%nflds = tape(t)%nflds + 1 + n = tape(t)%nflds + + ! Copy field information + + tape(t)%hlist(n)%field = masterlist(f)%field + + ! Determine bounds + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + call get_proc_global(numg, numl, numc, nump) + + ! Modify type1d_out if necessary + + if (hist_dov2xy(t)) then + + ! If xy output averaging is requested, set output 1d type to grlnd + ! ***NOTE- the following logic is what permits non lat/lon grids to + ! be written to clm history file + + type1d = tape(t)%hlist(n)%field%type1d + + if (type1d == nameg .or. & + type1d == namel .or. & + type1d == namec .or. & + type1d == namep) then + tape(t)%hlist(n)%field%type1d_out = grlnd + end if + if (type1d == grlnd) then + tape(t)%hlist(n)%field%type1d_out = grlnd + end if + + else if (hist_type1d_pertape(t) /= ' ') then + + ! Set output 1d type based on namelist setting of hist_type1d_pertape + ! Only applies to tapes when xy output is not required + + type1d = tape(t)%hlist(n)%field%type1d + + select case (trim(hist_type1d_pertape(t))) + case('GRID') + tape(t)%hlist(n)%field%type1d_out = nameg + case('LAND') + tape(t)%hlist(n)%field%type1d_out = namel + case('COLS') + tape(t)%hlist(n)%field%type1d_out = namec + case ('PFTS') + tape(t)%hlist(n)%field%type1d_out = namep + case default + write(iulog,*) trim(subname),' ERROR: unknown input hist_type1d_pertape= ', hist_type1d_pertape(t) + call endrun() + end select + + endif + + ! Determine output 1d dimensions + + type1d_out = tape(t)%hlist(n)%field%type1d_out + if (type1d_out == grlnd) then + beg1d_out = begg + end1d_out = endg + num1d_out = numg + else if (type1d_out == nameg) then + beg1d_out = begg + end1d_out = endg + num1d_out = numg + else if (type1d_out == namel) then + beg1d_out = begl + end1d_out = endl + num1d_out = numl + else if (type1d_out == namec) then + beg1d_out = begc + end1d_out = endc + num1d_out = numc + else if (type1d_out == namep) then + beg1d_out = begp + end1d_out = endp + num1d_out = nump + else + write(iulog,*) trim(subname),' ERROR: incorrect value of type1d_out= ',type1d_out + call endrun() + end if + + tape(t)%hlist(n)%field%beg1d_out = beg1d_out + tape(t)%hlist(n)%field%end1d_out = end1d_out + tape(t)%hlist(n)%field%num1d_out = num1d_out + + ! Alloccate and initialize history buffer and related info + + num2d = tape(t)%hlist(n)%field%num2d + allocate (tape(t)%hlist(n)%hbuf(beg1d_out:end1d_out,num2d)) + allocate (tape(t)%hlist(n)%nacs(beg1d_out:end1d_out,num2d)) + tape(t)%hlist(n)%hbuf(:,:) = 0._r8 + tape(t)%hlist(n)%nacs(:,:) = 0 + + ! Set time averaging flag based on masterlist setting or + ! override the default averaging flag with namelist setting + + select case (avgflag) + case (' ') + tape(t)%hlist(n)%avgflag = masterlist(f)%avgflag(t) + case ('A','I','X','M') + tape(t)%hlist(n)%avgflag = avgflag + case default + write(iulog,*) trim(subname),' ERROR: unknown avgflag=', avgflag + call endrun() + end select + + end subroutine htape_addfld + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_update_hbuf +! +! !INTERFACE: + subroutine hist_update_hbuf() +! +! !DESCRIPTION: +! Accumulate (or take min, max, etc. as appropriate) input field +! into its history buffer for appropriate tapes. +! +! !USES: +! +! !ARGUMENTS: + implicit none +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: t ! tape index + integer :: f ! field index + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: num2d ! size of second dimension (e.g. number of vertical levels) + character(len=*),parameter :: subname = 'hist_update_hbuf' +!----------------------------------------------------------------------- + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + do t = 1,ntapes +!$OMP PARALLEL DO PRIVATE (f, num2d) + do f = 1,tape(t)%nflds + num2d = tape(t)%hlist(f)%field%num2d + if ( num2d == 1) then + call hist_update_hbuf_field_1d (t, f, begp, endp, begc, endc, begl, endl, begg, endg) + else + call hist_update_hbuf_field_2d (t, f, begp, endp, begc, endc, begl, endl, begg, endg, num2d) + end if + end do +!$OMP END PARALLEL DO + end do + + end subroutine hist_update_hbuf + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_update_hbuf_field_1d +! +! !INTERFACE: + subroutine hist_update_hbuf_field_1d (t, f, begp, endp, begc, endc, begl, endl, begg, endg) +! +! !DESCRIPTION: +! Accumulate (or take min, max, etc. as appropriate) input field +! into its history buffer for appropriate tapes. +! +! !USES: + use clmtype + use subgridAveMod, only : p2g, c2g, l2g + use clm_varcon , only : istice_mec +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + integer, intent(in) :: f ! field index + integer, intent(in) :: begp, endp ! per-proc beginning and ending pft indices + integer, intent(in) :: begc, endc ! per-proc beginning and ending column indices + integer, intent(in) :: begl, endl ! per-proc beginning and ending landunit indices + integer, intent(in) :: begg, endg ! per-proc gridcell ending gridcell indices +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: hpindex ! history pointer index + integer :: k ! gridcell, landunit, column or pft index + integer :: l ! landunit index + integer :: beg1d,end1d ! beginning and ending indices + logical :: checkwt ! true => check weight of pft relative to gridcell + logical :: valid ! true => history operation is valid + logical :: map2gcell ! true => map clm pointer field to gridcell + character(len=8) :: type1d ! 1d clm pointerr type ["gridcell","landunit","column","pft"] + character(len=8) :: type1d_out ! 1d history buffer type ["gridcell","landunit","column","pft"] + character(len=1) :: avgflag ! time averaging flag + character(len=8) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column + character(len=8) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits + character(len=8) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells + real(r8), pointer :: hbuf(:,:) ! history buffer + integer , pointer :: nacs(:,:) ! accumulation counter + integer , pointer :: ltype(:) ! landunit type + integer , pointer :: plandunit(:) ! pft's landunit index + real(r8), pointer :: pwtgcell(:) ! weight of pft relative to corresponding gridcell + real(r8), pointer :: field(:) ! clm 1d pointer field + real(r8) :: field_gcell(begg:endg) ! gricell level field (used if mapping to gridcell is done) + integer j + character(len=*),parameter :: subname = 'hist_update_hbuf_field_1d' +!----------------------------------------------------------------------- + + avgflag = tape(t)%hlist(f)%avgflag + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + beg1d = tape(t)%hlist(f)%field%beg1d + end1d = tape(t)%hlist(f)%field%end1d + type1d = tape(t)%hlist(f)%field%type1d + type1d_out = tape(t)%hlist(f)%field%type1d_out + p2c_scale_type = tape(t)%hlist(f)%field%p2c_scale_type + c2l_scale_type = tape(t)%hlist(f)%field%c2l_scale_type + l2g_scale_type = tape(t)%hlist(f)%field%l2g_scale_type + hpindex = tape(t)%hlist(f)%field%hpindex + field => clmptr_rs(hpindex)%ptr + + ! set variables to check weights when allocate all pfts + + map2gcell = .false. + if (type1d_out == nameg .or. type1d_out == grlnd) then + if (type1d == namep) then + call p2g(begp, endp, begc, endc, begl, endl, begg, endg, field, field_gcell, & + p2c_scale_type, c2l_scale_type, l2g_scale_type) + map2gcell = .true. + else if (type1d == namec) then + call c2g(begc, endc, begl, endl, begg, endg, field, field_gcell, & + c2l_scale_type, l2g_scale_type) + map2gcell = .true. + else if (type1d == namel) then + call l2g(begl, endl, begg, endg, field, field_gcell, & + l2g_scale_type) + map2gcell = .true. + end if + end if + + if (map2gcell) then ! Map to gridcell + + ! note that in this case beg1d = begg and end1d=endg + select case (avgflag) + case ('I') ! Instantaneous + do k = begg,endg + if (field_gcell(k) /= spval) then + hbuf(k,1) = field_gcell(k) + else + hbuf(k,1) = spval + end if + nacs(k,1) = 1 + end do + case ('A') ! Time average + do k = begg,endg + if (field_gcell(k) /= spval) then + if (nacs(k,1) == 0) hbuf(k,1) = 0._r8 + hbuf(k,1) = hbuf(k,1) + field_gcell(k) + nacs(k,1) = nacs(k,1) + 1 + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + end do + case ('X') ! Maximum over time + do k = begg,endg + if (field_gcell(k) /= spval) then + if (nacs(k,1) == 0) hbuf(k,1) = -1.e50_r8 + hbuf(k,1) = max( hbuf(k,1), field_gcell(k) ) + else + hbuf(k,1) = spval + endif + nacs(k,1) = 1 + end do + case ('M') ! Minimum over time + do k = begg,endg + if (field_gcell(k) /= spval) then + if (nacs(k,1) == 0) hbuf(k,1) = +1.e50_r8 + hbuf(k,1) = min( hbuf(k,1), field_gcell(k) ) + else + hbuf(k,1) = spval + endif + nacs(k,1) = 1 + end do + case default + write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag + call endrun() + end select + + else ! Do not map to gridcell + + pwtgcell => pft%wtgcell + plandunit => pft%landunit + ltype => lun%itype + + checkwt = .false. + if (type1d == namep) checkwt = .true. + + select case (avgflag) + case ('I') ! Instantaneous + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + ! Note: some glacier_mec pfts may have zero weight and still be considered valid + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k) /= spval) then + hbuf(k,1) = field(k) + else + hbuf(k,1) = spval + end if + else + hbuf(k,1) = spval + end if + nacs(k,1) = 1 + end do + case ('A') ! Time average + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k) /= spval) then + if (nacs(k,1) == 0) hbuf(k,1) = 0._r8 + hbuf(k,1) = hbuf(k,1) + field(k) + nacs(k,1) = nacs(k,1) + 1 + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + end do + case ('X') ! Maximum over time + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k) /= spval) then + if (nacs(k,1) == 0) hbuf(k,1) = -1.e50_r8 + hbuf(k,1) = max( hbuf(k,1), field(k) ) + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + nacs(k,1) = 1 + end do + case ('M') ! Minimum over time + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k) /= spval) then + if (nacs(k,1) == 0) hbuf(k,1) = +1.e50_r8 + hbuf(k,1) = min( hbuf(k,1), field(k) ) + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + else + if (nacs(k,1) == 0) hbuf(k,1) = spval + end if + nacs(k,1) = 1 + end do + case default + write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag + call endrun() + end select + end if + + end subroutine hist_update_hbuf_field_1d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_update_hbuf_field_2d +! +! !INTERFACE: + subroutine hist_update_hbuf_field_2d (t, f, begp, endp, begc, endc, begl, endl, begg, endg, num2d) +! +! !DESCRIPTION: +! Accumulate (or take min, max, etc. as appropriate) input field +! into its history buffer for appropriate tapes. +! +! !USES: + use clmtype + use subgridAveMod, only : p2g, c2g, l2g + use clm_varcon , only : istice_mec +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + integer, intent(in) :: f ! field index + integer, intent(in) :: begp, endp ! per-proc beginning and ending pft indices + integer, intent(in) :: begc, endc ! per-proc beginning and ending column indices + integer, intent(in) :: begl, endl ! per-proc beginning and ending landunit indices + integer, intent(in) :: begg, endg ! per-proc gridcell ending gridcell indices + integer, intent(in) :: num2d ! size of second dimension +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: hpindex ! history pointer index + integer :: k ! gridcell, landunit, column or pft index + integer :: l ! landunit index + integer :: j ! level index + integer :: beg1d,end1d ! beginning and ending indices + logical :: checkwt ! true => check weight of pft relative to gridcell + logical :: valid ! true => history operation is valid + logical :: map2gcell ! true => map clm pointer field to gridcell + character(len=8) :: type1d ! 1d clm pointerr type ["gridcell","landunit","column","pft"] + character(len=8) :: type1d_out ! 1d history buffer type ["gridcell","landunit","column","pft"] + character(len=1) :: avgflag ! time averaging flag + character(len=8) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column + character(len=8) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits + character(len=8) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells + real(r8), pointer :: hbuf(:,:) ! history buffer + integer , pointer :: nacs(:,:) ! accumulation counter + integer , pointer :: ltype(:) ! landunit type + integer , pointer :: plandunit(:) ! pft's landunit index + real(r8), pointer :: pwtgcell(:) ! weight of pft relative to corresponding gridcell + real(r8), pointer :: field(:,:) ! clm 2d pointer field + real(r8) :: field_gcell(begg:endg,num2d) ! gricell level field (used if mapping to gridcell is done) + character(len=*),parameter :: subname = 'hist_update_hbuf_field_2d' +!----------------------------------------------------------------------- + + avgflag = tape(t)%hlist(f)%avgflag + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + beg1d = tape(t)%hlist(f)%field%beg1d + end1d = tape(t)%hlist(f)%field%end1d + type1d = tape(t)%hlist(f)%field%type1d + type1d_out = tape(t)%hlist(f)%field%type1d_out + p2c_scale_type = tape(t)%hlist(f)%field%p2c_scale_type + c2l_scale_type = tape(t)%hlist(f)%field%c2l_scale_type + l2g_scale_type = tape(t)%hlist(f)%field%l2g_scale_type + hpindex = tape(t)%hlist(f)%field%hpindex + field => clmptr_ra(hpindex)%ptr(:,1:num2d) + + ! set variables to check weights when allocate all pfts + + map2gcell = .false. + if (type1d_out == nameg .or. type1d_out == grlnd) then + if (type1d == namep) then + call p2g(begp, endp, begc, endc, begl, endl, begg, endg, num2d, field, field_gcell, & + p2c_scale_type, c2l_scale_type, l2g_scale_type) + map2gcell = .true. + else if (type1d == namec) then + call c2g(begc, endc, begl, endl, begg, endg, num2d, field, field_gcell, & + c2l_scale_type, l2g_scale_type) + map2gcell = .true. + else if (type1d == namel) then + call l2g(begl, endl, begg, endg, num2d, field, field_gcell, & + l2g_scale_type) + map2gcell = .true. + end if + end if + + if (map2gcell) then ! Map to gridcell + + ! note that in this case beg1d = begg and end1d=endg + select case (avgflag) + case ('I') ! Instantaneous + do j = 1,num2d + do k = begg,endg + if (field_gcell(k,j) /= spval) then + hbuf(k,j) = field_gcell(k,j) + else + hbuf(k,j) = spval + end if + nacs(k,j) = 1 + end do + end do + case ('A') ! Time average + do j = 1,num2d + do k = begg,endg + if (field_gcell(k,j) /= spval) then + if (nacs(k,j) == 0) hbuf(k,j) = 0._r8 + hbuf(k,j) = hbuf(k,j) + field_gcell(k,j) + nacs(k,j) = nacs(k,j) + 1 + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + endif + end do + end do + case ('X') ! Maximum over time + do j = 1,num2d + do k = begg,endg + if (field_gcell(k,j) /= spval) then + if (nacs(k,j) == 0) hbuf(k,j) = -1.e50_r8 + hbuf(k,j) = max( hbuf(k,j), field_gcell(k,j) ) + else + hbuf(k,j) = spval + endif + nacs(k,j) = 1 + end do + end do + case ('M') ! Minimum over time + do j = 1,num2d + do k = begg,endg + if (field_gcell(k,j) /= spval) then + if (nacs(k,j) == 0) hbuf(k,j) = +1.e50_r8 + hbuf(k,j) = min( hbuf(k,j), field_gcell(k,j) ) + else + hbuf(k,j) = spval + endif + nacs(k,j) = 1 + end do + end do + case default + write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag + call endrun() + end select + + else ! Do not map to gridcell + + ! Note that since field points to an array section the + ! bounds are field(1:end1d-beg1d+1, num2d) - therefore + ! need to do the shifting below + + pwtgcell => pft%wtgcell + plandunit => pft%landunit + ltype => lun%itype + + checkwt = .false. + if (type1d == namep) checkwt = .true. + + select case (avgflag) + case ('I') ! Instantaneous + do j = 1,num2d + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k-beg1d+1,j) /= spval) then + hbuf(k,j) = field(k-beg1d+1,j) + else + hbuf(k,j) = spval + end if + else + hbuf(k,j) = spval + end if + nacs(k,j) = 1 + end do + end do + case ('A') ! Time average + do j = 1,num2d + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k-beg1d+1,j) /= spval) then + if (nacs(k,j) == 0) hbuf(k,j) = 0._r8 + hbuf(k,j) = hbuf(k,j) + field(k-beg1d+1,j) + nacs(k,j) = nacs(k,j) + 1 + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + end if + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + end if + end do + end do + case ('X') ! Maximum over time + do j = 1,num2d + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k-beg1d+1,j) /= spval) then + if (nacs(k,j) == 0) hbuf(k,j) = -1.e50_r8 + hbuf(k,j) = max( hbuf(k,j), field(k-beg1d+1,j) ) + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + end if + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + end if + nacs(k,j) = 1 + end do + end do + case ('M') ! Minimum over time + do j = 1,num2d + do k = beg1d,end1d + valid = .true. + if (checkwt) then + l = plandunit(k) + if (pwtgcell(k) == 0._r8 .and. ltype(l)/=istice_mec) valid = .false. + end if + if (valid) then + if (field(k-beg1d+1,j) /= spval) then + if (nacs(k,j) == 0) hbuf(k,j) = +1.e50_r8 + hbuf(k,j) = min( hbuf(k,j), field(k-beg1d+1,j)) + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + end if + else + if (nacs(k,j) == 0) hbuf(k,j) = spval + end if + nacs(k,j) = 1 + end do + end do + case default + write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag + call endrun() + end select + end if + + end subroutine hist_update_hbuf_field_2d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hfields_normalize +! +! !INTERFACE: + subroutine hfields_normalize (t) +! +! !DESCRIPTION: +! Normalize fields on a history file by the number of accumulations. +! Loop over fields on the tape. Need averaging flag and number of +! accumulations to perform normalization. +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + integer :: k ! 1d index + integer :: j ! 2d index + logical :: aflag ! averaging flag + integer :: beg1d_out,end1d_out ! hbuf 1d beginning and ending indices + integer :: num2d ! hbuf size of second dimension (e.g. number of vertical levels) + character(len=1) :: avgflag ! averaging flag + real(r8), pointer :: hbuf(:,:) ! history buffer + integer , pointer :: nacs(:,:) ! accumulation counter + character(len=*),parameter :: subname = 'hfields_normalize' +!----------------------------------------------------------------------- +!dir$ inlinenever hfields_normalize + + ! Normalize by number of accumulations for time averaged case + + do f = 1,tape(t)%nflds + avgflag = tape(t)%hlist(f)%avgflag + beg1d_out = tape(t)%hlist(f)%field%beg1d_out + end1d_out = tape(t)%hlist(f)%field%end1d_out + num2d = tape(t)%hlist(f)%field%num2d + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + if (avgflag == 'A') then + aflag = .true. + else + aflag = .false. + end if + + do j = 1, num2d + do k = beg1d_out, end1d_out + if (aflag .and. nacs(k,j) /= 0) then + hbuf(k,j) = hbuf(k,j) / float(nacs(k,j)) + end if + end do + end do + end do + + end subroutine hfields_normalize + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hfields_zero +! +! !INTERFACE: + subroutine hfields_zero (t) +! +! !DESCRIPTION: +! Zero out accumulation and history buffers for a given history tape. +! Loop through fields on the tape. +! +! !USES: +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + character(len=*),parameter :: subname = 'hfields_zero' +!----------------------------------------------------------------------- + + do f = 1,tape(t)%nflds + tape(t)%hlist(f)%hbuf(:,:) = 0._r8 + tape(t)%hlist(f)%nacs(:,:) = 0 + end do + + end subroutine hfields_zero + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: htape_create +! +! !INTERFACE: + subroutine htape_create (t, histrest) +! +! !DESCRIPTION: +! Define contents of history file t. Issue the required netcdf +! wrapper calls to define the history file contents. +! +! !USES: + use clmtype + use clm_varpar , only : nlevgrnd, nlevlak, numrad, maxpatch_glcmec + use clm_varctl , only : caseid, ctitle, fsurdat, finidat, fpftcon, & + version, hostname, username, conventions, source + use domainMod , only : ldomain + use fileutils , only : get_filename +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + logical, intent(in), optional :: histrest ! if creating the history restart file +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + integer :: p,c,l,n ! indices + integer :: ier ! error code + integer :: num2d ! size of second dimension (e.g. number of vertical levels) + integer :: dimid ! dimension id temporary + integer :: dim1id(1) ! netCDF dimension id + integer :: dim2id(2) ! netCDF dimension id + integer :: ndims ! dimension counter + integer :: omode ! returned mode from netCDF call + integer :: ncprec ! output netCDF write precision + integer :: ret ! netCDF error status + integer :: nump ! total number of pfts across all processors + integer :: numc ! total number of columns across all processors + integer :: numl ! total number of landunits across all processors + integer :: numg ! total number of gridcells across all processors + integer :: numa ! total number of atm cells across all processors + logical :: lhistrest ! local history restart flag + type(file_desc_t) :: lnfid ! local file id + character(len= 8) :: curdate ! current date + character(len= 8) :: curtime ! current time + character(len=256) :: name ! name of attribute + character(len=256) :: units ! units of attribute + character(len=256) :: str ! global attribute string + character(len= 1) :: avgflag ! time averaging flag + character(len=*),parameter :: subname = 'htape_create' +!----------------------------------------------------------------------- + + if ( present(histrest) )then + lhistrest = histrest + else + lhistrest = .false. + end if + + ! Determine necessary indices + + call get_proc_global(numg, numl, numc, nump) + + ! define output write precsion for tape + + ncprec = tape(t)%ncprec + + ! Create new netCDF file. It will be in define mode + + if ( .not. lhistrest )then + if (masterproc) then + write(iulog,*) trim(subname),' : Opening netcdf htape ', & + trim(locfnh(t)) + call shr_sys_flush(iulog) + end if + call ncd_pio_createfile(lnfid, trim(locfnh(t))) + call ncd_putatt(lnfid, ncd_global, 'title', 'CLM History file information' ) + call ncd_putatt(lnfid, ncd_global, 'comment', & + "NOTE: None of the variables are weighted by land fraction!" ) + else + if (masterproc) then + write(iulog,*) trim(subname),' : Opening netcdf rhtape ', & + trim(locfnhr(t)) + call shr_sys_flush(iulog) + end if + call ncd_pio_createfile(lnfid, trim(locfnhr(t))) + call ncd_putatt(lnfid, ncd_global, 'title', & + 'CLM Restart History information, required to continue a simulation' ) + call ncd_putatt(lnfid, ncd_global, 'comment', & + "This entire file NOT needed for startup or branch simulations") + end if + + ! Create global attributes. Attributes are used to store information + ! about the data set. Global attributes are information about the + ! data set as a whole, as opposed to a single variable + + call ncd_putatt(lnfid, ncd_global, 'Conventions', trim(conventions)) + call getdatetime(curdate, curtime) + str = 'created on ' // curdate // ' ' // curtime + call ncd_putatt(lnfid, ncd_global, 'history' , trim(str)) + call ncd_putatt(lnfid, ncd_global, 'source' , trim(source)) + call ncd_putatt(lnfid, ncd_global, 'hostname', trim(hostname)) + call ncd_putatt(lnfid, ncd_global, 'username', trim(username)) + call ncd_putatt(lnfid, ncd_global, 'version' , trim(version)) + + str = & + '$Id: histFileMod.F90 55821 2013-12-04 08:15:53Z erik $' + call ncd_putatt(lnfid, ncd_global, 'revision_id', trim(str)) + call ncd_putatt(lnfid, ncd_global, 'case_title', trim(ctitle)) + call ncd_putatt(lnfid, ncd_global, 'case_id', trim(caseid)) + str = get_filename(fsurdat) + call ncd_putatt(lnfid, ncd_global, 'Surface_dataset', trim(str)) + if (finidat == ' ') then + str = 'arbitrary initialization' + else + str = get_filename(finidat) + endif + call ncd_putatt(lnfid, ncd_global, 'Initial_conditions_dataset', trim(str)) + str = get_filename(fpftcon) + call ncd_putatt(lnfid, ncd_global, 'PFT_physiological_constants_dataset', trim(str)) + + ! Define dimensions. + ! Time is an unlimited dimension. Character string is treated as an array of characters. + + ! Global uncompressed dimensions (including non-land points) + if (ldomain%isgrid2d) then + call ncd_defdim(lnfid, 'lon' , ldomain%ni, dimid) + call ncd_defdim(lnfid, 'lat' , ldomain%nj, dimid) + else + call ncd_defdim(lnfid, trim(grlnd), ldomain%ns, dimid) + end if + + ! Global compressed dimensions (not including non-land points) + call ncd_defdim(lnfid, trim(nameg), numg, dimid) + call ncd_defdim(lnfid, trim(namel), numl, dimid) + call ncd_defdim(lnfid, trim(namec), numc, dimid) + call ncd_defdim(lnfid, trim(namep), nump, dimid) + + ! "level" dimensions + call ncd_defdim(lnfid, 'levgrnd', nlevgrnd, dimid) + call ncd_defdim(lnfid, 'levlak' , nlevlak, dimid) + call ncd_defdim(lnfid, 'numrad' , numrad , dimid) + if (maxpatch_glcmec > 0) then + call ncd_defdim(lnfid, 'glc_nec' , maxpatch_glcmec , dimid) + end if + + do n = 1,num_subs + call ncd_defdim(lnfid, subs_name(n), subs_dim(n), dimid) + end do + call ncd_defdim(lnfid, 'string_length', 8, strlen_dimid) + + if ( .not. lhistrest )then + call ncd_defdim(lnfid, 'hist_interval', 2, hist_interval_dimid) + call ncd_defdim(lnfid, 'time', ncd_unlimited, time_dimid) + nfid(t) = lnfid + if (masterproc)then + write(iulog,*) trim(subname), & + ' : Successfully defined netcdf history file ',t + call shr_sys_flush(iulog) + end if + else + ncid_hist(t) = lnfid + if (masterproc)then + write(iulog,*) trim(subname), & + ' : Successfully defined netcdf restart history file ',t + call shr_sys_flush(iulog) + end if + end if + + end subroutine htape_create + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: htape_timeconst3D +! +! !INTERFACE: + subroutine htape_timeconst3D(t, mode) +! +! !DESCRIPTION: +! Write time constant 3D variables to history tapes. +! Only write out when this subroutine is called (normally only for +! primary history files at very first time-step, nstep=0). +! Issue the required netcdf wrapper calls to define the history file +! contents. +! +! !USES: + use clmtype + use subgridAveMod , only : c2g + use clm_varpar , only : nlevgrnd + use shr_string_mod, only : shr_string_listAppend + use domainMod , only : ldomain +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + character(len=*), intent(in) :: mode ! 'define' or 'write' +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: c,l,lev,ifld ! indices + integer :: ier ! error status + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + character(len=max_chars) :: long_name ! variable long name + character(len=max_namlen):: varname ! variable name + character(len=max_namlen):: units ! variable units + character(len=8) :: l2g_scale_type ! scale type for subgrid averaging of landunits to grid cells + real(r8), pointer :: histi(:,:) ! temporary + real(r8), pointer :: histo(:,:) ! temporary + type(landunit_type), pointer :: lptr ! pointer to landunit derived subtype + type(column_type) , pointer :: cptr ! pointer to column derived subtype + integer, parameter :: nflds = 6 ! Number of 3D time-constant fields + character(len=*),parameter :: subname = 'htape_timeconst3D' + character(len=*),parameter :: varnames(nflds) = (/ & + 'ZSOI ', & + 'DZSOI ', & + 'WATSAT', & + 'SUCSAT', & + 'BSW ', & + 'HKSAT ' & + /) +!----------------------------------------------------------------------- + +!------------------------------------------------------------------------------- +!*** Non-time varying 3D fields *** +!*** Only write out when this subroutine is called *** +!*** Normally only called once for primary tapes *** +!------------------------------------------------------------------------------- + + if (mode == 'define') then + + do ifld = 1,nflds + ! Field indices MUST match varnames array order above! + if (ifld == 1) then + long_name='soil depth'; units = 'm' + else if (ifld == 2) then + long_name='soil thickness'; units = 'm' + else if (ifld == 3) then + long_name='saturated soil water content (porosity)'; units = 'mm3/mm3' + else if (ifld == 4) then + long_name='saturated soil matric potential'; units = 'mm' + else if (ifld == 5) then + long_name='slope of soil water retention curve'; units = 'unitless' + else if (ifld == 6) then + long_name='saturated hydraulic conductivity'; units = 'unitless' + else + call endrun( subname//' ERROR: bad 3D time-constant field index' ) + end if + if (tape(t)%dov2xy) then + if (ldomain%isgrid2d) then + call ncd_defvar(ncid=nfid(t), varname=trim(varnames(ifld)), xtype=tape(t)%ncprec,& + dim1name='lon', dim2name='lat', dim3name='levgrnd', & + long_name=long_name, units=units, missing_value=spval, fill_value=spval) + else + call ncd_defvar(ncid=nfid(t), varname=trim(varnames(ifld)), xtype=tape(t)%ncprec, & + dim1name=grlnd, dim2name='levgrnd', & + long_name=long_name, units=units, missing_value=spval, fill_value=spval) + end if + else + call ncd_defvar(ncid=nfid(t), varname=trim(varnames(ifld)), xtype=tape(t)%ncprec, & + dim1name=namec, dim2name='levgrnd', & + long_name=long_name, units=units, missing_value=spval, fill_value=spval) + end if + call shr_string_listAppend(TimeConst3DVars,varnames(ifld)) + end do + + else if (mode == 'write') then + + ! Set pointers into derived type and get necessary bounds + + lptr => lun + cptr => col + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + allocate(histi(begc:endc,nlevgrnd), stat=ier) + if (ier /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation error for histi'; call endrun() + end if + + ! Write time constant fields + + if (tape(t)%dov2xy) then + allocate(histo(begg:endg,nlevgrnd), stat=ier) + if (ier /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation error for histo'; call endrun() + end if + end if + + do ifld = 1,nflds + + ! WJS (10-25-11): Note about l2g_scale_type in the following: ZSOI & DZSOI are + ! currently constant in space, except for urban points, so their scale type + ! doesn't matter at the moment as long as it excludes urban points. I am using + ! 'nonurb' so that the values are output everywhere where the fields are + ! constant (i.e., everywhere except urban points). For the other fields, I am + ! using 'veg' to be consistent with the l2g_scale_type that is now used for many + ! of the 3-d time-variant fields; in theory, though, one might want versions of + ! these variables output for different landunits. + + ! Field indices MUST match varnames array order above! + if (ifld == 1) then ! ZSOI + l2g_scale_type = 'nonurb' + else if (ifld == 2) then ! DZSOI + l2g_scale_type = 'nonurb' + else if (ifld == 3) then ! WATSAT + l2g_scale_type = 'veg' + else if (ifld == 4) then ! SUCSAT + l2g_scale_type = 'veg' + else if (ifld == 5) then ! BSW + l2g_scale_type = 'veg' + else if (ifld == 6) then ! HKSAT + l2g_scale_type = 'veg' + end if + + histi(:,:) = spval + do lev = 1,nlevgrnd + do c = begc, endc + l = cptr%landunit(c) + if (.not. lptr%lakpoi(l)) then + ! Field indices MUST match varnames array order above! + if (ifld ==1) histi(c,lev) = cps%z(c,lev) + if (ifld ==2) histi(c,lev) = cps%dz(c,lev) + if (ifld ==3) histi(c,lev) = cps%watsat(c,lev) + if (ifld ==4) histi(c,lev) = cps%sucsat(c,lev) + if (ifld ==5) histi(c,lev) = cps%bsw(c,lev) + if (ifld ==6) histi(c,lev) = cps%hksat(c,lev) + end if + end do + end do + if (tape(t)%dov2xy) then + histo(:,:) = spval + call c2g(begc, endc, begl, endl, begg, endg, nlevgrnd, histi, histo, & + c2l_scale_type='unity', l2g_scale_type=l2g_scale_type) + + if (ldomain%isgrid2d) then + call ncd_io(varname=trim(varnames(ifld)), dim1name=grlnd, & + data=histo, ncid=nfid(t), flag='write') + else + call ncd_io(varname=trim(varnames(ifld)), dim1name=grlnd, & + data=histo, ncid=nfid(t), flag='write') + end if + else + call ncd_io(varname=trim(varnames(ifld)), dim1name=namec, & + data=histi, ncid=nfid(t), flag='write') + end if + end do + + if (tape(t)%dov2xy) deallocate(histo) + deallocate(histi) + + end if ! (define/write mode + + end subroutine htape_timeconst3D + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: htape_timeconst +! +! !INTERFACE: + subroutine htape_timeconst(t, mode) +! +! !DESCRIPTION: +! Write time constant values to primary history tape. +! Issue the required netcdf wrapper calls to define the history file +! contents. +! +! !USES: + use clmtype + use clm_varcon , only : zsoi, zlak, secspday + use domainMod , only : ldomain, lon1d, lat1d + use clm_time_manager, only : get_nstep, get_curr_date, get_curr_time + use clm_time_manager, only : get_ref_date, get_calendar, NO_LEAP_C, GREGORIAN_C +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + character(len=*), intent(in) :: mode ! 'define' or 'write' +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: vid,n,i,j,m ! indices + integer :: nstep ! current step + integer :: mcsec ! seconds of current date + integer :: mdcur ! current day + integer :: mscur ! seconds of current day + integer :: mcdate ! current date + integer :: yr,mon,day,nbsec ! year,month,day,seconds components of a date + integer :: hours,minutes,secs ! hours,minutes,seconds of hh:mm:ss + character(len= 10) :: basedate ! base date (yyyymmdd) + character(len= 8) :: basesec ! base seconds + character(len= 8) :: cdate ! system date + character(len= 8) :: ctime ! system time + real(r8):: time ! current time + real(r8):: timedata(2) ! time interval boundaries + integer :: dim1id(1) ! netCDF dimension id + integer :: dim2id(2) ! netCDF dimension id + integer :: varid ! netCDF variable id + type(Var_desc_t) :: vardesc ! netCDF variable description + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + character(len=max_chars) :: long_name ! variable long name + character(len=max_namlen):: varname ! variable name + character(len=max_namlen):: units ! variable units + character(len=max_namlen):: cal ! calendar from the time-manager + character(len=max_namlen):: caldesc ! calendar description to put on file + character(len=256):: str ! global attribute string + real(r8), pointer :: histo(:,:) ! temporary + type(landunit_type), pointer :: lptr ! pointer to landunit derived subtype + type(column_type) , pointer :: cptr ! pointer to column derived subtype + integer :: status + + character(len=*),parameter :: subname = 'htape_timeconst' +!----------------------------------------------------------------------- + + !------------------------------------------------------------------------------- + !*** Time constant grid variables only on first time-sample of file *** + !------------------------------------------------------------------------------- + if (tape(t)%ntimes == 1) then + if (mode == 'define') then + call ncd_defvar(varname='levgrnd', xtype=tape(t)%ncprec, & + dim1name='levgrnd', & + long_name='coordinate soil levels', units='m', ncid=nfid(t)) + call ncd_defvar(varname='levlak', xtype=tape(t)%ncprec, & + dim1name='levlak', & + long_name='coordinate lake levels', units='m', ncid=nfid(t)) + elseif (mode == 'write') then + call ncd_io(varname='levgrnd', data=zsoi , ncid=nfid(t), flag='write') + call ncd_io(varname='levlak' , data=zlak , ncid=nfid(t), flag='write') + endif + endif + + !------------------------------------------------------------------------------- + !*** Time definition variables *** + !------------------------------------------------------------------------------- + + ! For define mode -- only do this for first time-sample + if (mode == 'define' .and. tape(t)%ntimes == 1) then + call get_ref_date(yr, mon, day, nbsec) + nstep = get_nstep() + hours = nbsec / 3600 + minutes = (nbsec - hours*3600) / 60 + secs = (nbsec - hours*3600 - minutes*60) + write(basedate,80) yr,mon,day +80 format(i4.4,'-',i2.2,'-',i2.2) + write(basesec ,90) hours, minutes, secs +90 format(i2.2,':',i2.2,':',i2.2) + + dim1id(1) = time_dimid + str = 'days since ' // basedate // " " // basesec + call ncd_defvar(nfid(t), 'time', tape(t)%ncprec, 1, dim1id, varid, & + long_name='time',units=str) + cal = get_calendar() + if ( trim(cal) == NO_LEAP_C )then + caldesc = "noleap" + else if ( trim(cal) == GREGORIAN_C )then + caldesc = "gregorian" + end if + call ncd_putatt(nfid(t), varid, 'calendar', caldesc) + call ncd_putatt(nfid(t), varid, 'bounds', 'time_bounds') + + dim1id(1) = time_dimid + call ncd_defvar(nfid(t) , 'mcdate', ncd_int, 1, dim1id , varid, & + long_name = 'current date (YYYYMMDD)') + call ncd_defvar(nfid(t) , 'mcsec' , ncd_int, 1, dim1id , varid, & + long_name = 'current seconds of current date', units='s') + call ncd_defvar(nfid(t) , 'mdcur' , ncd_int, 1, dim1id , varid, & + long_name = 'current day (from base day)') + call ncd_defvar(nfid(t) , 'mscur' , ncd_int, 1, dim1id , varid, & + long_name = 'current seconds of current day') + call ncd_defvar(nfid(t) , 'nstep' , ncd_int, 1, dim1id , varid, & + long_name = 'time step') + + dim2id(1) = hist_interval_dimid; dim2id(2) = time_dimid + call ncd_defvar(nfid(t), 'time_bounds', ncd_double, 2, dim2id, varid, & + long_name = 'history time interval endpoints') + + dim2id(1) = strlen_dimid; dim2id(2) = time_dimid + call ncd_defvar(nfid(t), 'date_written', ncd_char, 2, dim2id, varid) + call ncd_defvar(nfid(t), 'time_written', ncd_char, 2, dim2id, varid) + + if ( len_trim(TimeConst3DVars_Filename) > 0 )then + call ncd_putatt(nfid(t), ncd_global, 'Time_constant_3Dvars_filename', & + trim(TimeConst3DVars_Filename)) + end if + if ( len_trim(TimeConst3DVars) > 0 )then + call ncd_putatt(nfid(t), ncd_global, 'Time_constant_3Dvars', & + trim(TimeConst3DVars)) + end if + + elseif (mode == 'write') then + + call get_curr_time (mdcur, mscur) + call get_curr_date (yr, mon, day, mcsec) + mcdate = yr*10000 + mon*100 + day + nstep = get_nstep() + + call ncd_io('mcdate', mcdate, 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('mcsec' , mcsec , 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('mdcur' , mdcur , 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('mscur' , mscur , 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('nstep' , nstep , 'write', nfid(t), nt=tape(t)%ntimes) + + time = mdcur + mscur/secspday + call ncd_io('time' , time , 'write', nfid(t), nt=tape(t)%ntimes) + + timedata(1) = tape(t)%begtime + timedata(2) = time + call ncd_io('time_bounds', timedata, 'write', nfid(t), nt=tape(t)%ntimes) + + call getdatetime (cdate, ctime) + call ncd_io('date_written', cdate, 'write', nfid(t), nt=tape(t)%ntimes) + + call ncd_io('time_written', ctime, 'write', nfid(t), nt=tape(t)%ntimes) + + endif + + !------------------------------------------------------------------------------- + !*** Grid definition variables *** + !------------------------------------------------------------------------------- + ! For define mode -- only do this for first time-sample + if (mode == 'define' .and. tape(t)%ntimes == 1) then + + if (ldomain%isgrid2d) then + call ncd_defvar(varname='lon', xtype=tape(t)%ncprec, dim1name='lon', & + long_name='coordinate longitude', units='degrees_east', & + ncid=nfid(t), missing_value=spval, fill_value=spval) + else + call ncd_defvar(varname='lon', xtype=tape(t)%ncprec, & + dim1name=grlnd, & + long_name='coordinate longitude', units='degrees_east', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + end if + if (ldomain%isgrid2d) then + call ncd_defvar(varname='lat', xtype=tape(t)%ncprec, dim1name='lat', & + long_name='coordinate latitude', units='degrees_north', & + ncid=nfid(t), missing_value=spval, fill_value=spval) + else + call ncd_defvar(varname='lat', xtype=tape(t)%ncprec, & + dim1name=grlnd, & + long_name='coordinate latitude', units='degrees_north', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + end if + if (ldomain%isgrid2d) then + call ncd_defvar(varname='area', xtype=tape(t)%ncprec, & + dim1name='lon', dim2name='lat',& + long_name='grid cell areas', units='km^2', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + else + call ncd_defvar(varname='area', xtype=tape(t)%ncprec, & + dim1name=grlnd, & + long_name='grid cell areas', units='km^2', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + end if + if (ldomain%isgrid2d) then + call ncd_defvar(varname='topo', xtype=tape(t)%ncprec, & + dim1name='lon', dim2name='lat',& + long_name='grid cell topography', units='m', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + else + call ncd_defvar(varname='topo', xtype=tape(t)%ncprec, & + dim1name=grlnd, & + long_name='grid cell topography', units='m', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + end if + if (ldomain%isgrid2d) then + call ncd_defvar(varname='landfrac', xtype=tape(t)%ncprec, & + dim1name='lon', dim2name='lat', & + long_name='land fraction', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + else + call ncd_defvar(varname='landfrac', xtype=tape(t)%ncprec, & + dim1name=grlnd, & + long_name='land fraction', ncid=nfid(t), & + missing_value=spval, fill_value=spval) + end if + if (ldomain%isgrid2d) then + call ncd_defvar(varname='landmask', xtype=ncd_int, & + dim1name='lon', dim2name='lat', & + long_name='land/ocean mask (0.=ocean and 1.=land)', ncid=nfid(t), & + imissing_value=ispval, ifill_value=ispval) + else + call ncd_defvar(varname='landmask', xtype=ncd_int, & + dim1name=grlnd, & + long_name='land/ocean mask (0.=ocean and 1.=land)', ncid=nfid(t), & + imissing_value=ispval, ifill_value=ispval) + end if + if (ldomain%isgrid2d) then + call ncd_defvar(varname='pftmask' , xtype=ncd_int, & + dim1name='lon', dim2name='lat', & + long_name='pft real/fake mask (0.=fake and 1.=real)', ncid=nfid(t), & + imissing_value=ispval, ifill_value=ispval) + else + call ncd_defvar(varname='pftmask' , xtype=ncd_int, & + dim1name=grlnd, & + long_name='pft real/fake mask (0.=fake and 1.=real)', ncid=nfid(t), & + imissing_value=ispval, ifill_value=ispval) + end if + + else if (mode == 'write') then + + ! Most of this is constant and only needs to be done on tape(t)%ntimes=1 + ! But, some may change for dynamic PFT mode for example + ! Set pointers into derived type and get necessary bounds + + lptr => lun + cptr => col + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + if (ldomain%isgrid2d) then + call ncd_io(varname='lon', data=lon1d, ncid=nfid(t), flag='write') + call ncd_io(varname='lat', data=lat1d, ncid=nfid(t), flag='write') + else + call ncd_io(varname='lon', data=ldomain%lonc, dim1name=grlnd, ncid=nfid(t), flag='write') + call ncd_io(varname='lat', data=ldomain%latc, dim1name=grlnd, ncid=nfid(t), flag='write') + end if + call ncd_io(varname='area' , data=ldomain%area, dim1name=grlnd, ncid=nfid(t), flag='write') + call ncd_io(varname='landfrac', data=ldomain%frac, dim1name=grlnd, ncid=nfid(t), flag='write') + call ncd_io(varname='landmask', data=ldomain%mask, dim1name=grlnd, ncid=nfid(t), flag='write') + call ncd_io(varname='pftmask' , data=ldomain%pftm, dim1name=grlnd, ncid=nfid(t), flag='write') + + end if ! (define/write mode + + end subroutine htape_timeconst + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hfields_write +! +! !INTERFACE: + subroutine hfields_write(t, mode) +! +! !DESCRIPTION: +! Write history tape. Issue the call to write the variable. +! +! !USES: + use clmtype + use domainMod , only : ldomain +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + character(len=*), intent(in) :: mode ! 'define' or 'write' +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + integer :: k ! 1d index + integer :: c,l,p ! indices + integer :: beg1d_out ! on-node 1d hbuf pointer start index + integer :: end1d_out ! on-node 1d hbuf pointer end index + integer :: num1d_out ! size of hbuf first dimension (overall all nodes) + integer :: num2d ! hbuf second dimension size + integer :: nt ! time index + integer :: ier ! error status + character(len=1) :: avgflag ! time averaging flag + character(len=max_chars) :: long_name! long name + character(len=max_chars) :: units ! units + character(len=max_namlen):: varname ! variable name + character(len=32) :: avgstr ! time averaging type + character(len=8) :: type1d_out ! history output 1d type + character(len=8) :: type2d ! history output 2d type + character(len=32) :: dim1name ! temporary + character(len=32) :: dim2name ! temporary + real(r8), pointer :: histo(:,:) ! temporary + real(r8), pointer :: hist1do(:) ! temporary + character(len=*),parameter :: subname = 'hfields_write' +!----------------------------------------------------------------------- + + ! Write/define 1d topological info + + if (.not. tape(t)%dov2xy) then + if (mode == 'define') then + call hfields_1dinfo(t, mode='define') + else if (mode == 'write') then + call hfields_1dinfo(t, mode='write') + end if + end if + + ! Define time-dependent variables create variables and attributes for field list + + do f = 1,tape(t)%nflds + + ! Set history field variables + + varname = tape(t)%hlist(f)%field%name + long_name = tape(t)%hlist(f)%field%long_name + units = tape(t)%hlist(f)%field%units + avgflag = tape(t)%hlist(f)%avgflag + type1d_out = tape(t)%hlist(f)%field%type1d_out + beg1d_out = tape(t)%hlist(f)%field%beg1d_out + end1d_out = tape(t)%hlist(f)%field%end1d_out + num1d_out = tape(t)%hlist(f)%field%num1d_out + type2d = tape(t)%hlist(f)%field%type2d + num2d = tape(t)%hlist(f)%field%num2d + nt = tape(t)%ntimes + + if (mode == 'define') then + + select case (avgflag) + case ('A') + avgstr = 'mean' + case ('I') + avgstr = 'instantaneous' + case ('X') + avgstr = 'maximum' + case ('M') + avgstr = 'minimum' + case default + write(iulog,*) trim(subname),' ERROR: unknown time averaging flag (avgflag)=',avgflag; call endrun() + end select + + if (type1d_out == grlnd) then + if (ldomain%isgrid2d) then + dim1name = 'lon' ; dim2name = 'lat' + else + dim1name = trim(grlnd); dim2name = 'undefined' + end if + else + dim1name = type1d_out ; dim2name = 'undefined' + endif + + if (dim2name == 'undefined') then + if (num2d == 1) then + call ncd_defvar(ncid=nfid(t), varname=varname, xtype=tape(t)%ncprec, & + dim1name=dim1name, dim2name='time', & + long_name=long_name, units=units, cell_method=avgstr, & + missing_value=spval, fill_value=spval) + else + call ncd_defvar(ncid=nfid(t), varname=varname, xtype=tape(t)%ncprec, & + dim1name=dim1name, dim2name=type2d, dim3name='time', & + long_name=long_name, units=units, cell_method=avgstr, & + missing_value=spval, fill_value=spval) + end if + else + if (num2d == 1) then + call ncd_defvar(ncid=nfid(t), varname=varname, xtype=tape(t)%ncprec, & + dim1name=dim1name, dim2name=dim2name, dim3name='time', & + long_name=long_name, units=units, cell_method=avgstr, & + missing_value=spval, fill_value=spval) + else + call ncd_defvar(ncid=nfid(t), varname=varname, xtype=tape(t)%ncprec, & + dim1name=dim1name, dim2name=dim2name, dim3name=type2d, dim4name='time', & + long_name=long_name, units=units, cell_method=avgstr, & + missing_value=spval, fill_value=spval) + end if + endif + + else if (mode == 'write') then + + ! Determine output buffer + + histo => tape(t)%hlist(f)%hbuf + + ! Allocate dynamic memory + + if (num2d == 1) then + allocate(hist1do(beg1d_out:end1d_out), stat=ier) + if (ier /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation'; call endrun() + end if + hist1do(beg1d_out:end1d_out) = histo(beg1d_out:end1d_out,1) + end if + + ! Write history output. Always output land and ocean runoff on xy grid. + + if (num2d == 1) then + call ncd_io(flag='write', varname=varname, & + dim1name=type1d_out, data=hist1do, ncid=nfid(t), nt=nt) + else + call ncd_io(flag='write', varname=varname, & + dim1name=type1d_out, data=histo, ncid=nfid(t), nt=nt) + end if + + + ! Deallocate dynamic memory + + if (num2d == 1) then + deallocate(hist1do) + end if + + end if + + end do + + end subroutine hfields_write + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hfields_1dinfo +! +! !INTERFACE: + subroutine hfields_1dinfo(t, mode) +! +! !DESCRIPTION: +! Write/define 1d info for history tape. +! +! !USES: + use clmtype + use decompMod , only : ldecomp + use domainMod , only : ldomain, ldomain +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: t ! tape index + character(len=*), intent(in) :: mode ! 'define' or 'write' +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: f ! field index + integer :: k ! 1d index + integer :: g,c,l,p ! indices + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: ier ! errir status + real(r8), pointer :: rgarr(:) ! temporary + real(r8), pointer :: rcarr(:) ! temporary + real(r8), pointer :: rlarr(:) ! temporary + real(r8), pointer :: rparr(:) ! temporary + integer , pointer :: igarr(:) ! temporary + integer , pointer :: icarr(:) ! temporary + integer , pointer :: ilarr(:) ! temporary + integer , pointer :: iparr(:) ! temporary + type(file_desc_t) :: ncid ! netcdf file + type(gridcell_type), pointer :: gptr ! pointer to gridcell derived subtype + type(landunit_type), pointer :: lptr ! pointer to landunit derived subtype + type(column_type) , pointer :: cptr ! pointer to column derived subtype + type(pft_type) , pointer :: pptr ! pointer to pft derived subtype + character(len=*),parameter :: subname = 'hfields_1dinfo' +!----------------------------------------------------------------------- + + ncid = nfid(t) + + if (mode == 'define') then + + ! Define gridcell info + + call ncd_defvar(varname='grid1d_lon', xtype=ncd_double, dim1name=nameg, & + long_name='gridcell longitude', units='degrees_east', ncid=ncid) + + call ncd_defvar(varname='grid1d_lat', xtype=ncd_double, dim1name=nameg, & + long_name='gridcell latitude', units='degrees_north', ncid=ncid) + + call ncd_defvar(varname='grid1d_ixy', xtype=ncd_int, dim1name=nameg, & + long_name='2d longitude index of corresponding gridcell', ncid=ncid) + + call ncd_defvar(varname='grid1d_jxy', xtype=ncd_int, dim1name=nameg, & + long_name='2d latitude index of corresponding gridcell', ncid=ncid) + + ! Define landunit info + + call ncd_defvar(varname='land1d_lon', xtype=ncd_double, dim1name=namel, & + long_name='landunit longitude', units='degrees_east', ncid=ncid) + + call ncd_defvar(varname='land1d_lat', xtype=ncd_double, dim1name=namel, & + long_name='landunit latitude', units='degrees_north', ncid=ncid) + + call ncd_defvar(varname='land1d_ixy', xtype=ncd_int, dim1name=namel, & + long_name='2d longitude index of corresponding landunit', ncid=ncid) + + call ncd_defvar(varname='land1d_jxy', xtype=ncd_int, dim1name=namel, & + long_name='2d latitude index of corresponding landunit', ncid=ncid) + + ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 --- Bug 1310 + !call ncd_defvar(varname='land1d_gi', xtype=ncd_int, dim1name='landunit', & + ! long_name='1d grid index of corresponding landunit', ncid=ncid) + ! ---------------------------------------------------------------- + + call ncd_defvar(varname='land1d_wtgcell', xtype=ncd_double, dim1name=namel, & + long_name='landunit weight relative to corresponding gridcell', ncid=ncid) + + call ncd_defvar(varname='land1d_ityplunit', xtype=ncd_int, dim1name=namel, & + long_name='landunit type (vegetated,urban,lake,wetland,glacier or glacier_mec)', & + ncid=ncid) + + ! Define column info + + call ncd_defvar(varname='cols1d_lon', xtype=ncd_double, dim1name=namec, & + long_name='column longitude', units='degrees_east', ncid=ncid) + + call ncd_defvar(varname='cols1d_lat', xtype=ncd_double, dim1name=namec, & + long_name='column latitude', units='degrees_north', ncid=ncid) + + call ncd_defvar(varname='cols1d_ixy', xtype=ncd_int, dim1name=namec, & + long_name='2d longitude index of corresponding column', ncid=ncid) + + call ncd_defvar(varname='cols1d_jxy', xtype=ncd_int, dim1name=namec, & + long_name='2d latitude index of corresponding column', ncid=ncid) + + ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 --- Bug 1310 + !call ncd_defvar(varname='cols1d_gi', xtype=ncd_int, dim1name='column', & + ! long_name='1d grid index of corresponding column', ncid=ncid) + + !call ncd_defvar(varname='cols1d_li', xtype=ncd_int, dim1name='column', & + ! long_name='1d landunit index of corresponding column', ncid=ncid) + ! ---------------------------------------------------------------- + + call ncd_defvar(varname='cols1d_wtgcell', xtype=ncd_double, dim1name=namec, & + long_name='column weight relative to corresponding gridcell', ncid=ncid) + + call ncd_defvar(varname='cols1d_wtlunit', xtype=ncd_double, dim1name=namec, & + long_name='column weight relative to corresponding landunit', ncid=ncid) + + call ncd_defvar(varname='cols1d_itype_lunit', xtype=ncd_int, dim1name=namec, & + long_name='column landunit type (vegetated,urban,lake,wetland,glacier or glacier_mec)', & + ncid=ncid) + + ! Define pft info + + call ncd_defvar(varname='pfts1d_lon', xtype=ncd_double, dim1name=namep, & + long_name='pft longitude', units='degrees_east', ncid=ncid) + + call ncd_defvar(varname='pfts1d_lat', xtype=ncd_double, dim1name=namep, & + long_name='pft latitude', units='degrees_north', ncid=ncid) + + call ncd_defvar(varname='pfts1d_ixy', xtype=ncd_int, dim1name=namep, & + long_name='2d longitude index of corresponding pft', ncid=ncid) + + call ncd_defvar(varname='pfts1d_jxy', xtype=ncd_int, dim1name=namep, & + long_name='2d latitude index of corresponding pft', ncid=ncid) + + ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 --- Bug 1310 + !call ncd_defvar(varname='pfts1d_gi', xtype=ncd_int, dim1name='pft', & + ! long_name='1d grid index of corresponding pft', ncid=ncid) + + !call ncd_defvar(varname='pfts1d_li', xtype=ncd_int, dim1name='pft', & + ! long_name='1d landunit index of corresponding pft', ncid=ncid) + + !call ncd_defvar(varname='pfts1d_ci', xtype=ncd_int, dim1name='pft', & + ! long_name='1d column index of corresponding pft', ncid=ncid) + ! ---------------------------------------------------------------- + + call ncd_defvar(varname='pfts1d_wtgcell', xtype=ncd_double, dim1name=namep, & + long_name='pft weight relative to corresponding gridcell', ncid=ncid) + + call ncd_defvar(varname='pfts1d_wtlunit', xtype=ncd_double, dim1name=namep, & + long_name='pft weight relative to corresponding landunit', ncid=ncid) + + call ncd_defvar(varname='pfts1d_wtcol', xtype=ncd_double, dim1name=namep, & + long_name='pft weight relative to corresponding column', ncid=ncid) + + call ncd_defvar(varname='pfts1d_itype_veg', xtype=ncd_int, dim1name=namep, & + long_name='pft vegetation type', ncid=ncid) + + call ncd_defvar(varname='pfts1d_itype_lunit', xtype=ncd_int, dim1name=namep, & + long_name='pft landunit type (vegetated,urban,lake,wetland,glacier or glacier_mec)', & + ncid=ncid) + + else if (mode == 'write') then + + ! Set pointers into derived type + + gptr => grc + lptr => lun + cptr => col + pptr => pft + + ! Determine bounds + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + allocate(rgarr(begg:endg),rlarr(begl:endl),rcarr(begc:endc),rparr(begp:endp),stat=ier) + if (ier /= 0) call endrun('hfields_1dinfo allocation error of rarrs') + + allocate(igarr(begg:endg),ilarr(begl:endl),icarr(begc:endc),iparr(begp:endp),stat=ier) + if (ier /= 0) call endrun('hfields_1dinfo allocation error of iarrs') + + ! Write gridcell info + + call ncd_io(varname='grid1d_lon', data=gptr%londeg, dim1name=nameg, ncid=ncid, flag='write') + call ncd_io(varname='grid1d_lat', data=gptr%latdeg, dim1name=nameg, ncid=ncid, flag='write') + do g=begg,endg + igarr(g)= mod(ldecomp%gdc2glo(g)-1,ldomain%ni) + 1 + enddo + call ncd_io(varname='grid1d_ixy', data=igarr , dim1name=nameg, ncid=ncid, flag='write') + do g=begg,endg + igarr(g)= (ldecomp%gdc2glo(g) - 1)/ldomain%ni + 1 + enddo + call ncd_io(varname='grid1d_jxy', data=igarr , dim1name=nameg, ncid=ncid, flag='write') + + ! Write landunit info + + do l=begl,endl + rlarr(l) = gptr%londeg(lptr%gridcell(l)) + enddo + call ncd_io(varname='land1d_lon', data=rlarr, dim1name=namel, ncid=ncid, flag='write') + do l=begl,endl + rlarr(l) = gptr%latdeg(lptr%gridcell(l)) + enddo + call ncd_io(varname='land1d_lat', data=rlarr, dim1name=namel, ncid=ncid, flag='write') + do l=begl,endl + ilarr(l) = mod(ldecomp%gdc2glo(lptr%gridcell(l))-1,ldomain%ni) + 1 + enddo + call ncd_io(varname='land1d_ixy', data=ilarr, dim1name=namel, ncid=ncid, flag='write') + do l=begl,endl + ilarr(l) = (ldecomp%gdc2glo(lptr%gridcell(l))-1)/ldomain%ni + 1 + enddo + call ncd_io(varname='land1d_jxy' , data=ilarr , dim1name=namel, ncid=ncid, flag='write') + ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 Bug 1310 + !call ncd_io(varname='land1d_gi' , data=lptr%gridcell, dim1name=namel, ncid=ncid, flag='write') + ! ---------------------------------------------------------------- + call ncd_io(varname='land1d_wtgcell' , data=lptr%wtgcell , dim1name=namel, ncid=ncid, flag='write') + call ncd_io(varname='land1d_ityplunit', data=lptr%itype , dim1name=namel, ncid=ncid, flag='write') + + ! Write column info + + do c=begc,endc + rcarr(c) = gptr%londeg(cptr%gridcell(c)) + enddo + call ncd_io(varname='cols1d_lon', data=rcarr, dim1name=namec, ncid=ncid, flag='write') + do c=begc,endc + rcarr(c) = gptr%latdeg(cptr%gridcell(c)) + enddo + call ncd_io(varname='cols1d_lat', data=rcarr, dim1name=namec, ncid=ncid, flag='write') + do c=begc,endc + icarr(c) = mod(ldecomp%gdc2glo(cptr%gridcell(c))-1,ldomain%ni) + 1 + enddo + call ncd_io(varname='cols1d_ixy', data=icarr, dim1name=namec, ncid=ncid, flag='write') + do c=begc,endc + icarr(c) = (ldecomp%gdc2glo(cptr%gridcell(c))-1)/ldomain%ni + 1 + enddo + call ncd_io(varname='cols1d_jxy' , data=icarr ,dim1name=namec, ncid=ncid, flag='write') + ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 Bug 1310 + !call ncd_io(varname='cols1d_gi' , data=cptr%gridcell, dim1name=namec, ncid=ncid, flag='write') + !call ncd_io(varname='cols1d_li' , data=cptr%landunit, dim1name=namec, ncid=ncid, flag='write') + ! ---------------------------------------------------------------- + call ncd_io(varname='cols1d_wtgcell', data=cptr%wtgcell , dim1name=namec, ncid=ncid, flag='write') + call ncd_io(varname='cols1d_wtlunit', data=cptr%wtlunit , dim1name=namec, ncid=ncid, flag='write') + do c=begc,endc + icarr(c) = lptr%itype(cptr%landunit(c)) + enddo + call ncd_io(varname='cols1d_itype_lunit', data=icarr , dim1name=namec, ncid=ncid, flag='write') + + ! Write pft info + + do p=begp,endp + rparr(p) = gptr%londeg(pptr%gridcell(p)) + enddo + call ncd_io(varname='pfts1d_lon', data=rparr, dim1name=namep, ncid=ncid, flag='write') + do p=begp,endp + rparr(p) = gptr%latdeg(pptr%gridcell(p)) + enddo + call ncd_io(varname='pfts1d_lat', data=rparr, dim1name=namep, ncid=ncid, flag='write') + do p=begp,endp + iparr(p) = mod(ldecomp%gdc2glo(pptr%gridcell(p))-1,ldomain%ni) + 1 + enddo + call ncd_io(varname='pfts1d_ixy', data=iparr, dim1name=namep, ncid=ncid, flag='write') + do p=begp,endp + iparr(p) = (ldecomp%gdc2glo(pptr%gridcell(p))-1)/ldomain%ni + 1 + enddo + call ncd_io(varname='pfts1d_jxy' , data=iparr , dim1name=namep, ncid=ncid, flag='write') + ! --- EBK Do NOT write out indices that are incorrect 4/1/2011 --- Bug 1310 + !call ncd_io(varname='pfts1d_gi' , data=pptr%gridcell, dim1name=namep, ncid=ncid, flag='write') + !call ncd_io(varname='pfts1d_li' , data=pptr%landunit, dim1name=namep, ncid=ncid, flag='write') + !call ncd_io(varname='pfts1d_ci' , data=pptr%column , dim1name=namep, ncid=ncid, flag='write') + ! ---------------------------------------------------------------- + call ncd_io(varname='pfts1d_wtgcell' , data=pptr%wtgcell , dim1name=namep, ncid=ncid, flag='write') + call ncd_io(varname='pfts1d_wtlunit' , data=pptr%wtlunit , dim1name=namep, ncid=ncid, flag='write') + call ncd_io(varname='pfts1d_wtcol' , data=pptr%wtcol , dim1name=namep, ncid=ncid, flag='write') + call ncd_io(varname='pfts1d_itype_veg', data=pptr%itype , dim1name=namep, ncid=ncid, flag='write') + + do p=begp,endp + iparr(p) = lptr%itype(pptr%landunit(p)) + enddo + call ncd_io(varname='pfts1d_itype_lunit', data=iparr , dim1name=namep, ncid=ncid, flag='write') + + deallocate(rgarr,rlarr,rcarr,rparr) + deallocate(igarr,ilarr,icarr,iparr) + + end if + + end subroutine hfields_1dinfo + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_htapes_wrapup +! +! !INTERFACE: + subroutine hist_htapes_wrapup( rstwr, nlend ) +! +! !DESCRIPTION: +! Write history tape(s) +! Determine if next time step is beginning of history interval and if so: +! increment the current time sample counter, open a new history file +! and if needed (i.e., when ntim = 1), write history data to current +! history file, reset field accumulation counters to zero. +! If primary history file is full or at the last time step of the simulation, +! write restart dataset and close all history fiels. +! If history file is full or at the last time step of the simulation: +! close history file +! and reset time sample counter to zero if file is full. +! Daily-averaged data for the first day in September are written on +! date = 00/09/02 with mscur = 0. +! Daily-averaged data for the first day in month mm are written on +! date = yyyy/mm/02 with mscur = 0. +! Daily-averaged data for the 30th day (last day in September) are written +! on date = 0000/10/01 mscur = 0. +! Daily-averaged data for the last day in month mm are written on +! date = yyyy/mm+1/01 with mscur = 0. +! +! !USES: + use clm_time_manager, only : get_nstep, get_curr_date, get_curr_time, get_prev_date + use clm_varcon , only : secspday + use clmtype +! +! !ARGUMENTS: + implicit none + logical, intent(in) :: rstwr ! true => write restart file this step + logical, intent(in) :: nlend ! true => end of run on this step +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: t ! tape index + integer :: f ! field index + integer :: ier ! error code + integer :: nstep ! current step + integer :: day ! current day (1 -> 31) + integer :: mon ! current month (1 -> 12) + integer :: yr ! current year (0 -> ...) + integer :: mdcur ! current day + integer :: mscur ! seconds of current day + integer :: mcsec ! current time of day [seconds] + integer :: daym1 ! nstep-1 day (1 -> 31) + integer :: monm1 ! nstep-1 month (1 -> 12) + integer :: yrm1 ! nstep-1 year (0 -> ...) + integer :: mcsecm1 ! nstep-1 time of day [seconds] + real(r8):: time ! current time + character(len=256) :: str ! global attribute string + logical :: if_stop ! true => last time step of run + logical, save :: do_3Dtconst = .true. ! true => write out 3D time-constant data + character(len=*),parameter :: subname = 'hist_htapes_wrapup' +!----------------------------------------------------------------------- + + ! get current step + + nstep = get_nstep() + + ! Set calendar for current time step + + call get_curr_date (yr, mon, day, mcsec) + call get_curr_time (mdcur, mscur) + time = mdcur + mscur/secspday + + ! Set calendar for current for previous time step + + call get_prev_date (yrm1, monm1, daym1, mcsecm1) + + ! Loop over active history tapes, create new history files if necessary + ! and write data to history files if end of history interval. + do t = 1, ntapes + + ! Skip nstep=0 if monthly average + + if (nstep==0 .and. tape(t)%nhtfrq==0) cycle + + ! Determine if end of history interval + tape(t)%is_endhist = .false. + if (tape(t)%nhtfrq==0) then !monthly average + if (mon /= monm1) tape(t)%is_endhist = .true. + else + if (mod(nstep,tape(t)%nhtfrq) == 0) tape(t)%is_endhist = .true. + end if + + ! If end of history interval + + if (tape(t)%is_endhist) then + + ! Normalize history buffer if time averaged + + call hfields_normalize(t) + + ! Increment current time sample counter. + + tape(t)%ntimes = tape(t)%ntimes + 1 + + ! Create history file if appropriate and build time comment + + ! If first time sample, generate unique history file name, open file, + ! define dims, vars, etc. + + if (tape(t)%ntimes == 1) then + locfnh(t) = set_hist_filename (hist_freq=tape(t)%nhtfrq, & + hist_mfilt=tape(t)%mfilt, hist_file=t) + if (masterproc) then + write(iulog,*) trim(subname),' : Creating history file ', trim(locfnh(t)), & + ' at nstep = ',get_nstep() + write(iulog,*)'calling htape_create for file t = ',t + endif + call htape_create (t) + + ! Define time-constant field variables + call htape_timeconst(t, mode='define') + + ! Define 3D time-constant field variables only to first primary tape + + if ( do_3Dtconst .and. t == 1 ) then + call htape_timeconst3D(t, mode='define') + TimeConst3DVars_Filename = trim(locfnh(t)) + end if + + ! Define model field variables + + call hfields_write(t, mode='define') + + ! Exit define model + call ncd_enddef(nfid(t)) + + endif + + ! Write time constant history variables + call htape_timeconst(t, mode='write') + + ! Write 3D time constant history variables only to first primary tape + if ( do_3Dtconst .and. t == 1 .and. tape(t)%ntimes == 1 )then + call htape_timeconst3D(t, mode='write') + do_3Dtconst = .false. + end if + + if (masterproc) then + write(iulog,*) + write(iulog,*) trim(subname),' : Writing current time sample to local history file ', & + trim(locfnh(t)),' at nstep = ',get_nstep(), & + ' for history time interval beginning at ', tape(t)%begtime, & + ' and ending at ',time + write(iulog,*) + call shr_sys_flush(iulog) + endif + + ! Update beginning time of next interval + + tape(t)%begtime = time + + ! Write history time samples + + call hfields_write(t, mode='write') + + ! Zero necessary history buffers + + call hfields_zero(t) + + end if + + end do ! end loop over history tapes + + ! Determine if file needs to be closed + + call hist_do_disp (ntapes, tape(:)%ntimes, tape(:)%mfilt, if_stop, if_disphist, rstwr, nlend) + + ! Close open history file + ! Auxilary files may have been closed and saved off without being full, + ! must reopen the files + + do t = 1, ntapes + if (if_disphist(t)) then + if (tape(t)%ntimes /= 0) then + if (masterproc) then + write(iulog,*) + write(iulog,*) trim(subname),' : Closing local history file ',& + trim(locfnh(t)),' at nstep = ', get_nstep() + write(iulog,*) + endif + call ncd_pio_closefile(nfid(t)) + if (.not.if_stop .and. (tape(t)%ntimes/=tape(t)%mfilt)) then + call ncd_pio_openfile (nfid(t), trim(locfnh(t)), ncd_write) + end if + else + if (masterproc) then + write(iulog,*) trim(subname),' : history tape ',t,': no open file to close' + end if + endif + endif + end do + + ! Reset number of time samples to zero if file is full + + do t = 1, ntapes + if (if_disphist(t) .and. tape(t)%ntimes==tape(t)%mfilt) then + tape(t)%ntimes = 0 + end if + end do + + end subroutine hist_htapes_wrapup + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_restart_ncd +! +! !INTERFACE: + subroutine hist_restart_ncd (ncid, flag, rdate) +! +! !DESCRIPTION: +! Read/write history file restart data. +! If the current history file(s) are not full, file(s) are opened +! so that subsequent time samples are added until the file is full. +! A new history file is used on a branch run. +! +! !USES: + use clm_varctl , only : nsrest, caseid, inst_suffix, nsrStartup, nsrBranch + use fileutils , only : getfil + use clmtype + use domainMod , only : ldomain + use clm_varpar , only : nlevgrnd, nlevlak, numrad + use clm_time_manager, only : is_restart +! +! !ARGUMENTS: + implicit none + type(file_desc_t), intent(inout) :: ncid ! netcdf file + character(len=*) , intent(in) :: flag !'read' or 'write' + character(len=*) , intent(in), optional :: rdate ! restart file time stamp for name +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: max_nflds ! Max number of fields + integer :: num1d,beg1d,end1d ! 1d size, beginning and ending indices + integer :: num1d_out,beg1d_out,end1d_out ! 1d size, beginning and ending indices + integer :: num2d ! 2d size (e.g. number of vertical levels) + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: numa ! total number of atm cells across all processors + integer :: numg ! total number of gridcells across all processors + integer :: numl ! total number of landunits across all processors + integer :: numc ! total number of columns across all processors + integer :: nump ! total number of pfts across all processors + character(len=max_namlen) :: name ! variable name + character(len=max_namlen) :: name_acc ! accumulator variable name + character(len=max_namlen) :: long_name ! long name of variable + character(len=max_chars) :: long_name_acc ! long name for accumulator + character(len=max_chars) :: units ! units of variable + character(len=max_chars) :: units_acc ! accumulator units + character(len=max_chars) :: fname ! full name of history file + character(len=max_chars) :: locrest(max_tapes) ! local history restart file names + + character(len=max_namlen),allocatable :: tname(:) + character(len=max_chars), allocatable :: tunits(:),tlongname(:) + character(len=8), allocatable :: tmpstr(:,:) + character(len=1), allocatable :: tavgflag(:) + integer :: start(2) + + character(len=1) :: hnum ! history file index + character(len=8) :: type1d ! clm pointer 1d type + character(len=8) :: type1d_out ! history buffer 1d type + character(len=8) :: type2d ! history buffer 2d type + character(len=32) :: dim1name ! temporary + character(len=32) :: dim2name ! temporary + type(var_desc_t) :: name_desc ! variable descriptor for name + type(var_desc_t) :: longname_desc ! variable descriptor for long_name + type(var_desc_t) :: units_desc ! variable descriptor for units + type(var_desc_t) :: type1d_desc ! variable descriptor for type1d + type(var_desc_t) :: type1d_out_desc ! variable descriptor for type1d_out + type(var_desc_t) :: type2d_desc ! variable descriptor for type2d + type(var_desc_t) :: avgflag_desc ! variable descriptor for avgflag + type(var_desc_t) :: p2c_scale_type_desc ! variable descriptor for p2c_scale_type + type(var_desc_t) :: c2l_scale_type_desc ! variable descriptor for c2l_scale_type + type(var_desc_t) :: l2g_scale_type_desc ! variable descriptor for l2g_scale_type + integer :: status ! error status + integer :: dimid ! dimension ID + integer :: k ! 1d index + integer :: ntapes_onfile ! number of history tapes on the restart file + integer :: nflds_onfile ! number of history fields on the restart file + integer :: t ! tape index + integer :: f ! field index + integer :: varid ! variable id + integer, allocatable :: itemp2d(:,:) ! 2D temporary + real(r8), pointer :: hbuf(:,:) ! history buffer + real(r8), pointer :: hbuf1d(:) ! 1d history buffer + integer , pointer :: nacs(:,:) ! accumulation counter + integer , pointer :: nacs1d(:) ! 1d accumulation counter + character(len=*),parameter :: subname = 'hist_restart_ncd' +!------------------------------------------------------------------------ + + ! If branch run, initialize file times and return + + if (flag == 'read') then + if (nsrest == nsrBranch) then + do t = 1,ntapes + tape(t)%ntimes = 0 + end do + RETURN + end if + ! If startup run just return + if (nsrest == nsrStartup) then + RETURN + end if + endif + + ! Read history file data only for restart run (not for branch run) + + ! + ! First when writing out and in define mode, create files and define all variables + ! + !================================================ + if (flag == 'define') then + !================================================ + + if (.not. present(rdate)) then + call endrun('variable rdate must be present for writing restart files') + end if + + ! + ! On master restart file add ntapes/max_chars dimension + ! and then add the history and history restart filenames + ! + call ncd_defdim( ncid, 'ntapes' , ntapes , dimid) + call ncd_defdim( ncid, 'max_chars' , max_chars , dimid) + + call ncd_defvar(ncid=ncid, varname='locfnh', xtype=ncd_char, & + long_name="History filename", & + comment="This variable NOT needed for startup or branch simulations", & + dim1name='max_chars', dim2name="ntapes" ) + call ncd_defvar(ncid=ncid, varname='locfnhr', xtype=ncd_char, & + long_name="Restart history filename", & + comment="This variable NOT needed for startup or branch simulations", & + dim1name='max_chars', dim2name="ntapes" ) + + ! max_nflds is the maximum number of fields on any tape + ! max_flds is the maximum number possible number of fields + + max_nflds = max_nFields() + + call get_proc_global(numg, numl, numc, nump) + + ! Loop over tapes - write out namelist information to each restart-history tape + ! only read/write accumulators and counters if needed + + do t = 1,ntapes + + ! + ! Create the restart history filename and open it + ! + write(hnum,'(i1.1)') t-1 + locfnhr(t) = "./" // trim(caseid) //".clm2"// trim(inst_suffix) & + // ".rh" // hnum //"."// trim(rdate) //".nc" + + call htape_create( t, histrest=.true. ) + + ! + ! Add read/write accumultators and counters if needed + ! + if (.not. tape(t)%is_endhist) then + do f = 1,tape(t)%nflds + name = tape(t)%hlist(f)%field%name + long_name = tape(t)%hlist(f)%field%long_name + units = tape(t)%hlist(f)%field%units + name_acc = trim(name) // "_acc" + units_acc = "unitless positive integer" + long_name_acc = trim(long_name) // " accumulator number of samples" + type1d_out = tape(t)%hlist(f)%field%type1d_out + type2d = tape(t)%hlist(f)%field%type2d + num2d = tape(t)%hlist(f)%field%num2d + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + if (type1d_out == grlnd) then + if (ldomain%isgrid2d) then + dim1name = 'lon' ; dim2name = 'lat' + else + dim1name = trim(grlnd); dim2name = 'undefined' + end if + else + dim1name = type1d_out ; dim2name = 'undefined' + endif + + if (dim2name == 'undefined') then + if (num2d == 1) then + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & + dim1name=dim1name, & + long_name=trim(long_name), units=trim(units)) + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & + dim1name=dim1name, & + long_name=trim(long_name_acc), units=trim(units_acc)) + else + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & + dim1name=dim1name, dim2name=type2d, & + long_name=trim(long_name), units=trim(units)) + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & + dim1name=dim1name, dim2name=type2d, & + long_name=trim(long_name_acc), units=trim(units_acc)) + end if + else + if (num2d == 1) then + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & + dim1name=dim1name, dim2name=dim2name, & + long_name=trim(long_name), units=trim(units)) + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & + dim1name=dim1name, dim2name=dim2name, & + long_name=trim(long_name_acc), units=trim(units_acc)) + else + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & + dim1name=dim1name, dim2name=dim2name, dim3name=type2d, & + long_name=trim(long_name), units=trim(units)) + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & + dim1name=dim1name, dim2name=dim2name, dim3name=type2d, & + long_name=trim(long_name_acc), units=trim(units_acc)) + end if + endif + end do + endif + + ! + ! Add namelist information to each restart history tape + ! + call ncd_defdim( ncid_hist(t), 'fname_lenp2' , max_namlen+2, dimid) + call ncd_defdim( ncid_hist(t), 'fname_len' , max_namlen , dimid) + call ncd_defdim( ncid_hist(t), 'len1' , 1 , dimid) + call ncd_defdim( ncid_hist(t), 'scalar' , 1 , dimid) + call ncd_defdim( ncid_hist(t), 'max_chars' , max_chars , dimid) + call ncd_defdim( ncid_hist(t), 'max_nflds' , max_nflds , dimid) + call ncd_defdim( ncid_hist(t), 'max_flds' , max_flds , dimid) + + call ncd_defvar(ncid=ncid_hist(t), varname='nhtfrq', xtype=ncd_int, & + long_name="Frequency of history writes", & + comment="Namelist item", & + units="absolute value of negative is in hours, 0=monthly, positive is time-steps", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='mfilt', xtype=ncd_int, & + long_name="Number of history time samples on a file", units="unitless", & + comment="Namelist item", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='ncprec', xtype=ncd_int, & + long_name="Flag for data precision", flag_values=(/1,2/), & + comment="Namelist item", & + nvalid_range=(/1,2/), & + flag_meanings=(/"single-precision", "double-precision"/), & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='dov2xy', xtype=ncd_log, & + long_name="Output on 2D grid format (TRUE) or vector format (FALSE)", & + comment="Namelist item", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='fincl', xtype=ncd_char, & + comment="Namelist item", & + long_name="Fieldnames to include", & + dim1name='fname_lenp2', dim2name='max_flds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='fexcl', xtype=ncd_char, & + comment="Namelist item", & + long_name="Fieldnames to exclude", & + dim1name='fname_lenp2', dim2name='max_flds' ) + + call ncd_defvar(ncid=ncid_hist(t), varname='nflds', xtype=ncd_int, & + long_name="Number of fields on file", units="unitless", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='ntimes', xtype=ncd_int, & + long_name="Number of time steps on file", units="time-step", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='is_endhist', xtype=ncd_log, & + long_name="End of history file", dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='begtime', xtype=ncd_double, & + long_name="Beginning time", units="time units", & + dim1name='scalar') + + call ncd_defvar(ncid=ncid_hist(t), varname='num2d', xtype=ncd_int, & + long_name="Size of second dimension", units="unitless", & + dim1name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='hpindex', xtype=ncd_int, & + long_name="History pointer index", units="unitless", & + dim1name='max_nflds' ) + + call ncd_defvar(ncid=ncid_hist(t), varname='avgflag', xtype=ncd_char, & + long_name="Averaging flag", & + units="A=Average, X=Maximum, M=Minimum, I=Instantaneous", & + dim1name='len1', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='name', xtype=ncd_char, & + long_name="Fieldnames", & + dim1name='fname_len', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='long_name', xtype=ncd_char, & + long_name="Long descriptive names for fields", & + dim1name='max_chars', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='units', xtype=ncd_char, & + long_name="Units for each history field output", & + dim1name='max_chars', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='type1d', xtype=ncd_char, & + long_name="1st dimension type", & + dim1name='string_length', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='type1d_out', xtype=ncd_char, & + long_name="1st output dimension type", & + dim1name='string_length', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='type2d', xtype=ncd_char, & + long_name="2nd dimension type", & + dim1name='string_length', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='p2c_scale_type', xtype=ncd_char, & + long_name="PFT to column scale type", & + dim1name='string_length', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='c2l_scale_type', xtype=ncd_char, & + long_name="column to landunit scale type", & + dim1name='string_length', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='l2g_scale_type', xtype=ncd_char, & + long_name="landunit to gridpoint scale type", & + dim1name='string_length', dim2name='max_nflds' ) + + call ncd_enddef(ncid_hist(t)) + + end do ! end of ntapes loop + + RETURN + + ! + ! First write out namelist information to each restart history file + ! + !================================================ + else if (flag == 'write') then + !================================================ + + ! Add history filenames to master restart file + do t = 1,ntapes + call ncd_io('locfnh', locfnh(t), 'write', ncid, nt=t) + call ncd_io('locfnhr', locfnhr(t), 'write', ncid, nt=t) + end do + + fincl(:,1) = hist_fincl1(:) + fincl(:,2) = hist_fincl2(:) + fincl(:,3) = hist_fincl3(:) + fincl(:,4) = hist_fincl4(:) + fincl(:,5) = hist_fincl5(:) + fincl(:,6) = hist_fincl6(:) + + fexcl(:,1) = hist_fexcl1(:) + fexcl(:,2) = hist_fexcl2(:) + fexcl(:,3) = hist_fexcl3(:) + fexcl(:,4) = hist_fexcl4(:) + fexcl(:,5) = hist_fexcl5(:) + fexcl(:,6) = hist_fexcl6(:) + + max_nflds = max_nFields() + + start(1)=1 + + allocate(itemp2d(max_nflds,ntapes)) + + ! + ! Add history namelist data to each history restart tape + ! + do t = 1,ntapes + call ncd_io(varname='fincl', data=fincl(:,t), ncid=ncid_hist(t), flag='write') + + call ncd_io(varname='fexcl', data=fexcl(:,t), ncid=ncid_hist(t), flag='write') + + call ncd_io(varname='is_endhist', data=tape(t)%is_endhist, ncid=ncid_hist(t), flag='write') + + call ncd_io(varname='dov2xy', data=tape(t)%dov2xy, ncid=ncid_hist(t), flag='write') + + itemp2d(:,:) = 0 + do f=1,tape(t)%nflds + itemp2d(f,t) = tape(t)%hlist(f)%field%num2d + end do + call ncd_io(varname='num2d', data=itemp2d(:,t), ncid=ncid_hist(t), flag='write') + + itemp2d(:,:) = 0 + do f=1,tape(t)%nflds + itemp2d(f,t) = tape(t)%hlist(f)%field%hpindex + end do + call ncd_io(varname='hpindex', data=itemp2d(:,t), ncid=ncid_hist(t), flag='write') + + call ncd_io('nflds', tape(t)%nflds, 'write', ncid_hist(t) ) + call ncd_io('ntimes', tape(t)%ntimes, 'write', ncid_hist(t) ) + call ncd_io('nhtfrq', tape(t)%nhtfrq, 'write', ncid_hist(t) ) + call ncd_io('mfilt', tape(t)%mfilt, 'write', ncid_hist(t) ) + call ncd_io('ncprec', tape(t)%ncprec, 'write', ncid_hist(t) ) + call ncd_io('begtime', tape(t)%begtime, 'write', ncid_hist(t) ) + allocate(tmpstr(tape(t)%nflds,6 ),tname(tape(t)%nflds), & + tavgflag(tape(t)%nflds),tunits(tape(t)%nflds),tlongname(tape(t)%nflds)) + do f=1,tape(t)%nflds + tname(f) = tape(t)%hlist(f)%field%name + tunits(f) = tape(t)%hlist(f)%field%units + tlongname(f) = tape(t)%hlist(f)%field%long_name + tmpstr(f,1) = tape(t)%hlist(f)%field%type1d + tmpstr(f,2) = tape(t)%hlist(f)%field%type1d_out + tmpstr(f,3) = tape(t)%hlist(f)%field%type2d + tavgflag(f) = tape(t)%hlist(f)%avgflag + tmpstr(f,4) = tape(t)%hlist(f)%field%p2c_scale_type + tmpstr(f,5) = tape(t)%hlist(f)%field%c2l_scale_type + tmpstr(f,6) = tape(t)%hlist(f)%field%l2g_scale_type + end do + call ncd_io( 'name', tname, 'write',ncid_hist(t)) + call ncd_io('long_name', tlongname, 'write', ncid_hist(t)) + call ncd_io('units', tunits, 'write',ncid_hist(t)) + call ncd_io('type1d', tmpstr(:,1), 'write', ncid_hist(t)) + call ncd_io('type1d_out', tmpstr(:,2), 'write', ncid_hist(t)) + call ncd_io('type2d', tmpstr(:,3), 'write', ncid_hist(t)) + call ncd_io('avgflag',tavgflag , 'write', ncid_hist(t)) + call ncd_io('p2c_scale_type', tmpstr(:,4), 'write', ncid_hist(t)) + call ncd_io('c2l_scale_type', tmpstr(:,5), 'write', ncid_hist(t)) + call ncd_io('l2g_scale_type', tmpstr(:,6), 'write', ncid_hist(t)) + deallocate(tname,tlongname,tunits,tmpstr,tavgflag) + enddo + deallocate(itemp2d) + + ! + ! Read in namelist information + ! + !================================================ + else if (flag == 'read') then + !================================================ + + call ncd_inqdlen(ncid,dimid,ntapes_onfile, name='ntapes') + if ( is_restart() .and. ntapes_onfile /= ntapes )then + write(iulog,*) 'ntapes = ', ntapes, ' ntapes_onfile = ', ntapes_onfile + call endrun( trim(subname)//' ERROR: number of ntapes different than on restart file!, '// & + ' you can NOT change history options on restart!' ) + end if + if ( is_restart() .and. ntapes > 0 )then + call ncd_io('locfnh', locfnh(1:ntapes), 'read', ncid ) + call ncd_io('locfnhr', locrest(1:ntapes), 'read', ncid ) + do t = 1,ntapes + call strip_null(locrest(t)) + call strip_null(locfnh(t)) + end do + end if + + ! Determine necessary indices - the following is needed if model decomposition is different on restart + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + call get_proc_global(numg, numl, numc, nump) + + start(1)=1 + + do t = 1,ntapes + + call getfil( locrest(t), locfnhr(t), 0 ) + call ncd_pio_openfile (ncid_hist(t), trim(locfnhr(t)), ncd_nowrite) + + if ( t == 1 )then + + call ncd_inqdlen(ncid_hist(1),dimid,max_nflds,name='max_nflds') + + allocate(itemp2d(max_nflds,ntapes)) + end if + + call ncd_inqvid(ncid_hist(t), 'name', varid, name_desc) + call ncd_inqvid(ncid_hist(t), 'long_name', varid, longname_desc) + call ncd_inqvid(ncid_hist(t), 'units', varid, units_desc) + call ncd_inqvid(ncid_hist(t), 'type1d', varid, type1d_desc) + call ncd_inqvid(ncid_hist(t), 'type1d_out', varid, type1d_out_desc) + call ncd_inqvid(ncid_hist(t), 'type2d', varid, type2d_desc) + call ncd_inqvid(ncid_hist(t), 'avgflag', varid, avgflag_desc) + call ncd_inqvid(ncid_hist(t), 'p2c_scale_type', varid, p2c_scale_type_desc) + call ncd_inqvid(ncid_hist(t), 'c2l_scale_type', varid, c2l_scale_type_desc) + call ncd_inqvid(ncid_hist(t), 'l2g_scale_type', varid, l2g_scale_type_desc) + + call ncd_io(varname='fincl', data=fincl(:,t), ncid=ncid_hist(t), flag='read') + + call ncd_io(varname='fexcl', data=fexcl(:,t), ncid=ncid_hist(t), flag='read') + + call ncd_io('nflds', tape(t)%nflds, 'read', ncid_hist(t) ) + call ncd_io('ntimes', tape(t)%ntimes, 'read', ncid_hist(t) ) + call ncd_io('nhtfrq', tape(t)%nhtfrq, 'read', ncid_hist(t) ) + call ncd_io('mfilt', tape(t)%mfilt, 'read', ncid_hist(t) ) + call ncd_io('ncprec', tape(t)%ncprec, 'read', ncid_hist(t) ) + call ncd_io('begtime', tape(t)%begtime, 'read', ncid_hist(t) ) + + call ncd_io(varname='is_endhist', data=tape(t)%is_endhist, ncid=ncid_hist(t), flag='read') + call ncd_io(varname='dov2xy', data=tape(t)%dov2xy, ncid=ncid_hist(t), flag='read') + call ncd_io(varname='num2d', data=itemp2d(:,t), ncid=ncid_hist(t), flag='read') + do f=1,tape(t)%nflds + tape(t)%hlist(f)%field%num2d = itemp2d(f,t) + end do + + call ncd_io(varname='hpindex', data=itemp2d(:,t), ncid=ncid_hist(t), flag='read') + do f=1,tape(t)%nflds + tape(t)%hlist(f)%field%hpindex = itemp2d(f,t) + end do + + do f=1,tape(t)%nflds + start(2) = f + call ncd_io( name_desc, tape(t)%hlist(f)%field%name, & + 'read', ncid_hist(t), start ) + call ncd_io( longname_desc, tape(t)%hlist(f)%field%long_name, & + 'read', ncid_hist(t), start ) + call ncd_io( units_desc, tape(t)%hlist(f)%field%units, & + 'read', ncid_hist(t), start ) + call ncd_io( type1d_desc, tape(t)%hlist(f)%field%type1d, & + 'read', ncid_hist(t), start ) + call ncd_io( type1d_out_desc, tape(t)%hlist(f)%field%type1d_out, & + 'read', ncid_hist(t), start ) + call ncd_io( type2d_desc, tape(t)%hlist(f)%field%type2d, & + 'read', ncid_hist(t), start ) + call ncd_io( avgflag_desc, tape(t)%hlist(f)%avgflag, & + 'read', ncid_hist(t), start ) + call ncd_io( p2c_scale_type_desc, tape(t)%hlist(f)%field%p2c_scale_type, & + 'read', ncid_hist(t), start ) + call ncd_io( c2l_scale_type_desc, tape(t)%hlist(f)%field%c2l_scale_type, & + 'read', ncid_hist(t), start ) + call ncd_io( l2g_scale_type_desc, tape(t)%hlist(f)%field%l2g_scale_type, & + 'read', ncid_hist(t), start ) + call strip_null(tape(t)%hlist(f)%field%name) + call strip_null(tape(t)%hlist(f)%field%long_name) + call strip_null(tape(t)%hlist(f)%field%units) + call strip_null(tape(t)%hlist(f)%field%type1d) + call strip_null(tape(t)%hlist(f)%field%type1d_out) + call strip_null(tape(t)%hlist(f)%field%type2d) + call strip_null(tape(t)%hlist(f)%field%p2c_scale_type) + call strip_null(tape(t)%hlist(f)%field%c2l_scale_type) + call strip_null(tape(t)%hlist(f)%field%l2g_scale_type) + call strip_null(tape(t)%hlist(f)%avgflag) + + type1d_out = trim(tape(t)%hlist(f)%field%type1d_out) + select case (trim(type1d_out)) + case (grlnd) + num1d_out = numg + beg1d_out = begg + end1d_out = endg + case (nameg) + num1d_out = numg + beg1d_out = begg + end1d_out = endg + case (namel) + num1d_out = numl + beg1d_out = begl + end1d_out = endl + case (namec) + num1d_out = numc + beg1d_out = begc + end1d_out = endc + case (namep) + num1d_out = nump + beg1d_out = begp + end1d_out = endp + case default + write(iulog,*) trim(subname),' ERROR: read unknown 1d output type=',trim(type1d_out) + call endrun () + end select + + tape(t)%hlist(f)%field%num1d_out = num1d_out + tape(t)%hlist(f)%field%beg1d_out = beg1d_out + tape(t)%hlist(f)%field%end1d_out = end1d_out + + num2d = tape(t)%hlist(f)%field%num2d + allocate (tape(t)%hlist(f)%hbuf(beg1d_out:end1d_out,num2d), & + tape(t)%hlist(f)%nacs(beg1d_out:end1d_out,num2d), & + stat=status) + if (status /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation error for hbuf,nacs at t,f=',t,f + call endrun() + endif + tape(t)%hlist(f)%hbuf(:,:) = 0._r8 + tape(t)%hlist(f)%nacs(:,:) = 0 + + type1d = tape(t)%hlist(f)%field%type1d + select case (type1d) + case (grlnd) + num1d = numg + beg1d = begg + end1d = endg + case (nameg) + num1d = numg + beg1d = begg + end1d = endg + case (namel) + num1d = numl + beg1d = begl + end1d = endl + case (namec) + num1d = numc + beg1d = begc + end1d = endc + case (namep) + num1d = nump + beg1d = begp + end1d = endp + case default + write(iulog,*) trim(subname),' ERROR: read unknown 1d type=',type1d + call endrun () + end select + + tape(t)%hlist(f)%field%num1d = num1d + tape(t)%hlist(f)%field%beg1d = beg1d + tape(t)%hlist(f)%field%end1d = end1d + + end do ! end of flds loop + + ! If history file is not full, open it + + if (tape(t)%ntimes /= 0) then + call ncd_pio_openfile (nfid(t), trim(locfnh(t)), ncd_write) + end if + + end do ! end of tapes loop + + hist_fincl1(:) = fincl(:,1) + hist_fincl2(:) = fincl(:,2) + hist_fincl3(:) = fincl(:,3) + hist_fincl4(:) = fincl(:,4) + hist_fincl5(:) = fincl(:,5) + hist_fincl6(:) = fincl(:,6) + + hist_fexcl1(:) = fexcl(:,1) + hist_fexcl2(:) = fexcl(:,2) + hist_fexcl3(:) = fexcl(:,3) + hist_fexcl4(:) = fexcl(:,4) + hist_fexcl5(:) = fexcl(:,5) + hist_fexcl6(:) = fexcl(:,6) + + if ( allocated(itemp2d) ) deallocate(itemp2d) + + end if + + !====================================================================== + ! Read/write history file restart data. + ! If the current history file(s) are not full, file(s) are opened + ! so that subsequent time samples are added until the file is full. + ! A new history file is used on a branch run. + !====================================================================== + + if (flag == 'write') then + + do t = 1,ntapes + if (.not. tape(t)%is_endhist) then + + do f = 1,tape(t)%nflds + name = tape(t)%hlist(f)%field%name + name_acc = trim(name) // "_acc" + type1d_out = tape(t)%hlist(f)%field%type1d_out + type2d = tape(t)%hlist(f)%field%type2d + num2d = tape(t)%hlist(f)%field%num2d + beg1d_out = tape(t)%hlist(f)%field%beg1d_out + end1d_out = tape(t)%hlist(f)%field%end1d_out + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + if (num2d == 1) then + allocate(hbuf1d(beg1d_out:end1d_out), & + nacs1d(beg1d_out:end1d_out), stat=status) + if (status /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation'; call endrun() + end if + + hbuf1d(beg1d_out:end1d_out) = hbuf(beg1d_out:end1d_out,1) + nacs1d(beg1d_out:end1d_out) = nacs(beg1d_out:end1d_out,1) + + call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name), & + dim1name=type1d_out, data=hbuf1d) + call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name_acc), & + dim1name=type1d_out, data=nacs1d) + + deallocate(hbuf1d) + deallocate(nacs1d) + else + call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name), & + dim1name=type1d_out, data=hbuf) + call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name_acc), & + dim1name=type1d_out, data=nacs) + end if + + end do + + end if ! end of is_endhist block + + call ncd_pio_closefile(ncid_hist(t)) + + end do ! end of ntapes loop + + else if (flag == 'read') then + + ! Read history restart information if history files are not full + + do t = 1,ntapes + + if (.not. tape(t)%is_endhist) then + + do f = 1,tape(t)%nflds + name = tape(t)%hlist(f)%field%name + name_acc = trim(name) // "_acc" + type1d_out = tape(t)%hlist(f)%field%type1d_out + type2d = tape(t)%hlist(f)%field%type2d + num2d = tape(t)%hlist(f)%field%num2d + beg1d_out = tape(t)%hlist(f)%field%beg1d_out + end1d_out = tape(t)%hlist(f)%field%end1d_out + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + if (num2d == 1) then + allocate(hbuf1d(beg1d_out:end1d_out), & + nacs1d(beg1d_out:end1d_out), stat=status) + if (status /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation'; call endrun() + end if + + call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name), & + dim1name=type1d_out, data=hbuf1d) + call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name_acc), & + dim1name=type1d_out, data=nacs1d) + + hbuf(beg1d_out:end1d_out,1) = hbuf1d(beg1d_out:end1d_out) + nacs(beg1d_out:end1d_out,1) = nacs1d(beg1d_out:end1d_out) + + deallocate(hbuf1d) + deallocate(nacs1d) + else + call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name), & + dim1name=type1d_out, data=hbuf) + call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name_acc), & + dim1name=type1d_out, data=nacs) + end if + end do + + end if + + call ncd_pio_closefile(ncid_hist(t)) + + end do + + end if + + end subroutine hist_restart_ncd + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: max_nFields +! +! !INTERFACE: +integer function max_nFields() +! +! !DESCRIPTION: +! Get the maximum number of fields on all tapes. +! +! !ARGUMENTS: + implicit none +! +! !REVISION HISTORY: +! Created by Erik Kluzek +! +! +! !LOCAL VARIABLES: +!EOP + integer :: t ! index + character(len=*),parameter :: subname = 'max_nFields' +!----------------------------------------------------------------------- + max_nFields = 0 + do t = 1,ntapes + max_nFields = max(max_nFields, tape(t)%nflds) + end do + + return + +end function max_nFields + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: getname +! +! !INTERFACE: + character(len=max_namlen) function getname (inname) +! +! !DESCRIPTION: +! Retrieve name portion of inname. If an averaging flag separater character +! is present (:) in inname, lop it off. +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: inname +! +! !REVISION HISTORY: +! Created by Jim Rosinski +! +! +! !LOCAL VARIABLES: +!EOP + integer :: length + integer :: i + character(len=*),parameter :: subname = 'getname' +!----------------------------------------------------------------------- + + length = len (inname) + + if (length < max_namlen .or. length > max_namlen+2) then + write(iulog,*) trim(subname),' ERROR: bad length=',length + call endrun() + end if + + getname = ' ' + do i = 1,max_namlen + if (inname(i:i) == ':') exit + getname(i:i) = inname(i:i) + end do + + end function getname + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: getflag +! +! !INTERFACE: + character(len=1) function getflag (inname) +! +! !DESCRIPTION: +! Retrieve flag portion of inname. If an averaging flag separater character +! is present (:) in inname, return the character after it as the flag +! +! !ARGUMENTS: + implicit none + character(len=*) inname ! character string +! +! !REVISION HISTORY: +! Created by Jim Rosinski +! +! +! !LOCAL VARIABLES: +!EOP + integer :: length ! length of inname + integer :: i ! loop index + character(len=*),parameter :: subname = 'getflag' +!----------------------------------------------------------------------- + + length = len (inname) + + if (length < max_namlen .or. length > max_namlen+2) then + write(iulog,*) trim(subname),' ERROR: bad length=',length + call endrun() + end if + + getflag = ' ' + do i = 1,length + if (inname(i:i) == ':') then + getflag = inname(i+1:i+1) + exit + end if + end do + + end function getflag + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: list_index +! +! !INTERFACE: + subroutine list_index (list, name, index) +! +! !DESCRIPTION: +! +! !USES: +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: list(max_flds) ! input list of names, possibly ":" delimited + character(len=max_namlen), intent(in) :: name ! name to be searched for + integer, intent(out) :: index ! index of "name" in "list" +! +! !REVISION HISTORY: +! Created by Jim Rosinski +! +! +! !LOCAL VARIABLES: +!EOP + character(len=max_namlen) :: listname ! input name with ":" stripped off. + integer f ! field index + character(len=*),parameter :: subname = 'list_index' +!----------------------------------------------------------------------- + + ! Only list items + + index = 0 + do f=1,max_flds + listname = getname (list(f)) + if (listname == ' ') exit + if (listname == name) then + index = f + exit + end if + end do + + end subroutine list_index + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: set_hist_filename +! +! !INTERFACE: + character(len=256) function set_hist_filename (hist_freq, hist_mfilt, hist_file) +! +! !DESCRIPTION: +! Determine history dataset filenames. +! +! !USES: + use clm_varctl, only : caseid, inst_suffix + use clm_time_manager, only : get_curr_date, get_prev_date +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: hist_freq !history file frequency + integer, intent(in) :: hist_mfilt !history file number of time-samples + integer, intent(in) :: hist_file !history file index +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + character(len=256) :: cdate !date char string + character(len= 1) :: hist_index !p,1 or 2 (currently) + integer :: day !day (1 -> 31) + integer :: mon !month (1 -> 12) + integer :: yr !year (0 -> ...) + integer :: sec !seconds into current day + character(len=*),parameter :: subname = 'set_hist_filename' +!----------------------------------------------------------------------- + + if (hist_freq == 0 .and. hist_mfilt == 1) then !monthly + call get_prev_date (yr, mon, day, sec) + write(cdate,'(i4.4,"-",i2.2)') yr,mon + else !other + call get_curr_date (yr, mon, day, sec) + write(cdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr,mon,day,sec + endif + write(hist_index,'(i1.1)') hist_file - 1 + set_hist_filename = "./"//trim(caseid)//".clm2"//trim(inst_suffix)//& + ".h"//hist_index//"."//trim(cdate)//".nc" + + end function set_hist_filename + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_addfld1d +! +! !INTERFACE: + subroutine hist_addfld1d (fname, units, avgflag, long_name, type1d_out, & + ptr_gcell, ptr_lunit, ptr_col, ptr_pft, ptr_lnd, & + ptr_atm, p2c_scale_type, c2l_scale_type, & + l2g_scale_type, set_lake, set_urb, set_nourb, & + set_noglcmec, set_spec, default) +! +! !DESCRIPTION: +! Initialize a single level history field. The pointer, ptrhist, +! is a pointer to the clmtype array that the history buffer will use. +! The value of type1d passed to masterlist\_add\_fld determines which of the +! 1d type of the output and the beginning and ending indices the history +! buffer field). Default history contents for given field on all tapes +! are set by calling [masterlist\_make\_active] for the appropriate tape. +! After the masterlist is built, routine [htapes\_build] is called for an +! initial or branch run to initialize the actual history tapes. +! +! !USES: + use clmtype +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: fname ! field name + character(len=*), intent(in) :: units ! units of field + character(len=1), intent(in) :: avgflag ! time averaging flag + character(len=*), intent(in) :: long_name ! long name of field + character(len=*), optional, intent(in) :: type1d_out ! output type (from clmtype) + real(r8) , optional, pointer :: ptr_gcell(:) ! pointer to gridcell array + real(r8) , optional, pointer :: ptr_lunit(:) ! pointer to landunit array + real(r8) , optional, pointer :: ptr_col(:) ! pointer to column array + real(r8) , optional, pointer :: ptr_pft(:) ! pointer to pft array + real(r8) , optional, pointer :: ptr_lnd(:) ! pointer to lnd array + real(r8) , optional, pointer :: ptr_atm(:) ! pointer to atm array + real(r8) , optional, intent(in) :: set_lake ! value to set lakes to + real(r8) , optional, intent(in) :: set_urb ! value to set urban to + real(r8) , optional, intent(in) :: set_nourb ! value to set non-urban to + real(r8) , optional, intent(in) :: set_noglcmec ! value to set non-glacier_mec to + real(r8) , optional, intent(in) :: set_spec ! value to set special to + character(len=*), optional, intent(in) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column + character(len=*), optional, intent(in) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits + character(len=*), optional, intent(in) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells + character(len=*), optional, intent(in) :: default ! if set to 'inactive, field will not appear on primary tape +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: p,c,l,g ! indices + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: hpindex ! history buffer pointer index + character(len=8) :: l_type1d ! 1d data type + character(len=8) :: l_type1d_out ! 1d output type + character(len=8) :: scale_type_p2c ! scale type for subgrid averaging of pfts to column + character(len=8) :: scale_type_c2l ! scale type for subgrid averaging of columns to landunits + character(len=8) :: scale_type_l2g ! scale type for subgrid averaging of landunits to gridcells + character(len=*),parameter :: subname = 'hist_addfld1d' +!------------------------------------------------------------------------ + + ! Determine processor bounds + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + ! History buffer pointer + + hpindex = pointer_index() + + if (present(ptr_lnd)) then + l_type1d = grlnd + l_type1d_out = grlnd + clmptr_rs(hpindex)%ptr => ptr_lnd + + else if (present(ptr_gcell)) then + l_type1d = nameg + l_type1d_out = nameg + clmptr_rs(hpindex)%ptr => ptr_gcell + + else if (present(ptr_lunit)) then + l_type1d = namel + l_type1d_out = namel + clmptr_rs(hpindex)%ptr => ptr_lunit + if (present(set_lake)) then + do l = begl,endl + if (lun%lakpoi(l)) ptr_lunit(l) = set_lake + end do + end if + if (present(set_urb)) then + do l = begl,endl + if (lun%urbpoi(l)) ptr_lunit(l) = set_urb + end do + end if + if (present(set_nourb)) then + do l = begl,endl + if (.not.(lun%urbpoi(l))) ptr_lunit(l) = set_nourb + end do + end if + if (present(set_spec)) then + do l = begl,endl + if (lun%ifspecial(l)) ptr_lunit(l) = set_spec + end do + end if + + else if (present(ptr_col)) then + l_type1d = namec + l_type1d_out = namec + clmptr_rs(hpindex)%ptr => ptr_col + if (present(set_lake)) then + do c = begc,endc + l = col%landunit(c) + if (lun%lakpoi(l)) ptr_col(c) = set_lake + end do + end if + if (present(set_urb)) then + do c = begc,endc + l = col%landunit(c) + if (lun%urbpoi(l)) ptr_col(c) = set_urb + end do + end if + if (present(set_nourb)) then + do c = begc,endc + l = col%landunit(c) + if (.not.(lun%urbpoi(l))) ptr_col(c) = set_nourb + end do + end if + if (present(set_spec)) then + do c = begc,endc + l = col%landunit(c) + if (lun%ifspecial(l)) ptr_col(c) = set_spec + end do + end if + if (present(set_noglcmec)) then + do c = begc,endc + l = col%landunit(c) + if (.not.(lun%glcmecpoi(l))) ptr_col(c) = set_noglcmec + end do + endif + + else if (present(ptr_pft)) then + l_type1d = namep + l_type1d_out = namep + clmptr_rs(hpindex)%ptr => ptr_pft + if (present(set_lake)) then + do p = begp,endp + l = pft%landunit(p) + if (lun%lakpoi(l)) ptr_pft(p) = set_lake + end do + end if + if (present(set_urb)) then + do p = begp,endp + l = pft%landunit(p) + if (lun%urbpoi(l)) ptr_pft(p) = set_urb + end do + end if + if (present(set_nourb)) then + do p = begp,endp + l = pft%landunit(p) + if (.not.(lun%urbpoi(l))) ptr_pft(p) = set_nourb + end do + end if + if (present(set_spec)) then + do p = begp,endp + l = pft%landunit(p) + if (lun%ifspecial(l)) ptr_pft(p) = set_spec + end do + end if + if (present(set_noglcmec)) then + do p = begp,endp + l = pft%landunit(p) + if (.not.(lun%glcmecpoi(l))) ptr_pft(p) = set_noglcmec + end do + end if + else + write(iulog,*) trim(subname),' ERROR: must specify a valid pointer index,', & + ' choices are [ptr_atm, ptr_lnd, ptr_gcell, ptr_lunit, ptr_col, ptr_pft] ' + call endrun() + + end if + + ! Set scaling factor + + scale_type_p2c = 'unity' + scale_type_c2l = 'unity' + scale_type_l2g = 'unity' + + if (present(p2c_scale_type)) scale_type_p2c = p2c_scale_type + if (present(c2l_scale_type)) scale_type_c2l = c2l_scale_type + if (present(l2g_scale_type)) scale_type_l2g = l2g_scale_type + if (present(type1d_out)) l_type1d_out = type1d_out + + ! Add field to masterlist + + call masterlist_addfld (fname=trim(fname), type1d=l_type1d, type1d_out=l_type1d_out, & + type2d='unset', num2d=1, & + units=units, avgflag=avgflag, long_name=long_name, hpindex=hpindex, & + p2c_scale_type=scale_type_p2c, c2l_scale_type=scale_type_c2l, l2g_scale_type=scale_type_l2g) + + if (present(default)) then + if (trim(default) == 'inactive') return + else + call masterlist_make_active (name=trim(fname), tape_index=1) + end if + + end subroutine hist_addfld1d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_addfld2d +! +! !INTERFACE: + subroutine hist_addfld2d (fname, type2d, units, avgflag, long_name, type1d_out, & + ptr_gcell, ptr_lunit, ptr_col, ptr_pft, ptr_lnd, ptr_atm, & + p2c_scale_type, c2l_scale_type, l2g_scale_type, & + set_lake, set_urb, set_nourb, set_spec, default) +! +! !DESCRIPTION: +! Initialize a single level history field. The pointer, ptrhist, +! is a pointer to the clmtype array that the history buffer will use. +! The value of type1d passed to masterlist\_add\_fld determines which of the +! 1d type of the output and the beginning and ending indices the history +! buffer field). Default history contents for given field on all tapes +! are set by calling [masterlist\_make\_active] for the appropriatae tape. +! After the masterlist is built, routine [htapes\_build] is called for an +! initial or branch run to initialize the actual history tapes. +! +! !USES: + use clmtype + use clm_varpar, only : nlevgrnd, nlevlak, numrad, maxpatch_glcmec +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: fname ! field name + character(len=*), intent(in) :: type2d ! 2d output type + character(len=*), intent(in) :: units ! units of field + character(len=1), intent(in) :: avgflag ! time averaging flag + character(len=*), intent(in) :: long_name ! long name of field + character(len=*), optional, intent(in) :: type1d_out ! output type (from clmtype) + real(r8) , optional, pointer :: ptr_atm(:,:) ! pointer to atm array + real(r8) , optional, pointer :: ptr_lnd(:,:) ! pointer to lnd array + real(r8) , optional, pointer :: ptr_gcell(:,:) ! pointer to gridcell array + real(r8) , optional, pointer :: ptr_lunit(:,:) ! pointer to landunit array + real(r8) , optional, pointer :: ptr_col(:,:) ! pointer to column array + real(r8) , optional, pointer :: ptr_pft(:,:) ! pointer to pft array + real(r8) , optional, intent(in) :: set_lake ! value to set lakes to + real(r8) , optional, intent(in) :: set_urb ! value to set urban to + real(r8) , optional, intent(in) :: set_nourb ! value to set non-urban to + real(r8) , optional, intent(in) :: set_spec ! value to set special to + character(len=*), optional, intent(in) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column + character(len=*), optional, intent(in) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits + character(len=*), optional, intent(in) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells + character(len=*), optional, intent(in) :: default ! if set to 'inactive, field will not appear on primary tape +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: p,c,l,g ! indices + integer :: num2d ! size of second dimension (e.g. number of vertical levels) + integer :: begp, endp ! per-proc beginning and ending pft indices + integer :: begc, endc ! per-proc beginning and ending column indices + integer :: begl, endl ! per-proc beginning and ending landunit indices + integer :: begg, endg ! per-proc gridcell ending gridcell indices + integer :: hpindex ! history buffer index + character(len=8) :: l_type1d ! 1d data type + character(len=8) :: l_type1d_out ! 1d output type + character(len=8) :: scale_type_p2c ! scale type for subgrid averaging of pfts to column + character(len=8) :: scale_type_c2l ! scale type for subgrid averaging of columns to landunits + character(len=8) :: scale_type_l2g ! scale type for subgrid averaging of landunits to gridcells + character(len=*),parameter :: subname = 'hist_addfld2d' +!------------------------------------------------------------------------ + + ! Determine second dimension size + + select case (type2d) + case ('levgrnd') + num2d = nlevgrnd + case ('levlak') + num2d = nlevlak + case ('numrad') + num2d = numrad + case ('glc_nec') + if (maxpatch_glcmec > 0) then + num2d = maxpatch_glcmec + else + write(iulog,*) trim(subname),' ERROR: 2d type =', trim(type2d), & + ' only valid for maxpatch_glcmec > 0' + call endrun() + end if + case default + write(iulog,*) trim(subname),' ERROR: unsupported 2d type ',type2d, & + ' currently supported types for multi level fields are [levgrnd,levlak,numrad,glc_nec]' + call endrun() + end select + + ! Determine processor bounds + + call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + + ! History buffer pointer + + hpindex = pointer_index() + + if (present(ptr_lnd)) then + l_type1d = grlnd + l_type1d_out = grlnd + clmptr_ra(hpindex)%ptr => ptr_lnd + + else if (present(ptr_gcell)) then + l_type1d = nameg + l_type1d_out = nameg + clmptr_ra(hpindex)%ptr => ptr_gcell + + else if (present(ptr_lunit)) then + l_type1d = namel + l_type1d_out = namel + clmptr_ra(hpindex)%ptr => ptr_lunit + if (present(set_lake)) then + do l = begl,endl + if (lun%lakpoi(l)) ptr_lunit(l,:) = set_lake + end do + end if + if (present(set_urb)) then + do l = begl,endl + if (lun%urbpoi(l)) ptr_lunit(l,:) = set_urb + end do + end if + if (present(set_nourb)) then + do l = begl,endl + if (.not.(lun%urbpoi(l))) ptr_lunit(l,:) = set_nourb + end do + end if + if (present(set_spec)) then + do l = begl,endl + if (lun%ifspecial(l)) ptr_lunit(l,:) = set_spec + end do + end if + + else if (present(ptr_col)) then + l_type1d = namec + l_type1d_out = namec + clmptr_ra(hpindex)%ptr => ptr_col + if (present(set_lake)) then + do c = begc,endc + l = col%landunit(c) + if (lun%lakpoi(l)) ptr_col(c,:) = set_lake + end do + end if + if (present(set_urb)) then + do c = begc,endc + l = col%landunit(c) + if (lun%urbpoi(l)) ptr_col(c,:) = set_urb + end do + end if + if (present(set_nourb)) then + do c = begc,endc + l = col%landunit(c) + if (.not.(lun%urbpoi(l))) ptr_col(c,:) = set_nourb + end do + end if + if (present(set_spec)) then + do c = begc,endc + l = col%landunit(c) + if (lun%ifspecial(l)) ptr_col(c,:) = set_spec + end do + end if + + else if (present(ptr_pft)) then + l_type1d = namep + l_type1d_out = namep + clmptr_ra(hpindex)%ptr => ptr_pft + if (present(set_lake)) then + do p = begp,endp + l = pft%landunit(p) + if (lun%lakpoi(l)) ptr_pft(p,:) = set_lake + end do + end if + if (present(set_urb)) then + do p = begp,endp + l = pft%landunit(p) + if (lun%urbpoi(l)) ptr_pft(p,:) = set_urb + end do + end if + if (present(set_nourb)) then + do p = begp,endp + l = pft%landunit(p) + if (.not.(lun%urbpoi(l))) ptr_pft(p,:) = set_nourb + end do + end if + if (present(set_spec)) then + do p = begp,endp + l = pft%landunit(p) + if (lun%ifspecial(l)) ptr_pft(p,:) = set_spec + end do + end if + + else + write(iulog,*) trim(subname),' ERROR: must specify a valid pointer index,', & + ' choices are ptr_atm, ptr_lnd, ptr_gcell, ptr_lunit, ptr_col, ptr_pft' + call endrun() + + end if + + ! Set scaling factor + + scale_type_p2c = 'unity' + scale_type_c2l = 'unity' + scale_type_l2g = 'unity' + + if (present(p2c_scale_type)) scale_type_p2c = p2c_scale_type + if (present(c2l_scale_type)) scale_type_c2l = c2l_scale_type + if (present(l2g_scale_type)) scale_type_l2g = l2g_scale_type + if (present(type1d_out)) l_type1d_out = type1d_out + + ! Add field to masterlist + + call masterlist_addfld (fname=trim(fname), type1d=l_type1d, type1d_out=l_type1d_out, & + type2d=type2d, num2d=num2d, & + units=units, avgflag=avgflag, long_name=long_name, hpindex=hpindex, & + p2c_scale_type=scale_type_p2c, c2l_scale_type=scale_type_c2l, l2g_scale_type=scale_type_l2g) + + if (present(default)) then + if (trim(default) == 'inactive') return + else + call masterlist_make_active (name=trim(fname), tape_index=1) + end if + + end subroutine hist_addfld2d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: pointer_index +! +! !INTERFACE: + integer function pointer_index () +! +! !DESCRIPTION: +! Set the current pointer index and increment the value of the index. +! +! !ARGUMENTS: + implicit none +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +!EOP + integer, save :: lastindex = 1 + character(len=*),parameter :: subname = 'pointer_index' +!----------------------------------------------------------------------- + + pointer_index = lastindex + lastindex = lastindex + 1 + if (lastindex > max_mapflds) then + write(iulog,*) trim(subname),' ERROR: ',& + ' lastindex = ',lastindex,' greater than max_mapflds= ',max_mapflds + call endrun() + endif + + end function pointer_index + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: hist_add_subscript +! +! !INTERFACE: + subroutine hist_add_subscript(name, dim) +! +! !DESCRIPTION: +! Add a history variable to the output history tape. +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: name ! name of subscript + integer , intent(in) :: dim ! dimension of subscript +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + character(len=*),parameter :: subname = 'hist_add_subscript' +!----------------------------------------------------------------------- + + num_subs = num_subs + 1 + if (num_subs > max_subs) then + write(iulog,*) trim(subname),' ERROR: ',& + ' num_subs = ',num_subs,' greater than max_subs= ',max_subs + call endrun() + endif + subs_name(num_subs) = name + subs_dim(num_subs) = dim + + end subroutine hist_add_subscript + +!----------------------------------------------------------------------- + + subroutine strip_null(str) + character(len=*), intent(inout) :: str + integer :: i + do i=1,len(str) + if(ichar(str(i:i))==0) str(i:i)=' ' + end do + end subroutine strip_null + +!------------------------------------------------------------------------ +!BOP +! +! !ROUTINE: hist_do_disp +! +! !INTERFACE: + subroutine hist_do_disp (ntapes, hist_ntimes, hist_mfilt, if_stop, if_disphist, rstwr, nlend) +! +! !DESCRIPTION: +! Determine logic for closeing and/or disposing history file +! Sets values for if_disphist, if_stop (arguments) +! Remove history files unless this is end of run or +! history file is not full. +! +! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_sys_mod , only : shr_sys_abort + use clm_time_manager, only : is_last_step +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: ntapes !actual number of history tapes + integer, intent(in) :: hist_ntimes(ntapes) !current numbers of time samples on history tape + integer, intent(in) :: hist_mfilt(ntapes) !maximum number of time samples per tape + logical, intent(out) :: if_stop !true => last time step of run + logical, intent(out) :: if_disphist(ntapes) !true => save and dispose history file + logical, intent(in) :: rstwr + logical, intent(in) :: nlend + ! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +! +! !LOCAL VARIABLES: +!EOP + integer :: t ! history tape index + logical :: rest_now ! temporary + logical :: stop_now ! temporary +!------------------------------------------------------------------------ + + rest_now = .false. + stop_now = .false. + + if (nlend) stop_now = .true. + if (rstwr) rest_now = .true. + + if_stop = stop_now + + if (stop_now) then + ! End of run - dispose all history files + + if_disphist(1:ntapes) = .true. + + else if (rest_now) then + ! Restart - dispose all history files + + do t = 1,ntapes + if_disphist(t) = .true. + end do + else + ! Dispose + + if_disphist(1:ntapes) = .false. + do t = 1,ntapes + if (hist_ntimes(t) == hist_mfilt(t)) then + if_disphist(t) = .true. + endif + end do + endif + + end subroutine hist_do_disp + +end module histFileMod + diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeochem/CNBalanceCheckMod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeochem/CNBalanceCheckMod.F90 new file mode 100644 index 0000000000..f3fe64bab4 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeochem/CNBalanceCheckMod.F90 @@ -0,0 +1,433 @@ + +! DART note: this file started life as: +! /glade/p/cesm/releases/cesm1_2_1/models/lnd/clm/src/clm4_5/biogeochem/CNBalanceCheckMod.F90 + +module CNBalanceCheckMod +#ifdef CN + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: CNBalanceCheckMod +! +! !DESCRIPTION: +! Module for carbon mass balance checking. +! +! !USES: + use abortutils , only: endrun + use shr_kind_mod, only: r8 => shr_kind_r8 + use clm_varctl , only: iulog + implicit none + save + private +! !PUBLIC MEMBER FUNCTIONS: + public :: BeginCBalance + public :: BeginNBalance + public :: CBalanceCheck + public :: NBalanceCheck +! +! !REVISION HISTORY: +! 4/23/2004: Created by Peter Thornton +! +!EOP +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BeginCBalance +! +! !INTERFACE: +subroutine BeginCBalance(lbc, ubc, num_soilc, filter_soilc) +! +! !DESCRIPTION: +! On the radiation time step, calculate the beginning carbon balance for mass +! conservation checks. +! +! !USES: + use clmtype +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_soilc ! number of soil columns filter + integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! 2/4/05: Created by Peter Thornton +! +! !LOCAL VARIABLES: +! local pointers to implicit in arrays + real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool +! +! local pointers to implicit out arrays + real(r8), pointer :: col_begcb(:) ! carbon mass, beginning of time step (gC/m**2) + +! +! !OTHER LOCAL VARIABLES: + integer :: c ! indices + integer :: fc ! lake filter indices +! +!EOP +!----------------------------------------------------------------------- + ! assign local pointers at the column level + col_begcb => ccbal%begcb + totcolc => ccs%totcolc + + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! calculate beginning column-level carbon balance, + ! for mass conservation check + + col_begcb(c) = totcolc(c) + + end do ! end of columns loop + + +end subroutine BeginCBalance +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BeginNBalance +! +! !INTERFACE: +subroutine BeginNBalance(lbc, ubc, num_soilc, filter_soilc) +! +! !DESCRIPTION: +! On the radiation time step, calculate the beginning nitrogen balance for mass +! conservation checks. +! +! !USES: + use clmtype +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_soilc ! number of soil columns filter + integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! 2/4/05: Created by Peter Thornton +! +! !LOCAL VARIABLES: +! local pointers to implicit in arrays + real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg +! +! local pointers to implicit out arrays + real(r8), pointer :: col_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2) +! +! !OTHER LOCAL VARIABLES: + integer :: c ! indices + integer :: fc ! lake filter indices +! +!EOP +!----------------------------------------------------------------------- + ! assign local pointers at the column level + col_begnb => cnbal%begnb + totcoln => cns%totcoln + + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! calculate beginning column-level nitrogen balance, + ! for mass conservation check + + col_begnb(c) = totcoln(c) + + end do ! end of columns loop + +end subroutine BeginNBalance +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: CBalanceCheck +! +! !INTERFACE: +subroutine CBalanceCheck(lbc, ubc, num_soilc, filter_soilc) +! +! !DESCRIPTION: +! On the radiation time step, perform carbon mass conservation check for column and pft +! +! !USES: + use clmtype + use clm_time_manager, only: get_step_size, is_first_restart_step +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_soilc ! number of soil columns in filter + integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! 12/9/03: Created by Peter Thornton +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arrays + real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool + real(r8), pointer :: gpp(:) ! (gC/m2/s) gross primary production + real(r8), pointer :: er(:) ! (gC/m2/s) total ecosystem respiration, autotrophic + heterotrophic + real(r8), pointer :: col_fire_closs(:) ! (gC/m2/s) total column-level fire C loss + real(r8), pointer :: col_hrv_xsmrpool_to_atm(:) ! excess MR pool harvest mortality (gC/m2/s) + real(r8), pointer :: dwt_closs(:) ! (gC/m2/s) total carbon loss from product pools and conversion + real(r8), pointer :: product_closs(:) ! (gC/m2/s) total wood product carbon loss + real(r8), pointer :: som_c_leached(:) ! total SOM C loss from vertical transport (gC/m^2/s) +! +! local pointers to implicit out arrays + real(r8), pointer :: col_cinputs(:) ! (gC/m2/s) total column-level carbon inputs (for balance check) + real(r8), pointer :: col_coutputs(:) ! (gC/m2/s) total column-level carbon outputs (for balance check) + real(r8), pointer :: col_begcb(:) ! carbon mass, beginning of time step (gC/m**2) + real(r8), pointer :: col_endcb(:) ! carbon mass, end of time step (gC/m**2) + real(r8), pointer :: col_errcb(:) ! carbon balance error for the timestep (gC/m**2) +! +! !OTHER LOCAL VARIABLES: + integer :: c,err_index ! indices + integer :: fc ! lake filter indices + logical :: err_found ! error flag + real(r8):: dt ! radiation time step (seconds) +!EOP +!----------------------------------------------------------------------- + + ! assign local pointers to column-level arrays + totcolc => ccs%totcolc + gpp => pcf_a%gpp + er => ccf%er + col_fire_closs => ccf%col_fire_closs + col_hrv_xsmrpool_to_atm => pcf_a%hrv_xsmrpool_to_atm + dwt_closs => ccf%dwt_closs + product_closs => ccf%product_closs + + col_cinputs => ccf%col_cinputs + col_coutputs => ccf%col_coutputs + col_begcb => ccbal%begcb + col_endcb => ccbal%endcb + col_errcb => ccbal%errcb + som_c_leached => ccf%som_c_leached + + + ! set time steps + dt = real( get_step_size(), r8 ) + + err_found = .false. + ! column loop + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! calculate the total column-level carbon storage, for mass conservation check + + col_endcb(c) = totcolc(c) + + ! calculate total column-level inputs + + col_cinputs(c) = gpp(c) + + ! calculate total column-level outputs + ! er = ar + hr, col_fire_closs includes pft-level fire losses + + col_coutputs(c) = er(c) + col_fire_closs(c) + dwt_closs(c) + product_closs(c) + col_hrv_xsmrpool_to_atm(c) + + ! subtract leaching flux + col_coutputs(c) = col_coutputs(c) - som_c_leached(c) + + ! calculate the total column-level carbon balance error for this time step + col_errcb(c) = (col_cinputs(c) - col_coutputs(c))*dt - & + (col_endcb(c) - col_begcb(c)) + + ! check for significant errors + if (abs(col_errcb(c)) > 1e-8_r8) then + err_found = .true. + err_index = c + end if + + end do ! end of columns loop + + if ( err_found .and. (.not. is_first_restart_step()) ) then ! TJH + c = err_index + write(iulog,*)'column cbalance error = ', col_errcb(c), c + write(iulog,*)'Latdeg,Londeg=',grc%latdeg(col%gridcell(c)),grc%londeg(col%gridcell(c)) + write(iulog,*)'begcb = ',col_begcb(c) + write(iulog,*)'endcb = ',col_endcb(c) + write(iulog,*)'delta store = ',col_endcb(c)-col_begcb(c) + + call endrun('column carbon balance') + end if + + +end subroutine CBalanceCheck +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: NBalanceCheck +! +! !INTERFACE: +subroutine NBalanceCheck(lbc, ubc, num_soilc, filter_soilc) +! +! !DESCRIPTION: +! On the radiation time step, perform nitrogen mass conservation check +! for column and pft +! +! !USES: + use clmtype + use clm_time_manager, only: get_step_size, is_first_restart_step + use surfrdMod , only: crop_prog +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_soilc ! number of soil columns in filter + integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! 12/9/03: Created by Peter Thornton +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arrays + real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg + real(r8), pointer :: ndep_to_sminn(:) ! atmospheric N deposition to soil mineral N (gN/m2/s) + real(r8), pointer :: nfix_to_sminn(:) ! symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s) + real(r8), pointer :: fert_to_sminn(:) + real(r8), pointer :: soyfixn_to_sminn(:) + real(r8), pointer :: supplement_to_sminn(:) ! supplemental N supply (gN/m2/s) + real(r8), pointer :: denit(:) ! total rate of denitrification (gN/m2/s) +#ifndef NITRIF_DENITRIF + real(r8), pointer :: sminn_leached(:) ! soil mineral N pool loss to leaching (gN/m2/s) +#else + real(r8), pointer :: smin_no3_leached(:) ! soil mineral NO3 pool loss to leaching (gN/m2/s) + real(r8), pointer :: smin_no3_runoff(:) ! soil mineral NO3 pool loss to runoff (gN/m2/s) + real(r8), pointer :: f_n2o_nit(:) ! flux of N2o from nitrification [gN/m^2/s] +#endif + real(r8), pointer :: col_fire_nloss(:) ! total column-level fire N loss (gN/m2/s) + real(r8), pointer :: dwt_nloss(:) ! (gN/m2/s) total nitrogen loss from product pools and conversion + real(r8), pointer :: product_nloss(:) ! (gN/m2/s) total wood product nitrogen loss + real(r8), pointer :: som_n_leached(:) ! total SOM N loss from vertical transport +! +! local pointers to implicit in/out arrays +! +! local pointers to implicit out arrays + real(r8), pointer :: col_ninputs(:) ! column-level N inputs (gN/m2/s) + real(r8), pointer :: col_noutputs(:) ! column-level N outputs (gN/m2/s) + real(r8), pointer :: col_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2) + real(r8), pointer :: col_endnb(:) ! nitrogen mass, end of time step (gN/m**2) + real(r8), pointer :: col_errnb(:) ! nitrogen balance error for the timestep (gN/m**2) + +! !OTHER LOCAL VARIABLES: + integer :: c,err_index,j ! indices + integer :: fc ! lake filter indices + logical :: err_found ! error flag + real(r8):: dt ! radiation time step (seconds) +!EOP +!----------------------------------------------------------------------- + ! assign local pointers to column-level arrays + + totcoln => cns%totcoln + ndep_to_sminn => cnf%ndep_to_sminn + nfix_to_sminn => cnf%nfix_to_sminn + fert_to_sminn => cnf%fert_to_sminn + soyfixn_to_sminn => cnf%soyfixn_to_sminn + supplement_to_sminn => cnf%supplement_to_sminn + denit => cnf%denit +#ifndef NITRIF_DENITRIF + sminn_leached => cnf%sminn_leached +#else + smin_no3_leached => cnf%smin_no3_leached + smin_no3_runoff => cnf%smin_no3_runoff + f_n2o_nit => cnf%f_n2o_nit +#endif + col_fire_nloss => cnf%col_fire_nloss + dwt_nloss => cnf%dwt_nloss + product_nloss => cnf%product_nloss + som_n_leached => cnf%som_n_leached + + col_ninputs => cnf%col_ninputs + col_noutputs => cnf%col_noutputs + col_begnb => cnbal%begnb + col_endnb => cnbal%endnb + col_errnb => cnbal%errnb + + ! set time steps + dt = real( get_step_size(), r8 ) + + err_found = .false. + ! column loop + do fc = 1,num_soilc + c=filter_soilc(fc) + + ! calculate the total column-level nitrogen storage, for mass conservation check + + col_endnb(c) = totcoln(c) + + ! calculate total column-level inputs + + col_ninputs(c) = ndep_to_sminn(c) + nfix_to_sminn(c) + supplement_to_sminn(c) + if (crop_prog) col_ninputs(c) = col_ninputs(c) + & + fert_to_sminn(c) + soyfixn_to_sminn(c) + + ! calculate total column-level outputs + + col_noutputs(c) = denit(c) + col_fire_nloss(c) + dwt_nloss(c) + product_nloss(c) + +#ifndef NITRIF_DENITRIF + col_noutputs(c) = col_noutputs(c) + sminn_leached(c) +#else + col_noutputs(c) = col_noutputs(c) + f_n2o_nit(c) + + col_noutputs(c) = col_noutputs(c) + smin_no3_leached(c) + smin_no3_runoff(c) +#endif + + col_noutputs(c) = col_noutputs(c) - som_n_leached(c) + + ! calculate the total column-level nitrogen balance error for this time step + + col_errnb(c) = (col_ninputs(c) - col_noutputs(c))*dt - & + (col_endnb(c) - col_begnb(c)) + + if (abs(col_errnb(c)) > 1e-8_r8) then + err_found = .true. + err_index = c + end if + + end do ! end of columns loop + + if ( err_found .and. (.not. is_first_restart_step()) ) then ! TJH + c = err_index + write(iulog,*)'column nbalance error = ', col_errnb(c), c + write(iulog,*)'Latdeg,Londeg=',grc%latdeg(col%gridcell(c)),grc%londeg(col%gridcell(c)) + write(iulog,*)'begnb = ',col_begnb(c) + write(iulog,*)'endnb = ',col_endnb(c) + write(iulog,*)'delta store = ',col_endnb(c)-col_begnb(c) + write(iulog,*)'input mass = ',col_ninputs(c)*dt + write(iulog,*)'output mass = ',col_noutputs(c)*dt + write(iulog,*)'net flux = ',(col_ninputs(c)-col_noutputs(c))*dt + + call endrun('column nitrogen balance error') + end if + +end subroutine NBalanceCheck +!----------------------------------------------------------------------- +#endif + +end module CNBalanceCheckMod diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeophys/BalanceCheckMod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeophys/BalanceCheckMod.F90 new file mode 100644 index 0000000000..bd1c2a6089 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeophys/BalanceCheckMod.F90 @@ -0,0 +1,796 @@ + +! DART note: this file started life as: +! /glade/p/cesm/releases/cesm1_2_1/models/lnd/clm/src/clm4_5/biogeophys/BalanceCheckMod.F90 + +module BalanceCheckMod + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: BalanceCheckMod +! +! !DESCRIPTION: +! Water and energy balance check. +! +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use abortutils, only: endrun + use clm_varctl, only: iulog + +! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + public :: BeginWaterBalance ! Initialize water balance check + public :: BalanceCheck ! Water and energy balance check +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +!EOP +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BeginWaterBalance +! +! !INTERFACE: + subroutine BeginWaterBalance(lbc, ubc, lbp, ubp, & + num_nolakec, filter_nolakec, num_lakec, filter_lakec, & + num_hydrologyc, filter_hydrologyc) +! +! !DESCRIPTION: +! Initialize column-level water balance at beginning of time step +! +! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use clmtype + use clm_varpar , only : nlevgrnd, nlevsoi, nlevurb + use subgridAveMod, only : p2c + use clm_varcon , only : icol_roof, icol_sunwall, icol_shadewall, icol_road_perv, & + icol_road_imperv + use clm_varcon , only : denh2o, denice +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column-index bounds + integer, intent(in) :: lbp, ubp ! pft-index bounds + integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points + integer, intent(in) :: num_lakec ! number of column non-lake points in column filter + integer, intent(in) :: filter_lakec(ubc-lbc+1) ! column filter for non-lake points + integer , intent(in) :: num_hydrologyc ! number of column soil points in column filter + integer , intent(in) :: filter_hydrologyc(ubc-lbc+1) ! column filter for soil points +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! Created by Peter Thornton +! +!EOP +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in variables +! + real(r8), pointer :: h2osfc(:) ! surface water (mm) + real(r8), pointer :: londeg(:) ! longitude + real(r8), pointer :: latdeg(:) ! latitude + integer , pointer :: cgridcell(:) ! column's gridcell index + integer , pointer :: clandunit(:) ! column's landunit + integer , pointer :: ltype(:) ! landunit type + real(r8), pointer :: h2osno(:) ! snow water (mm H2O) + real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) + real(r8), pointer :: h2ocan_pft(:) ! canopy water (mm H2O) (pft-level) + real(r8), pointer :: wa(:) ! water in the unconfined aquifer (mm) + integer , pointer :: ctype(:) ! column type + real(r8), pointer :: zwt(:) ! water table depth (m) + real(r8), pointer :: zi(:,:) ! interface level below a "z" level (m) +! +! local pointers to original implicit out variables +! + real(r8), pointer :: h2ocan_col(:) ! canopy water (mm H2O) (column level) + real(r8), pointer :: begwb(:) ! water mass begining of the time step +! +! !OTHER LOCAL VARIABLES: +! + integer :: c, p, f, j, fc ! indices + real(r8):: h2osoi_vol + real(r8), pointer :: dz(:,:), watsat(:,:) +!----------------------------------------------------------------------- + + ! Assign local pointers to derived type members (column-level) + + h2osfc => cws%h2osfc + londeg => grc%londeg + latdeg => grc%latdeg + cgridcell =>col%gridcell + clandunit =>col%landunit + ltype => lun%itype + dz => cps%dz + watsat => cps%watsat + h2osno => cws%h2osno + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + begwb => cwbal%begwb + h2ocan_col => pws_a%h2ocan + wa => cws%wa + ctype => col%itype + zwt => cws%zwt + zi => cps%zi + + ! Assign local pointers to derived type members (pft-level) + + h2ocan_pft => pws%h2ocan + + ! Determine beginning water balance for time step + ! pft-level canopy water averaged to column + call p2c(num_nolakec, filter_nolakec, h2ocan_pft, h2ocan_col) + + do f = 1, num_hydrologyc + c = filter_hydrologyc(f) + if(zwt(c) <= zi(c,nlevsoi)) then + wa(c) = 5000._r8 + end if + end do + + do f = 1, num_nolakec + c = filter_nolakec(f) + if (ctype(c) == icol_roof .or. ctype(c) == icol_sunwall & + .or. ctype(c) == icol_shadewall .or. ctype(c) == icol_road_imperv) then + begwb(c) = h2ocan_col(c) + h2osno(c) + else + begwb(c) = h2ocan_col(c) + h2osno(c) + h2osfc(c) + wa(c) + end if + + end do + do j = 1, nlevgrnd + do f = 1, num_nolakec + c = filter_nolakec(f) + if ((ctype(c) == icol_sunwall .or. ctype(c) == icol_shadewall & + .or. ctype(c) == icol_roof) .and. j > nlevurb) then + else + begwb(c) = begwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + end if + end do + end do + + do f = 1, num_lakec + c = filter_lakec(f) + begwb(c) = h2osno(c) + end do + + end subroutine BeginWaterBalance +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BalanceCheck +! +! !INTERFACE: + subroutine BalanceCheck(lbp, ubp, lbc, ubc, lbl, ubl, lbg, ubg) +! +! !DESCRIPTION: +! This subroutine accumulates the numerical truncation errors of the water +! and energy balance calculation. It is helpful to see the performance of +! the process of integration. +! +! The error for energy balance: +! +! error = abs(Net radiation - change of internal energy - Sensible heat +! - Latent heat) +! +! The error for water balance: +! +! error = abs(precipitation - change of water storage - evaporation - runoff) +! +! !USES: + use clmtype + use clm_atmlnd , only : clm_a2l + use subgridAveMod + use clm_time_manager , only : get_step_size, get_nstep, is_first_restart_step + use clm_varcon , only : isturb, icol_roof, icol_sunwall, icol_shadewall, & + spval, icol_road_perv, icol_road_imperv, istice_mec, & + istdlak, istslak,istsoil,istcrop,istwet + use clm_varctl , only : glc_dyntopo, create_glacier_mec_landunit +! +! !ARGUMENTS: + implicit none + integer :: lbp, ubp ! pft-index bounds + integer :: lbc, ubc ! column-index bounds + integer :: lbl, ubl ! landunit-index bounds + integer :: lbg, ubg ! grid-index bounds +! +! !CALLED FROM: +! subroutine clm_driver +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 10 November 2000: Mariana Vertenstein +! Migrated to new data structures by Mariana Vertenstein and +! Peter Thornton +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in arguments +! + real(r8), pointer :: tws(:) !total water storage (mm H2O) + real(r8), pointer :: volr(:) !river water storage (m3) + real(r8), pointer :: area(:) !gridcell area (km2) + logical , pointer :: do_capsnow(:) ! true => do snow capping + real(r8), pointer :: qflx_rain_grnd_col(:) ! rain on ground after interception (mm H2O/s) [+] + real(r8), pointer :: qflx_snow_grnd_col(:) ! snow on ground after interception (mm H2O/s) [+] + real(r8), pointer :: qflx_snow_h2osfc(:) ! snow falling on surface water (mm/s) + real(r8), pointer :: frac_sno_eff(:) ! effective snow fraction + real(r8), pointer :: qflx_h2osfc_to_ice(:) ! conversion of h2osfc to ice + real(r8), pointer :: qflx_snow_melt(:) ! snow melt (net) + real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1) + real(r8), pointer :: qflx_drain_perched(:) ! sub-surface runoff (mm H2O /s) + real(r8), pointer :: qflx_floodc(:) ! total runoff due to flooding + real(r8), pointer :: qflx_evap_soi(:) ! soil evaporation (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_h2osfc_surf(:)!surface water runoff (mm/s) + real(r8), pointer :: sabg_soil(:) ! solar radiation absorbed by soil (W/m**2) + real(r8), pointer :: sabg_snow(:) ! solar radiation absorbed by snow (W/m**2) + real(r8), pointer :: sabg_chk(:) ! sum of soil/snow using current fsno, for balance check + integer , pointer :: pcolumn(:) ! pft's column index + logical , pointer :: pactive(:) ! true=>do computations on this pft (see reweightMod for details) + logical , pointer :: cactive(:) ! true=>do computations on this column (see reweightMod for details) + integer , pointer :: pgridcell(:) ! pft's gridcell index + integer , pointer :: plandunit(:) ! pft's landunit index + integer , pointer :: cgridcell(:) ! column's gridcell index + integer , pointer :: clandunit(:) ! column's landunit index + integer , pointer :: ltype(:) ! landunit type + integer , pointer :: ctype(:) ! column type + real(r8), pointer :: forc_rain(:) ! rain rate [mm/s] + real(r8), pointer :: forc_snow(:) ! snow rate [mm/s] + real(r8), pointer :: forc_lwrad(:) ! downward infrared (longwave) radiation (W/m**2) + real(r8), pointer :: endwb(:) ! water mass end of the time step + real(r8), pointer :: begwb(:) ! water mass begining of the time step + real(r8), pointer :: fsa(:) ! solar radiation absorbed (total) (W/m**2) + real(r8), pointer :: fsr(:) ! solar radiation reflected (W/m**2) + real(r8), pointer :: eflx_lwrad_out(:) ! emitted infrared (longwave) radiation (W/m**2) + real(r8), pointer :: eflx_lwrad_net(:) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(r8), pointer :: sabv(:) ! solar radiation absorbed by vegetation (W/m**2) + real(r8), pointer :: sabg(:) ! solar radiation absorbed by ground (W/m**2) + real(r8), pointer :: eflx_sh_tot(:) ! total sensible heat flux (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_totg(:) ! total sensible heat flux at grid level (W/m**2) [+ to atm] + real(r8), pointer :: eflx_dynbal(:) ! energy conversion flux due to dynamic land cover change(W/m**2) [+ to atm] + real(r8), pointer :: eflx_lh_tot(:) ! total latent heat flux (W/m8*2) [+ to atm] + real(r8), pointer :: eflx_soil_grnd(:) ! soil heat flux (W/m**2) [+ = into soil] + real(r8), pointer :: qflx_evap_tot(:) ! qflx_evap_soi + qflx_evap_can + qflx_tran_veg + real(r8), pointer :: qflx_irrig(:) ! irrigation flux (mm H2O /s) + real(r8), pointer :: qflx_surf(:) ! surface runoff (mm H2O /s) + real(r8), pointer :: qflx_qrgwl(:) ! qflx_surf at glaciers, wetlands, lakes + real(r8), pointer :: qflx_drain(:) ! sub-surface runoff (mm H2O /s) + real(r8), pointer :: qflx_runoff(:) ! total runoff (mm H2O /s) + real(r8), pointer :: qflx_runoffg(:) ! total runoff at gridcell level inc land cover change flux (mm H2O /s) + real(r8), pointer :: qflx_liq_dynbal(:) ! liq runoff due to dynamic land cover change (mm H2O /s) + real(r8), pointer :: qflx_snwcp_ice(:) ! excess snowfall due to snow capping (mm H2O /s) [+]` + real(r8), pointer :: qflx_glcice(:) ! flux of new glacier ice (mm H2O /s) [+ if ice grows] + real(r8), pointer :: qflx_glcice_frz(:) ! ice growth (mm H2O/s) [+] + real(r8), pointer :: qflx_snwcp_iceg(:) ! excess snowfall due to snow cap inc land cover change flux (mm H20/s) + real(r8), pointer :: qflx_ice_dynbal(:) ! ice runoff due to dynamic land cover change (mm H2O /s) + real(r8), pointer :: forc_solad(:,:) ! direct beam radiation (vis=forc_sols , nir=forc_soll ) + real(r8), pointer :: forc_solai(:,:) ! diffuse radiation (vis=forc_solsd, nir=forc_solld) + real(r8), pointer :: eflx_traffic_pft(:) ! traffic sensible heat flux (W/m**2) + real(r8), pointer :: eflx_wasteheat_pft(:) ! sensible heat flux from urban heating/cooling sources of waste heat (W/m**2) + real(r8), pointer :: canyon_hwr(:) ! ratio of building height to street width + real(r8), pointer :: eflx_heat_from_ac_pft(:) !sensible heat flux put back into canyon due to removal by AC (W/m**2) + real(r8), pointer :: h2osno(:) ! snow water (mm H2O) + real(r8), pointer :: h2osno_old(:) ! snow water (mm H2O) at previous time step + real(r8), pointer :: qflx_dew_snow(:) ! surface dew added to snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_sub_snow(:) ! sublimation rate from snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_top_soil(:) ! net water input into soil from top (mm/s) + real(r8), pointer :: qflx_dew_grnd(:) ! ground surface dew formation (mm H2O /s) [+] + real(r8), pointer :: qflx_evap_grnd(:) ! ground surface evaporation rate (mm H2O/s) [+] + real(r8), pointer :: qflx_prec_grnd(:) ! water onto ground including canopy runoff [kg/(m2 s)] + real(r8), pointer :: qflx_snwcp_liq(:) ! excess liquid water due to snow capping (mm H2O /s) [+]` + real(r8), pointer :: qflx_sl_top_soil(:) ! liquid water + ice from layer above soil to top soil layer or sent to qflx_qrgwl (mm H2O/s) + integer , pointer :: snl(:) ! number of snow layers +! +! local pointers to original implicit out arguments +! + real(r8), pointer :: errh2o(:) ! water conservation error (mm H2O) + real(r8), pointer :: errsol(:) ! solar radiation conservation error (W/m**2) + real(r8), pointer :: errlon(:) ! longwave radiation conservation error (W/m**2) + real(r8), pointer :: errseb(:) ! surface energy conservation error (W/m**2) + real(r8), pointer :: netrad(:) ! net radiation (positive downward) (W/m**2) + real(r8), pointer :: errsoi_col(:) ! column-level soil/lake energy conservation error (W/m**2) + real(r8), pointer :: snow_sources(:) ! snow sources (mm H2O /s) + real(r8), pointer :: snow_sinks(:) ! snow sinks (mm H2O /s) + real(r8), pointer :: errh2osno(:) ! error in h2osno (kg m-2) +! +!EOP +! +! !OTHER LOCAL VARIABLES: + integer :: p,c,l,g ! indices + real(r8) :: dtime ! land model time step (sec) + integer :: nstep ! time step number + logical :: found ! flag in search loop + integer :: indexp,indexc,indexl,indexg ! index of first found in search loop + real(r8) :: forc_rain_col(lbc:ubc) ! column level rain rate [mm/s] + real(r8) :: forc_snow_col(lbc:ubc) ! column level snow rate [mm/s] +!----------------------------------------------------------------------- + + ! Assign local pointers to derived type scalar members (gridcell-level) + + tws => grc%tws + area => grc%area + volr => clm_a2l%volr + do_capsnow => cps%do_capsnow + qflx_rain_grnd_col => pwf_a%qflx_rain_grnd + qflx_snow_grnd_col => pwf_a%qflx_snow_grnd + qflx_snow_h2osfc => cwf%qflx_snow_h2osfc + frac_sno_eff => cps%frac_sno_eff + qflx_h2osfc_to_ice => cwf%qflx_h2osfc_to_ice + frac_sno => cps%frac_sno + qflx_drain_perched => cwf%qflx_drain_perched + qflx_floodc => cwf%qflx_floodc + qflx_evap_soi => pwf_a%qflx_evap_soi + qflx_h2osfc_surf => cwf%qflx_h2osfc_surf + qflx_snow_melt => cwf%qflx_snow_melt + sabg_soil => pef%sabg_soil + sabg_snow => pef%sabg_snow + sabg_chk => pef%sabg_chk + pcolumn =>pft%column + forc_rain => clm_a2l%forc_rain + forc_snow => clm_a2l%forc_snow + forc_lwrad => clm_a2l%forc_lwrad + forc_solad => clm_a2l%forc_solad + forc_solai => clm_a2l%forc_solai + + ! Assign local pointers to derived type scalar members (landunit-level) + + ltype => lun%itype + canyon_hwr =>lun%canyon_hwr + + ! Assign local pointers to derived type scalar members (column-level) + + cactive => col%active + ctype => col%itype + cgridcell =>col%gridcell + clandunit =>col%landunit + endwb => cwbal%endwb + begwb => cwbal%begwb + qflx_irrig => cwf%qflx_irrig + qflx_surf => cwf%qflx_surf + qflx_qrgwl => cwf%qflx_qrgwl + qflx_drain => cwf%qflx_drain + qflx_runoff => cwf%qflx_runoff + qflx_snwcp_ice => pwf_a%qflx_snwcp_ice + qflx_evap_tot => pwf_a%qflx_evap_tot + qflx_glcice => cwf%qflx_glcice + qflx_glcice_frz => cwf%qflx_glcice_frz + errh2o => cwbal%errh2o + errsoi_col => cebal%errsoi + h2osno => cws%h2osno + h2osno_old => cws%h2osno_old + qflx_dew_snow => pwf_a%qflx_dew_snow + qflx_sub_snow => pwf_a%qflx_sub_snow + qflx_top_soil => cwf%qflx_top_soil + qflx_evap_grnd => pwf_a%qflx_evap_grnd + qflx_dew_grnd => pwf_a%qflx_dew_grnd + qflx_prec_grnd => pwf_a%qflx_prec_grnd + qflx_snwcp_liq => pwf_a%qflx_snwcp_liq + qflx_sl_top_soil => cwf%qflx_sl_top_soil + snow_sources => cws%snow_sources + snow_sinks => cws%snow_sinks + errh2osno => cws%errh2osno + snl => cps%snl + + ! Assign local pointers to derived type scalar members (pft-level) + + pactive => pft%active + pgridcell =>pft%gridcell + plandunit =>pft%landunit + fsa => pef%fsa + fsr => pef%fsr + eflx_lwrad_out => pef%eflx_lwrad_out + eflx_lwrad_net => pef%eflx_lwrad_net + sabv => pef%sabv + sabg => pef%sabg + eflx_sh_tot => pef%eflx_sh_tot + eflx_lh_tot => pef%eflx_lh_tot + eflx_soil_grnd => pef%eflx_soil_grnd + errsol => pebal%errsol + errseb => pebal%errseb + errlon => pebal%errlon + netrad => pef%netrad + eflx_wasteheat_pft => pef%eflx_wasteheat_pft + eflx_heat_from_ac_pft => pef%eflx_heat_from_ac_pft + eflx_traffic_pft => pef%eflx_traffic_pft + + ! Assign local pointers to derived type scalar members (gridcell-level) + + qflx_runoffg => gwf%qflx_runoffg + qflx_liq_dynbal => gwf%qflx_liq_dynbal + qflx_snwcp_iceg => gwf%qflx_snwcp_iceg + qflx_ice_dynbal => gwf%qflx_ice_dynbal + eflx_sh_totg => gef%eflx_sh_totg + eflx_dynbal => gef%eflx_dynbal + + ! Get step size and time step + + nstep = get_nstep() + dtime = get_step_size() + + ! Determine column level incoming snow and rain + ! Assume no incident precipitation on urban wall columns (as in Hydrology1Mod.F90). + + do c = lbc,ubc + g = cgridcell(c) + if (ctype(c) == icol_sunwall .or. ctype(c) == icol_shadewall) then + forc_rain_col(c) = 0. + forc_snow_col(c) = 0. + else + forc_rain_col(c) = forc_rain(g) + forc_snow_col(c) = forc_snow(g) + end if + end do + + ! Water balance check + + do c = lbc, ubc + g = cgridcell(c) + l = clandunit(c) + + ! add qflx_drain_perched and qflx_flood + if (cactive(c))then + errh2o(c) = endwb(c) - begwb(c) & + - (forc_rain_col(c) + forc_snow_col(c) + qflx_floodc(c) + qflx_irrig(c) & + - qflx_evap_tot(c) - qflx_surf(c) - qflx_h2osfc_surf(c) & + - qflx_qrgwl(c) - qflx_drain(c) - qflx_drain_perched(c) - qflx_snwcp_ice(c)) * dtime + + ! Suppose glc_dyntopo = T: + ! (1) We have qflx_snwcp_ice = 0, and excess snow has been incorporated in qflx_glcice. + ! This flux must be included here to complete the water balance. + ! (2) Meltwater from ice is allowed to run off and is included in qflx_qrgwl, + ! but the water content of the ice column has not changed (at least for now) because + ! an equivalent ice mass has been "borrowed" from the base of the column. That + ! meltwater is included in qflx_glcice. + ! + ! Note that qflx_glcice is only valid over ice_mec landunits; elsewhere it is spval + + if (glc_dyntopo .and. ltype(l)==istice_mec) then + errh2o(c) = errh2o(c) + qflx_glcice(c)*dtime + end if + + else + + errh2o(c) = 0.0_r8 + + end if + + end do + + found = .false. + do c = lbc, ubc + if (abs(errh2o(c)) > 1e-7_r8) then + found = .true. + indexc = c + end if + end do + + if ( found .and. (.not. is_first_restart_step()) ) then ! TJH + write(iulog,*)'WARNING: water balance error ',& + ' nstep = ',nstep,' indexc= ',indexc,' errh2o= ',errh2o(indexc) + if ((ctype(indexc) .eq. icol_roof .or. ctype(indexc) .eq. icol_road_imperv .or. & + ctype(indexc) .eq. icol_road_perv) .and. abs(errh2o(indexc)) > 1.e-1 .and. (nstep > 2) ) then + write(iulog,*)'clm urban model is stopping - error is greater than 1.e-1' + write(iulog,*)'nstep = ',nstep,' indexc= ',indexc,' errh2o= ',errh2o(indexc) + write(iulog,*)'ctype(indexc): ',ctype(indexc) + write(iulog,*)'forc_rain = ',forc_rain_col(indexc) + write(iulog,*)'forc_snow = ',forc_snow_col(indexc) + write(iulog,*)'endwb = ',endwb(indexc) + write(iulog,*)'begwb = ',begwb(indexc) + write(iulog,*)'qflx_evap_tot= ',qflx_evap_tot(indexc) + write(iulog,*)'qflx_irrig = ',qflx_irrig(indexc) + write(iulog,*)'qflx_surf = ',qflx_surf(indexc) + write(iulog,*)'qflx_qrgwl = ',qflx_qrgwl(indexc) + write(iulog,*)'qflx_drain = ',qflx_drain(indexc) + write(iulog,*)'qflx_snwcp_ice = ',qflx_snwcp_ice(indexc) + write(iulog,*)'clm model is stopping' + call endrun('clm urban model is stopping - water balance error is greater than 1.e-1') + else if (abs(errh2o(indexc)) > .10_r8 .and. (nstep > 2) ) then + write(iulog,*)'clm model is stopping - error is greater than .10' + write(iulog,*)'nstep = ',nstep,' indexc= ',indexc,' errh2o= ',errh2o(indexc) + write(iulog,*)'ctype(indexc): ',ctype(indexc) + write(iulog,*)'forc_rain = ',forc_rain_col(indexc) + write(iulog,*)'forc_snow = ',forc_snow_col(indexc) + write(iulog,*)'endwb = ',endwb(indexc) + write(iulog,*)'begwb = ',begwb(indexc) + write(iulog,*)'qflx_evap_tot= ',qflx_evap_tot(indexc) + write(iulog,*)'qflx_irrig = ',qflx_irrig(indexc) + write(iulog,*)'qflx_surf = ',qflx_surf(indexc) + write(iulog,*)'qflx_h2osfc_surf = ',qflx_h2osfc_surf(indexc) + write(iulog,*)'qflx_qrgwl = ',qflx_qrgwl(indexc) + write(iulog,*)'qflx_drain = ',qflx_drain(indexc) + write(iulog,*)'qflx_drain_perched = ',qflx_drain_perched(indexc) + write(iulog,*)'qflx_flood = ',qflx_floodc(indexc) + write(iulog,*)'qflx_snwcp_ice = ',qflx_snwcp_ice(indexc) + write(iulog,*)'clm model is stopping' + call endrun('clm model is stopping - water balance error is greater than .10') + end if + end if + + ! Snow balance check + + do c = lbc, ubc + g = cgridcell(c) + l = clandunit(c) + ! As defined here, snow_sources - snow_sinks will equal the change in h2osno at + ! any given time step but only if there is at least one snow layer. h2osno + ! also includes snow that is part of the soil column (an initial snow layer is + ! only created if h2osno > 10mm). + if (snl(c) .lt. 0) then + snow_sources(c) = qflx_prec_grnd(c) + qflx_dew_snow(c) + qflx_dew_grnd(c) + snow_sinks(c) = qflx_sub_snow(c) + qflx_evap_grnd(c) + qflx_snow_melt(c) & + + qflx_snwcp_ice(c) + qflx_snwcp_liq(c) + qflx_sl_top_soil(c) + + if (ltype(l) == istdlak) then + if ( do_capsnow(c) ) then + snow_sources(c) = qflx_snow_grnd_col(c) & + + frac_sno_eff(c) * (qflx_dew_snow(c) + qflx_dew_grnd(c) ) + + snow_sinks(c) = frac_sno_eff(c) * (qflx_sub_snow(c) + qflx_evap_grnd(c) ) & + + (qflx_snwcp_ice(c) + qflx_snwcp_liq(c) - qflx_prec_grnd(c)) & + + qflx_snow_melt(c) + qflx_sl_top_soil(c) + else + snow_sources(c) = qflx_snow_grnd_col(c) & + + frac_sno_eff(c) * (qflx_rain_grnd_col(c) & + + qflx_dew_snow(c) + qflx_dew_grnd(c) ) + + snow_sinks(c) = frac_sno_eff(c) * (qflx_sub_snow(c) + qflx_evap_grnd(c) ) & + + qflx_snow_melt(c) + qflx_sl_top_soil(c) + endif + endif + + if (ltype(l) == istsoil .or. ltype(l) == istcrop .or. ltype(l) == istwet ) then + if ( do_capsnow(c) ) then + snow_sources(c) = frac_sno_eff(c) * (qflx_dew_snow(c) + qflx_dew_grnd(c) ) & + + qflx_h2osfc_to_ice(c) + qflx_prec_grnd(c) + + snow_sinks(c) = frac_sno_eff(c) * (qflx_sub_snow(c) + qflx_evap_grnd(c)) & + + qflx_snwcp_ice(c) + qflx_snwcp_liq(c) & + + qflx_snow_melt(c) + qflx_sl_top_soil(c) + else + snow_sources(c) = (qflx_snow_grnd_col(c) - qflx_snow_h2osfc(c) ) & + + frac_sno_eff(c) * (qflx_rain_grnd_col(c) & + + qflx_dew_snow(c) + qflx_dew_grnd(c) ) + qflx_h2osfc_to_ice(c) + + snow_sinks(c) = frac_sno_eff(c) * (qflx_sub_snow(c) + qflx_evap_grnd(c)) & + + qflx_snow_melt(c) + qflx_sl_top_soil(c) + endif + endif + + ! For ice_mec landunits, if glc_dyntopo is true, then qflx_snwcp_ice = 0, + ! and qflx_glcice_frz instead stores this flux + if (ltype(l) == istice_mec .and. glc_dyntopo) then + snow_sinks(c) = snow_sinks(c) + qflx_glcice_frz(c) + end if + + errh2osno(c) = (h2osno(c) - h2osno_old(c)) - (snow_sources(c) - snow_sinks(c)) * dtime + else + snow_sources(c) = 0._r8 + snow_sinks(c) = 0._r8 + errh2osno(c) = 0._r8 + end if + end do + + found = .false. + do c = lbc, ubc + if (cactive(c) .and. abs(errh2osno(c)) > 1.0e-7_r8) then + found = .true. + indexc = c + end if + end do + if ( found .and. (.not. is_first_restart_step()) ) then ! TJH + write(iulog,*)'WARNING: snow balance error ',& + ' nstep = ',nstep,' indexc= ',indexc,'ltype: ', ltype(clandunit(indexc)),' errh2osno= ',errh2osno(indexc) + if (abs(errh2osno(indexc)) > 0.1_r8 .and. (nstep > 2) ) then + write(iulog,*)'clm model is stopping - error is greater than .10' + write(iulog,*)'nstep = ',nstep,' indexc= ',indexc,' errh2osno= ',errh2osno(indexc) + write(iulog,*)'ltype: ', ltype(clandunit(indexc)) + write(iulog,*)'ctype(indexc): ',ctype(indexc) + write(iulog,*)'snl: ',snl(indexc) + write(iulog,*)'h2osno: ',h2osno(indexc) + write(iulog,*)'h2osno_old: ',h2osno_old(indexc) + write(iulog,*)'snow_sources: ', snow_sources(indexc) + write(iulog,*)'snow_sinks: ', snow_sinks(indexc) + write(iulog,*)'qflx_prec_grnd: ',qflx_prec_grnd(indexc)*dtime + write(iulog,*)'qflx_sub_snow: ',qflx_sub_snow(indexc)*dtime + write(iulog,*)'qflx_evap_grnd: ',qflx_evap_grnd(indexc)*dtime + write(iulog,*)'qflx_top_soil: ',qflx_top_soil(indexc)*dtime + write(iulog,*)'qflx_dew_snow: ',qflx_dew_snow(indexc)*dtime + write(iulog,*)'qflx_dew_grnd: ',qflx_dew_grnd(indexc)*dtime + write(iulog,*)'qflx_snwcp_ice: ',qflx_snwcp_ice(indexc)*dtime + write(iulog,*)'qflx_snwcp_liq: ',qflx_snwcp_liq(indexc)*dtime + write(iulog,*)'qflx_sl_top_soil: ',qflx_sl_top_soil(indexc)*dtime + if (create_glacier_mec_landunit) & + write(iulog,*)'qflx_glcice_frz: ',qflx_glcice_frz(indexc)*dtime + write(iulog,*)'clm model is stopping' + call endrun('clm model is stopping - snow balance error is greater than .10') + end if + end if + + ! Energy balance checks + + do p = lbp, ubp + if (pactive(p)) then + l = plandunit(p) + g = pgridcell(p) + + ! Solar radiation energy balance + ! Do not do this check for an urban pft since it will not balance on a per-column + ! level because of interactions between columns and since a separate check is done + ! in the urban radiation module + if (ltype(l) /= isturb) then + errsol(p) = fsa(p) + fsr(p) & + - (forc_solad(g,1) + forc_solad(g,2) + forc_solai(g,1) + forc_solai(g,2)) + else + errsol(p) = spval + end if + + ! Longwave radiation energy balance + ! Do not do this check for an urban pft since it will not balance on a per-column + ! level because of interactions between columns and since a separate check is done + ! in the urban radiation module + if (ltype(l) /= isturb) then + errlon(p) = eflx_lwrad_out(p) - eflx_lwrad_net(p) - forc_lwrad(g) + else + errlon(p) = spval + end if + + ! Surface energy balance + ! Changed to using (eflx_lwrad_net) here instead of (forc_lwrad - eflx_lwrad_out) because + ! there are longwave interactions between urban columns (and therefore pfts). + ! For surfaces other than urban, (eflx_lwrad_net) equals (forc_lwrad - eflx_lwrad_out), + ! and a separate check is done above for these terms. + + if (ltype(l) /= isturb) then + c=pcolumn(p) + errseb(p) = sabv(p) + sabg_chk(p) + forc_lwrad(g) - eflx_lwrad_out(p) & + - eflx_sh_tot(p) - eflx_lh_tot(p) - eflx_soil_grnd(p) + else + errseb(p) = sabv(p) + sabg(p) & + - eflx_lwrad_net(p) & + - eflx_sh_tot(p) - eflx_lh_tot(p) - eflx_soil_grnd(p) & + + eflx_wasteheat_pft(p) + eflx_heat_from_ac_pft(p) + eflx_traffic_pft(p) + end if + netrad(p) = fsa(p) - eflx_lwrad_net(p) + end if + end do + + ! Solar radiation energy balance check + + found = .false. + do p = lbp, ubp + if (pactive(p)) then + if ( (errsol(p) /= spval) .and. (abs(errsol(p)) > .10_r8) ) then + found = .true. + indexp = p + indexg = pgridcell(p) + end if + end if + end do + if ( found .and. (nstep > 2) .and. (.not. is_first_restart_step() ) ) then ! TJH + write(iulog,100)'BalanceCheck: solar radiation balance error', nstep, indexp, errsol(indexp) + write(iulog,*)'fsa = ',fsa(indexp) + write(iulog,*)'fsr = ',fsr(indexp) + write(iulog,*)'forc_solad(1)= ',forc_solad(indexg,1) + write(iulog,*)'forc_solad(2)= ',forc_solad(indexg,2) + write(iulog,*)'forc_solai(1)= ',forc_solai(indexg,1) + write(iulog,*)'forc_solai(2)= ',forc_solai(indexg,2) + write(iulog,*)'forc_tot = ',forc_solad(indexg,1)+forc_solad(indexg,2)& + +forc_solai(indexg,1)+forc_solai(indexg,2) + write(iulog,*)'clm model is stopping' + call endrun('BalanceCheck: solar radiation balance error') + end if + + ! Longwave radiation energy balance check + + found = .false. + do p = lbp, ubp + if (pactive(p)) then + if ( (errlon(p) /= spval) .and. (abs(errlon(p)) > .10_r8) ) then + found = .true. + indexp = p + end if + end if + end do + if ( found .and. (nstep > 2) .and. (.not. is_first_restart_step() ) ) then ! TJH + write(iulog,100)'BalanceCheck: longwave energy balance error',nstep,indexp,errlon(indexp) + write(iulog,*)'clm model is stopping' + call endrun('BalanceCheck: longwave energy balance error') + end if + + ! Surface energy balance check + + found = .false. + do p = lbp, ubp + if (pactive(p)) then + if (abs(errseb(p)) > .10_r8 ) then + found = .true. + indexp = p + end if + end if + end do + if ( found .and. (nstep > 2) .and. (.not. is_first_restart_step() ) ) then ! TJH + write(iulog,100)'BalanceCheck: surface flux energy balance error',nstep,indexp,errseb(indexp) + write(iulog,*)' sabv = ',sabv(indexp) + c=pcolumn(indexp) + write(iulog,*)' column = ',c + write(iulog,*)' sabg = ',sabg(indexp), ((1._r8- frac_sno(c))*sabg_soil(indexp) + & + frac_sno(c)*sabg_snow(indexp)),sabg_chk(indexp) + write(iulog,*)' eflx_lwrad_net = ',eflx_lwrad_net(indexp) + write(iulog,*)' eflx_sh_tot = ',eflx_sh_tot(indexp) + write(iulog,*)' eflx_lh_tot = ',eflx_lh_tot(indexp) + write(iulog,*)' eflx_soil_grnd = ',eflx_soil_grnd(indexp) + write(iulog,*)'clm model is stopping' + call endrun('BalanceCheck: surface flux energy balance error') + end if + + ! Soil energy balance check + + found = .false. + do c = lbc, ubc + if (abs(errsoi_col(c)) > 1.0e-7_r8 ) then + found = .true. + indexc = c + end if + end do + if ( found .and. (.not. is_first_restart_step() ) ) then ! TJH + if (abs(errsoi_col(indexc)) > .10_r8 .and. (nstep > 2) ) then + write(iulog,100)'BalanceCheck: soil balance error',nstep,indexc,errsoi_col(indexc) + write(iulog,*)'nstep = ',nstep,' indexc= ',indexc,' errsoi_col= ',errsoi_col(indexc) + write(iulog,*)'clm model is stopping' + call endrun('BalanceCheck: soil balance error') + end if + end if + + ! Update SH and RUNOFF for dynamic land cover change energy and water fluxes + call c2g( lbc, ubc, lbl, ubl, lbg, ubg, & + qflx_runoff(lbc:ubc), qflx_runoffg(lbg:ubg), & + c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) + do g = lbg, ubg + qflx_runoffg(g) = qflx_runoffg(g) - qflx_liq_dynbal(g) + enddo + + call c2g( lbc, ubc, lbl, ubl, lbg, ubg, & + qflx_snwcp_ice(lbc:ubc), qflx_snwcp_iceg(lbg:ubg), & + c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) + do g = lbg, ubg + qflx_snwcp_iceg(g) = qflx_snwcp_iceg(g) - qflx_ice_dynbal(g) + enddo + + call p2g( lbp, ubp, lbc, ubc, lbl, ubl, lbg, ubg, & + eflx_sh_tot(lbp:ubp), eflx_sh_totg(lbg:ubg), & + p2c_scale_type='unity',c2l_scale_type='urbanf',l2g_scale_type='unity') + do g = lbg, ubg + eflx_sh_totg(g) = eflx_sh_totg(g) - eflx_dynbal(g) + enddo + +! calculate total water storage for history files +! first set tws to gridcell total endwb + call c2g( lbc, ubc, lbl, ubl, lbg, ubg, & + endwb(lbc:ubc), tws(lbg:ubg), & + c2l_scale_type= 'urbanf', l2g_scale_type='unity' ) +! second add river storage as gridcell average depth +! 1.e-3 converts [m3/km2] to [mm] + do g = lbg, ubg + tws(g) = tws(g) + volr(g) / area(g) * 1.e-3_r8 + enddo +100 format (1x,a,' nstep =',i10,' point =',i6,' imbalance =',f12.6,' W/m2') +200 format (1x,a,' nstep =',i10,' point =',i6,' imbalance =',f12.6,' mm') + + end subroutine BalanceCheck + +end module BalanceCheckMod diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeophys/SLakeHydrologyMod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeophys/SLakeHydrologyMod.F90 new file mode 100644 index 0000000000..8956898a4d --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeophys/SLakeHydrologyMod.F90 @@ -0,0 +1,1062 @@ + +! DART note: this file started life as: +! /glade/p/cesm/releases/cesm1_2_1/models/lnd/clm/src/clm4_5/biogeophys/SLakeHydrologyMod.F90 +! +! NOTE: It includes a Lake Hydrology bug documented in bugzilla report 1717 +! and may resolve bugzilla report 1927. + +module SLakeHydrologyMod + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: SLakeHydrologyMod +! +! !DESCRIPTION: +! Calculation of Lake Hydrology. Full hydrology, aerosol deposition, etc. of snow layers is +! done. However, there is no infiltration, and the water budget is balanced with +! qflx_qrgwl. Lake water mass is kept constant. The soil is simply maintained at +! volumetric saturation if ice melting frees up pore space. Likewise, if the water +! portion alone at some point exceeds pore capacity, it is reduced. This is consistent +! with the possibility of initializing the soil layer with excess ice. +! +! If snow layers are present over an unfrozen lake, and the top layer of the lake +! is capable of absorbing the latent heat without going below freezing, +! the snow-water is runoff and the latent heat is subtracted from the lake. +! +! Minimum snow layer thickness for lakes has been increased to avoid instabilities with 30 min timestep. +! Also frost / dew is prevented from being added to top snow layers that have already melted during the phase change step. +! +! !PUBLIC TYPES: + implicit none + save + private +! +! !PUBLIC MEMBER FUNCTIONS: + public :: SLakeHydrology ! Calculates soil/snow hydrology +! +! !REVISION HISTORY: +! Created by Zack Subin, 2009 +! +!EOP +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: SLakeHydrology +! +! !INTERFACE: + subroutine SLakeHydrology(lbc, ubc, lbp, ubp, num_lakec, filter_lakec, & + num_lakep, filter_lakep & + ! Snow filter for lakes is not returned to driver. That's okay, because it looks like it is only + ! needed for the call to SnowAge_grain, which will be done at the bottom of this module. + ) +! +! !DESCRIPTION: +! +! WARNING: This subroutine assumes lake columns have one and only one pft. +! +! Sequence is: +! SLakeHydrology: +! Do needed tasks from Hydrology1, Biogeophysics2, & top of Hydrology2. +! -> SnowWater: change of snow mass and snow water onto soil +! -> SnowCompaction: compaction of snow layers +! -> CombineSnowLayers: combine snow layers that are thinner than minimum +! -> DivideSnowLayers: subdivide snow layers that are thicker than maximum +! Add water to soil if melting has left it with open pore space. +! If snow layers are found above a lake with unfrozen top layer, whose top +! layer has enough heat to melt all the snow ice without freezing, do so +! and eliminate the snow layers. +! Cleanup and do water balance. +! Do SNICAR stuff and diagnostics. +! Call SnowAge_grain (it must be done here because the snow filters at the driver level are non-lakec only. +! +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use clmtype + use clm_atmlnd , only : clm_a2l + use clm_varcon , only : denh2o, denice, spval, hfus, tfrz, cpliq, cpice + use SLakeCon , only : lsadz + use clm_varpar , only : nlevsno, nlevgrnd, nlevsoi + use clm_varctl , only : iulog + use SnowHydrologyMod, only : SnowCompaction, CombineSnowLayers, & + SnowWater, BuildSnowFilter + use SnowHydrologyMod, only : DivideSnowLayers_Lake + use clm_time_manager, only : get_step_size, is_perpetual + use SNICARMod , only : SnowAge_grain, snw_rds_min +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: lbp, ubp ! pft bounds + integer, intent(in) :: num_lakec ! number of column lake points in column filter + integer, intent(in) :: filter_lakec(ubc-lbc+1) ! column filter for lake points + integer, intent(in) :: num_lakep ! number of pft lake points in column filter + integer, intent(in) :: filter_lakep(ubp-lbp+1) ! pft filter for lake points +! +! !CALLED FROM: +! subroutine driver +! +! !REVISION HISTORY: +! Created by Zack Subin +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arguments +! + real(r8), pointer :: frac_sno_eff(:) ! needed for snicar code + real(r8), pointer :: qflx_floodg(:) ! gridcell flux of flood water from RTM + real(r8), pointer :: qflx_floodc(:) ! column flux of flood water from RTM + real(r8), pointer :: frost_table(:) ! frost table depth (m) + real(r8), pointer :: zwt_perched(:) ! perched water table depth (m) + real(r8), pointer :: qflx_drain_perched(:)! perched wt sub-surface runoff (mm H2O /s) + real(r8), pointer :: qflx_h2osfc_surf(:) ! surface water runoff (mm H2O /s) + real(r8), pointer :: qflx_snow_melt(:)! net snow melt + real(r8), pointer :: qflx_rsub_sat(:) !soil saturation excess [mm h2o/s] + integer , pointer :: pcolumn(:) ! pft's column index + integer , pointer :: pgridcell(:) ! pft's gridcell index + integer , pointer :: cgridcell(:) ! column's gridcell + integer , pointer :: clandunit(:) ! column's landunit + real(r8), pointer :: watsat(:,:) ! volumetric soil water at saturation (porosity) + real(r8), pointer :: z(:,:) ! layer depth (m) + real(r8), pointer :: dz_lake(:,:) ! layer thickness for lake (m) + real(r8), pointer :: forc_rain(:) ! rain rate [mm/s] + real(r8), pointer :: forc_snow(:) ! snow rate [mm/s] + real(r8), pointer :: begwb(:) ! water mass begining of the time step + real(r8), pointer :: qflx_evap_tot(:) ! qflx_evap_soi + qflx_evap_can + qflx_tran_veg + real(r8), pointer :: forc_t(:) ! atmospheric temperature (Kelvin) + logical , pointer :: do_capsnow(:) ! true => do snow capping + real(r8), pointer :: t_grnd(:) ! ground temperature (Kelvin) + real(r8), pointer :: qflx_evap_soi(:) ! soil evaporation (mm H2O/s) (+ = to atm) +! +! local pointers to implicit inout arguments +! + real(r8), pointer :: dz(:,:) ! layer thickness depth (m) + real(r8), pointer :: zi(:,:) ! interface depth (m) + integer , pointer :: snl(:) ! number of snow layers + real(r8), pointer :: h2osno(:) ! snow water (mm H2O) + real(r8), pointer :: snow_depth(:) ! snow height (m) + real(r8), pointer :: lake_icefrac(:,:)! mass fraction of lake layer that is frozen + real(r8), pointer :: t_lake(:,:) ! lake temperature (Kelvin) + real(r8), pointer :: qflx_snomelt(:) ! snow melt (mm H2O /s) + real(r8), pointer :: eflx_snomelt(:) ! snow melt heat flux (W/m**2) + real(r8), pointer :: eflx_sh_tot(:) ! total sensible heat flux (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_grnd(:) ! sensible heat flux from ground (W/m**2) [+ to atm] + real(r8), pointer :: eflx_soil_grnd(:)! heat flux into snow / lake (W/m**2) [+ = into soil] + ! Here this includes the whole lake radiation absorbed. + real(r8), pointer :: eflx_gnet(:) ! net heat flux into ground (W/m**2) + real(r8), pointer :: eflx_grnd_lake(:)! net heat flux into lake / snow surface, excluding light transmission (W/m**2) + + +! +! local pointers to implicit out arguments +! + real(r8), pointer :: endwb(:) ! water mass end of the time step + real(r8), pointer :: snowice(:) ! average snow ice lens + real(r8), pointer :: snowliq(:) ! average snow liquid water + real(r8), pointer :: t_soisno(:,:) ! snow temperature (Kelvin) + real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) + real(r8), pointer :: h2osoi_vol(:,:) ! volumetric soil water [m3/m3] + real(r8), pointer :: qflx_drain(:) ! sub-surface runoff (mm H2O /s) + real(r8), pointer :: qflx_surf(:) ! surface runoff (mm H2O /s) + real(r8), pointer :: qflx_infl(:) ! infiltration (mm H2O /s) + real(r8), pointer :: qflx_qrgwl(:) ! qflx_surf at glaciers, wetlands, lakes + real(r8), pointer :: qflx_runoff(:) ! total runoff (qflx_drain+qflx_surf+qflx_qrgwl) (mm H2O /s) + real(r8), pointer :: qcharge(:) ! aquifer recharge rate (mm/s) + real(r8), pointer :: qflx_top_soil(:) ! net water input into soil from top (mm/s) + real(r8), pointer :: qflx_sl_top_soil(:) ! liquid water + ice from layer above soil to top soil layer or sent to qflx_qrgwl (mm H2O/s) + real(r8), pointer :: qflx_prec_grnd(:) ! water onto ground including canopy runoff [kg/(m2 s)] + real(r8), pointer :: qflx_prec_grnd_col(:) ! water onto ground including canopy runoff [kg/(m2 s)] + real(r8), pointer :: qflx_snow_grnd_pft(:) ! snow on ground after interception (mm H2O/s) [+] + real(r8), pointer :: qflx_snow_grnd_col(:) ! snow on ground after interception (mm H2O/s) [+] + real(r8), pointer :: qflx_rain_grnd(:) ! rain on ground after interception (mm H2O/s) [+] + real(r8), pointer :: frac_iceold(:,:) ! fraction of ice relative to the tot water + real(r8), pointer :: qflx_evap_tot_col(:) ! pft quantity averaged to the column (assuming one pft) + real(r8) ,pointer :: soilalpha(:) ! factor that reduces ground saturated specific humidity (-) + real(r8), pointer :: zwt(:) ! water table depth + real(r8), pointer :: fcov(:) ! fractional area with water table at surface + real(r8), pointer :: fsat(:) ! fractional area with water table at surface + real(r8), pointer :: rootr_column(:,:) ! effective fraction of roots in each soil layer + real(r8), pointer :: qflx_evap_grnd(:) ! ground surface evaporation rate (mm H2O/s) [+] + real(r8), pointer :: qflx_evap_grnd_col(:) ! ground surface evaporation rate (mm H2O/s) [+] + real(r8), pointer :: qflx_sub_snow(:) ! sublimation rate from snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_sub_snow_col(:) ! sublimation rate from snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_dew_snow(:) ! surface dew added to snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_dew_snow_col(:) ! surface dew added to snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_dew_grnd(:) ! ground surface dew formation (mm H2O /s) [+] + real(r8), pointer :: qflx_dew_grnd_col(:) ! ground surface dew formation (mm H2O /s) [+] + real(r8), pointer :: qflx_rain_grnd_col(:) ! rain on ground after interception (mm H2O/s) [+] + real(r8), pointer :: qflx_snwcp_ice_col(:) ! excess snowfall due to snow capping (mm H2O /s) [+] + real(r8), pointer :: qflx_snwcp_ice(:) ! excess snowfall due to snow capping (mm H2O /s) [+] + real(r8), pointer :: qflx_snwcp_liq_col(:) ! excess rainfall due to snow capping (mm H2O /s) [+] + real(r8), pointer :: qflx_snwcp_liq(:) ! excess rainfall due to snow capping (mm H2O /s) [+] + real(r8), pointer :: qflx_irrig(:) ! irrigation flux (mm H2O /s) + !New SNICAR variables from Hydrology1 + real(r8), pointer :: snw_rds(:,:) ! effective snow grain radius (col,lyr) [microns, m^-6] + real(r8), pointer :: mss_bcpho(:,:) ! mass of hydrophobic BC in snow (col,lyr) [kg] + real(r8), pointer :: mss_bcphi(:,:) ! mass of hydrophilic BC in snow (col,lyr) [kg] + real(r8), pointer :: mss_bctot(:,:) ! total mass of BC in snow (col,lyr) [kg] + real(r8), pointer :: mss_bc_col(:) ! total column mass of BC in snow (col,lyr) [kg] + real(r8), pointer :: mss_bc_top(:) ! total top-layer mass of BC (col,lyr) [kg] + real(r8), pointer :: mss_ocpho(:,:) ! mass of hydrophobic OC in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocphi(:,:) ! mass of hydrophilic OC in snow (col,lyr) [kg] + real(r8), pointer :: mss_octot(:,:) ! total mass of OC in snow (col,lyr) [kg] + real(r8), pointer :: mss_oc_col(:) ! total column mass of OC in snow (col,lyr) [kg] + real(r8), pointer :: mss_oc_top(:) ! total top-layer mass of OC (col,lyr) [kg] + real(r8), pointer :: mss_dst1(:,:) ! mass of dust species 1 in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst2(:,:) ! mass of dust species 2 in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst3(:,:) ! mass of dust species 3 in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst4(:,:) ! mass of dust species 4 in snow (col,lyr) [kg] + real(r8), pointer :: mss_dsttot(:,:) ! total mass of dust in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst_col(:) ! total column mass of dust in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst_top(:) ! total top-layer mass of dust in snow (col,lyr) [kg] + !Additional SNICAR variables from Hydrology2 + real(r8), pointer :: mss_cnc_bcphi(:,:) ! mass concentration of BC species 1 (col,lyr) [kg/kg] + real(r8), pointer :: mss_cnc_bcpho(:,:) ! mass concentration of BC species 2 (col,lyr) [kg/kg] + real(r8), pointer :: mss_cnc_ocphi(:,:) ! mass concentration of OC species 1 (col,lyr) [kg/kg] + real(r8), pointer :: mss_cnc_ocpho(:,:) ! mass concentration of OC species 2 (col,lyr) [kg/kg] + real(r8), pointer :: mss_cnc_dst1(:,:) ! mass concentration of dust species 1 (col,lyr) [kg/kg] + real(r8), pointer :: mss_cnc_dst2(:,:) ! mass concentration of dust species 2 (col,lyr) [kg/kg] + real(r8), pointer :: mss_cnc_dst3(:,:) ! mass concentration of dust species 3 (col,lyr) [kg/kg] + real(r8), pointer :: mss_cnc_dst4(:,:) ! mass concentration of dust species 4 (col,lyr) [kg/kg] + + + ! New Diagnostics + real(r8), pointer :: snot_top(:) ! snow temperature in top layer (col) [K] + real(r8), pointer :: dTdz_top(:) ! temperature gradient in top layer (col) [K m-1] + real(r8), pointer :: snw_rds_top(:) ! effective snow grain size, top layer(col) [microns] + real(r8), pointer :: sno_liq_top(:) ! liquid water fraction in top snow layer (col) [frc] + real(r8), pointer :: h2osno_top(:) ! mass of snow in top layer (col) [kg] + + +!!!!!! +! +!EOP +! +! !OTHER LOCAL VARIABLES: +! + integer :: p,fp,g,l,c,j,fc,jtop ! indices + integer :: num_shlakesnowc ! number of column snow points + integer :: filter_shlakesnowc(ubc-lbc+1) ! column filter for snow points + integer :: num_shlakenosnowc ! number of column non-snow points + integer :: filter_shlakenosnowc(ubc-lbc+1) ! column filter for non-snow points + real(r8) :: dtime ! land model time step (sec) + integer :: newnode ! flag when new snow node is set, (1=yes, 0=no) + real(r8) :: dz_snowf ! layer thickness rate change due to precipitation [mm/s] + real(r8) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + real(r8) :: fracsnow(lbp:ubp) ! frac of precipitation that is snow + real(r8) :: fracrain(lbp:ubp) ! frac of precipitation that is rain + real(r8) :: qflx_prec_grnd_snow(lbp:ubp) ! snow precipitation incident on ground [mm/s] + real(r8) :: qflx_prec_grnd_rain(lbp:ubp) ! rain precipitation incident on ground [mm/s] + real(r8) :: qflx_evap_soi_lim ! temporary evap_soi limited by top snow layer content [mm/s] + real(r8) :: h2osno_temp ! temporary h2osno [kg/m^2] + real(r8) :: sumsnowice(lbc:ubc) ! sum of snow ice if snow layers found above unfrozen lake [kg/m&2] + logical :: unfrozen(lbc:ubc) ! true if top lake layer is unfrozen with snow layers above + real(r8) :: heatrem ! used in case above [J/m^2] + real(r8) :: heatsum(lbc:ubc) ! used in case above [J/m^2] + real(r8) :: snowmass ! liquid+ice snow mass in a layer [kg/m2] + real(r8) :: snowcap_scl_fct ! temporary factor used to correct for snow capping + real(r8), parameter :: snow_bd = 250._r8 ! assumed snow bulk density (for lakes w/out resolved snow layers) [kg/m^3] + ! Should only be used for frost below. +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtypes components (gridcell-level) + + forc_rain => clm_a2l%forc_rain + forc_snow => clm_a2l%forc_snow + forc_t => clm_a2l%forc_t + + ! Assign local pointers to derived subtypes components (column-level) + + frac_sno_eff => cps%frac_sno_eff + cgridcell =>col%gridcell + clandunit =>col%landunit + snl => cps%snl + t_grnd => ces%t_grnd + h2osno => cws%h2osno + snowice => cws%snowice + snowliq => cws%snowliq + zwt => cws%zwt + fcov => cws%fcov + fsat => cws%fsat + qcharge => cws%qcharge + qflx_top_soil => cwf%qflx_top_soil + qflx_prec_grnd_col => pwf_a%qflx_prec_grnd + qflx_evap_grnd_col => pwf_a%qflx_evap_grnd + qflx_dew_grnd_col => pwf_a%qflx_dew_grnd + qflx_dew_snow_col => pwf_a%qflx_dew_snow + qflx_sub_snow_col => pwf_a%qflx_sub_snow + qflx_snwcp_ice_col => pwf_a%qflx_snwcp_ice + watsat => cps%watsat + z => cps%z + dz => cps%dz + zi => cps%zi + t_soisno => ces%t_soisno + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + h2osoi_vol => cws%h2osoi_vol + qflx_drain => cwf%qflx_drain + qflx_surf => cwf%qflx_surf + qflx_infl => cwf%qflx_infl + qflx_qrgwl => cwf%qflx_qrgwl + qflx_runoff => cwf%qflx_runoff + qflx_irrig => cwf%qflx_irrig + endwb => cwbal%endwb + begwb => cwbal%begwb + dz_lake => cps%dz_lake + t_lake => ces%t_lake + lake_icefrac => cws%lake_icefrac + do_capsnow => cps%do_capsnow + snow_depth => cps%snow_depth + qflx_snow_grnd_col => pwf_a%qflx_snow_grnd + frac_iceold => cps%frac_iceold + qflx_evap_tot_col => pwf_a%qflx_evap_tot + soilalpha => cws%soilalpha + zwt => cws%zwt + rootr_column => cps%rootr_column + qflx_rain_grnd_col => pwf_a%qflx_rain_grnd + qflx_snomelt => cwf%qflx_snomelt + eflx_snomelt => cef%eflx_snomelt + ! Use column variables here. + qflx_snwcp_ice_col => pwf_a%qflx_snwcp_ice + qflx_snwcp_liq_col => pwf_a%qflx_snwcp_liq + !SNICAR variables from Hydrology1 + snw_rds => cps%snw_rds + mss_bcpho => cps%mss_bcpho + mss_bcphi => cps%mss_bcphi + mss_bctot => cps%mss_bctot + mss_bc_col => cps%mss_bc_col + mss_bc_top => cps%mss_bc_top + mss_ocpho => cps%mss_ocpho + mss_ocphi => cps%mss_ocphi + mss_octot => cps%mss_octot + mss_oc_col => cps%mss_oc_col + mss_oc_top => cps%mss_oc_top + mss_dst1 => cps%mss_dst1 + mss_dst2 => cps%mss_dst2 + mss_dst3 => cps%mss_dst3 + mss_dst4 => cps%mss_dst4 + mss_dsttot => cps%mss_dsttot + mss_dst_col => cps%mss_dst_col + mss_dst_top => cps%mss_dst_top + ! Diagnostics + snot_top => cps%snot_top + dTdz_top => cps%dTdz_top + snw_rds_top => cps%snw_rds_top + sno_liq_top => cps%sno_liq_top + h2osno_top => cps%h2osno_top + ! SNICAR variables from Hydrology2 + mss_cnc_bcphi => cps%mss_cnc_bcphi + mss_cnc_bcpho => cps%mss_cnc_bcpho + mss_cnc_ocphi => cps%mss_cnc_ocphi + mss_cnc_ocpho => cps%mss_cnc_ocpho + mss_cnc_dst1 => cps%mss_cnc_dst1 + mss_cnc_dst2 => cps%mss_cnc_dst2 + mss_cnc_dst3 => cps%mss_cnc_dst3 + mss_cnc_dst4 => cps%mss_cnc_dst4 + ! Flooding terms + qflx_floodg => clm_a2l%forc_flood + qflx_floodc => cwf%qflx_floodc + frost_table => cws%frost_table + zwt_perched => cws%zwt_perched + qflx_drain_perched=> cwf%qflx_drain_perched + qflx_h2osfc_surf => cwf%qflx_h2osfc_surf + qflx_snow_melt => cwf%qflx_snow_melt + qflx_rsub_sat => cwf%qflx_rsub_sat + qflx_top_soil => cwf%qflx_top_soil + qflx_sl_top_soil => cwf%qflx_sl_top_soil + + + + ! Assign local pointers to derived type members (pft-level) + + pcolumn =>pft%column + pgridcell =>pft%gridcell + qflx_sub_snow => pwf%qflx_sub_snow + qflx_evap_grnd => pwf%qflx_evap_grnd + qflx_dew_snow => pwf%qflx_dew_snow + qflx_dew_grnd => pwf%qflx_dew_grnd + qflx_prec_grnd => pwf%qflx_prec_grnd + qflx_snow_grnd_pft => pwf%qflx_snow_grnd + qflx_rain_grnd => pwf%qflx_rain_grnd + qflx_evap_tot => pwf%qflx_evap_tot + qflx_evap_soi => pwf%qflx_evap_soi + qflx_snwcp_ice => pwf%qflx_snwcp_ice + qflx_snwcp_liq => pwf%qflx_snwcp_liq + eflx_sh_tot => pef%eflx_sh_tot + eflx_sh_grnd => pef%eflx_sh_grnd + eflx_soil_grnd => pef%eflx_soil_grnd + eflx_gnet => pef%eflx_gnet + eflx_grnd_lake => pef%eflx_grnd_lake + + + ! Determine step size + + dtime = get_step_size() + + ! Add soil water to water balance. + do j = 1, nlevgrnd + do fc = 1, num_lakec + c = filter_lakec(fc) + begwb(c) = begwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + end do + end do + +!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! Do precipitation onto ground, etc., from Hydrology1. + + do fp = 1, num_lakep + p = filter_lakep(fp) + g = pgridcell(p) + c = pcolumn(p) + + qflx_prec_grnd_snow(p) = forc_snow(g) + qflx_prec_grnd_rain(p) = forc_rain(g) + qflx_prec_grnd(p) = qflx_prec_grnd_snow(p) + qflx_prec_grnd_rain(p) + + if (do_capsnow(c)) then + qflx_snwcp_ice(p) = qflx_prec_grnd_snow(p) + qflx_snwcp_liq(p) = qflx_prec_grnd_rain(p) + qflx_snow_grnd_pft(p) = 0._r8 + qflx_rain_grnd(p) = 0._r8 + else + qflx_snwcp_ice(p) = 0._r8 + qflx_snwcp_liq(p) = 0._r8 + qflx_snow_grnd_pft(p) = qflx_prec_grnd_snow(p) ! ice onto ground (mm/s) + qflx_rain_grnd(p) = qflx_prec_grnd_rain(p) ! liquid water onto ground (mm/s) + end if + ! Assuming one PFT; needed for below + qflx_snow_grnd_col(c) = qflx_snow_grnd_pft(p) + qflx_rain_grnd_col(c) = qflx_rain_grnd(p) + + end do ! (end pft loop) + + ! Determine snow height and snow water + + do fc = 1, num_lakec + c = filter_lakec(fc) + g = cgridcell(c) + + ! Use Alta relationship, Anderson(1976); LaChapelle(1961), + ! U.S.Department of Agriculture Forest Service, Project F, + ! Progress Rep. 1, Alta Avalanche Study Center:Snow Layer Densification. + + if (do_capsnow(c)) then + dz_snowf = 0._r8 + else + if (forc_t(g) > tfrz + 2._r8) then + bifall=50._r8 + 1.7_r8*(17.0_r8)**1.5_r8 + else if (forc_t(g) > tfrz - 15._r8) then + bifall=50._r8 + 1.7_r8*(forc_t(g) - tfrz + 15._r8)**1.5_r8 + else + bifall=50._r8 + end if + dz_snowf = qflx_snow_grnd_col(c)/bifall + snow_depth(c) = snow_depth(c) + dz_snowf*dtime + h2osno(c) = h2osno(c) + qflx_snow_grnd_col(c)*dtime ! snow water equivalent (mm) + end if + + ! When the snow accumulation exceeds 40 mm, initialize snow layer + ! Currently, the water temperature for the precipitation is simply set + ! as the surface air temperature + + newnode = 0 ! flag for when snow node will be initialized + if (snl(c) == 0 .and. qflx_snow_grnd_col(c) > 0.0_r8 .and. snow_depth(c) >= 0.01_r8 + lsadz) then + newnode = 1 + snl(c) = -1 + dz(c,0) = snow_depth(c) ! meter + z(c,0) = -0.5_r8*dz(c,0) + zi(c,-1) = -dz(c,0) + t_soisno(c,0) = min(tfrz, forc_t(g)) ! K + h2osoi_ice(c,0) = h2osno(c) ! kg/m2 + h2osoi_liq(c,0) = 0._r8 ! kg/m2 + frac_iceold(c,0) = 1._r8 + + ! intitialize SNICAR variables for fresh snow: + snw_rds(c,0) = snw_rds_min + + mss_bcpho(c,:) = 0._r8 + mss_bcphi(c,:) = 0._r8 + mss_bctot(c,:) = 0._r8 + mss_bc_col(c) = 0._r8 + mss_bc_top(c) = 0._r8 + + mss_ocpho(c,:) = 0._r8 + mss_ocphi(c,:) = 0._r8 + mss_octot(c,:) = 0._r8 + mss_oc_col(c) = 0._r8 + mss_oc_top(c) = 0._r8 + + mss_dst1(c,:) = 0._r8 + mss_dst2(c,:) = 0._r8 + mss_dst3(c,:) = 0._r8 + mss_dst4(c,:) = 0._r8 + mss_dsttot(c,:) = 0._r8 + mss_dst_col(c) = 0._r8 + mss_dst_top(c) = 0._r8 + end if + + ! The change of ice partial density of surface node due to precipitation. + ! Only ice part of snowfall is added here, the liquid part will be added + ! later. + + if (snl(c) < 0 .and. newnode == 0) then + h2osoi_ice(c,snl(c)+1) = h2osoi_ice(c,snl(c)+1)+dtime*qflx_snow_grnd_col(c) + dz(c,snl(c)+1) = dz(c,snl(c)+1)+dz_snowf*dtime + end if + + end do + + ! Calculate sublimation and dew, adapted from HydrologyLake and Biogeophysics2. + + do fp = 1,num_lakep + p = filter_lakep(fp) + c = pcolumn(p) + jtop = snl(c)+1 + + qflx_evap_grnd(p) = 0._r8 + qflx_sub_snow(p) = 0._r8 + qflx_dew_snow(p) = 0._r8 + qflx_dew_grnd(p) = 0._r8 + + if (jtop <= 0) then ! snow layers + j = jtop + ! Assign ground evaporation to sublimation from soil ice or to dew + ! on snow or ground + + if (qflx_evap_soi(p) >= 0._r8) then + ! for evaporation partitioning between liquid evap and ice sublimation, + ! use the ratio of liquid to (liquid+ice) in the top layer to determine split + ! Since we're not limiting evap over lakes, but still can't remove more from top + ! snow layer than there is there, create temp. limited evap_soi. + qflx_evap_soi_lim = min(qflx_evap_soi(p), (h2osoi_liq(c,j)+h2osoi_ice(c,j))/dtime) + if ((h2osoi_liq(c,j)+h2osoi_ice(c,j)) > 0._r8) then + qflx_evap_grnd(p) = max(qflx_evap_soi_lim*(h2osoi_liq(c,j)/(h2osoi_liq(c,j)+h2osoi_ice(c,j))), 0._r8) + else + qflx_evap_grnd(p) = 0._r8 + end if + qflx_sub_snow(p) = qflx_evap_soi_lim - qflx_evap_grnd(p) + else + ! if (t_grnd(c) < tfrz) then + ! Causes rare blowup when thin snow layer should completely melt and has a high temp after thermal physics, + ! but then is not eliminated in SnowHydrology because of this added frost. Also see below removal of + ! completely melted single snow layer. + if (t_grnd(c) < tfrz .and. t_soisno(c,j) < tfrz) then + qflx_dew_snow(p) = abs(qflx_evap_soi(p)) + ! If top layer is only snow layer, SnowHydrology won't eliminate it if dew is added. + else if (j < 0 .or. (t_grnd(c) == tfrz .and. t_soisno(c,j) == tfrz)) then + qflx_dew_grnd(p) = abs(qflx_evap_soi(p)) + end if + end if + ! Update the pft-level qflx_snowcap + ! This was moved in from Hydrology2 to keep all pft-level + ! calculations out of Hydrology2 + if (do_capsnow(c)) then + qflx_snwcp_ice(p) = qflx_snwcp_ice(p) + qflx_dew_snow(p) + qflx_snwcp_liq(p) = qflx_snwcp_liq(p) + qflx_dew_grnd(p) + end if + + else ! No snow layers: do as in HydrologyLake but with actual clmtype variables + if (qflx_evap_soi(p) >= 0._r8) then + ! Sublimation: do not allow for more sublimation than there is snow + ! after melt. Remaining surface evaporation used for infiltration. + qflx_sub_snow(p) = min(qflx_evap_soi(p), h2osno(c)/dtime) + qflx_evap_grnd(p) = qflx_evap_soi(p) - qflx_sub_snow(p) + else + if (t_grnd(c) < tfrz-0.1_r8) then + qflx_dew_snow(p) = abs(qflx_evap_soi(p)) + else + qflx_dew_grnd(p) = abs(qflx_evap_soi(p)) + end if + end if + + ! Update snow pack for dew & sub. + + h2osno_temp = h2osno(c) + if (do_capsnow(c)) then + h2osno(c) = h2osno(c) - qflx_sub_snow(p)*dtime + qflx_snwcp_ice(p) = qflx_snwcp_ice(p) + qflx_dew_snow(p) + qflx_snwcp_liq(p) = qflx_snwcp_liq(p) + qflx_dew_grnd(p) + else + h2osno(c) = h2osno(c) + (-qflx_sub_snow(p)+qflx_dew_snow(p))*dtime + end if + if (h2osno_temp > 0._r8) then + snow_depth(c) = snow_depth(c) * h2osno(c) / h2osno_temp + else + snow_depth(c) = h2osno(c)/snow_bd !Assume a constant snow bulk density = 250. + end if + +#if (defined PERGRO) + if (abs(h2osno(c)) < 1.e-10_r8) h2osno(c) = 0._r8 + if (h2osno(c) == 0._r8) snow_depth(c) = 0._r8 +#else + h2osno(c) = max(h2osno(c), 0._r8) +#endif + + end if + + qflx_snwcp_ice_col(c) = qflx_snwcp_ice(p) + qflx_snwcp_liq_col(c) = qflx_snwcp_liq(p) + + + end do + + ! pft averages must be done here -- BEFORE SNOW CALCULATIONS AS THEY USE IT. + ! for output to history tape and other uses + ! (note that pft2col is called before SLakeHydrology, so we can't use that routine + ! to do these column -> pft averages) + do fp = 1,num_lakep + p = filter_lakep(fp) + c = pcolumn(p) + qflx_evap_tot_col(c) = qflx_evap_tot(p) + qflx_prec_grnd_col(c) = qflx_prec_grnd(p) + qflx_evap_grnd_col(c) = qflx_evap_grnd(p) + qflx_dew_grnd_col(c) = qflx_dew_grnd(p) + qflx_dew_snow_col(c) = qflx_dew_snow(p) + qflx_sub_snow_col(c) = qflx_sub_snow(p) + + enddo + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Determine initial snow/no-snow filters (will be modified possibly by + ! routines CombineSnowLayers and DivideSnowLayers below) + + call BuildSnowFilter(lbc, ubc, num_lakec, filter_lakec, & + num_shlakesnowc, filter_shlakesnowc, num_shlakenosnowc, filter_shlakenosnowc) + + ! specify snow fraction + do fc = 1, num_lakec + c = filter_lakec(fc) + if (h2osno(c) > 0.0_r8) then + frac_sno_eff(c) = 1._r8 + else + frac_sno_eff(c) = 0._r8 + endif + enddo + + ! Determine the change of snow mass and the snow water onto soil + + call SnowWater(lbc, ubc, num_shlakesnowc, filter_shlakesnowc, num_shlakenosnowc, filter_shlakenosnowc) + + + ! Determine soil hydrology + ! Here this consists only of making sure that soil is saturated even as it melts and + ! pore space opens up. Conversely, if excess ice is melting and the liquid water exceeds the + ! saturation value, then remove water. + + do j = 1,nlevsoi !nlevgrnd + ! changed to nlevsoi on 8/11/10 to make consistent with non-lake bedrock + do fc = 1, num_lakec + c = filter_lakec(fc) + + h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) + ! Could have changed during phase change! (Added 8/11/10) + + if (h2osoi_vol(c,j) < watsat(c,j)) then + h2osoi_liq(c,j) = (watsat(c,j)*dz(c,j) - h2osoi_ice(c,j)/denice)*denh2o + ! h2osoi_vol will be updated below, and this water addition will come from qflx_qrgwl + else if (h2osoi_liq(c,j) > watsat(c,j)*denh2o*dz(c,j)) then + h2osoi_liq(c,j) = watsat(c,j)*denh2o*dz(c,j) + ! Another way to do this would be: if h2osoi_vol > watsat then remove min(h2osoi_liq, + !(h2osoi_vol-watsat)*dz*denh2o) from h2osoi_liq. The question is whether the excess ice + ! melts first or last (or simultaneously) to the pore ice. Because excess ice is often in chunks, + ! requiring greater convergence of heat to melt, assume it melts last. + ! This will also improve the initialization behavior or in an occasionally warm year, the excess ice + ! won't start going away if a layer is briefly at freezing. + + ! Allow up to 10% excess ice over watsat in refreezing soil, + ! e.g. heaving soil. (As with > 10% excess ice modeling, and for the lake water, + ! the thermal conductivity will be adjusted down to compensate for the fact that the nominal dz is smaller + ! than the real soil volume.) The current solution is consistent but perhaps unrealistic in real soils, + ! where slow drainage may occur during freezing; drainage is only assumed to occur here when >10% excess + ! ice melts. The latter is more likely to be permanent rather than seasonal anyway. Attempting to remove the + ! ice volume after some has already frozen during the timestep would not conserve energy unless this were + ! incorporated into the ice stream. + + end if + + end do + end do +!!!!!!!!!! + + if (.not. is_perpetual()) then + + ! Natural compaction and metamorphosis. + + call SnowCompaction(lbc, ubc, num_shlakesnowc, filter_shlakesnowc) + + ! Combine thin snow elements + + call CombineSnowLayers(lbc, ubc, num_shlakesnowc, filter_shlakesnowc) + + ! Divide thick snow elements + + call DivideSnowLayers_Lake(lbc, ubc, num_shlakesnowc, filter_shlakesnowc) + + else + + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + h2osno(c) = 0._r8 + end do + do j = -nlevsno+1,0 + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + if (j >= snl(c)+1) then + h2osno(c) = h2osno(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + end if + end do + end do + + end if + + ! Check for single completely unfrozen snow layer over lake. Modeling this ponding is unnecessary and + ! can cause instability after the timestep when melt is completed, as the temperature after melt can be + ! excessive because the fluxes were calculated with a fixed ground temperature of freezing, but the + ! phase change was unable to restore the temperature to freezing. + do fp = 1, num_lakep + p = filter_lakep(fp) + c = pcolumn(p) + + j = 0 + + ! TJH this block is to correct for bugzilla 1927 ... ultimately bugzilla 1717 + ! http://bugs.cgd.ucar.edu/show_bug.cgi?id=1927 + ! http://bugs.cgd.ucar.edu/show_bug.cgi?id=1717 + + if (snl(c) == -1) then + if (h2osoi_ice(c,j) > 0._r8 .and. t_soisno(c,j) > tfrz) then + + ! Take extra heat of layer and release to sensible heat in order + ! to maintain energy conservation. + heatrem = (cpliq*h2osoi_liq(c,j))*(t_soisno(c,j) - tfrz) + t_soisno(c,j) = tfrz + eflx_sh_tot(p) = eflx_sh_tot(p) + heatrem/dtime + eflx_sh_grnd(p) = eflx_sh_grnd(p) + heatrem/dtime + eflx_soil_grnd(p) = eflx_soil_grnd(p) - heatrem/dtime + eflx_gnet(p) = eflx_gnet(p) - heatrem/dtime + eflx_grnd_lake(p) = eflx_grnd_lake(p) - heatrem/dtime + else if (h2osoi_ice(c,j) == 0._r8) then + ! Remove layer + ! Take extra heat of layer and release to sensible heat in order + ! to maintain energy conservation. + heatrem = cpliq*h2osoi_liq(c,j)*(t_soisno(c,j) - tfrz) + eflx_sh_tot(p) = eflx_sh_tot(p) + heatrem/dtime + eflx_sh_grnd(p) = eflx_sh_grnd(p) + heatrem/dtime + eflx_soil_grnd(p) = eflx_soil_grnd(p) - heatrem/dtime + eflx_gnet(p) = eflx_gnet(p) - heatrem/dtime + eflx_grnd_lake(p) = eflx_grnd_lake(p) - heatrem/dtime + qflx_sl_top_soil(c) = qflx_sl_top_soil(c) + h2osno(c)/dtime + snl(c) = 0 + h2osno(c) = 0._r8 + snow_depth(c) = 0._r8 + ! Rest of snow layer book-keeping will be done below. + else + eflx_grnd_lake(p) = eflx_gnet(p) + end if + else + eflx_grnd_lake(p) = eflx_gnet(p) + end if + end do + + + ! Check for snow layers above lake with unfrozen top layer. Mechanically, + ! the snow will fall into the lake and melt or turn to ice. If the top layer has + ! sufficient heat to melt the snow without freezing, then that will be done. + ! Otherwise, the top layer will undergo freezing, but only if the top layer will + ! not freeze completely. Otherwise, let the snow layers persist and melt by diffusion. + do fc = 1, num_lakec + c = filter_lakec(fc) + + if (t_lake(c,1) > tfrz .and. lake_icefrac(c,1) == 0._r8 .and. snl(c) < 0) then + unfrozen(c) = .true. + else + unfrozen(c) = .false. + end if + end do + + do j = -nlevsno+1,0 + do fc = 1, num_lakec + c = filter_lakec(fc) + + if (unfrozen(c)) then + if (j == -nlevsno+1) then + sumsnowice(c) = 0._r8 + heatsum(c) = 0._r8 + end if + if (j >= snl(c)+1) then + sumsnowice(c) = sumsnowice(c) + h2osoi_ice(c,j) + heatsum(c) = heatsum(c) + h2osoi_ice(c,j)*cpice*(tfrz - t_soisno(c,j)) & + + h2osoi_liq(c,j)*cpliq*(tfrz - t_soisno(c,j)) + end if + end if + end do + end do + + do fc = 1, num_lakec + c = filter_lakec(fc) + + if (unfrozen(c)) then + heatsum(c) = heatsum(c) + sumsnowice(c)*hfus + heatrem = (t_lake(c,1) - tfrz)*cpliq*denh2o*dz_lake(c,1) - heatsum(c) + + if (heatrem + denh2o*dz_lake(c,1)*hfus > 0._r8) then + ! Remove snow and subtract the latent heat from the top layer. + qflx_snomelt(c) = qflx_snomelt(c) + h2osno(c)/dtime + eflx_snomelt(c) = eflx_snomelt(c) + h2osno(c)*hfus/dtime + ! update snow melt for this case + qflx_snow_melt(c) = qflx_snow_melt(c) + qflx_snomelt(c) + + qflx_sl_top_soil(c) = qflx_sl_top_soil(c) + h2osno(c) + + h2osno(c) = 0._r8 + snow_depth(c) = 0._r8 + snl(c) = 0 + ! The rest of the bookkeeping for the removed snow will be done below. + if (heatrem > 0._r8) then ! simply subtract the heat from the layer + t_lake(c,1) = tfrz + heatrem/(cpliq*denh2o*dz_lake(c,1)) ! TJH as per Zack/Keith O. + else !freeze part of the layer + t_lake(c,1) = tfrz + lake_icefrac(c,1) = -heatrem/(denh2o*dz_lake(c,1)*hfus) + end if + end if + end if + end do +!!!!!!!!!!!! + + ! Set empty snow layers to zero + + do j = -nlevsno+1,0 + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + if (j <= snl(c) .and. snl(c) > -nlevsno) then + h2osoi_ice(c,j) = 0._r8 + h2osoi_liq(c,j) = 0._r8 + t_soisno(c,j) = 0._r8 + dz(c,j) = 0._r8 + z(c,j) = 0._r8 + zi(c,j-1) = 0._r8 + end if + end do + end do + + ! Build new snow filter + + call BuildSnowFilter(lbc, ubc, num_lakec, filter_lakec, & + num_shlakesnowc, filter_shlakesnowc, num_shlakenosnowc, filter_shlakenosnowc) + + ! Vertically average t_soisno and sum of h2osoi_liq and h2osoi_ice + ! over all snow layers for history output + + do fc = 1, num_lakec + c = filter_lakec(fc) + snowice(c) = 0._r8 + snowliq(c) = 0._r8 + end do + + do j = -nlevsno+1, 0 + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + if (j >= snl(c)+1) then + snowice(c) = snowice(c) + h2osoi_ice(c,j) + snowliq(c) = snowliq(c) + h2osoi_liq(c,j) + end if + end do + end do + + ! Determine ending water balance and volumetric soil water + + do fc = 1, num_lakec + + c = filter_lakec(fc) + endwb(c) = h2osno(c) + end do + + do j = 1, nlevgrnd + do fc = 1, num_lakec + c = filter_lakec(fc) + endwb(c) = endwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) + end do + end do + +!!!!!!!!!!!!! + ! Do history variables and set special landunit runoff (adapted from end of HydrologyLake) + do fp = 1,num_lakep + p = filter_lakep(fp) + c = pcolumn(p) + g = pgridcell(p) + + zwt_perched(c) = spval + frost_table(c) = spval + qflx_drain_perched(c)= 0._r8 + qflx_h2osfc_surf(c) = 0._r8 + qflx_rsub_sat(c) = 0._r8 + qflx_infl(c) = 0._r8 + qflx_surf(c) = 0._r8 + qflx_drain(c) = 0._r8 + qflx_irrig(c) = 0._r8 + rootr_column(c,:) = spval + soilalpha(c) = spval + zwt(c) = spval + fcov(c) = spval + fsat(c) = spval + qcharge(c) = spval + + ! Insure water balance using qflx_qrgwl + qflx_qrgwl(c) = forc_rain(g) + forc_snow(g) - qflx_evap_tot(p) - qflx_snwcp_ice(p) & + - (endwb(c)-begwb(c))/dtime + qflx_floodg(g) + qflx_floodc(c) = qflx_floodg(g) + qflx_runoff(c) = qflx_drain(c) + qflx_surf(c) + qflx_qrgwl(c) + qflx_top_soil(c) = qflx_prec_grnd_rain(p) + qflx_snomelt(c) + + enddo + + ! SNICAR Code and diagnostics + + ! Calculate column-integrated aerosol masses, and + ! mass concentrations for radiative calculations and output + ! (based on new snow level state, after SnowFilter is rebuilt. + ! NEEDS TO BE AFTER SnowFiler is rebuilt, otherwise there + ! can be zero snow layers but an active column in filter) + + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + + ! Zero column-integrated aerosol mass before summation + mss_bc_col(c) = 0._r8 + mss_oc_col(c) = 0._r8 + mss_dst_col(c) = 0._r8 + + do j = -nlevsno+1, 0 + + ! layer mass of snow: + snowmass = h2osoi_ice(c,j)+h2osoi_liq(c,j) + + ! Correct the top layer aerosol mass to account for snow capping. + ! This approach conserves the aerosol mass concentration + ! (but not the aerosol amss) when snow-capping is invoked + + if (j == snl(c)+1) then + if (do_capsnow(c)) then + snowcap_scl_fct = snowmass / (snowmass+(qflx_snwcp_ice_col(c)*dtime)) + ! Make sure column variable here + mss_bcpho(c,j) = mss_bcpho(c,j)*snowcap_scl_fct + mss_bcphi(c,j) = mss_bcphi(c,j)*snowcap_scl_fct + mss_ocpho(c,j) = mss_ocpho(c,j)*snowcap_scl_fct + mss_ocphi(c,j) = mss_ocphi(c,j)*snowcap_scl_fct + + mss_dst1(c,j) = mss_dst1(c,j)*snowcap_scl_fct + mss_dst2(c,j) = mss_dst2(c,j)*snowcap_scl_fct + mss_dst3(c,j) = mss_dst3(c,j)*snowcap_scl_fct + mss_dst4(c,j) = mss_dst4(c,j)*snowcap_scl_fct + endif + endif + + if (j >= snl(c)+1) then + mss_bctot(c,j) = mss_bcpho(c,j) + mss_bcphi(c,j) + mss_bc_col(c) = mss_bc_col(c) + mss_bctot(c,j) + mss_cnc_bcphi(c,j) = mss_bcphi(c,j) / snowmass + mss_cnc_bcpho(c,j) = mss_bcpho(c,j) / snowmass + + mss_octot(c,j) = mss_ocpho(c,j) + mss_ocphi(c,j) + mss_oc_col(c) = mss_oc_col(c) + mss_octot(c,j) + mss_cnc_ocphi(c,j) = mss_ocphi(c,j) / snowmass + mss_cnc_ocpho(c,j) = mss_ocpho(c,j) / snowmass + + mss_dsttot(c,j) = mss_dst1(c,j) + mss_dst2(c,j) + mss_dst3(c,j) + mss_dst4(c,j) + mss_dst_col(c) = mss_dst_col(c) + mss_dsttot(c,j) + mss_cnc_dst1(c,j) = mss_dst1(c,j) / snowmass + mss_cnc_dst2(c,j) = mss_dst2(c,j) / snowmass + mss_cnc_dst3(c,j) = mss_dst3(c,j) / snowmass + mss_cnc_dst4(c,j) = mss_dst4(c,j) / snowmass + + else + !set variables of empty snow layers to zero + snw_rds(c,j) = 0._r8 + + mss_bcpho(c,j) = 0._r8 + mss_bcphi(c,j) = 0._r8 + mss_bctot(c,j) = 0._r8 + mss_cnc_bcphi(c,j) = 0._r8 + mss_cnc_bcpho(c,j) = 0._r8 + + mss_ocpho(c,j) = 0._r8 + mss_ocphi(c,j) = 0._r8 + mss_octot(c,j) = 0._r8 + mss_cnc_ocphi(c,j) = 0._r8 + mss_cnc_ocpho(c,j) = 0._r8 + + mss_dst1(c,j) = 0._r8 + mss_dst2(c,j) = 0._r8 + mss_dst3(c,j) = 0._r8 + mss_dst4(c,j) = 0._r8 + mss_dsttot(c,j) = 0._r8 + mss_cnc_dst1(c,j) = 0._r8 + mss_cnc_dst2(c,j) = 0._r8 + mss_cnc_dst3(c,j) = 0._r8 + mss_cnc_dst4(c,j) = 0._r8 + endif + enddo + + ! top-layer diagnostics + h2osno_top(c) = h2osoi_ice(c,snl(c)+1) + h2osoi_liq(c,snl(c)+1) + mss_bc_top(c) = mss_bctot(c,snl(c)+1) + mss_oc_top(c) = mss_octot(c,snl(c)+1) + mss_dst_top(c) = mss_dsttot(c,snl(c)+1) + enddo + + ! Zero mass variables in columns without snow + do fc = 1, num_shlakenosnowc + c = filter_shlakenosnowc(fc) + + h2osno_top(c) = 0._r8 + snw_rds(c,:) = 0._r8 + + mss_bc_top(c) = 0._r8 + mss_bc_col(c) = 0._r8 + mss_bcpho(c,:) = 0._r8 + mss_bcphi(c,:) = 0._r8 + mss_bctot(c,:) = 0._r8 + mss_cnc_bcphi(c,:) = 0._r8 + mss_cnc_bcpho(c,:) = 0._r8 + + mss_oc_top(c) = 0._r8 + mss_oc_col(c) = 0._r8 + mss_ocpho(c,:) = 0._r8 + mss_ocphi(c,:) = 0._r8 + mss_octot(c,:) = 0._r8 + mss_cnc_ocphi(c,:) = 0._r8 + mss_cnc_ocpho(c,:) = 0._r8 + + mss_dst_top(c) = 0._r8 + mss_dst_col(c) = 0._r8 + mss_dst1(c,:) = 0._r8 + mss_dst2(c,:) = 0._r8 + mss_dst3(c,:) = 0._r8 + mss_dst4(c,:) = 0._r8 + mss_dsttot(c,:) = 0._r8 + mss_cnc_dst1(c,:) = 0._r8 + mss_cnc_dst2(c,:) = 0._r8 + mss_cnc_dst3(c,:) = 0._r8 + mss_cnc_dst4(c,:) = 0._r8 + + ! top-layer diagnostics (spval is not averaged when computing history fields) + snot_top(c) = spval + dTdz_top(c) = spval + snw_rds_top(c) = spval + sno_liq_top(c) = spval + enddo + + !Must be done here because the snow filter used in Hydrology2 & the Driver are for non-lake columns. + call SnowAge_grain(lbc, ubc, num_shlakesnowc, filter_shlakesnowc, num_shlakenosnowc, filter_shlakenosnowc) + + end subroutine SLakeHydrology + +end module SLakeHydrologyMod diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeophys/SnowHydrologyMod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeophys/SnowHydrologyMod.F90 new file mode 100644 index 0000000000..7935ccb88b --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeophys/SnowHydrologyMod.F90 @@ -0,0 +1,2359 @@ + +! DART note: this file started life as: +! /glade/p/cesm/releases/cesm1_2_1/models/lnd/clm/src/clm4_5/biogeophys/SnowHydrologyMod.F90 +! +! NOTE: It includes a modified snow grain radius computation documented in bugzilla +! report 1934. + +module SnowHydrologyMod + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: SnowHydrologyMod +! +! !DESCRIPTION: +! Calculate snow hydrology. +! +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use clm_varpar , only: nlevsno + use clm_varctl , only: iulog +! +! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + public :: SnowWater ! Change of snow mass and the snow water onto soil + public :: SnowCompaction ! Change in snow layer thickness due to compaction + public :: CombineSnowLayers ! Combine snow layers less than a min thickness + public :: DivideSnowLayers ! Subdivide snow layers if they exceed maximum thickness + public :: DivideSnowLayers_Lake ! Adjusted so that snow layer thicknesses are larger over lakes + public :: BuildSnowFilter ! Construct snow/no-snow filters +! +! !PRIVATE MEMBER FUNCTIONS: + private :: Combo ! Returns the combined variables: dz, t, wliq, wice. +! +! !REVISION HISTORY: +! Created by Mariana Vertenstein +! +!EOP +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: SnowWater +! +! !INTERFACE: + subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & + num_nosnowc, filter_nosnowc) +! +! !DESCRIPTION: +! Evaluate the change of snow mass and the snow water onto soil. +! Water flow within snow is computed by an explicit and non-physical +! based scheme, which permits a part of liquid water over the holding +! capacity (a tentative value is used, i.e. equal to 0.033*porosity) to +! percolate into the underlying layer. Except for cases where the +! porosity of one of the two neighboring layers is less than 0.05, zero +! flow is assumed. The water flow out of the bottom of the snow pack will +! participate as the input of the soil water and runoff. This subroutine +! uses a filter for columns containing snow which must be constructed prior +! to being called. +! +! !USES: + use clmtype + use clm_varcon , only : denh2o, denice, wimp, ssi, isturb,istsoil,istdlak + use clm_time_manager , only : get_step_size + use clm_atmlnd , only : clm_a2l + use SNICARMod , only : scvng_fct_mlt_bcphi, scvng_fct_mlt_bcpho, & + scvng_fct_mlt_ocphi, scvng_fct_mlt_ocpho, & + scvng_fct_mlt_dst1, scvng_fct_mlt_dst2, & + scvng_fct_mlt_dst3, scvng_fct_mlt_dst4 +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_snowc ! number of snow points in column filter + integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer, intent(in) :: num_nosnowc ! number of non-snow points in column filter + integer, intent(in) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points +! +! !CALLED FROM: +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 15 November 2000: Mariana Vertenstein +! 2/26/02, Peter Thornton: Migrated to new data structures. +! 03/28/08, Mark Flanner: Added aerosol deposition and flushing with meltwater +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arguments +! + real(r8), pointer :: qflx_snow_melt(:) ! net snow melt + integer, pointer :: clandunit(:) ! columns's landunit + integer, pointer :: ltype(:) ! landunit type + real(r8), pointer :: frac_sno_eff(:) ! eff. fraction of ground covered by snow (0 to 1) + real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1) + real(r8), pointer :: int_snow(:) ! integrated snowfall [mm] + real(r8), pointer :: h2osno(:) ! snow water (mm H2O) + real(r8), pointer :: qflx_ev_snow(:) ! evaporation flux from snow (W/m**2) [+ to atm] + real(r8), pointer :: qflx_ev_soil(:) ! evaporation flux from soil (W/m**2) [+ to atm] + real(r8), pointer :: qflx_evap_soi(:) ! evaporation flux from soil (W/m**2) [+ to atm] + integer , pointer :: snl(:) !number of snow layers + logical , pointer :: do_capsnow(:) !true => do snow capping + real(r8), pointer :: qflx_snomelt(:) !snow melt (mm H2O /s) + real(r8), pointer :: qflx_rain_grnd(:) !rain on ground after interception (mm H2O/s) [+] + real(r8), pointer :: qflx_sub_snow(:) !sublimation rate from snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_evap_grnd(:) !ground surface evaporation rate (mm H2O/s) [+] + real(r8), pointer :: qflx_dew_snow(:) !surface dew added to snow pack (mm H2O /s) [+] + real(r8), pointer :: qflx_dew_grnd(:) !ground surface dew formation (mm H2O /s) [+] + real(r8), pointer :: dz(:,:) !layer depth (m) +! +! local pointers to implicit out arguments +! + real(r8), pointer :: qflx_top_soil(:) !net water input into soil from top (mm/s) +! +! local pointers to implicit inout arguments +! + real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) + integer , pointer :: cgridcell(:) ! columns's gridcell (col) + real(r8), pointer :: mss_bcphi(:,:) ! hydrophillic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_bcpho(:,:) ! hydrophobic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocphi(:,:) ! hydrophillic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocpho(:,:) ! hydrophobic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst1(:,:) ! mass of dust species 1 in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst2(:,:) ! mass of dust species 2 in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst3(:,:) ! mass of dust species 3 in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst4(:,:) ! mass of dust species 4 in snow (col,lyr) [kg] + real(r8), pointer :: flx_bc_dep_dry(:) ! dry BC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_bc_dep_wet(:) ! wet BC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_bc_dep(:) ! total BC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_bc_dep_pho(:) ! hydrophobic BC deposition (col) [kg m-1 s-1] + real(r8), pointer :: flx_bc_dep_phi(:) ! hydrophillic BC deposition (col) [kg m-1 s-1] + real(r8), pointer :: flx_oc_dep_dry(:) ! dry OC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_oc_dep_wet(:) ! wet OC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_oc_dep(:) ! total OC deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_oc_dep_pho(:) ! hydrophobic OC deposition (col) [kg m-1 s-1] + real(r8), pointer :: flx_oc_dep_phi(:) ! hydrophillic OC deposition (col) [kg m-1 s-1] + real(r8), pointer :: flx_dst_dep_dry1(:) ! dry dust (species 1) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_wet1(:) ! wet dust (species 1) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_dry2(:) ! dry dust (species 2) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_wet2(:) ! wet dust (species 2) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_dry3(:) ! dry dust (species 3) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_wet3(:) ! wet dust (species 3) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_dry4(:) ! dry dust (species 4) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep_wet4(:) ! wet dust (species 4) deposition (col) [kg m-2 s-1] + real(r8), pointer :: flx_dst_dep(:) ! total dust deposition (col) [kg m-2 s-1] + real(r8), pointer :: forc_aer(:,:) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1] +! +! +! !OTHER LOCAL VARIABLES: +!EOP +! + integer :: c, j, fc, l !do loop/array indices + real(r8) :: dtime !land model time step (sec) + real(r8) :: qin(lbc:ubc) !water flow into the elmement (mm/s) + real(r8) :: qout(lbc:ubc) !water flow out of the elmement (mm/s) + real(r8) :: wgdif !ice mass after minus sublimation + real(r8) :: vol_liq(lbc:ubc,-nlevsno+1:0) !partial volume of liquid water in layer + real(r8) :: vol_ice(lbc:ubc,-nlevsno+1:0) !partial volume of ice lens in layer + real(r8) :: eff_porosity(lbc:ubc,-nlevsno+1:0) !effective porosity = porosity - vol_ice + integer :: g ! gridcell loop index + real(r8) :: qin_bc_phi(lbc:ubc) ! flux of hydrophilic BC into layer [kg] + real(r8) :: qout_bc_phi(lbc:ubc) ! flux of hydrophilic BC out of layer [kg] + real(r8) :: qin_bc_pho(lbc:ubc) ! flux of hydrophobic BC into layer [kg] + real(r8) :: qout_bc_pho(lbc:ubc) ! flux of hydrophobic BC out of layer [kg] + real(r8) :: qin_oc_phi(lbc:ubc) ! flux of hydrophilic OC into layer [kg] + real(r8) :: qout_oc_phi(lbc:ubc) ! flux of hydrophilic OC out of layer [kg] + real(r8) :: qin_oc_pho(lbc:ubc) ! flux of hydrophobic OC into layer [kg] + real(r8) :: qout_oc_pho(lbc:ubc) ! flux of hydrophobic OC out of layer [kg] + real(r8) :: qin_dst1(lbc:ubc) ! flux of dust species 1 into layer [kg] + real(r8) :: qout_dst1(lbc:ubc) ! flux of dust species 1 out of layer [kg] + real(r8) :: qin_dst2(lbc:ubc) ! flux of dust species 2 into layer [kg] + real(r8) :: qout_dst2(lbc:ubc) ! flux of dust species 2 out of layer [kg] + real(r8) :: qin_dst3(lbc:ubc) ! flux of dust species 3 into layer [kg] + real(r8) :: qout_dst3(lbc:ubc) ! flux of dust species 3 out of layer [kg] + real(r8) :: qin_dst4(lbc:ubc) ! flux of dust species 4 into layer [kg] + real(r8) :: qout_dst4(lbc:ubc) ! flux of dust species 4 out of layer [kg] + real(r8) :: mss_liqice ! mass of liquid+ice in a layer + +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtype components (column-level) + + frac_sno_eff => cps%frac_sno_eff + frac_sno => cps%frac_sno + clandunit =>col%landunit + ltype => lun%itype + int_snow => cws%int_snow + h2osno => cws%h2osno + qflx_ev_snow => pwf_a%qflx_ev_snow + qflx_ev_soil => pwf_a%qflx_ev_soil + qflx_evap_soi => pwf_a%qflx_evap_soi + qflx_snow_melt => cwf%qflx_snow_melt + snl => cps%snl + do_capsnow => cps%do_capsnow + qflx_snomelt => cwf%qflx_snomelt + qflx_rain_grnd => pwf_a%qflx_rain_grnd + qflx_sub_snow => pwf_a%qflx_sub_snow + qflx_evap_grnd => pwf_a%qflx_evap_grnd + qflx_dew_snow => pwf_a%qflx_dew_snow + qflx_dew_grnd => pwf_a%qflx_dew_grnd + qflx_top_soil => cwf%qflx_top_soil + dz => cps%dz + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + cgridcell =>col%gridcell + mss_bcphi => cps%mss_bcphi + mss_bcpho => cps%mss_bcpho + mss_ocphi => cps%mss_ocphi + mss_ocpho => cps%mss_ocpho + mss_dst1 => cps%mss_dst1 + mss_dst2 => cps%mss_dst2 + mss_dst3 => cps%mss_dst3 + mss_dst4 => cps%mss_dst4 + flx_bc_dep => cwf%flx_bc_dep + flx_bc_dep_wet => cwf%flx_bc_dep_wet + flx_bc_dep_dry => cwf%flx_bc_dep_dry + flx_bc_dep_phi => cwf%flx_bc_dep_phi + flx_bc_dep_pho => cwf%flx_bc_dep_pho + flx_oc_dep => cwf%flx_oc_dep + flx_oc_dep_wet => cwf%flx_oc_dep_wet + flx_oc_dep_dry => cwf%flx_oc_dep_dry + flx_oc_dep_phi => cwf%flx_oc_dep_phi + flx_oc_dep_pho => cwf%flx_oc_dep_pho + flx_dst_dep => cwf%flx_dst_dep + flx_dst_dep_wet1 => cwf%flx_dst_dep_wet1 + flx_dst_dep_dry1 => cwf%flx_dst_dep_dry1 + flx_dst_dep_wet2 => cwf%flx_dst_dep_wet2 + flx_dst_dep_dry2 => cwf%flx_dst_dep_dry2 + flx_dst_dep_wet3 => cwf%flx_dst_dep_wet3 + flx_dst_dep_dry3 => cwf%flx_dst_dep_dry3 + flx_dst_dep_wet4 => cwf%flx_dst_dep_wet4 + flx_dst_dep_dry4 => cwf%flx_dst_dep_dry4 + forc_aer => clm_a2l%forc_aer + + ! Determine model time step + + dtime = get_step_size() + + ! Renew the mass of ice lens (h2osoi_ice) and liquid (h2osoi_liq) in the + ! surface snow layer resulting from sublimation (frost) / evaporation (condense) + + do fc = 1,num_snowc + c = filter_snowc(fc) + l=clandunit(c) + + if (do_capsnow(c)) then + wgdif = h2osoi_ice(c,snl(c)+1) - frac_sno_eff(c)*qflx_sub_snow(c)*dtime + h2osoi_ice(c,snl(c)+1) = wgdif + if (wgdif < 0._r8) then + h2osoi_ice(c,snl(c)+1) = 0._r8 + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif + end if + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) & + - frac_sno_eff(c)*qflx_evap_grnd(c) * dtime + else + wgdif = h2osoi_ice(c,snl(c)+1) & + + frac_sno_eff(c) * (qflx_dew_snow(c) - qflx_sub_snow(c)) * dtime + h2osoi_ice(c,snl(c)+1) = wgdif + if (wgdif < 0._r8) then + h2osoi_ice(c,snl(c)+1) = 0._r8 + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif + end if + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + & + frac_sno_eff(c) * (qflx_rain_grnd(c) + qflx_dew_grnd(c) & + - qflx_evap_grnd(c)) * dtime + end if + ! if negative, reduce deeper layer's liquid water content sequentially + if(h2osoi_liq(c,snl(c)+1) < 0._r8) then + do j = snl(c)+1, 1 + wgdif=h2osoi_liq(c,j) + if (wgdif >= 0._r8) exit + h2osoi_liq(c,j) = 0._r8 + h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + wgdif + enddo + end if + + end do + + ! Porosity and partial volume + + do j = -nlevsno+1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + ! need to scale dz by frac_sno to convert to grid cell average depth + vol_ice(c,j) = min(1._r8, h2osoi_ice(c,j)/(dz(c,j)*frac_sno_eff(c)*denice)) + eff_porosity(c,j) = 1._r8 - vol_ice(c,j) + vol_liq(c,j) = min(eff_porosity(c,j),h2osoi_liq(c,j)/(dz(c,j)*frac_sno_eff(c)*denh2o)) + end if + end do + end do + + ! Capillary forces within snow are usually two or more orders of magnitude + ! less than those of gravity. Only gravity terms are considered. + ! the genernal expression for water flow is "K * ss**3", however, + ! no effective parameterization for "K". Thus, a very simple consideration + ! (not physically based) is introduced: + ! when the liquid water of layer exceeds the layer's holding + ! capacity, the excess meltwater adds to the underlying neighbor layer. + + ! Also compute aerosol fluxes through snowpack in this loop: + ! 1) compute aerosol mass in each layer + ! 2) add aerosol mass flux from above layer to mass of this layer + ! 3) qout_xxx is mass flux of aerosol species xxx out bottom of + ! layer in water flow, proportional to (current) concentration + ! of aerosol in layer multiplied by a scavenging ratio. + ! 4) update mass of aerosol in top layer, accordingly + ! 5) update mass concentration of aerosol accordingly + + qin(:) = 0._r8 + qin_bc_phi(:) = 0._r8 + qin_bc_pho(:) = 0._r8 + qin_oc_phi(:) = 0._r8 + qin_oc_pho(:) = 0._r8 + qin_dst1(:) = 0._r8 + qin_dst2(:) = 0._r8 + qin_dst3(:) = 0._r8 + qin_dst4(:) = 0._r8 + + do j = -nlevsno+1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + h2osoi_liq(c,j) = h2osoi_liq(c,j) + qin(c) + + mss_bcphi(c,j) = mss_bcphi(c,j) + qin_bc_phi(c) + mss_bcpho(c,j) = mss_bcpho(c,j) + qin_bc_pho(c) + mss_ocphi(c,j) = mss_ocphi(c,j) + qin_oc_phi(c) + mss_ocpho(c,j) = mss_ocpho(c,j) + qin_oc_pho(c) + mss_dst1(c,j) = mss_dst1(c,j) + qin_dst1(c) + mss_dst2(c,j) = mss_dst2(c,j) + qin_dst2(c) + mss_dst3(c,j) = mss_dst3(c,j) + qin_dst3(c) + mss_dst4(c,j) = mss_dst4(c,j) + qin_dst4(c) + + if (j <= -1) then + ! No runoff over snow surface, just ponding on surface + if (eff_porosity(c,j) < wimp .OR. eff_porosity(c,j+1) < wimp) then + qout(c) = 0._r8 + else + ! dz must be scaled by frac_sno to obtain gridcell average value + qout(c) = max(0._r8,(vol_liq(c,j) & + - ssi*eff_porosity(c,j))*dz(c,j)*frac_sno_eff(c)) + qout(c) = min(qout(c),(1._r8-vol_ice(c,j+1) & + - vol_liq(c,j+1))*dz(c,j+1)*frac_sno_eff(c)) + end if + else + qout(c) = max(0._r8,(vol_liq(c,j) & + - ssi*eff_porosity(c,j))*dz(c,j)*frac_sno_eff(c)) + end if + qout(c) = qout(c)*1000._r8 + h2osoi_liq(c,j) = h2osoi_liq(c,j) - qout(c) + qin(c) = qout(c) + + ! mass of ice+water: in extremely rare circumstances, this can + ! be zero, even though there is a snow layer defined. In + ! this case, set the mass to a very small value to + ! prevent division by zero. + mss_liqice = h2osoi_liq(c,j)+h2osoi_ice(c,j) + if (mss_liqice < 1E-30_r8) then + mss_liqice = 1E-30_r8 + endif + + ! BCPHI: + ! 1. flux with meltwater: + qout_bc_phi(c) = qout(c)*scvng_fct_mlt_bcphi*(mss_bcphi(c,j)/mss_liqice) + if (qout_bc_phi(c) > mss_bcphi(c,j)) then + qout_bc_phi(c) = mss_bcphi(c,j) + endif + mss_bcphi(c,j) = mss_bcphi(c,j) - qout_bc_phi(c) + qin_bc_phi(c) = qout_bc_phi(c) + + ! BCPHO: + ! 1. flux with meltwater: + qout_bc_pho(c) = qout(c)*scvng_fct_mlt_bcpho*(mss_bcpho(c,j)/mss_liqice) + if (qout_bc_pho(c) > mss_bcpho(c,j)) then + qout_bc_pho(c) = mss_bcpho(c,j) + endif + mss_bcpho(c,j) = mss_bcpho(c,j) - qout_bc_pho(c) + qin_bc_pho(c) = qout_bc_pho(c) + + ! OCPHI: + ! 1. flux with meltwater: + qout_oc_phi(c) = qout(c)*scvng_fct_mlt_ocphi*(mss_ocphi(c,j)/mss_liqice) + if (qout_oc_phi(c) > mss_ocphi(c,j)) then + qout_oc_phi(c) = mss_ocphi(c,j) + endif + mss_ocphi(c,j) = mss_ocphi(c,j) - qout_oc_phi(c) + qin_oc_phi(c) = qout_oc_phi(c) + + ! OCPHO: + ! 1. flux with meltwater: + qout_oc_pho(c) = qout(c)*scvng_fct_mlt_ocpho*(mss_ocpho(c,j)/mss_liqice) + if (qout_oc_pho(c) > mss_ocpho(c,j)) then + qout_oc_pho(c) = mss_ocpho(c,j) + endif + mss_ocpho(c,j) = mss_ocpho(c,j) - qout_oc_pho(c) + qin_oc_pho(c) = qout_oc_pho(c) + + ! DUST 1: + ! 1. flux with meltwater: + qout_dst1(c) = qout(c)*scvng_fct_mlt_dst1*(mss_dst1(c,j)/mss_liqice) + if (qout_dst1(c) > mss_dst1(c,j)) then + qout_dst1(c) = mss_dst1(c,j) + endif + mss_dst1(c,j) = mss_dst1(c,j) - qout_dst1(c) + qin_dst1(c) = qout_dst1(c) + + ! DUST 2: + ! 1. flux with meltwater: + qout_dst2(c) = qout(c)*scvng_fct_mlt_dst2*(mss_dst2(c,j)/mss_liqice) + if (qout_dst2(c) > mss_dst2(c,j)) then + qout_dst2(c) = mss_dst2(c,j) + endif + mss_dst2(c,j) = mss_dst2(c,j) - qout_dst2(c) + qin_dst2(c) = qout_dst2(c) + + ! DUST 3: + ! 1. flux with meltwater: + qout_dst3(c) = qout(c)*scvng_fct_mlt_dst3*(mss_dst3(c,j)/mss_liqice) + if (qout_dst3(c) > mss_dst3(c,j)) then + qout_dst3(c) = mss_dst3(c,j) + endif + mss_dst3(c,j) = mss_dst3(c,j) - qout_dst3(c) + qin_dst3(c) = qout_dst3(c) + + ! DUST 4: + ! 1. flux with meltwater: + qout_dst4(c) = qout(c)*scvng_fct_mlt_dst4*(mss_dst4(c,j)/mss_liqice) + if (qout_dst4(c) > mss_dst4(c,j)) then + qout_dst4(c) = mss_dst4(c,j) + endif + mss_dst4(c,j) = mss_dst4(c,j) - qout_dst4(c) + qin_dst4(c) = qout_dst4(c) + + end if + end do + end do + + ! Adjust layer thickness for any water+ice content changes in excess of previous + ! layer thickness. Strictly speaking, only necessary for top snow layer, but doing + ! it for all snow layers will catch problems with older initial files. + ! Layer interfaces (zi) and node depths (z) do not need adjustment here because they + ! are adjusted in CombineSnowLayers and are not used up to that point. + + do j = -nlevsno+1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + dz(c,j) = max(dz(c,j),h2osoi_liq(c,j)/denh2o + h2osoi_ice(c,j)/denice) + end if + end do + end do + + do fc = 1, num_snowc + c = filter_snowc(fc) + ! Qout from snow bottom + qflx_snow_melt(c) = qflx_snow_melt(c) + (qout(c) / dtime) + + qflx_top_soil(c) = (qout(c) / dtime) & + + (1.0_r8 - frac_sno_eff(c)) * qflx_rain_grnd(c) + int_snow(c) = int_snow(c) + frac_sno_eff(c) * qflx_dew_snow(c) * dtime & + + frac_sno_eff(c) * qflx_rain_grnd(c) * dtime + end do + + do fc = 1, num_nosnowc + c = filter_nosnowc(fc) + qflx_snow_melt(c) = qflx_snomelt(c) + + qflx_top_soil(c) = qflx_rain_grnd(c) + qflx_snomelt(c) + ! reset accumulated snow when no snow present + if (h2osno(c) <= 0) int_snow(c) = 0. + if (h2osno(c) <= 0) frac_sno(c) = 0. + end do + + + ! set aerosol deposition fluxes from forcing array + ! The forcing array is either set from an external file + ! or from fluxes received from the atmosphere model + do c = lbc,ubc + g = cgridcell(c) + + flx_bc_dep_dry(c) = forc_aer(g,1) + forc_aer(g,2) + flx_bc_dep_wet(c) = forc_aer(g,3) + flx_bc_dep_phi(c) = forc_aer(g,1) + forc_aer(g,3) + flx_bc_dep_pho(c) = forc_aer(g,2) + flx_bc_dep(c) = forc_aer(g,1) + forc_aer(g,2) + forc_aer(g,3) + + flx_oc_dep_dry(c) = forc_aer(g,4) + forc_aer(g,5) + flx_oc_dep_wet(c) = forc_aer(g,6) + flx_oc_dep_phi(c) = forc_aer(g,4) + forc_aer(g,6) + flx_oc_dep_pho(c) = forc_aer(g,5) + flx_oc_dep(c) = forc_aer(g,4) + forc_aer(g,5) + forc_aer(g,6) + + flx_dst_dep_wet1(c) = forc_aer(g,7) + flx_dst_dep_dry1(c) = forc_aer(g,8) + flx_dst_dep_wet2(c) = forc_aer(g,9) + flx_dst_dep_dry2(c) = forc_aer(g,10) + flx_dst_dep_wet3(c) = forc_aer(g,11) + flx_dst_dep_dry3(c) = forc_aer(g,12) + flx_dst_dep_wet4(c) = forc_aer(g,13) + flx_dst_dep_dry4(c) = forc_aer(g,14) + flx_dst_dep(c) = forc_aer(g,7) + forc_aer(g,8) + forc_aer(g,9) + & + forc_aer(g,10) + forc_aer(g,11) + forc_aer(g,12) + & + forc_aer(g,13) + forc_aer(g,14) + + end do + + ! aerosol deposition fluxes into top layer + ! This is done after the inter-layer fluxes so that some aerosol + ! is in the top layer after deposition, and is not immediately + ! washed out before radiative calculations are done + do fc = 1, num_snowc + c = filter_snowc(fc) + mss_bcphi(c,snl(c)+1) = mss_bcphi(c,snl(c)+1) + (flx_bc_dep_phi(c)*dtime) + mss_bcpho(c,snl(c)+1) = mss_bcpho(c,snl(c)+1) + (flx_bc_dep_pho(c)*dtime) + mss_ocphi(c,snl(c)+1) = mss_ocphi(c,snl(c)+1) + (flx_oc_dep_phi(c)*dtime) + mss_ocpho(c,snl(c)+1) = mss_ocpho(c,snl(c)+1) + (flx_oc_dep_pho(c)*dtime) + + mss_dst1(c,snl(c)+1) = mss_dst1(c,snl(c)+1) + (flx_dst_dep_dry1(c) + flx_dst_dep_wet1(c))*dtime + mss_dst2(c,snl(c)+1) = mss_dst2(c,snl(c)+1) + (flx_dst_dep_dry2(c) + flx_dst_dep_wet2(c))*dtime + mss_dst3(c,snl(c)+1) = mss_dst3(c,snl(c)+1) + (flx_dst_dep_dry3(c) + flx_dst_dep_wet3(c))*dtime + mss_dst4(c,snl(c)+1) = mss_dst4(c,snl(c)+1) + (flx_dst_dep_dry4(c) + flx_dst_dep_wet4(c))*dtime + end do + + end subroutine SnowWater + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: SnowCompaction +! +! !INTERFACE: + subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc) +! +! !DESCRIPTION: +! Determine the change in snow layer thickness due to compaction and +! settling. +! Three metamorphisms of changing snow characteristics are implemented, +! i.e., destructive, overburden, and melt. The treatments of the former +! two are from SNTHERM.89 and SNTHERM.99 (1991, 1999). The contribution +! due to melt metamorphism is simply taken as a ratio of snow ice +! fraction after the melting versus before the melting. +! +! !USES: + use clmtype + use clm_time_manager, only : get_step_size + use clm_varcon , only : denice, denh2o, tfrz, istice_mec + use clm_varcon , only : rpi, isturb, istdlak, istsoil, istcrop + use clm_varctl , only : subgridflag +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_snowc ! number of column snow points in column filter + integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in module Hydrology2Mod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/28/02, Peter Thornton: Migrated to new data structures +! 2/29/08, David Lawrence: Revised snow overburden to be include 0.5 weight of current layer +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in scalars +! + real(r8), pointer :: frac_sno(:) !snow covered fraction + real(r8), pointer :: swe_old(:,:) !initial swe values + real(r8), pointer :: int_snow(:) !integrated snowfall [mm] + real(r8), pointer :: n_melt(:) !SCA shape parameter + integer, pointer :: snl(:) !number of snow layers +! +! local pointers to implicit in arguments +! + integer, pointer :: imelt(:,:) !flag for melting (=1), freezing (=2), Not=0 + real(r8), pointer :: frac_iceold(:,:) !fraction of ice relative to the tot water + real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin) + real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) +! +! local pointers to implicit inout arguments +! + real(r8), pointer :: dz(:,:) !layer depth (m) +! +! +! !OTHER LOCAL VARIABLES: +!EOP +! + integer :: j, l, c, fc ! indices + real(r8):: dtime ! land model time step (sec) + real(r8), parameter :: c2 = 23.e-3_r8 ! [m3/kg] + real(r8), parameter :: c3 = 2.777e-6_r8 ! [1/s] + real(r8), parameter :: c4 = 0.04_r8 ! [1/K] + real(r8), parameter :: c5 = 2.0_r8 ! + real(r8), parameter :: dm = 100.0_r8 ! Upper Limit on Destructive Metamorphism Compaction [kg/m3] + real(r8), parameter :: eta0 = 9.e+5_r8 ! The Viscosity Coefficient Eta0 [kg-s/m2] + real(r8) :: burden(lbc:ubc) ! pressure of overlying snow [kg/m2] + real(r8) :: ddz1 ! Rate of settling of snowpack due to destructive metamorphism. + real(r8) :: ddz2 ! Rate of compaction of snowpack due to overburden. + real(r8) :: ddz3 ! Rate of compaction of snowpack due to melt [1/s] + real(r8) :: dexpf ! expf=exp(-c4*(273.15-t_soisno)). + real(r8) :: fi ! Fraction of ice relative to the total water content at current time step + real(r8) :: td ! t_soisno - tfrz [K] + real(r8) :: pdzdtc ! Nodal rate of change in fractional-thickness due to compaction [fraction/s] + real(r8) :: void ! void (1 - vol_ice - vol_liq) + real(r8) :: wx ! water mass (ice+liquid) [kg/m2] + real(r8) :: bi ! partial density of ice [kg/m3] + real(r8) :: wsum ! snowpack total water mass (ice+liquid) [kg/m2] + real(r8) :: fsno_melt + integer, pointer :: clandunit(:) !landunit index for each column + integer, pointer :: ltype(:) !landunit type + real(r8), pointer :: snow_depth(:) ! snow height (m) + +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtypes (column-level) + + snow_depth => cps%snow_depth + frac_sno => cps%frac_sno_eff + swe_old => cws%swe_old + int_snow => cws%int_snow + ltype => lun%itype + clandunit =>col%landunit + n_melt => cps%n_melt + snl => cps%snl + dz => cps%dz + imelt => cps%imelt + frac_iceold => cps%frac_iceold + t_soisno => ces%t_soisno + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + clandunit =>col%landunit + ltype => lun%itype + + ! Get time step + + dtime = get_step_size() + + ! Begin calculation - note that the following column loops are only invoked if snl(c) < 0 + + burden(:) = 0._r8 + + do j = -nlevsno+1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + + wx = h2osoi_ice(c,j) + h2osoi_liq(c,j) + void = 1._r8 - (h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o) / dz(c,j) + wx = (h2osoi_ice(c,j) + h2osoi_liq(c,j)) + void = 1._r8 - (h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o)& + /(frac_sno(c) * dz(c,j)) + ! If void is negative, then increase dz such that void = 0. + ! This should be done for any landunit, but for now is done only for glacier_mec 1andunits. + l = clandunit(c) + if (ltype(l)==istice_mec .and. void < 0._r8) then + dz(c,j) = h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o + void = 0._r8 + endif + + ! Allow compaction only for non-saturated node and higher ice lens node. + if (void > 0.001_r8 .and. h2osoi_ice(c,j) > .1_r8) then + + bi = h2osoi_ice(c,j) / (frac_sno(c) * dz(c,j)) + fi = h2osoi_ice(c,j) / wx + td = tfrz-t_soisno(c,j) + dexpf = exp(-c4*td) + + ! Settling as a result of destructive metamorphism + + ddz1 = -c3*dexpf + if (bi > dm) ddz1 = ddz1*exp(-46.0e-3_r8*(bi-dm)) + + ! Liquid water term + + if (h2osoi_liq(c,j) > 0.01_r8*dz(c,j)*frac_sno(c)) ddz1=ddz1*c5 + + ! Compaction due to overburden + + ddz2 = -(burden(c)+wx/2._r8)*exp(-0.08_r8*td - c2*bi)/eta0 + + ! Compaction occurring during melt + + if (imelt(c,j) == 1) then + if(subgridflag==1 .and. (ltype(clandunit(c)) == istsoil .or. ltype(clandunit(c)) == istcrop)) then + ! first term is delta mass over mass + ddz3 = max(0._r8,min(1._r8,(swe_old(c,j) - wx)/wx)) + + ! 2nd term is delta fsno over fsno, allowing for negative values for ddz3 + wsum = sum(h2osoi_liq(c,snl(c)+1:0)+h2osoi_ice(c,snl(c)+1:0)) + fsno_melt = 1. - (acos(2.*min(1._r8,wsum/int_snow(c)) - 1._r8)/rpi)**(n_melt(c)) + + ddz3 = ddz3 - max(0._r8,(fsno_melt - frac_sno(c))/frac_sno(c)) + ddz3 = -1._r8/dtime * ddz3 + else + ddz3 = - 1._r8/dtime * max(0._r8,(frac_iceold(c,j) - fi)/frac_iceold(c,j)) + endif + else + ddz3 = 0._r8 + end if + + ! Time rate of fractional change in dz (units of s-1) + + pdzdtc = ddz1 + ddz2 + ddz3 + + ! The change in dz due to compaction + ! Limit compaction to be no greater than fully saturated layer thickness + + dz(c,j) = max(dz(c,j) * (1._r8+pdzdtc*dtime),(h2osoi_ice(c,j)/denice+ h2osoi_liq(c,j)/denh2o)/frac_sno(c)) + end if + + ! Pressure of overlying snow + + burden(c) = burden(c) + wx + + end if + end do + end do + + end subroutine SnowCompaction + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: CombineSnowLayers +! +! !INTERFACE: + subroutine CombineSnowLayers(lbc, ubc, num_snowc, filter_snowc) +! +! !DESCRIPTION: +! Combine snow layers that are less than a minimum thickness or mass +! If the snow element thickness or mass is less than a prescribed minimum, +! then it is combined with a neighboring element. The subroutine +! clm\_combo.f90 then executes the combination of mass and energy. +! +! !USES: + use clmtype + use clm_varcon, only : istsoil, isturb, istdlak + use SLakeCon , only : lsadz + use clm_varcon, only : istsoil, isturb,istwet,istice, istice_mec + use clm_varcon, only : istcrop + use clm_time_manager, only : get_step_size +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(inout) :: num_snowc ! number of column snow points in column filter + integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in module Hydrology2Mod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/28/02, Peter Thornton: Migrated to new data structures. +! 03/28/08, Mark Flanner: Added aerosol masses and snow grain radius +! 05/20/10, Zack Subin: Adjust minimum thickness for snow layers over lakes to be + lsadz +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arguments +! + real(r8), pointer :: frac_sno(:) !fraction of ground covered by snow (0 to 1) + real(r8), pointer :: frac_sno_eff(:) !fraction of ground covered by snow (0 to 1) + real(r8), pointer :: int_snow(:) !integrated snowfall [mm] + integer, pointer :: clandunit(:) !landunit index for each column + integer, pointer :: ltype(:) !landunit type +! +! local pointers to implicit inout arguments +! + integer , pointer :: snl(:) !number of snow layers + real(r8), pointer :: h2osno(:) !snow water (mm H2O) + real(r8), pointer :: snow_depth(:) !snow height (m) + real(r8), pointer :: dz(:,:) !layer depth (m) + real(r8), pointer :: zi(:,:) !interface level below a "z" level (m) + real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin) + real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) +! +! local pointers to implicit out arguments +! + real(r8), pointer :: z(:,:) ! layer thickness (m) + real(r8), pointer :: mss_bcphi(:,:) ! hydrophilic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_bcpho(:,:) ! hydrophobic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocphi(:,:) ! hydrophilic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocpho(:,:) ! hydrophobic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst1(:,:) ! dust species 1 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst2(:,:) ! dust species 2 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst3(:,:) ! dust species 3 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst4(:,:) ! dust species 4 mass in snow (col,lyr) [kg] + real(r8), pointer :: snw_rds(:,:) ! effective snow grain radius (col,lyr) [microns, m^-6] + real(r8), pointer :: qflx_sl_top_soil(:) ! liquid water + ice from layer above soil to top soil layer or sent to qflx_qrgwl (mm H2O/s) +! +! +! !OTHER LOCAL VARIABLES: +!EOP +! + integer :: c, fc ! column indices + integer :: i,k ! loop indices + integer :: j,l ! node indices + integer :: msn_old(lbc:ubc) ! number of top snow layer + integer :: mssi(lbc:ubc) ! node index + integer :: neibor ! adjacent node selected for combination + real(r8):: zwice(lbc:ubc) ! total ice mass in snow + real(r8):: zwliq (lbc:ubc) ! total liquid water in snow + real(r8):: dzmin(5) ! minimum of top snow layer + real(r8):: dzminloc(5) ! minimum of top snow layer (local) + real(r8) :: dtime !land model time step (sec) + + data dzmin /0.010_r8, 0.015_r8, 0.025_r8, 0.055_r8, 0.115_r8/ +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtypes (landunit-level) + + ltype => lun%itype + + ! Assign local pointers to derived subtypes (column-level) + + frac_sno => cps%frac_sno + frac_sno_eff => cps%frac_sno_eff + int_snow => cws%int_snow + clandunit =>col%landunit + snl => cps%snl + snow_depth => cps%snow_depth + h2osno => cws%h2osno + dz => cps%dz + zi => cps%zi + z => cps%z + t_soisno => ces%t_soisno + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + mss_bcphi => cps%mss_bcphi + mss_bcpho => cps%mss_bcpho + mss_ocphi => cps%mss_ocphi + mss_ocpho => cps%mss_ocpho + mss_dst1 => cps%mss_dst1 + mss_dst2 => cps%mss_dst2 + mss_dst3 => cps%mss_dst3 + mss_dst4 => cps%mss_dst4 + snw_rds => cps%snw_rds + qflx_sl_top_soil => cwf%qflx_sl_top_soil + + ! Determine model time step + + dtime = get_step_size() + + + ! Check the mass of ice lens of snow, when the total is less than a small value, + ! combine it with the underlying neighbor. + + dzminloc(:) = dzmin(:) ! dzmin will stay constant between timesteps + + ! Add lsadz to dzmin for lakes + ! Determine whether called from SLakeHydrology + ! Note: this assumes that this function is called separately with the lake-snow and non-lake-snow filters. + if (num_snowc > 0) then + c = filter_snowc(1) + l = clandunit(c) + if (ltype(l) == istdlak) then ! Called from SLakeHydrology + dzminloc(:) = dzmin(:) + lsadz + end if + end if + + do fc = 1, num_snowc + c = filter_snowc(fc) + + msn_old(c) = snl(c) + qflx_sl_top_soil(c) = 0._r8 + end do + + ! The following loop is NOT VECTORIZED + + do fc = 1, num_snowc + c = filter_snowc(fc) + l = clandunit(c) + do j = msn_old(c)+1,0 + ! use 0.01 to avoid runaway ice buildup + if (h2osoi_ice(c,j) <= .01_r8) then + if (ltype(l) == istsoil .or. ltype(l)==isturb .or. ltype(l) == istcrop) then + h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j) + h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j) + + if (j == 0) then + qflx_sl_top_soil(c) = (h2osoi_liq(c,j) + h2osoi_ice(c,j))/dtime + end if + + if (j /= 0) dz(c,j+1) = dz(c,j+1) + dz(c,j) + + ! NOTE: Temperature, and similarly snw_rds, of the + ! underlying snow layer are NOT adjusted in this case. + ! Because the layer being eliminated has a small mass, + ! this should not make a large difference, but it + ! would be more thorough to do so. + if (j /= 0) then + mss_bcphi(c,j+1) = mss_bcphi(c,j+1) + mss_bcphi(c,j) + mss_bcpho(c,j+1) = mss_bcpho(c,j+1) + mss_bcpho(c,j) + mss_ocphi(c,j+1) = mss_ocphi(c,j+1) + mss_ocphi(c,j) + mss_ocpho(c,j+1) = mss_ocpho(c,j+1) + mss_ocpho(c,j) + mss_dst1(c,j+1) = mss_dst1(c,j+1) + mss_dst1(c,j) + mss_dst2(c,j+1) = mss_dst2(c,j+1) + mss_dst2(c,j) + mss_dst3(c,j+1) = mss_dst3(c,j+1) + mss_dst3(c,j) + mss_dst4(c,j+1) = mss_dst4(c,j+1) + mss_dst4(c,j) + end if + + else if (ltype(l) /= istsoil .and. ltype(l) /= isturb .and. ltype(l) /= istcrop .and. j /= 0) then + h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j) + h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j) + dz(c,j+1) = dz(c,j+1) + dz(c,j) + + mss_bcphi(c,j+1) = mss_bcphi(c,j+1) + mss_bcphi(c,j) + mss_bcpho(c,j+1) = mss_bcpho(c,j+1) + mss_bcpho(c,j) + mss_ocphi(c,j+1) = mss_ocphi(c,j+1) + mss_ocphi(c,j) + mss_ocpho(c,j+1) = mss_ocpho(c,j+1) + mss_ocpho(c,j) + mss_dst1(c,j+1) = mss_dst1(c,j+1) + mss_dst1(c,j) + mss_dst2(c,j+1) = mss_dst2(c,j+1) + mss_dst2(c,j) + mss_dst3(c,j+1) = mss_dst3(c,j+1) + mss_dst3(c,j) + mss_dst4(c,j+1) = mss_dst4(c,j+1) + mss_dst4(c,j) + + end if + + ! shift all elements above this down one. + if (j > snl(c)+1 .and. snl(c) < -1) then + do i = j, snl(c)+2, -1 + ! If the layer closest to the surface is less than 0.1 mm and the ltype is not + ! urban, soil or crop, the h2osoi_liq and h2osoi_ice associated with this layer is sent + ! to qflx_qrgwl later on in the code. To keep track of this for the snow balance + ! error check, we add this to qflx_sl_top_soil here + if (ltype(l) /= istsoil .and. ltype(l) /= istcrop .and. ltype(l) /= isturb .and. i == 0) then + qflx_sl_top_soil(c) = (h2osoi_liq(c,i) + h2osoi_ice(c,i))/dtime + end if + + t_soisno(c,i) = t_soisno(c,i-1) + h2osoi_liq(c,i) = h2osoi_liq(c,i-1) + h2osoi_ice(c,i) = h2osoi_ice(c,i-1) + + mss_bcphi(c,i) = mss_bcphi(c,i-1) + mss_bcpho(c,i) = mss_bcpho(c,i-1) + mss_ocphi(c,i) = mss_ocphi(c,i-1) + mss_ocpho(c,i) = mss_ocpho(c,i-1) + mss_dst1(c,i) = mss_dst1(c,i-1) + mss_dst2(c,i) = mss_dst2(c,i-1) + mss_dst3(c,i) = mss_dst3(c,i-1) + mss_dst4(c,i) = mss_dst4(c,i-1) + snw_rds(c,i) = snw_rds(c,i-1) + + dz(c,i) = dz(c,i-1) + end do + end if + snl(c) = snl(c) + 1 + end if + end do + end do + + do fc = 1, num_snowc + c = filter_snowc(fc) + h2osno(c) = 0._r8 + snow_depth(c) = 0._r8 + zwice(c) = 0._r8 + zwliq(c) = 0._r8 + end do + + do j = -nlevsno+1,0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + h2osno(c) = h2osno(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + snow_depth(c) = snow_depth(c) + dz(c,j) + zwice(c) = zwice(c) + h2osoi_ice(c,j) + zwliq(c) = zwliq(c) + h2osoi_liq(c,j) + end if + end do + end do + + ! Check the snow depth - all snow gone + ! The liquid water assumes ponding on soil surface. + + do fc = 1, num_snowc + c = filter_snowc(fc) + l = clandunit(c) + if (snow_depth(c) > 0._r8) then + if ((ltype(l) == istdlak .and. snow_depth(c) < 0.01_r8 + lsadz ) .or. & + ((ltype(l) /= istdlak) .and. ((frac_sno_eff(c)*snow_depth(c) < 0.01_r8) & + .or. (h2osno(c)/(frac_sno_eff(c)*snow_depth(c)) < 50._r8)))) then + + snl(c) = 0 + h2osno(c) = zwice(c) + + mss_bcphi(c,:) = 0._r8 + mss_bcpho(c,:) = 0._r8 + mss_ocphi(c,:) = 0._r8 + mss_ocpho(c,:) = 0._r8 + mss_dst1(c,:) = 0._r8 + mss_dst2(c,:) = 0._r8 + mss_dst3(c,:) = 0._r8 + mss_dst4(c,:) = 0._r8 + + if (h2osno(c) <= 0._r8) snow_depth(c) = 0._r8 + ! this is where water is transfered from layer 0 (snow) to layer 1 (soil) + if (ltype(l) == istsoil .or. ltype(l) == isturb .or. ltype(l) == istcrop) then + h2osoi_liq(c,0) = 0.0_r8 + h2osoi_liq(c,1) = h2osoi_liq(c,1) + zwliq(c) + end if + if (ltype(l) == istwet) then + h2osoi_liq(c,0) = 0.0_r8 + endif + if (ltype(l) == istice .or. ltype(l)==istice_mec) then + h2osoi_liq(c,0) = 0.0_r8 + endif + endif + end if + if (h2osno(c) <= 0._r8) then + snow_depth(c) = 0._r8 + frac_sno(c) = 0._r8 + frac_sno_eff(c) = 0._r8 + int_snow(c) = 0._r8 + endif + end do + + ! Check the snow depth - snow layers combined + ! The following loop IS NOT VECTORIZED + + do fc = 1, num_snowc + c = filter_snowc(fc) + + ! Two or more layers + + if (snl(c) < -1) then + + msn_old(c) = snl(c) + mssi(c) = 1 + + do i = msn_old(c)+1,0 + if ((frac_sno_eff(c)*dz(c,i) < dzminloc(mssi(c))) .or. & + ((h2osoi_ice(c,i) + h2osoi_liq(c,i))/(frac_sno_eff(c)*dz(c,i)) < 50._r8)) then + if (i == snl(c)+1) then + ! If top node is removed, combine with bottom neighbor. + neibor = i + 1 + else if (i == 0) then + ! If the bottom neighbor is not snow, combine with the top neighbor. + neibor = i - 1 + else + ! If none of the above special cases apply, combine with the thinnest neighbor + neibor = i + 1 + if ((dz(c,i-1)+dz(c,i)) < (dz(c,i+1)+dz(c,i))) neibor = i-1 + end if + + ! Node l and j are combined and stored as node j. + if (neibor > i) then + j = neibor + l = i + else + j = i + l = neibor + end if + + ! this should be included in 'Combo' for consistency, + ! but functionally it is the same to do it here + mss_bcphi(c,j)=mss_bcphi(c,j)+mss_bcphi(c,l) + mss_bcpho(c,j)=mss_bcpho(c,j)+mss_bcpho(c,l) + mss_ocphi(c,j)=mss_ocphi(c,j)+mss_ocphi(c,l) + mss_ocpho(c,j)=mss_ocpho(c,j)+mss_ocpho(c,l) + mss_dst1(c,j)=mss_dst1(c,j)+mss_dst1(c,l) + mss_dst2(c,j)=mss_dst2(c,j)+mss_dst2(c,l) + mss_dst3(c,j)=mss_dst3(c,j)+mss_dst3(c,l) + mss_dst4(c,j)=mss_dst4(c,j)+mss_dst4(c,l) + ! mass-weighted combination of effective grain size: + snw_rds(c,j) = (snw_rds(c,j)*(h2osoi_liq(c,j)+h2osoi_ice(c,j)) + & + snw_rds(c,l)*(h2osoi_liq(c,l)+h2osoi_ice(c,l))) / & + (h2osoi_liq(c,j)+h2osoi_ice(c,j)+h2osoi_liq(c,l)+h2osoi_ice(c,l)) + + call Combo (dz(c,j), h2osoi_liq(c,j), h2osoi_ice(c,j), & + t_soisno(c,j), dz(c,l), h2osoi_liq(c,l), h2osoi_ice(c,l), t_soisno(c,l) ) + + ! Now shift all elements above this down one. + if (j-1 > snl(c)+1) then + + do k = j-1, snl(c)+2, -1 + t_soisno(c,k) = t_soisno(c,k-1) + h2osoi_ice(c,k) = h2osoi_ice(c,k-1) + h2osoi_liq(c,k) = h2osoi_liq(c,k-1) + + mss_bcphi(c,k) = mss_bcphi(c,k-1) + mss_bcpho(c,k) = mss_bcpho(c,k-1) + mss_ocphi(c,k) = mss_ocphi(c,k-1) + mss_ocpho(c,k) = mss_ocpho(c,k-1) + mss_dst1(c,k) = mss_dst1(c,k-1) + mss_dst2(c,k) = mss_dst2(c,k-1) + mss_dst3(c,k) = mss_dst3(c,k-1) + mss_dst4(c,k) = mss_dst4(c,k-1) + snw_rds(c,k) = snw_rds(c,k-1) + + dz(c,k) = dz(c,k-1) + end do + end if + + ! Decrease the number of snow layers + snl(c) = snl(c) + 1 + if (snl(c) >= -1) EXIT + + else + + ! The layer thickness is greater than the prescribed minimum value + mssi(c) = mssi(c) + 1 + + end if + end do + + end if + + end do + + ! Reset the node depth and the depth of layer interface + + do j = 0, -nlevsno+1, -1 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c) + 1) then + z(c,j) = zi(c,j) - 0.5_r8*dz(c,j) + zi(c,j-1) = zi(c,j) - dz(c,j) + end if + end do + end do + + end subroutine CombineSnowLayers + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: DivideSnowLayers +! +! !INTERFACE: + subroutine DivideSnowLayers(lbc, ubc, num_snowc, filter_snowc) +! +! !DESCRIPTION: +! Subdivides snow layers if they exceed their prescribed maximum thickness. +! +! !USES: + use clmtype + use clm_varcon, only : tfrz +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(inout) :: num_snowc ! number of column snow points in column filter + integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in module Hydrology2Mod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/28/02, Peter Thornton: Migrated to new data structures. +! 2/29/08, David Lawrence: Snowpack T profile maintained during layer splitting +! 03/28/08, Mark Flanner: Added aerosol masses and snow grain radius +! +! !LOCAL VARIABLES: +! +! local pointers to implicit inout arguments +! + real(r8), pointer :: frac_sno(:) !fraction of ground covered by snow (0 to 1) + integer , pointer :: snl(:) !number of snow layers + real(r8), pointer :: dz(:,:) !layer depth (m) + real(r8), pointer :: zi(:,:) !interface level below a "z" level (m) + real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin) + real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) +! +! local pointers to implicit out arguments +! + real(r8), pointer :: z(:,:) ! layer thickness (m) + real(r8), pointer :: mss_bcphi(:,:) ! hydrophilic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_bcpho(:,:) ! hydrophobic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocphi(:,:) ! hydrophilic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocpho(:,:) ! hydrophobic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst1(:,:) ! dust species 1 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst2(:,:) ! dust species 2 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst3(:,:) ! dust species 3 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst4(:,:) ! dust species 4 mass in snow (col,lyr) [kg] + real(r8), pointer :: snw_rds(:,:) ! effective snow grain radius (col,lyr) [microns, m^-6] +! +! +! !OTHER LOCAL VARIABLES: +!EOP +! + integer :: j, c, fc ! indices + real(r8) :: drr ! thickness of the combined [m] + integer :: msno ! number of snow layer 1 (top) to msno (bottom) + real(r8) :: dzsno(lbc:ubc,nlevsno) ! Snow layer thickness [m] + real(r8) :: swice(lbc:ubc,nlevsno) ! Partial volume of ice [m3/m3] + real(r8) :: swliq(lbc:ubc,nlevsno) ! Partial volume of liquid water [m3/m3] + real(r8) :: tsno(lbc:ubc ,nlevsno) ! Nodel temperature [K] + real(r8) :: zwice ! temporary + real(r8) :: zwliq ! temporary + real(r8) :: propor ! temporary + real(r8) :: dtdz ! temporary + + ! temporary variables mimicking the structure of other layer division variables + real(r8) :: mbc_phi(lbc:ubc,nlevsno) ! mass of BC in each snow layer + real(r8) :: zmbc_phi ! temporary + real(r8) :: mbc_pho(lbc:ubc,nlevsno) ! mass of BC in each snow layer + real(r8) :: zmbc_pho ! temporary + real(r8) :: moc_phi(lbc:ubc,nlevsno) ! mass of OC in each snow layer + real(r8) :: zmoc_phi ! temporary + real(r8) :: moc_pho(lbc:ubc,nlevsno) ! mass of OC in each snow layer + real(r8) :: zmoc_pho ! temporary + real(r8) :: mdst1(lbc:ubc,nlevsno) ! mass of dust 1 in each snow layer + real(r8) :: zmdst1 ! temporary + real(r8) :: mdst2(lbc:ubc,nlevsno) ! mass of dust 2 in each snow layer + real(r8) :: zmdst2 ! temporary + real(r8) :: mdst3(lbc:ubc,nlevsno) ! mass of dust 3 in each snow layer + real(r8) :: zmdst3 ! temporary + real(r8) :: mdst4(lbc:ubc,nlevsno) ! mass of dust 4 in each snow layer + real(r8) :: zmdst4 ! temporary + real(r8) :: rds(lbc:ubc,nlevsno) + +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtype components (column-level) + + frac_sno => cps%frac_sno_eff + snl => cps%snl + dz => cps%dz + zi => cps%zi + z => cps%z + t_soisno => ces%t_soisno + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + mss_bcphi => cps%mss_bcphi + mss_bcpho => cps%mss_bcpho + mss_ocphi => cps%mss_ocphi + mss_ocpho => cps%mss_ocpho + mss_dst1 => cps%mss_dst1 + mss_dst2 => cps%mss_dst2 + mss_dst3 => cps%mss_dst3 + mss_dst4 => cps%mss_dst4 + snw_rds => cps%snw_rds + + + ! Begin calculation - note that the following column loops are only invoked + ! for snow-covered columns + + do j = 1,nlevsno + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j <= abs(snl(c))) then + dzsno(c,j) = frac_sno(c)*dz(c,j+snl(c)) + swice(c,j) = h2osoi_ice(c,j+snl(c)) + swliq(c,j) = h2osoi_liq(c,j+snl(c)) + tsno(c,j) = t_soisno(c,j+snl(c)) + + mbc_phi(c,j) = mss_bcphi(c,j+snl(c)) + mbc_pho(c,j) = mss_bcpho(c,j+snl(c)) + moc_phi(c,j) = mss_ocphi(c,j+snl(c)) + moc_pho(c,j) = mss_ocpho(c,j+snl(c)) + mdst1(c,j) = mss_dst1(c,j+snl(c)) + mdst2(c,j) = mss_dst2(c,j+snl(c)) + mdst3(c,j) = mss_dst3(c,j+snl(c)) + mdst4(c,j) = mss_dst4(c,j+snl(c)) + rds(c,j) = snw_rds(c,j+snl(c)) + + end if + end do + end do + + do fc = 1, num_snowc + c = filter_snowc(fc) + + msno = abs(snl(c)) + + if (msno == 1) then + ! Specify a new snow layer + if (dzsno(c,1) > 0.03_r8) then + msno = 2 + dzsno(c,1) = dzsno(c,1)/2._r8 + swice(c,1) = swice(c,1)/2._r8 + swliq(c,1) = swliq(c,1)/2._r8 + dzsno(c,2) = dzsno(c,1) + swice(c,2) = swice(c,1) + swliq(c,2) = swliq(c,1) + tsno(c,2) = tsno(c,1) + + mbc_phi(c,1) = mbc_phi(c,1)/2._r8 + mbc_phi(c,2) = mbc_phi(c,1) + mbc_pho(c,1) = mbc_pho(c,1)/2._r8 + mbc_pho(c,2) = mbc_pho(c,1) + moc_phi(c,1) = moc_phi(c,1)/2._r8 + moc_phi(c,2) = moc_phi(c,1) + moc_pho(c,1) = moc_pho(c,1)/2._r8 + moc_pho(c,2) = moc_pho(c,1) + mdst1(c,1) = mdst1(c,1)/2._r8 + mdst1(c,2) = mdst1(c,1) + mdst2(c,1) = mdst2(c,1)/2._r8 + mdst2(c,2) = mdst2(c,1) + mdst3(c,1) = mdst3(c,1)/2._r8 + mdst3(c,2) = mdst3(c,1) + mdst4(c,1) = mdst4(c,1)/2._r8 + mdst4(c,2) = mdst4(c,1) + rds(c,2) = rds(c,1) + + end if + end if + + if (msno > 1) then + if (dzsno(c,1) > 0.02_r8) then + drr = dzsno(c,1) - 0.02_r8 + propor = drr/dzsno(c,1) + zwice = propor*swice(c,1) + zwliq = propor*swliq(c,1) + + zmbc_phi = propor*mbc_phi(c,1) + zmbc_pho = propor*mbc_pho(c,1) + zmoc_phi = propor*moc_phi(c,1) + zmoc_pho = propor*moc_pho(c,1) + zmdst1 = propor*mdst1(c,1) + zmdst2 = propor*mdst2(c,1) + zmdst3 = propor*mdst3(c,1) + zmdst4 = propor*mdst4(c,1) + + propor = 0.02_r8/dzsno(c,1) + swice(c,1) = propor*swice(c,1) + swliq(c,1) = propor*swliq(c,1) + + mbc_phi(c,1) = propor*mbc_phi(c,1) + mbc_pho(c,1) = propor*mbc_pho(c,1) + moc_phi(c,1) = propor*moc_phi(c,1) + moc_pho(c,1) = propor*moc_pho(c,1) + mdst1(c,1) = propor*mdst1(c,1) + mdst2(c,1) = propor*mdst2(c,1) + mdst3(c,1) = propor*mdst3(c,1) + mdst4(c,1) = propor*mdst4(c,1) + + dzsno(c,1) = 0.02_r8 + + mbc_phi(c,2) = mbc_phi(c,2)+zmbc_phi ! (combo) + mbc_pho(c,2) = mbc_pho(c,2)+zmbc_pho ! (combo) + moc_phi(c,2) = moc_phi(c,2)+zmoc_phi ! (combo) + moc_pho(c,2) = moc_pho(c,2)+zmoc_pho ! (combo) + mdst1(c,2) = mdst1(c,2)+zmdst1 ! (combo) + mdst2(c,2) = mdst2(c,2)+zmdst2 ! (combo) + mdst3(c,2) = mdst3(c,2)+zmdst3 ! (combo) + mdst4(c,2) = mdst4(c,2)+zmdst4 ! (combo) + !mgf++ 20140225: Mass-weighted combination of radius ... bugzilla 1934 + !rds(c,2) = rds(c,1) ! (combo) + rds(c,2) = (rds(c,2)*(swliq(c,2)+swice(c,2)) + & + rds(c,1)*(zwliq+zwice))/(swliq(c,2)+swice(c,2)+zwliq+zwice) + !mgf-- bugzilla 1934 + + call Combo (dzsno(c,2), swliq(c,2), swice(c,2), tsno(c,2), drr, & + zwliq, zwice, tsno(c,1)) + + ! Subdivide a new layer + if (msno <= 2 .and. dzsno(c,2) > 0.07_r8) then + msno = 3 + dtdz = (tsno(c,1) - tsno(c,2))/((dzsno(c,1)+dzsno(c,2))/2._r8) + dzsno(c,2) = dzsno(c,2)/2._r8 + swice(c,2) = swice(c,2)/2._r8 + swliq(c,2) = swliq(c,2)/2._r8 + dzsno(c,3) = dzsno(c,2) + swice(c,3) = swice(c,2) + swliq(c,3) = swliq(c,2) + tsno(c,3) = tsno(c,2) - dtdz*dzsno(c,2)/2._r8 + if (tsno(c,3) >= tfrz) then + tsno(c,3) = tsno(c,2) + else + tsno(c,2) = tsno(c,2) + dtdz*dzsno(c,2)/2._r8 + endif + + mbc_phi(c,2) = mbc_phi(c,2)/2._r8 + mbc_phi(c,3) = mbc_phi(c,2) + mbc_pho(c,2) = mbc_pho(c,2)/2._r8 + mbc_pho(c,3) = mbc_pho(c,2) + moc_phi(c,2) = moc_phi(c,2)/2._r8 + moc_phi(c,3) = moc_phi(c,2) + moc_pho(c,2) = moc_pho(c,2)/2._r8 + moc_pho(c,3) = moc_pho(c,2) + mdst1(c,2) = mdst1(c,2)/2._r8 + mdst1(c,3) = mdst1(c,2) + mdst2(c,2) = mdst2(c,2)/2._r8 + mdst2(c,3) = mdst2(c,2) + mdst3(c,2) = mdst3(c,2)/2._r8 + mdst3(c,3) = mdst3(c,2) + mdst4(c,2) = mdst4(c,2)/2._r8 + mdst4(c,3) = mdst4(c,2) + rds(c,3) = rds(c,2) + + end if + end if + end if + + if (msno > 2) then + if (dzsno(c,2) > 0.05_r8) then + drr = dzsno(c,2) - 0.05_r8 + propor = drr/dzsno(c,2) + zwice = propor*swice(c,2) + zwliq = propor*swliq(c,2) + + zmbc_phi = propor*mbc_phi(c,2) + zmbc_pho = propor*mbc_pho(c,2) + zmoc_phi = propor*moc_phi(c,2) + zmoc_pho = propor*moc_pho(c,2) + zmdst1 = propor*mdst1(c,2) + zmdst2 = propor*mdst2(c,2) + zmdst3 = propor*mdst3(c,2) + zmdst4 = propor*mdst4(c,2) + + propor = 0.05_r8/dzsno(c,2) + swice(c,2) = propor*swice(c,2) + swliq(c,2) = propor*swliq(c,2) + + mbc_phi(c,2) = propor*mbc_phi(c,2) + mbc_pho(c,2) = propor*mbc_pho(c,2) + moc_phi(c,2) = propor*moc_phi(c,2) + moc_pho(c,2) = propor*moc_pho(c,2) + mdst1(c,2) = propor*mdst1(c,2) + mdst2(c,2) = propor*mdst2(c,2) + mdst3(c,2) = propor*mdst3(c,2) + mdst4(c,2) = propor*mdst4(c,2) + + dzsno(c,2) = 0.05_r8 + + mbc_phi(c,3) = mbc_phi(c,3)+zmbc_phi ! (combo) + mbc_pho(c,3) = mbc_pho(c,3)+zmbc_pho ! (combo) + moc_phi(c,3) = moc_phi(c,3)+zmoc_phi ! (combo) + moc_pho(c,3) = moc_pho(c,3)+zmoc_pho ! (combo) + mdst1(c,3) = mdst1(c,3)+zmdst1 ! (combo) + mdst2(c,3) = mdst2(c,3)+zmdst2 ! (combo) + mdst3(c,3) = mdst3(c,3)+zmdst3 ! (combo) + mdst4(c,3) = mdst4(c,3)+zmdst4 ! (combo) + !mgf++ 20140225: Mass-weighted combination of radius ... bugzilla 1934 + !rds(c,3) = rds(c,2) ! (combo) + rds(c,3) = (rds(c,3)*(swliq(c,3)+swice(c,3)) + & + rds(c,2)*(zwliq+zwice))/(swliq(c,3)+swice(c,3)+zwliq+zwice) + !mgf-- bugzilla 1934 + + + call Combo (dzsno(c,3), swliq(c,3), swice(c,3), tsno(c,3), drr, & + zwliq, zwice, tsno(c,2)) + + ! Subdivided a new layer + if (msno <= 3 .and. dzsno(c,3) > 0.18_r8) then + msno = 4 + dtdz = (tsno(c,2) - tsno(c,3))/((dzsno(c,2)+dzsno(c,3))/2._r8) + dzsno(c,3) = dzsno(c,3)/2._r8 + swice(c,3) = swice(c,3)/2._r8 + swliq(c,3) = swliq(c,3)/2._r8 + dzsno(c,4) = dzsno(c,3) + swice(c,4) = swice(c,3) + swliq(c,4) = swliq(c,3) + tsno(c,4) = tsno(c,3) - dtdz*dzsno(c,3)/2._r8 + if (tsno(c,4) >= tfrz) then + tsno(c,4) = tsno(c,3) + else + tsno(c,3) = tsno(c,3) + dtdz*dzsno(c,3)/2._r8 + endif + + mbc_phi(c,3) = mbc_phi(c,3)/2._r8 + mbc_phi(c,4) = mbc_phi(c,3) + mbc_pho(c,3) = mbc_pho(c,3)/2._r8 + mbc_pho(c,4) = mbc_pho(c,3) + moc_phi(c,3) = moc_phi(c,3)/2._r8 + moc_phi(c,4) = moc_phi(c,3) + moc_pho(c,3) = moc_pho(c,3)/2._r8 + moc_pho(c,4) = moc_pho(c,3) + mdst1(c,3) = mdst1(c,3)/2._r8 + mdst1(c,4) = mdst1(c,3) + mdst2(c,3) = mdst2(c,3)/2._r8 + mdst2(c,4) = mdst2(c,3) + mdst3(c,3) = mdst3(c,3)/2._r8 + mdst3(c,4) = mdst3(c,3) + mdst4(c,3) = mdst4(c,3)/2._r8 + mdst4(c,4) = mdst4(c,3) + rds(c,4) = rds(c,3) + + end if + end if + end if + + if (msno > 3) then + if (dzsno(c,3) > 0.11_r8) then + drr = dzsno(c,3) - 0.11_r8 + propor = drr/dzsno(c,3) + zwice = propor*swice(c,3) + zwliq = propor*swliq(c,3) + + zmbc_phi = propor*mbc_phi(c,3) + zmbc_pho = propor*mbc_pho(c,3) + zmoc_phi = propor*moc_phi(c,3) + zmoc_pho = propor*moc_pho(c,3) + zmdst1 = propor*mdst1(c,3) + zmdst2 = propor*mdst2(c,3) + zmdst3 = propor*mdst3(c,3) + zmdst4 = propor*mdst4(c,3) + + propor = 0.11_r8/dzsno(c,3) + swice(c,3) = propor*swice(c,3) + swliq(c,3) = propor*swliq(c,3) + + mbc_phi(c,3) = propor*mbc_phi(c,3) + mbc_pho(c,3) = propor*mbc_pho(c,3) + moc_phi(c,3) = propor*moc_phi(c,3) + moc_pho(c,3) = propor*moc_pho(c,3) + mdst1(c,3) = propor*mdst1(c,3) + mdst2(c,3) = propor*mdst2(c,3) + mdst3(c,3) = propor*mdst3(c,3) + mdst4(c,3) = propor*mdst4(c,3) + + dzsno(c,3) = 0.11_r8 + + mbc_phi(c,4) = mbc_phi(c,4)+zmbc_phi ! (combo) + mbc_pho(c,4) = mbc_pho(c,4)+zmbc_pho ! (combo) + moc_phi(c,4) = moc_phi(c,4)+zmoc_phi ! (combo) + moc_pho(c,4) = moc_pho(c,4)+zmoc_pho ! (combo) + mdst1(c,4) = mdst1(c,4)+zmdst1 ! (combo) + mdst2(c,4) = mdst2(c,4)+zmdst2 ! (combo) + mdst3(c,4) = mdst3(c,4)+zmdst3 ! (combo) + mdst4(c,4) = mdst4(c,4)+zmdst4 ! (combo) + !mgf++ 20140225: Mass-weighted combination of radius ... bugzilla 1934 + !rds(c,4) = rds(c,3) ! (combo) + rds(c,4) = (rds(c,4)*(swliq(c,4)+swice(c,4)) + & + rds(c,3)*(zwliq+zwice))/(swliq(c,4)+swice(c,4)+zwliq+zwice) + !mgf-- bugzilla 1934 + + + call Combo (dzsno(c,4), swliq(c,4), swice(c,4), tsno(c,4), drr, & + zwliq, zwice, tsno(c,3)) + + ! Subdivided a new layer + if (msno <= 4 .and. dzsno(c,4) > 0.41_r8) then + msno = 5 + dtdz = (tsno(c,3) - tsno(c,4))/((dzsno(c,3)+dzsno(c,4))/2._r8) + dzsno(c,4) = dzsno(c,4)/2._r8 + swice(c,4) = swice(c,4)/2._r8 + swliq(c,4) = swliq(c,4)/2._r8 + dzsno(c,5) = dzsno(c,4) + swice(c,5) = swice(c,4) + swliq(c,5) = swliq(c,4) + tsno(c,5) = tsno(c,4) - dtdz*dzsno(c,4)/2._r8 + if (tsno(c,5) >= tfrz) then + tsno(c,5) = tsno(c,4) + else + tsno(c,4) = tsno(c,4) + dtdz*dzsno(c,4)/2._r8 + endif + + mbc_phi(c,4) = mbc_phi(c,4)/2._r8 + mbc_phi(c,5) = mbc_phi(c,4) + mbc_pho(c,4) = mbc_pho(c,4)/2._r8 + mbc_pho(c,5) = mbc_pho(c,4) + moc_phi(c,4) = moc_phi(c,4)/2._r8 + moc_phi(c,5) = moc_phi(c,4) + moc_pho(c,4) = moc_pho(c,4)/2._r8 + moc_pho(c,5) = moc_pho(c,4) + mdst1(c,4) = mdst1(c,4)/2._r8 + mdst1(c,5) = mdst1(c,4) + mdst2(c,4) = mdst2(c,4)/2._r8 + mdst2(c,5) = mdst2(c,4) + mdst3(c,4) = mdst3(c,4)/2._r8 + mdst3(c,5) = mdst3(c,4) + mdst4(c,4) = mdst4(c,4)/2._r8 + mdst4(c,5) = mdst4(c,4) + rds(c,5) = rds(c,4) + + end if + end if + end if + + if (msno > 4) then + if (dzsno(c,4) > 0.23_r8) then + drr = dzsno(c,4) - 0.23_r8 + propor = drr/dzsno(c,4) + zwice = propor*swice(c,4) + zwliq = propor*swliq(c,4) + + zmbc_phi = propor*mbc_phi(c,4) + zmbc_pho = propor*mbc_pho(c,4) + zmoc_phi = propor*moc_phi(c,4) + zmoc_pho = propor*moc_pho(c,4) + zmdst1 = propor*mdst1(c,4) + zmdst2 = propor*mdst2(c,4) + zmdst3 = propor*mdst3(c,4) + zmdst4 = propor*mdst4(c,4) + + propor = 0.23_r8/dzsno(c,4) + swice(c,4) = propor*swice(c,4) + swliq(c,4) = propor*swliq(c,4) + + mbc_phi(c,4) = propor*mbc_phi(c,4) + mbc_pho(c,4) = propor*mbc_pho(c,4) + moc_phi(c,4) = propor*moc_phi(c,4) + moc_pho(c,4) = propor*moc_pho(c,4) + mdst1(c,4) = propor*mdst1(c,4) + mdst2(c,4) = propor*mdst2(c,4) + mdst3(c,4) = propor*mdst3(c,4) + mdst4(c,4) = propor*mdst4(c,4) + + dzsno(c,4) = 0.23_r8 + + mbc_phi(c,5) = mbc_phi(c,5)+zmbc_phi ! (combo) + mbc_pho(c,5) = mbc_pho(c,5)+zmbc_pho ! (combo) + moc_phi(c,5) = moc_phi(c,5)+zmoc_phi ! (combo) + moc_pho(c,5) = moc_pho(c,5)+zmoc_pho ! (combo) + mdst1(c,5) = mdst1(c,5)+zmdst1 ! (combo) + mdst2(c,5) = mdst2(c,5)+zmdst2 ! (combo) + mdst3(c,5) = mdst3(c,5)+zmdst3 ! (combo) + mdst4(c,5) = mdst4(c,5)+zmdst4 ! (combo) + !mgf++ 20140225: Mass-weighted combination of radius ... bugzilla 1934 + !rds(c,5) = rds(c,4) ! (combo) + rds(c,5) = (rds(c,5)*(swliq(c,5)+swice(c,5)) + & + rds(c,4)*(zwliq+zwice))/(swliq(c,5)+swice(c,5)+zwliq+zwice) + !mgf-- bugzilla 1934 + + call Combo (dzsno(c,5), swliq(c,5), swice(c,5), tsno(c,5), drr, & + zwliq, zwice, tsno(c,4)) + end if + end if + + snl(c) = -msno + + end do + + do j = -nlevsno+1,0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + dz(c,j) = dzsno(c,j-snl(c))/frac_sno(c) + h2osoi_ice(c,j) = swice(c,j-snl(c)) + h2osoi_liq(c,j) = swliq(c,j-snl(c)) + t_soisno(c,j) = tsno(c,j-snl(c)) + + mss_bcphi(c,j) = mbc_phi(c,j-snl(c)) + mss_bcpho(c,j) = mbc_pho(c,j-snl(c)) + mss_ocphi(c,j) = moc_phi(c,j-snl(c)) + mss_ocpho(c,j) = moc_pho(c,j-snl(c)) + mss_dst1(c,j) = mdst1(c,j-snl(c)) + mss_dst2(c,j) = mdst2(c,j-snl(c)) + mss_dst3(c,j) = mdst3(c,j-snl(c)) + mss_dst4(c,j) = mdst4(c,j-snl(c)) + snw_rds(c,j) = rds(c,j-snl(c)) + + end if + end do + end do + + do j = 0, -nlevsno+1, -1 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + z(c,j) = zi(c,j) - 0.5_r8*dz(c,j) + zi(c,j-1) = zi(c,j) - dz(c,j) + end if + end do + end do + + end subroutine DivideSnowLayers + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: Combo +! +! !INTERFACE: + subroutine Combo(dz, wliq, wice, t, dz2, wliq2, wice2, t2) +! +! !DESCRIPTION: +! Combines two elements and returns the following combined +! variables: dz, t, wliq, wice. +! The combined temperature is based on the equation: +! the sum of the enthalpies of the two elements = +! that of the combined element. +! +! !USES: + use clm_varcon, only : cpice, cpliq, tfrz, hfus +! +! !ARGUMENTS: + implicit none + real(r8), intent(in) :: dz2 ! nodal thickness of 2 elements being combined [m] + real(r8), intent(in) :: wliq2 ! liquid water of element 2 [kg/m2] + real(r8), intent(in) :: wice2 ! ice of element 2 [kg/m2] + real(r8), intent(in) :: t2 ! nodal temperature of element 2 [K] + real(r8), intent(inout) :: dz ! nodal thickness of 1 elements being combined [m] + real(r8), intent(inout) :: wliq ! liquid water of element 1 + real(r8), intent(inout) :: wice ! ice of element 1 [kg/m2] + real(r8), intent(inout) :: t ! nodel temperature of elment 1 [K] +! +! !CALLED FROM: +! subroutine CombineSnowLayers in this module +! subroutine DivideSnowLayers in this module +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! +! +! !LOCAL VARIABLES: +!EOP +! + real(r8) :: dzc ! Total thickness of nodes 1 and 2 (dzc=dz+dz2). + real(r8) :: wliqc ! Combined liquid water [kg/m2] + real(r8) :: wicec ! Combined ice [kg/m2] + real(r8) :: tc ! Combined node temperature [K] + real(r8) :: h ! enthalpy of element 1 [J/m2] + real(r8) :: h2 ! enthalpy of element 2 [J/m2] + real(r8) :: hc ! temporary +!----------------------------------------------------------------------- + + dzc = dz+dz2 + wicec = (wice+wice2) + wliqc = (wliq+wliq2) + h = (cpice*wice+cpliq*wliq) * (t-tfrz)+hfus*wliq + h2= (cpice*wice2+cpliq*wliq2) * (t2-tfrz)+hfus*wliq2 + + hc = h + h2 + tc = tfrz + (hc - hfus*wliqc) / (cpice*wicec + cpliq*wliqc) + + dz = dzc + wice = wicec + wliq = wliqc + t = tc + + end subroutine Combo + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: BuildSnowFilter +! +! !INTERFACE: + subroutine BuildSnowFilter(lbc, ubc, num_nolakec, filter_nolakec, & + num_snowc, filter_snowc, & + num_nosnowc, filter_nosnowc) +! +! !DESCRIPTION: +! Constructs snow filter for use in vectorized loops for snow hydrology. +! +! !USES: + use clmtype +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points + integer, intent(out) :: num_snowc ! number of column snow points in column filter + integer, intent(out) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer, intent(out) :: num_nosnowc ! number of column non-snow points in column filter + integer, intent(out) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in Hydrology2Mod +! subroutine CombineSnowLayers in this module +! +! !REVISION HISTORY: +! 2003 July 31: Forrest Hoffman +! +! !LOCAL VARIABLES: +! local pointers to implicit in arguments + integer , pointer :: snl(:) ! number of snow layers +! +! +! !OTHER LOCAL VARIABLES: +!EOP + integer :: fc, c +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtype components (column-level) + + snl => cps%snl + + ! Build snow/no-snow filters for other subroutines + + num_snowc = 0 + num_nosnowc = 0 + do fc = 1, num_nolakec + c = filter_nolakec(fc) + if (snl(c) < 0) then + num_snowc = num_snowc + 1 + filter_snowc(num_snowc) = c + else + num_nosnowc = num_nosnowc + 1 + filter_nosnowc(num_nosnowc) = c + end if + end do + + end subroutine BuildSnowFilter + +!!!!!!!!!!!!!!!!!!! New subroutine for lakes +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: DivideSnowLayers_Lake +! +! !INTERFACE: + subroutine DivideSnowLayers_Lake(lbc, ubc, num_snowc, filter_snowc) +! +! !DESCRIPTION: +! Subdivides snow layers if they exceed their prescribed maximum thickness. +! +! !USES: + use clmtype + use clm_varcon, only : tfrz + use SLakeCon , only : lsadz + use clm_varctl, only : iulog + use abortutils, only : endrun +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(inout) :: num_snowc ! number of column snow points in column filter + integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in module Hydrology2Mod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/28/02, Peter Thornton: Migrated to new data structures. +! 2/29/08, David Lawrence: Snowpack T profile maintained during layer splitting +! 03/28/08, Mark Flanner: Added aerosol masses and snow grain radius +! 05/20/10, Zack Subin: Adjust all thicknesses + lsadz for lakes +! +! !LOCAL VARIABLES: +! +! local pointers to implicit inout arguments +! + integer , pointer :: snl(:) !number of snow layers + real(r8), pointer :: dz(:,:) !layer depth (m) + real(r8), pointer :: zi(:,:) !interface level below a "z" level (m) + real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin) + real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) +! +! local pointers to implicit out arguments +! + real(r8), pointer :: z(:,:) ! layer thickness (m) + real(r8), pointer :: mss_bcphi(:,:) ! hydrophilic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_bcpho(:,:) ! hydrophobic BC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocphi(:,:) ! hydrophilic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_ocpho(:,:) ! hydrophobic OC mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst1(:,:) ! dust species 1 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst2(:,:) ! dust species 2 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst3(:,:) ! dust species 3 mass in snow (col,lyr) [kg] + real(r8), pointer :: mss_dst4(:,:) ! dust species 4 mass in snow (col,lyr) [kg] + real(r8), pointer :: snw_rds(:,:) ! effective snow grain radius (col,lyr) [microns, m^-6] +! +! +! !OTHER LOCAL VARIABLES: +!EOP +! + integer :: j, c, fc ! indices + real(r8) :: drr ! thickness of the combined [m] + integer :: msno ! number of snow layer 1 (top) to msno (bottom) + real(r8) :: dzsno(lbc:ubc,nlevsno) ! Snow layer thickness [m] + real(r8) :: swice(lbc:ubc,nlevsno) ! Partial volume of ice [m3/m3] + real(r8) :: swliq(lbc:ubc,nlevsno) ! Partial volume of liquid water [m3/m3] + real(r8) :: tsno(lbc:ubc ,nlevsno) ! Nodel temperature [K] + real(r8) :: zwice ! temporary + real(r8) :: zwliq ! temporary + real(r8) :: propor ! temporary + real(r8) :: dtdz ! temporary + + ! temporary variables mimicking the structure of other layer division variables + real(r8) :: mbc_phi(lbc:ubc,nlevsno) ! mass of BC in each snow layer + real(r8) :: zmbc_phi ! temporary + real(r8) :: mbc_pho(lbc:ubc,nlevsno) ! mass of BC in each snow layer + real(r8) :: zmbc_pho ! temporary + real(r8) :: moc_phi(lbc:ubc,nlevsno) ! mass of OC in each snow layer + real(r8) :: zmoc_phi ! temporary + real(r8) :: moc_pho(lbc:ubc,nlevsno) ! mass of OC in each snow layer + real(r8) :: zmoc_pho ! temporary + real(r8) :: mdst1(lbc:ubc,nlevsno) ! mass of dust 1 in each snow layer + real(r8) :: zmdst1 ! temporary + real(r8) :: mdst2(lbc:ubc,nlevsno) ! mass of dust 2 in each snow layer + real(r8) :: zmdst2 ! temporary + real(r8) :: mdst3(lbc:ubc,nlevsno) ! mass of dust 3 in each snow layer + real(r8) :: zmdst3 ! temporary + real(r8) :: mdst4(lbc:ubc,nlevsno) ! mass of dust 4 in each snow layer + real(r8) :: zmdst4 ! temporary + real(r8) :: rds(lbc:ubc,nlevsno) + + ! Variables for consistency check + real(r8) :: dztot(lbc:ubc), snwicetot(lbc:ubc), snwliqtot(lbc:ubc) +!----------------------------------------------------------------------- + + ! Assign local pointers to derived subtype components (column-level) + + snl => cps%snl + dz => cps%dz + zi => cps%zi + z => cps%z + t_soisno => ces%t_soisno + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + mss_bcphi => cps%mss_bcphi + mss_bcpho => cps%mss_bcpho + mss_ocphi => cps%mss_ocphi + mss_ocpho => cps%mss_ocpho + mss_dst1 => cps%mss_dst1 + mss_dst2 => cps%mss_dst2 + mss_dst3 => cps%mss_dst3 + mss_dst4 => cps%mss_dst4 + snw_rds => cps%snw_rds + + + ! Initialize for consistency check + do j = -nlevsno+1,0 + do fc = 1, num_snowc + c = filter_snowc(fc) + + if (j == -nlevsno+1) then + dztot(c) = 0._r8 + snwicetot(c) = 0._r8 + snwliqtot(c) = 0._r8 + end if + + if (j >= snl(c)+1) then + dztot(c) = dztot(c) + dz(c,j) + snwicetot(c) = snwicetot(c) + h2osoi_ice(c,j) + snwliqtot(c) = snwliqtot(c) + h2osoi_liq(c,j) + end if + end do + end do + + + ! Begin calculation - note that the following column loops are only invoked + ! for snow-covered columns + + do j = 1,nlevsno + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j <= abs(snl(c))) then + dzsno(c,j) = dz(c,j+snl(c)) + swice(c,j) = h2osoi_ice(c,j+snl(c)) + swliq(c,j) = h2osoi_liq(c,j+snl(c)) + tsno(c,j) = t_soisno(c,j+snl(c)) + + mbc_phi(c,j) = mss_bcphi(c,j+snl(c)) + mbc_pho(c,j) = mss_bcpho(c,j+snl(c)) + moc_phi(c,j) = mss_ocphi(c,j+snl(c)) + moc_pho(c,j) = mss_ocpho(c,j+snl(c)) + mdst1(c,j) = mss_dst1(c,j+snl(c)) + mdst2(c,j) = mss_dst2(c,j+snl(c)) + mdst3(c,j) = mss_dst3(c,j+snl(c)) + mdst4(c,j) = mss_dst4(c,j+snl(c)) + rds(c,j) = snw_rds(c,j+snl(c)) + + end if + end do + end do + + do fc = 1, num_snowc + c = filter_snowc(fc) + + msno = abs(snl(c)) + + if (msno == 1) then + ! Specify a new snow layer + if (dzsno(c,1) > 0.03_r8 + 2._r8 * lsadz) then + msno = 2 + dzsno(c,1) = dzsno(c,1)/2._r8 + swice(c,1) = swice(c,1)/2._r8 + swliq(c,1) = swliq(c,1)/2._r8 + dzsno(c,2) = dzsno(c,1) + swice(c,2) = swice(c,1) + swliq(c,2) = swliq(c,1) + tsno(c,2) = tsno(c,1) + + mbc_phi(c,1) = mbc_phi(c,1)/2._r8 + mbc_phi(c,2) = mbc_phi(c,1) + mbc_pho(c,1) = mbc_pho(c,1)/2._r8 + mbc_pho(c,2) = mbc_pho(c,1) + moc_phi(c,1) = moc_phi(c,1)/2._r8 + moc_phi(c,2) = moc_phi(c,1) + moc_pho(c,1) = moc_pho(c,1)/2._r8 + moc_pho(c,2) = moc_pho(c,1) + mdst1(c,1) = mdst1(c,1)/2._r8 + mdst1(c,2) = mdst1(c,1) + mdst2(c,1) = mdst2(c,1)/2._r8 + mdst2(c,2) = mdst2(c,1) + mdst3(c,1) = mdst3(c,1)/2._r8 + mdst3(c,2) = mdst3(c,1) + mdst4(c,1) = mdst4(c,1)/2._r8 + mdst4(c,2) = mdst4(c,1) + rds(c,2) = rds(c,1) + + end if + end if + + if (msno > 1) then + if (dzsno(c,1) > 0.02_r8 + lsadz) then + drr = dzsno(c,1) - 0.02_r8 - lsadz + propor = drr/dzsno(c,1) + zwice = propor*swice(c,1) + zwliq = propor*swliq(c,1) + + zmbc_phi = propor*mbc_phi(c,1) + zmbc_pho = propor*mbc_pho(c,1) + zmoc_phi = propor*moc_phi(c,1) + zmoc_pho = propor*moc_pho(c,1) + zmdst1 = propor*mdst1(c,1) + zmdst2 = propor*mdst2(c,1) + zmdst3 = propor*mdst3(c,1) + zmdst4 = propor*mdst4(c,1) + + propor = (0.02_r8+lsadz)/dzsno(c,1) + swice(c,1) = propor*swice(c,1) + swliq(c,1) = propor*swliq(c,1) + + mbc_phi(c,1) = propor*mbc_phi(c,1) + mbc_pho(c,1) = propor*mbc_pho(c,1) + moc_phi(c,1) = propor*moc_phi(c,1) + moc_pho(c,1) = propor*moc_pho(c,1) + mdst1(c,1) = propor*mdst1(c,1) + mdst2(c,1) = propor*mdst2(c,1) + mdst3(c,1) = propor*mdst3(c,1) + mdst4(c,1) = propor*mdst4(c,1) + + dzsno(c,1) = 0.02_r8 + lsadz + + mbc_phi(c,2) = mbc_phi(c,2)+zmbc_phi ! (combo) + mbc_pho(c,2) = mbc_pho(c,2)+zmbc_pho ! (combo) + moc_phi(c,2) = moc_phi(c,2)+zmoc_phi ! (combo) + moc_pho(c,2) = moc_pho(c,2)+zmoc_pho ! (combo) + mdst1(c,2) = mdst1(c,2)+zmdst1 ! (combo) + mdst2(c,2) = mdst2(c,2)+zmdst2 ! (combo) + mdst3(c,2) = mdst3(c,2)+zmdst3 ! (combo) + mdst4(c,2) = mdst4(c,2)+zmdst4 ! (combo) + rds(c,2) = rds(c,1) ! (combo) + + call Combo (dzsno(c,2), swliq(c,2), swice(c,2), tsno(c,2), drr, & + zwliq, zwice, tsno(c,1)) + + ! Subdivide a new layer + if (msno <= 2 .and. dzsno(c,2) > 0.07_r8+2._r8*lsadz) then + msno = 3 + dtdz = (tsno(c,1) - tsno(c,2))/((dzsno(c,1)+dzsno(c,2))/2._r8) + dzsno(c,2) = dzsno(c,2)/2._r8 + swice(c,2) = swice(c,2)/2._r8 + swliq(c,2) = swliq(c,2)/2._r8 + dzsno(c,3) = dzsno(c,2) + swice(c,3) = swice(c,2) + swliq(c,3) = swliq(c,2) + tsno(c,3) = tsno(c,2) - dtdz*dzsno(c,2)/2._r8 + if (tsno(c,3) >= tfrz) then + tsno(c,3) = tsno(c,2) + else + tsno(c,2) = tsno(c,2) + dtdz*dzsno(c,2)/2._r8 + endif + + mbc_phi(c,2) = mbc_phi(c,2)/2._r8 + mbc_phi(c,3) = mbc_phi(c,2) + mbc_pho(c,2) = mbc_pho(c,2)/2._r8 + mbc_pho(c,3) = mbc_pho(c,2) + moc_phi(c,2) = moc_phi(c,2)/2._r8 + moc_phi(c,3) = moc_phi(c,2) + moc_pho(c,2) = moc_pho(c,2)/2._r8 + moc_pho(c,3) = moc_pho(c,2) + mdst1(c,2) = mdst1(c,2)/2._r8 + mdst1(c,3) = mdst1(c,2) + mdst2(c,2) = mdst2(c,2)/2._r8 + mdst2(c,3) = mdst2(c,2) + mdst3(c,2) = mdst3(c,2)/2._r8 + mdst3(c,3) = mdst3(c,2) + mdst4(c,2) = mdst4(c,2)/2._r8 + mdst4(c,3) = mdst4(c,2) + rds(c,3) = rds(c,2) + + end if + end if + end if + + if (msno > 2) then + if (dzsno(c,2) > 0.05_r8 + lsadz) then + drr = dzsno(c,2) - 0.05_r8 - lsadz + propor = drr/dzsno(c,2) + zwice = propor*swice(c,2) + zwliq = propor*swliq(c,2) + + zmbc_phi = propor*mbc_phi(c,2) + zmbc_pho = propor*mbc_pho(c,2) + zmoc_phi = propor*moc_phi(c,2) + zmoc_pho = propor*moc_pho(c,2) + zmdst1 = propor*mdst1(c,2) + zmdst2 = propor*mdst2(c,2) + zmdst3 = propor*mdst3(c,2) + zmdst4 = propor*mdst4(c,2) + + propor = (0.05_r8+lsadz)/dzsno(c,2) + swice(c,2) = propor*swice(c,2) + swliq(c,2) = propor*swliq(c,2) + + mbc_phi(c,2) = propor*mbc_phi(c,2) + mbc_pho(c,2) = propor*mbc_pho(c,2) + moc_phi(c,2) = propor*moc_phi(c,2) + moc_pho(c,2) = propor*moc_pho(c,2) + mdst1(c,2) = propor*mdst1(c,2) + mdst2(c,2) = propor*mdst2(c,2) + mdst3(c,2) = propor*mdst3(c,2) + mdst4(c,2) = propor*mdst4(c,2) + + dzsno(c,2) = 0.05_r8+lsadz + + mbc_phi(c,3) = mbc_phi(c,3)+zmbc_phi ! (combo) + mbc_pho(c,3) = mbc_pho(c,3)+zmbc_pho ! (combo) + moc_phi(c,3) = moc_phi(c,3)+zmoc_phi ! (combo) + moc_pho(c,3) = moc_pho(c,3)+zmoc_pho ! (combo) + mdst1(c,3) = mdst1(c,3)+zmdst1 ! (combo) + mdst2(c,3) = mdst2(c,3)+zmdst2 ! (combo) + mdst3(c,3) = mdst3(c,3)+zmdst3 ! (combo) + mdst4(c,3) = mdst4(c,3)+zmdst4 ! (combo) + rds(c,3) = rds(c,2) ! (combo) + + call Combo (dzsno(c,3), swliq(c,3), swice(c,3), tsno(c,3), drr, & + zwliq, zwice, tsno(c,2)) + + ! Subdivided a new layer + if (msno <= 3 .and. dzsno(c,3) > 0.18_r8+2._r8*lsadz) then + msno = 4 + dtdz = (tsno(c,2) - tsno(c,3))/((dzsno(c,2)+dzsno(c,3))/2._r8) + dzsno(c,3) = dzsno(c,3)/2._r8 + swice(c,3) = swice(c,3)/2._r8 + swliq(c,3) = swliq(c,3)/2._r8 + dzsno(c,4) = dzsno(c,3) + swice(c,4) = swice(c,3) + swliq(c,4) = swliq(c,3) + tsno(c,4) = tsno(c,3) - dtdz*dzsno(c,3)/2._r8 + if (tsno(c,4) >= tfrz) then + tsno(c,4) = tsno(c,3) + else + tsno(c,3) = tsno(c,3) + dtdz*dzsno(c,3)/2._r8 + endif + + mbc_phi(c,3) = mbc_phi(c,3)/2._r8 + mbc_phi(c,4) = mbc_phi(c,3) + mbc_pho(c,3) = mbc_pho(c,3)/2._r8 + mbc_pho(c,4) = mbc_pho(c,3) + moc_phi(c,3) = moc_phi(c,3)/2._r8 + moc_phi(c,4) = moc_phi(c,3) + moc_pho(c,3) = moc_pho(c,3)/2._r8 + moc_pho(c,4) = moc_pho(c,3) + mdst1(c,3) = mdst1(c,3)/2._r8 + mdst1(c,4) = mdst1(c,3) + mdst2(c,3) = mdst2(c,3)/2._r8 + mdst2(c,4) = mdst2(c,3) + mdst3(c,3) = mdst3(c,3)/2._r8 + mdst3(c,4) = mdst3(c,3) + mdst4(c,3) = mdst4(c,3)/2._r8 + mdst4(c,4) = mdst4(c,3) + rds(c,4) = rds(c,3) + + end if + end if + end if + + if (msno > 3) then + if (dzsno(c,3) > 0.11_r8 + lsadz) then + drr = dzsno(c,3) - 0.11_r8 - lsadz + propor = drr/dzsno(c,3) + zwice = propor*swice(c,3) + zwliq = propor*swliq(c,3) + + zmbc_phi = propor*mbc_phi(c,3) + zmbc_pho = propor*mbc_pho(c,3) + zmoc_phi = propor*moc_phi(c,3) + zmoc_pho = propor*moc_pho(c,3) + zmdst1 = propor*mdst1(c,3) + zmdst2 = propor*mdst2(c,3) + zmdst3 = propor*mdst3(c,3) + zmdst4 = propor*mdst4(c,3) + + propor = (0.11_r8+lsadz)/dzsno(c,3) + swice(c,3) = propor*swice(c,3) + swliq(c,3) = propor*swliq(c,3) + + mbc_phi(c,3) = propor*mbc_phi(c,3) + mbc_pho(c,3) = propor*mbc_pho(c,3) + moc_phi(c,3) = propor*moc_phi(c,3) + moc_pho(c,3) = propor*moc_pho(c,3) + mdst1(c,3) = propor*mdst1(c,3) + mdst2(c,3) = propor*mdst2(c,3) + mdst3(c,3) = propor*mdst3(c,3) + mdst4(c,3) = propor*mdst4(c,3) + + dzsno(c,3) = 0.11_r8 + lsadz + + mbc_phi(c,4) = mbc_phi(c,4)+zmbc_phi ! (combo) + mbc_pho(c,4) = mbc_pho(c,4)+zmbc_pho ! (combo) + moc_phi(c,4) = moc_phi(c,4)+zmoc_phi ! (combo) + moc_pho(c,4) = moc_pho(c,4)+zmoc_pho ! (combo) + mdst1(c,4) = mdst1(c,4)+zmdst1 ! (combo) + mdst2(c,4) = mdst2(c,4)+zmdst2 ! (combo) + mdst3(c,4) = mdst3(c,4)+zmdst3 ! (combo) + mdst4(c,4) = mdst4(c,4)+zmdst4 ! (combo) + rds(c,4) = rds(c,3) ! (combo) + + call Combo (dzsno(c,4), swliq(c,4), swice(c,4), tsno(c,4), drr, & + zwliq, zwice, tsno(c,3)) + + ! Subdivided a new layer + if (msno <= 4 .and. dzsno(c,4) > 0.41_r8 + 2._r8*lsadz) then + msno = 5 + dtdz = (tsno(c,3) - tsno(c,4))/((dzsno(c,3)+dzsno(c,4))/2._r8) + dzsno(c,4) = dzsno(c,4)/2._r8 + swice(c,4) = swice(c,4)/2._r8 + swliq(c,4) = swliq(c,4)/2._r8 + dzsno(c,5) = dzsno(c,4) + swice(c,5) = swice(c,4) + swliq(c,5) = swliq(c,4) + tsno(c,5) = tsno(c,4) - dtdz*dzsno(c,4)/2._r8 + if (tsno(c,5) >= tfrz) then + tsno(c,5) = tsno(c,4) + else + tsno(c,4) = tsno(c,4) + dtdz*dzsno(c,4)/2._r8 + endif + + mbc_phi(c,4) = mbc_phi(c,4)/2._r8 + mbc_phi(c,5) = mbc_phi(c,4) + mbc_pho(c,4) = mbc_pho(c,4)/2._r8 + mbc_pho(c,5) = mbc_pho(c,4) + moc_phi(c,4) = moc_phi(c,4)/2._r8 + moc_phi(c,5) = moc_phi(c,4) + moc_pho(c,4) = moc_pho(c,4)/2._r8 + moc_pho(c,5) = moc_pho(c,4) + mdst1(c,4) = mdst1(c,4)/2._r8 + mdst1(c,5) = mdst1(c,4) + mdst2(c,4) = mdst2(c,4)/2._r8 + mdst2(c,5) = mdst2(c,4) + mdst3(c,4) = mdst3(c,4)/2._r8 + mdst3(c,5) = mdst3(c,4) + mdst4(c,4) = mdst4(c,4)/2._r8 + mdst4(c,5) = mdst4(c,4) + rds(c,5) = rds(c,4) + + end if + end if + end if + + if (msno > 4) then + if (dzsno(c,4) > 0.23_r8 + lsadz) then + drr = dzsno(c,4) - 0.23_r8 - lsadz + propor = drr/dzsno(c,4) + zwice = propor*swice(c,4) + zwliq = propor*swliq(c,4) + + zmbc_phi = propor*mbc_phi(c,4) + zmbc_pho = propor*mbc_pho(c,4) + zmoc_phi = propor*moc_phi(c,4) + zmoc_pho = propor*moc_pho(c,4) + zmdst1 = propor*mdst1(c,4) + zmdst2 = propor*mdst2(c,4) + zmdst3 = propor*mdst3(c,4) + zmdst4 = propor*mdst4(c,4) + + propor = (0.23_r8+lsadz)/dzsno(c,4) + swice(c,4) = propor*swice(c,4) + swliq(c,4) = propor*swliq(c,4) + + mbc_phi(c,4) = propor*mbc_phi(c,4) + mbc_pho(c,4) = propor*mbc_pho(c,4) + moc_phi(c,4) = propor*moc_phi(c,4) + moc_pho(c,4) = propor*moc_pho(c,4) + mdst1(c,4) = propor*mdst1(c,4) + mdst2(c,4) = propor*mdst2(c,4) + mdst3(c,4) = propor*mdst3(c,4) + mdst4(c,4) = propor*mdst4(c,4) + + dzsno(c,4) = 0.23_r8 + lsadz + + mbc_phi(c,5) = mbc_phi(c,5)+zmbc_phi ! (combo) + mbc_pho(c,5) = mbc_pho(c,5)+zmbc_pho ! (combo) + moc_phi(c,5) = moc_phi(c,5)+zmoc_phi ! (combo) + moc_pho(c,5) = moc_pho(c,5)+zmoc_pho ! (combo) + mdst1(c,5) = mdst1(c,5)+zmdst1 ! (combo) + mdst2(c,5) = mdst2(c,5)+zmdst2 ! (combo) + mdst3(c,5) = mdst3(c,5)+zmdst3 ! (combo) + mdst4(c,5) = mdst4(c,5)+zmdst4 ! (combo) + rds(c,5) = rds(c,4) ! (combo) + + call Combo (dzsno(c,5), swliq(c,5), swice(c,5), tsno(c,5), drr, & + zwliq, zwice, tsno(c,4)) + end if + end if + + snl(c) = -msno + + end do + + do j = -nlevsno+1,0 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + dz(c,j) = dzsno(c,j-snl(c)) + h2osoi_ice(c,j) = swice(c,j-snl(c)) + h2osoi_liq(c,j) = swliq(c,j-snl(c)) + t_soisno(c,j) = tsno(c,j-snl(c)) + + mss_bcphi(c,j) = mbc_phi(c,j-snl(c)) + mss_bcpho(c,j) = mbc_pho(c,j-snl(c)) + mss_ocphi(c,j) = moc_phi(c,j-snl(c)) + mss_ocpho(c,j) = moc_pho(c,j-snl(c)) + mss_dst1(c,j) = mdst1(c,j-snl(c)) + mss_dst2(c,j) = mdst2(c,j-snl(c)) + mss_dst3(c,j) = mdst3(c,j-snl(c)) + mss_dst4(c,j) = mdst4(c,j-snl(c)) + snw_rds(c,j) = rds(c,j-snl(c)) + + end if + end do + end do + + ! Consistency check + do j = -nlevsno + 1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + + if (j >= snl(c)+1) then + dztot(c) = dztot(c) - dz(c,j) + snwicetot(c) = snwicetot(c) - h2osoi_ice(c,j) + snwliqtot(c) = snwliqtot(c) - h2osoi_liq(c,j) + end if + + if (j == 0) then + if ( abs(dztot(c)) > 1.e-10_r8 .or. abs(snwicetot(c)) > 1.e-7_r8 .or. & + abs(snwliqtot(c)) > 1.e-7_r8 ) then + write(iulog,*)'Inconsistency in SnowDivision_Lake! c, remainders', & + 'dztot, snwicetot, snwliqtot = ',c,dztot(c),snwicetot(c),snwliqtot(c) + call endrun() + end if + end if + end do + end do + + do j = 0, -nlevsno+1, -1 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + z(c,j) = zi(c,j) - 0.5_r8*dz(c,j) + zi(c,j-1) = zi(c,j) - dz(c,j) + end if + end do + end do + + end subroutine DivideSnowLayers_Lake +!!!!!!!!!!!!!!!!!!!!! End new subroutine + + +end module SnowHydrologyMod diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeophys/UrbanMod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeophys/UrbanMod.F90 new file mode 100644 index 0000000000..1b2836cea2 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.clm/src/clm4_5/biogeophys/UrbanMod.F90 @@ -0,0 +1,3483 @@ + +! DART note: this file started life as: +! /glade/p/cesm/releases/cesm1_2_1/models/lnd/clm/src/clm4_5/biogeophys/UrbanMod.F90 + +module UrbanMod + +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: UrbanMod +! +! !DESCRIPTION: +! Calculate solar and longwave radiation, and turbulent fluxes for urban landunit +! +! !USES: + use shr_kind_mod, only : r8 => shr_kind_r8 + use clm_varpar , only : numrad + use clm_varcon , only : isecspday, degpsec + use clm_varctl , only : iulog + use abortutils , only : endrun + use shr_sys_mod , only : shr_sys_flush +! +! !PUBLIC TYPES: + implicit none + save +! +! !PUBLIC MEMBER FUNCTIONS: + public :: UrbanClumpInit ! Initialization of urban clump data structure + public :: UrbanRadiation ! Urban radiative fluxes + public :: UrbanAlbedo ! Urban albedos + public :: UrbanSnowAlbedo ! Urban snow albedos + public :: UrbanFluxes ! Urban turbulent fluxes + +! !Urban control variables + character(len= *), parameter, public :: urban_hac_off = 'OFF' ! + character(len= *), parameter, public :: urban_hac_on = 'ON' ! + character(len= *), parameter, public :: urban_wasteheat_on = 'ON_WASTEHEAT' ! + character(len= 16), public :: urban_hac = urban_hac_off + logical, public :: urban_traffic = .false. ! urban traffic fluxes +! +! !REVISION HISTORY: +! Created by Gordon Bonan and Mariana Vertenstein and Keith Oleson 04/2003 +! +!EOP +! +! PRIVATE MEMBER FUNCTIONS + private :: view_factor ! View factors for road and one wall + private :: incident_direct ! Direct beam solar rad incident on walls and road in urban canyon + private :: incident_diffuse ! Diffuse solar rad incident on walls and road in urban canyon + private :: net_solar ! Solar radiation absorbed by road and both walls in urban canyon + private :: net_longwave ! Net longwave radiation for road and both walls in urban canyon + +! PRIVATE TYPES + private + type urban_clump_t + real(r8), pointer :: canyon_hwr(:) ! ratio of building height to street width + real(r8), pointer :: wtroad_perv(:) ! weight of pervious road wrt total road + real(r8), pointer :: ht_roof(:) ! height of urban roof (m) + real(r8), pointer :: wtlunit_roof(:) ! weight of roof with respect to landunit + real(r8), pointer :: wind_hgt_canyon(:) ! height above road at which wind in canyon is to be computed (m) + real(r8), pointer :: em_roof(:) ! roof emissivity + real(r8), pointer :: em_improad(:) ! impervious road emissivity + real(r8), pointer :: em_perroad(:) ! pervious road emissivity + real(r8), pointer :: em_wall(:) ! wall emissivity + real(r8), pointer :: alb_roof_dir(:,:) ! direct roof albedo + real(r8), pointer :: alb_roof_dif(:,:) ! diffuse roof albedo + real(r8), pointer :: alb_improad_dir(:,:) ! direct impervious road albedo + real(r8), pointer :: alb_improad_dif(:,:) ! diffuse impervious road albedo + real(r8), pointer :: alb_perroad_dir(:,:) ! direct pervious road albedo + real(r8), pointer :: alb_perroad_dif(:,:) ! diffuse pervious road albedo + real(r8), pointer :: alb_wall_dir(:,:) ! direct wall albedo + real(r8), pointer :: alb_wall_dif(:,:) ! diffuse wall albedo + end type urban_clump_t + + type (urban_clump_t), private, pointer :: urban_clump(:) ! array of urban clumps for this processor + + integer, private, parameter :: noonsec = isecspday / 2 ! seconds at local noon +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: UrbanAlbedo +! +! !INTERFACE: + subroutine UrbanAlbedo (nc, lbl, ubl, lbc, ubc, lbp, ubp, & + num_urbanl, filter_urbanl, & + num_urbanc, filter_urbanc, & + num_urbanp, filter_urbanp) +! +! !DESCRIPTION: +! Determine urban landunit component albedos +! +! !USES: + use clmtype + use shr_orb_mod , only : shr_orb_decl, shr_orb_cosz + use clm_varcon , only : icol_roof, icol_sunwall, icol_shadewall, icol_road_perv, icol_road_imperv, & + sb +! +! !ARGUMENTS: + implicit none + integer , intent(in) :: nc ! clump index + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer, intent(in) :: lbc, ubc ! column-index bounds + integer, intent(in) :: lbp, ubp ! pft-index bounds + integer , intent(in) :: num_urbanl ! number of urban landunits in clump + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + integer , intent(in) :: num_urbanc ! number of urban columns in clump + integer , intent(in) :: filter_urbanc(ubc-lbc+1) ! urban column filter + integer , intent(in) :: num_urbanp ! number of urban pfts in clump + integer , intent(in) :: filter_urbanp(ubp-lbp+1) ! urban pft filter +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! 03/2003, Mariana Vertenstein: Migrated to clm2.2 +! 01/2008, Erik Kluzek: Migrated to clm3.5.15 +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in arguments +! + integer , pointer :: pgridcell(:) ! gridcell of corresponding pft + integer , pointer :: lgridcell(:) ! gridcell of corresponding landunit + integer , pointer :: clandunit(:) ! column's landunit + integer , pointer :: cgridcell(:) ! gridcell of corresponding column + integer , pointer :: coli(:) ! beginning column index for landunit + integer , pointer :: colf(:) ! ending column index for landunit + integer , pointer :: ctype(:) ! column type + integer , pointer :: pcolumn(:) ! column of corresponding pft + real(r8), pointer :: czen(:) ! cosine of solar zenith angle for each column + real(r8), pointer :: lat(:) ! latitude (radians) + real(r8), pointer :: lon(:) ! longitude (radians) + real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1) +! +! local pointers to original implicit out arguments +! + real(r8), pointer :: albgrd(:,:) ! ground albedo (direct) + real(r8), pointer :: albgri(:,:) ! ground albedo (diffuse) + real(r8), pointer :: albd(:,:) ! surface albedo (direct) + real(r8), pointer :: albi(:,:) ! surface albedo (diffuse) + real(r8), pointer :: fabd(:,:) ! flux absorbed by veg per unit direct flux + real(r8), pointer :: fabd_sun(:,:)! flux absorbed by sunlit leaf per unit direct flux + real(r8), pointer :: fabd_sha(:,:)! flux absorbed by shaded leaf per unit direct flux + real(r8), pointer :: fabi(:,:) ! flux absorbed by veg per unit diffuse flux + real(r8), pointer :: fabi_sun(:,:)! flux absorbed by sunlit leaf per unit diffuse flux + real(r8), pointer :: fabi_sha(:,:)! flux absorbed by shaded leaf per unit diffuse flux + real(r8), pointer :: ftdd(:,:) ! down direct flux below veg per unit dir flx + real(r8), pointer :: ftid(:,:) ! down diffuse flux below veg per unit dir flx + real(r8), pointer :: ftii(:,:) ! down diffuse flux below veg per unit dif flx + real(r8), pointer :: fsun(:) ! sunlit fraction of canopy + real(r8), pointer :: vf_sr(:) ! view factor of sky for road + real(r8), pointer :: vf_wr(:) ! view factor of one wall for road + real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall + real(r8), pointer :: vf_rw(:) ! view factor of road for one wall + real(r8), pointer :: vf_ww(:) ! view factor of opposing wall for one wall + real(r8), pointer :: sabs_roof_dir(:,:) ! direct solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_roof_dif(:,:) ! diffuse solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_sunwall_dir(:,:) ! direct solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_sunwall_dif(:,:) ! diffuse solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dir(:,:) ! direct solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dif(:,:) ! diffuse solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_improad_dir(:,:) ! direct solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_improad_dif(:,:) ! diffuse solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dir(:,:) ! direct solar absorbed by pervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dif(:,:) ! diffuse solar absorbed by pervious road per unit ground area per unit incident flux +! +! +! !OTHER LOCAL VARIABLES +!EOP +! + real(r8) :: coszen(num_urbanl) ! cosine solar zenith angle + real(r8) :: coszen_pft(num_urbanp) ! cosine solar zenith angle for next time step (pft level) + real(r8) :: zen(num_urbanl) ! solar zenith angle (radians) + real(r8) :: sdir(num_urbanl, numrad) ! direct beam solar radiation on horizontal surface + real(r8) :: sdif(num_urbanl, numrad) ! diffuse solar radiation on horizontal surface + + real(r8) :: sdir_road(num_urbanl, numrad) ! direct beam solar radiation incident on road + real(r8) :: sdif_road(num_urbanl, numrad) ! diffuse solar radiation incident on road + real(r8) :: sdir_sunwall(num_urbanl, numrad) ! direct beam solar radiation (per unit wall area) incident on sunlit wall per unit incident flux + real(r8) :: sdif_sunwall(num_urbanl, numrad) ! diffuse solar radiation (per unit wall area) incident on sunlit wall per unit incident flux + real(r8) :: sdir_shadewall(num_urbanl, numrad) ! direct beam solar radiation (per unit wall area) incident on shaded wall per unit incident flux + real(r8) :: sdif_shadewall(num_urbanl, numrad) ! diffuse solar radiation (per unit wall area) incident on shaded wall per unit incident flux + real(r8) :: albsnd_roof(num_urbanl,numrad) ! snow albedo for roof (direct) + real(r8) :: albsni_roof(num_urbanl,numrad) ! snow albedo for roof (diffuse) + real(r8) :: albsnd_improad(num_urbanl,numrad) ! snow albedo for impervious road (direct) + real(r8) :: albsni_improad(num_urbanl,numrad) ! snow albedo for impervious road (diffuse) + real(r8) :: albsnd_perroad(num_urbanl,numrad) ! snow albedo for pervious road (direct) + real(r8) :: albsni_perroad(num_urbanl,numrad) ! snow albedo for pervious road (diffuse) + + integer :: fl,fp,fc,g,l,p,c,ib ! indices + integer :: ic ! 0=unit incoming direct; 1=unit incoming diffuse + integer :: num_solar ! counter + real(r8) :: alb_roof_dir_s(num_urbanl,numrad) ! direct roof albedo with snow effects + real(r8) :: alb_roof_dif_s(num_urbanl,numrad) ! diffuse roof albedo with snow effects + real(r8) :: alb_improad_dir_s(num_urbanl,numrad) ! direct impervious road albedo with snow effects + real(r8) :: alb_perroad_dir_s(num_urbanl,numrad) ! direct pervious road albedo with snow effects + real(r8) :: alb_improad_dif_s(num_urbanl,numrad) ! diffuse impervious road albedo with snow effects + real(r8) :: alb_perroad_dif_s(num_urbanl,numrad) ! diffuse pervious road albedo with snow effects + real(r8) :: sref_roof_dir(num_urbanl,numrad) ! direct solar reflected by roof per unit ground area per unit incident flux + real(r8) :: sref_roof_dif(num_urbanl,numrad) ! diffuse solar reflected by roof per unit ground area per unit incident flux + real(r8) :: sref_sunwall_dir(num_urbanl,numrad) ! direct solar reflected by sunwall per unit wall area per unit incident flux + real(r8) :: sref_sunwall_dif(num_urbanl,numrad) ! diffuse solar reflected by sunwall per unit wall area per unit incident flux + real(r8) :: sref_shadewall_dir(num_urbanl,numrad) ! direct solar reflected by shadewall per unit wall area per unit incident flux + real(r8) :: sref_shadewall_dif(num_urbanl,numrad) ! diffuse solar reflected by shadewall per unit wall area per unit incident flux + real(r8) :: sref_improad_dir(num_urbanl,numrad) ! direct solar reflected by impervious road per unit ground area per unit incident flux + real(r8) :: sref_improad_dif(num_urbanl,numrad) ! diffuse solar reflected by impervious road per unit ground area per unit incident flux + real(r8) :: sref_perroad_dir(num_urbanl,numrad) ! direct solar reflected by pervious road per unit ground area per unit incident flux + real(r8) :: sref_perroad_dif(num_urbanl,numrad) ! diffuse solar reflected by pervious road per unit ground area per unit incident flux + real(r8), pointer :: canyon_hwr(:) ! ratio of building height to street width + real(r8), pointer :: wtroad_perv(:) ! weight of pervious road wrt total road + real(r8), pointer :: alb_roof_dir(:,:) ! direct roof albedo + real(r8), pointer :: alb_roof_dif(:,:) ! diffuse roof albedo + real(r8), pointer :: alb_improad_dir(:,:) ! direct impervious road albedo + real(r8), pointer :: alb_perroad_dir(:,:) ! direct pervious road albedo + real(r8), pointer :: alb_improad_dif(:,:) ! diffuse imprevious road albedo + real(r8), pointer :: alb_perroad_dif(:,:) ! diffuse pervious road albedo + real(r8), pointer :: alb_wall_dir(:,:) ! direct wall albedo + real(r8), pointer :: alb_wall_dif(:,:) ! diffuse wall albedo +!----------------------------------------------------------------------- + + ! Assign pointers into module urban clumps + + canyon_hwr => urban_clump(nc)%canyon_hwr + wtroad_perv => urban_clump(nc)%wtroad_perv + alb_roof_dir => urban_clump(nc)%alb_roof_dir + alb_roof_dif => urban_clump(nc)%alb_roof_dif + alb_improad_dir => urban_clump(nc)%alb_improad_dir + alb_improad_dif => urban_clump(nc)%alb_improad_dif + alb_perroad_dir => urban_clump(nc)%alb_perroad_dir + alb_perroad_dif => urban_clump(nc)%alb_perroad_dif + alb_wall_dir => urban_clump(nc)%alb_wall_dir + alb_wall_dif => urban_clump(nc)%alb_wall_dif + + ! Assign gridcell level pointers + + lat => grc%lat + lon => grc%lon + + ! Assign landunit level pointer + + lgridcell =>lun%gridcell + coli =>lun%coli + colf =>lun%colf + vf_sr => lps%vf_sr + vf_wr => lps%vf_wr + vf_sw => lps%vf_sw + vf_rw => lps%vf_rw + vf_ww => lps%vf_ww + sabs_roof_dir => lps%sabs_roof_dir + sabs_roof_dif => lps%sabs_roof_dif + sabs_sunwall_dir => lps%sabs_sunwall_dir + sabs_sunwall_dif => lps%sabs_sunwall_dif + sabs_shadewall_dir => lps%sabs_shadewall_dir + sabs_shadewall_dif => lps%sabs_shadewall_dif + sabs_improad_dir => lps%sabs_improad_dir + sabs_improad_dif => lps%sabs_improad_dif + sabs_perroad_dir => lps%sabs_perroad_dir + sabs_perroad_dif => lps%sabs_perroad_dif + + ! Assign column level pointers + + ctype => col%itype + albgrd => cps%albgrd + albgri => cps%albgri + frac_sno => cps%frac_sno + clandunit =>col%landunit + cgridcell =>col%gridcell + czen => cps%coszen + + ! Assign pft level pointers + + pgridcell =>pft%gridcell + pcolumn =>pft%column + albd => pps%albd + albi => pps%albi + fabd => pps%fabd + fabd_sun => pps%fabd_sun + fabd_sha => pps%fabd_sha + fabi => pps%fabi + fabi_sun => pps%fabi_sun + fabi_sha => pps%fabi_sha + ftdd => pps%ftdd + ftid => pps%ftid + ftii => pps%ftii + fsun => pps%fsun + + + ! ---------------------------------------------------------------------------- + ! Solar declination and cosine solar zenith angle and zenith angle for + ! next time step + ! ---------------------------------------------------------------------------- + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + coszen(fl) = czen(coli(l)) ! Assumes coszen for each column are the same + zen(fl) = acos(coszen(fl)) + end do + + do fp = 1,num_urbanp + p = filter_urbanp(fp) + g = pgridcell(p) + c = pcolumn(p) + coszen_pft(fp) = czen(c) + end do + + ! ---------------------------------------------------------------------------- + ! Initialize clmtype output since solar radiation is only done if coszen > 0 + ! ---------------------------------------------------------------------------- + + do ib = 1,numrad + do fc = 1,num_urbanc + c = filter_urbanc(fc) + + albgrd(c,ib) = 0._r8 + albgri(c,ib) = 0._r8 + end do + + do fp = 1,num_urbanp + p = filter_urbanp(fp) + g = pgridcell(p) + albd(p,ib) = 1._r8 + albi(p,ib) = 1._r8 + fabd(p,ib) = 0._r8 + fabd_sun(p,ib) = 0._r8 + fabd_sha(p,ib) = 0._r8 + fabi(p,ib) = 0._r8 + fabi_sun(p,ib) = 0._r8 + fabi_sha(p,ib) = 0._r8 + if (coszen_pft(fp) > 0._r8) then + ftdd(p,ib) = 1._r8 + else + ftdd(p,ib) = 0._r8 + end if + ftid(p,ib) = 0._r8 + if (coszen_pft(fp) > 0._r8) then + ftii(p,ib) = 1._r8 + else + ftii(p,ib) = 0._r8 + end if + if (ib == 1) then + fsun(p) = 0._r8 + end if + end do + end do + + ! ---------------------------------------------------------------------------- + ! Urban Code + ! ---------------------------------------------------------------------------- + + num_solar = 0 + do fl = 1,num_urbanl + if (coszen(fl) > 0._r8) num_solar = num_solar + 1 + end do + + ! Initialize urban clump components + + do ib = 1,numrad + do fl = 1,num_urbanl + l = filter_urbanl(fl) + sabs_roof_dir(l,ib) = 0._r8 + sabs_roof_dif(l,ib) = 0._r8 + sabs_sunwall_dir(l,ib) = 0._r8 + sabs_sunwall_dif(l,ib) = 0._r8 + sabs_shadewall_dir(l,ib) = 0._r8 + sabs_shadewall_dif(l,ib) = 0._r8 + sabs_improad_dir(l,ib) = 0._r8 + sabs_improad_dif(l,ib) = 0._r8 + sabs_perroad_dir(l,ib) = 0._r8 + sabs_perroad_dif(l,ib) = 0._r8 + sref_roof_dir(fl,ib) = 1._r8 + sref_roof_dif(fl,ib) = 1._r8 + sref_sunwall_dir(fl,ib) = 1._r8 + sref_sunwall_dif(fl,ib) = 1._r8 + sref_shadewall_dir(fl,ib) = 1._r8 + sref_shadewall_dif(fl,ib) = 1._r8 + sref_improad_dir(fl,ib) = 1._r8 + sref_improad_dif(fl,ib) = 1._r8 + sref_perroad_dir(fl,ib) = 1._r8 + sref_perroad_dif(fl,ib) = 1._r8 + end do + end do + + ! View factors for road and one wall in urban canyon (depends only on canyon_hwr) + + if (num_urbanl .gt. 0) then + call view_factor (lbl, ubl, num_urbanl, filter_urbanl, canyon_hwr) + end if + + ! ---------------------------------------------------------------------------- + ! Only do the rest if all coszen are positive + ! ---------------------------------------------------------------------------- + + if (num_solar > 0)then + + ! Set constants - solar fluxes are per unit incoming flux + + do ib = 1,numrad + do fl = 1,num_urbanl + sdir(fl,ib) = 1._r8 + sdif(fl,ib) = 1._r8 + end do + end do + + ! Incident direct beam radiation for + ! (a) roof and (b) road and both walls in urban canyon + + if (num_urbanl .gt. 0) then + call incident_direct (lbl, ubl, num_urbanl, canyon_hwr, coszen, zen, sdir, sdir_road, sdir_sunwall, sdir_shadewall) + end if + + ! Incident diffuse radiation for + ! (a) roof and (b) road and both walls in urban canyon. + + if (num_urbanl .gt. 0) then + call incident_diffuse (lbl, ubl, num_urbanl, filter_urbanl, canyon_hwr, sdif, sdif_road, & + sdif_sunwall, sdif_shadewall) + end if + + ! Get snow albedos for roof and impervious and pervious road + if (num_urbanl .gt. 0) then + ic = 0; call UrbanSnowAlbedo(lbl, ubl, num_urbanl, filter_urbanl, coszen, ic, albsnd_roof, albsnd_improad, albsnd_perroad) + ic = 1; call UrbanSnowAlbedo(lbl, ubl, num_urbanl, filter_urbanl, coszen, ic, albsni_roof, albsni_improad, albsni_perroad) + end if + + ! Combine snow-free and snow albedos + do ib = 1,numrad + do fl = 1,num_urbanl + l = filter_urbanl(fl) + do c = coli(l),colf(l) + if (ctype(c) == icol_roof) then + alb_roof_dir_s(fl,ib) = alb_roof_dir(fl,ib)*(1._r8-frac_sno(c)) & + + albsnd_roof(fl,ib)*frac_sno(c) + alb_roof_dif_s(fl,ib) = alb_roof_dif(fl,ib)*(1._r8-frac_sno(c)) & + + albsni_roof(fl,ib)*frac_sno(c) + else if (ctype(c) == icol_road_imperv) then + alb_improad_dir_s(fl,ib) = alb_improad_dir(fl,ib)*(1._r8-frac_sno(c)) & + + albsnd_improad(fl,ib)*frac_sno(c) + alb_improad_dif_s(fl,ib) = alb_improad_dif(fl,ib)*(1._r8-frac_sno(c)) & + + albsni_improad(fl,ib)*frac_sno(c) + else if (ctype(c) == icol_road_perv) then + alb_perroad_dir_s(fl,ib) = alb_perroad_dir(fl,ib)*(1._r8-frac_sno(c)) & + + albsnd_perroad(fl,ib)*frac_sno(c) + alb_perroad_dif_s(fl,ib) = alb_perroad_dif(fl,ib)*(1._r8-frac_sno(c)) & + + albsni_perroad(fl,ib)*frac_sno(c) + end if + end do + end do + end do + + ! Reflected and absorbed solar radiation per unit incident radiation + ! for road and both walls in urban canyon allowing for multiple reflection + ! Reflected and absorbed solar radiation per unit incident radiation for roof + + if (num_urbanl .gt. 0) then + call net_solar (lbl, ubl, num_urbanl, filter_urbanl, coszen, canyon_hwr, wtroad_perv, sdir, sdif, & + alb_improad_dir_s, alb_perroad_dir_s, alb_wall_dir, alb_roof_dir_s, & + alb_improad_dif_s, alb_perroad_dif_s, alb_wall_dif, alb_roof_dif_s, & + sdir_road, sdir_sunwall, sdir_shadewall, & + sdif_road, sdif_sunwall, sdif_shadewall, & + sref_improad_dir, sref_perroad_dir, sref_sunwall_dir, sref_shadewall_dir, sref_roof_dir, & + sref_improad_dif, sref_perroad_dif, sref_sunwall_dif, sref_shadewall_dif, sref_roof_dif) + end if + + ! ---------------------------------------------------------------------------- + ! Map urban output to clmtype components + ! ---------------------------------------------------------------------------- + + ! Set albgrd and albgri (ground albedos) and albd and albi (surface albedos) + + do ib = 1,numrad + do fl = 1,num_urbanl + l = filter_urbanl(fl) + do c = coli(l),colf(l) + if (ctype(c) == icol_roof) then + albgrd(c,ib) = sref_roof_dir(fl,ib) + albgri(c,ib) = sref_roof_dif(fl,ib) + else if (ctype(c) == icol_sunwall) then + albgrd(c,ib) = sref_sunwall_dir(fl,ib) + albgri(c,ib) = sref_sunwall_dif(fl,ib) + else if (ctype(c) == icol_shadewall) then + albgrd(c,ib) = sref_shadewall_dir(fl,ib) + albgri(c,ib) = sref_shadewall_dif(fl,ib) + else if (ctype(c) == icol_road_perv) then + albgrd(c,ib) = sref_perroad_dir(fl,ib) + albgri(c,ib) = sref_perroad_dif(fl,ib) + else if (ctype(c) == icol_road_imperv) then + albgrd(c,ib) = sref_improad_dir(fl,ib) + albgri(c,ib) = sref_improad_dif(fl,ib) + endif + end do + end do + do fp = 1,num_urbanp + p = filter_urbanp(fp) + c = pcolumn(p) + albd(p,ib) = albgrd(c,ib) + albi(p,ib) = albgri(c,ib) + end do + end do + end if + + end subroutine UrbanAlbedo + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: UrbanSnowAlbedo +! +! !INTERFACE: + subroutine UrbanSnowAlbedo (lbl, ubl, num_urbanl, filter_urbanl, coszen, ind, & + albsn_roof, albsn_improad, albsn_perroad) +! +! !DESCRIPTION: +! Determine urban snow albedos +! +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use clmtype + use clm_varcon , only : icol_roof, icol_road_perv, icol_road_imperv +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer , intent(in) :: num_urbanl ! number of urban landunits in clump + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + integer , intent(in) :: ind ! 0=direct beam, 1=diffuse radiation + real(r8), intent(in) :: coszen(num_urbanl) ! cosine solar zenith angle + real(r8), intent(out):: albsn_roof(num_urbanl,2) ! roof snow albedo by waveband (assume 2 wavebands) + real(r8), intent(out):: albsn_improad(num_urbanl,2) ! impervious road snow albedo by waveband (assume 2 wavebands) + real(r8), intent(out):: albsn_perroad(num_urbanl,2) ! pervious road snow albedo by waveband (assume 2 wavebands) +! +! !CALLED FROM: +! subroutine UrbanAlbedo in this module +! +! !REVISION HISTORY: +! Author: Keith Oleson 9/2005 +! +! !LOCAL VARIABLES: +! +! local pointers to implicit in arguments + integer , pointer :: coli(:) ! beginning column index for landunit + integer , pointer :: colf(:) ! ending column index for landunit + real(r8), pointer :: h2osno(:) ! snow water (mm H2O) + integer , pointer :: ctype(:) ! column type +! +! +! !OTHER LOCAL VARIABLES: +!EOP + integer :: fl,c,l ! indices +! +! variables and constants for snow albedo calculation +! +! These values are derived from Marshall (1989) assuming soot content of 1.5e-5 +! (three times what LSM uses globally). Note that snow age effects are ignored here. + real(r8), parameter :: snal0 = 0.66_r8 ! vis albedo of urban snow + real(r8), parameter :: snal1 = 0.56_r8 ! nir albedo of urban snow +!----------------------------------------------------------------------- + + ! Assign local pointers to derived type members (landunit level) + + coli =>lun%coli + colf =>lun%colf + + ! Assign local pointers to derived subtypes components (column-level) + + ctype => col%itype + h2osno => cws%h2osno + + ! this code assumes that numrad = 2 , with the following + ! index values: 1 = visible, 2 = NIR + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + do c = coli(l),colf(l) + if (coszen(fl) > 0._r8 .and. h2osno(c) > 0._r8) then + if (ctype(c) == icol_roof) then + albsn_roof(fl,1) = snal0 + albsn_roof(fl,2) = snal1 + else if (ctype(c) == icol_road_imperv) then + albsn_improad(fl,1) = snal0 + albsn_improad(fl,2) = snal1 + else if (ctype(c) == icol_road_perv) then + albsn_perroad(fl,1) = snal0 + albsn_perroad(fl,2) = snal1 + end if + else + if (ctype(c) == icol_roof) then + albsn_roof(fl,1) = 0._r8 + albsn_roof(fl,2) = 0._r8 + else if (ctype(c) == icol_road_imperv) then + albsn_improad(fl,1) = 0._r8 + albsn_improad(fl,2) = 0._r8 + else if (ctype(c) == icol_road_perv) then + albsn_perroad(fl,1) = 0._r8 + albsn_perroad(fl,2) = 0._r8 + end if + end if + end do + end do + + end subroutine UrbanSnowAlbedo + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: UrbanRadiation +! +! !INTERFACE: + subroutine UrbanRadiation (nc, lbl, ubl, lbc, ubc, lbp, ubp, & + num_nourbanl, filter_nourbanl, & + num_urbanl, filter_urbanl, & + num_urbanc, filter_urbanc, & + num_urbanp, filter_urbanp) +! +! !DESCRIPTION: +! Solar fluxes absorbed and reflected by roof and canyon (walls, road). +! Also net and upward longwave fluxes. + +! !USES: + use clmtype + use clm_varcon , only : spval, icol_roof, icol_sunwall, icol_shadewall, & + icol_road_perv, icol_road_imperv, sb + use clm_varcon , only : tfrz ! To use new constant.. + use clm_time_manager , only : get_curr_date, get_step_size + use clm_atmlnd , only : clm_a2l +! +! !ARGUMENTS: + implicit none + integer , intent(in) :: nc ! clump index + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer, intent(in) :: lbc, ubc ! column-index bounds + integer, intent(in) :: lbp, ubp ! pft-index bounds + integer , intent(in) :: num_nourbanl ! number of non-urban landunits in clump + integer , intent(in) :: filter_nourbanl(ubl-lbl+1) ! non-urban landunit filter + integer , intent(in) :: num_urbanl ! number of urban landunits in clump + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + integer , intent(in) :: num_urbanc ! number of urban columns in clump + integer , intent(in) :: filter_urbanc(ubc-lbc+1) ! urban column filter + integer , intent(in) :: num_urbanp ! number of urban pfts in clump + integer , intent(in) :: filter_urbanp(ubp-lbp+1) ! urban pft filter +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! 03/2003, Mariana Vertenstein: Migrated to clm2.2 +! 07/2004, Mariana Vertenstein: Migrated to clm3.0 +! 01/2008, Erik Kluzek: Migrated to clm3.5.15 +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in arguments (urban clump) +! + real(r8), pointer :: canyon_hwr(:) ! ratio of building height to street width + real(r8), pointer :: wtroad_perv(:) ! weight of pervious road wrt total road + real(r8), pointer :: em_roof(:) ! roof emissivity + real(r8), pointer :: em_improad(:) ! impervious road emissivity + real(r8), pointer :: em_perroad(:) ! pervious road emissivity + real(r8), pointer :: em_wall(:) ! wall emissivity +! +! local pointers to original implicit in arguments (clmtype) +! + integer , pointer :: pgridcell(:) ! gridcell of corresponding pft + integer , pointer :: pcolumn(:) ! column of corresponding pft + integer , pointer :: lgridcell(:) ! gridcell of corresponding landunit + integer , pointer :: ctype(:) ! column type + integer , pointer :: coli(:) ! beginning column index for landunit + integer , pointer :: colf(:) ! ending column index for landunit + integer , pointer :: pfti(:) ! beginning pfti index for landunit + integer , pointer :: pftf(:) ! ending pftf index for landunit + real(r8), pointer :: londeg(:) ! longitude (degrees) + real(r8), pointer :: forc_lwrad(:) ! downward infrared (longwave) radiation (W/m**2) + real(r8), pointer :: forc_solad(:,:) ! direct beam radiation (vis=forc_sols , nir=forc_soll ) (W/m**2) + real(r8), pointer :: forc_solai(:,:) ! diffuse beam radiation (vis=forc_sols , nir=forc_soll ) (W/m**2) + real(r8), pointer :: forc_solar(:) ! incident solar radiation (W/m**2) + real(r8), pointer :: albd(:,:) ! surface albedo (direct) + real(r8), pointer :: albi(:,:) ! surface albedo (diffuse) + real(r8), pointer :: t_grnd(:) ! ground temperature (K) + real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1) + real(r8), pointer :: t_ref2m(:) ! 2 m height surface air temperature (K) + real(r8), pointer :: vf_sr(:) ! view factor of sky for road + real(r8), pointer :: vf_wr(:) ! view factor of one wall for road + real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall + real(r8), pointer :: vf_rw(:) ! view factor of road for one wall + real(r8), pointer :: vf_ww(:) ! view factor of opposing wall for one wall + real(r8), pointer :: sabs_roof_dir(:,:) ! direct solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_roof_dif(:,:) ! diffuse solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_sunwall_dir(:,:) ! direct solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_sunwall_dif(:,:) ! diffuse solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dir(:,:) ! direct solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dif(:,:) ! diffuse solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_improad_dir(:,:) ! direct solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_improad_dif(:,:) ! diffuse solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dir(:,:) ! direct solar absorbed by pervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dif(:,:) ! diffuse solar absorbed by pervious road per unit ground area per unit incident flux +! +! local pointers to original implicit out arguments (clmtype) +! + real(r8), pointer :: sabg(:) ! solar radiation absorbed by ground (W/m**2) + real(r8), pointer :: sabv(:) ! solar radiation absorbed by vegetation (W/m**2) + real(r8), pointer :: fsa(:) ! solar radiation absorbed (total) (W/m**2) + real(r8), pointer :: fsa_u(:) ! urban solar radiation absorbed (total) (W/m**2) + real(r8), pointer :: fsr(:) ! solar radiation reflected (total) (W/m**2) + real(r8), pointer :: fsds_vis_d(:) ! incident direct beam vis solar radiation (W/m**2) + real(r8), pointer :: fsds_nir_d(:) ! incident direct beam nir solar radiation (W/m**2) + real(r8), pointer :: fsds_vis_i(:) ! incident diffuse vis solar radiation (W/m**2) + real(r8), pointer :: fsds_nir_i(:) ! incident diffuse nir solar radiation (W/m**2) + real(r8), pointer :: fsr_vis_d(:) ! reflected direct beam vis solar radiation (W/m**2) + real(r8), pointer :: fsr_nir_d(:) ! reflected direct beam nir solar radiation (W/m**2) + real(r8), pointer :: fsr_vis_i(:) ! reflected diffuse vis solar radiation (W/m**2) + real(r8), pointer :: fsr_nir_i(:) ! reflected diffuse nir solar radiation (W/m**2) + real(r8), pointer :: fsds_vis_d_ln(:) ! incident direct beam vis solar rad at local noon (W/m**2) + real(r8), pointer :: fsds_vis_i_ln(:) ! incident diffuse beam vis solar rad at local noon (W/m**2) + real(r8), pointer :: parveg_ln(:) ! absorbed par by vegetation at local noon (W/m**2) + real(r8), pointer :: fsds_nir_d_ln(:) ! incident direct beam nir solar rad at local noon (W/m**2) + real(r8), pointer :: fsr_vis_d_ln(:) ! reflected direct beam vis solar rad at local noon (W/m**2) + real(r8), pointer :: fsr_nir_d_ln(:) ! reflected direct beam nir solar rad at local noon (W/m**2) + real(r8), pointer :: eflx_lwrad_out(:) ! emitted infrared (longwave) radiation (W/m**2) + real(r8), pointer :: eflx_lwrad_net(:) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(r8), pointer :: eflx_lwrad_net_u(:) ! urban net infrared (longwave) rad (W/m**2) [+ = to atm] +! +! +! !OTHER LOCAL VARIABLES +!EOP +! + integer :: fp,fl,p,c,l,g ! indices + integer :: local_secp1 ! seconds into current date in local time + real(r8) :: dtime ! land model time step (sec) + integer :: year,month,day ! temporaries (not used) + integer :: secs ! seconds into current date + + real(r8), parameter :: mpe = 1.e-06_r8 ! prevents overflow for division by zero + real(r8), parameter :: snoem = 0.97_r8 ! snow emissivity (should use value from Biogeophysics1) + + real(r8) :: lwnet_roof(num_urbanl) ! net (outgoing-incoming) longwave radiation (per unit ground area), roof (W/m**2) + real(r8) :: lwnet_improad(num_urbanl) ! net (outgoing-incoming) longwave radiation (per unit ground area), impervious road (W/m**2) + real(r8) :: lwnet_perroad(num_urbanl) ! net (outgoing-incoming) longwave radiation (per unit ground area), pervious road (W/m**2) + real(r8) :: lwnet_sunwall(num_urbanl) ! net (outgoing-incoming) longwave radiation (per unit wall area), sunlit wall (W/m**2) + real(r8) :: lwnet_shadewall(num_urbanl)! net (outgoing-incoming) longwave radiation (per unit wall area), shaded wall (W/m**2) + real(r8) :: lwnet_canyon(num_urbanl) ! net (outgoing-incoming) longwave radiation for canyon, per unit ground area (W/m**2) + real(r8) :: lwup_roof(num_urbanl) ! upward longwave radiation (per unit ground area), roof (W/m**2) + real(r8) :: lwup_improad(num_urbanl) ! upward longwave radiation (per unit ground area), impervious road (W/m**2) + real(r8) :: lwup_perroad(num_urbanl) ! upward longwave radiation (per unit ground area), pervious road (W/m**2) + real(r8) :: lwup_sunwall(num_urbanl) ! upward longwave radiation, (per unit wall area), sunlit wall (W/m**2) + real(r8) :: lwup_shadewall(num_urbanl) ! upward longwave radiation, (per unit wall area), shaded wall (W/m**2) + real(r8) :: lwup_canyon(num_urbanl) ! upward longwave radiation for canyon, per unit ground area (W/m**2) + real(r8) :: t_roof(num_urbanl) ! roof temperature (K) + real(r8) :: t_improad(num_urbanl) ! imppervious road temperature (K) + real(r8) :: t_perroad(num_urbanl) ! pervious road temperature (K) + real(r8) :: t_sunwall(num_urbanl) ! sunlit wall temperature (K) + real(r8) :: t_shadewall(num_urbanl) ! shaded wall temperature (K) + real(r8) :: lwdown(num_urbanl) ! atmospheric downward longwave radiation (W/m**2) + real(r8) :: em_roof_s(num_urbanl) ! roof emissivity with snow effects + real(r8) :: em_improad_s(num_urbanl) ! impervious road emissivity with snow effects + real(r8) :: em_perroad_s(num_urbanl) ! pervious road emissivity with snow effects +!----------------------------------------------------------------------- + + ! Assign pointers into module urban clumps + + if( num_urbanl > 0 )then + canyon_hwr => urban_clump(nc)%canyon_hwr + wtroad_perv => urban_clump(nc)%wtroad_perv + em_roof => urban_clump(nc)%em_roof + em_improad => urban_clump(nc)%em_improad + em_perroad => urban_clump(nc)%em_perroad + em_wall => urban_clump(nc)%em_wall + end if + + ! Assign local pointers to multi-level derived type members (gridcell level) + + londeg => grc%londeg + forc_solad => clm_a2l%forc_solad + forc_solai => clm_a2l%forc_solai + forc_solar => clm_a2l%forc_solar + forc_lwrad => clm_a2l%forc_lwrad + + ! Assign local pointers to derived type members (landunit level) + + pfti =>lun%pfti + pftf =>lun%pftf + coli =>lun%coli + colf =>lun%colf + lgridcell =>lun%gridcell + vf_sr => lps%vf_sr + vf_wr => lps%vf_wr + vf_sw => lps%vf_sw + vf_rw => lps%vf_rw + vf_ww => lps%vf_ww + sabs_roof_dir => lps%sabs_roof_dir + sabs_roof_dif => lps%sabs_roof_dif + sabs_sunwall_dir => lps%sabs_sunwall_dir + sabs_sunwall_dif => lps%sabs_sunwall_dif + sabs_shadewall_dir => lps%sabs_shadewall_dir + sabs_shadewall_dif => lps%sabs_shadewall_dif + sabs_improad_dir => lps%sabs_improad_dir + sabs_improad_dif => lps%sabs_improad_dif + sabs_perroad_dir => lps%sabs_perroad_dir + sabs_perroad_dif => lps%sabs_perroad_dif + + ! Assign local pointers to derived type members (column level) + + ctype => col%itype + t_grnd => ces%t_grnd + frac_sno => cps%frac_sno + + ! Assign local pointers to derived type members (pft level) + + pgridcell =>pft%gridcell + pcolumn =>pft%column + albd => pps%albd + albi => pps%albi + sabg => pef%sabg + sabv => pef%sabv + fsa => pef%fsa + fsa_u => pef%fsa_u + fsr => pef%fsr + fsds_vis_d => pef%fsds_vis_d + fsds_nir_d => pef%fsds_nir_d + fsds_vis_i => pef%fsds_vis_i + fsds_nir_i => pef%fsds_nir_i + fsr_vis_d => pef%fsr_vis_d + fsr_nir_d => pef%fsr_nir_d + fsr_vis_i => pef%fsr_vis_i + fsr_nir_i => pef%fsr_nir_i + fsds_vis_d_ln => pef%fsds_vis_d_ln + fsds_nir_d_ln => pef%fsds_nir_d_ln + fsds_vis_i_ln => pef%fsds_vis_i_ln + parveg_ln => pef%parveg_ln + fsr_vis_d_ln => pef%fsr_vis_d_ln + fsr_nir_d_ln => pef%fsr_nir_d_ln + eflx_lwrad_out => pef%eflx_lwrad_out + eflx_lwrad_net => pef%eflx_lwrad_net + eflx_lwrad_net_u => pef%eflx_lwrad_net_u + t_ref2m => pes%t_ref2m + + ! Define fields that appear on the restart file for non-urban landunits + + do fl = 1,num_nourbanl + l = filter_nourbanl(fl) + sabs_roof_dir(l,:) = spval + sabs_roof_dif(l,:) = spval + sabs_sunwall_dir(l,:) = spval + sabs_sunwall_dif(l,:) = spval + sabs_shadewall_dir(l,:) = spval + sabs_shadewall_dif(l,:) = spval + sabs_improad_dir(l,:) = spval + sabs_improad_dif(l,:) = spval + sabs_perroad_dir(l,:) = spval + sabs_perroad_dif(l,:) = spval + vf_sr(l) = spval + vf_wr(l) = spval + vf_sw(l) = spval + vf_rw(l) = spval + vf_ww(l) = spval + end do + + ! Set input forcing fields + do fl = 1,num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + ! Need to set the following temperatures to some defined value even if it + ! does not appear in the urban landunit for the net_longwave computation + + t_roof(fl) = 19._r8 + tfrz + t_sunwall(fl) = 19._r8 + tfrz + t_shadewall(fl) = 19._r8 + tfrz + t_improad(fl) = 19._r8 + tfrz + t_perroad(fl) = 19._r8 + tfrz + + ! Initial assignment of emissivity + em_roof_s(fl) = em_roof(fl) + em_improad_s(fl) = em_improad(fl) + em_perroad_s(fl) = em_perroad(fl) + + ! Set urban temperatures and emissivity including snow effects. + do c = coli(l),colf(l) + if (ctype(c) == icol_roof ) then + t_roof(fl) = t_grnd(c) + em_roof_s(fl) = em_roof(fl)*(1._r8-frac_sno(c)) + snoem*frac_sno(c) + else if (ctype(c) == icol_road_imperv) then + t_improad(fl) = t_grnd(c) + em_improad_s(fl) = em_improad(fl)*(1._r8-frac_sno(c)) + snoem*frac_sno(c) + else if (ctype(c) == icol_road_perv ) then + t_perroad(fl) = t_grnd(c) + em_perroad_s(fl) = em_perroad(fl)*(1._r8-frac_sno(c)) + snoem*frac_sno(c) + else if (ctype(c) == icol_sunwall ) then + t_sunwall(fl) = t_grnd(c) + else if (ctype(c) == icol_shadewall ) then + t_shadewall(fl) = t_grnd(c) + end if + end do + lwdown(fl) = forc_lwrad(g) + end do + + ! Net longwave radiation for road and both walls in urban canyon allowing for multiple re-emission + + if (num_urbanl .gt. 0) then + call net_longwave (lbl, ubl, num_urbanl, filter_urbanl, canyon_hwr, wtroad_perv, & + lwdown, em_roof_s, em_improad_s, em_perroad_s, em_wall, & + t_roof, t_improad, t_perroad, t_sunwall, t_shadewall, & + lwnet_roof, lwnet_improad, lwnet_perroad, lwnet_sunwall, lwnet_shadewall, lwnet_canyon, & + lwup_roof, lwup_improad, lwup_perroad, lwup_sunwall, lwup_shadewall, lwup_canyon) + end if + + dtime = get_step_size() + call get_curr_date (year, month, day, secs) + + ! Determine clmtype variables needed for history output and communication with atm + ! Loop over urban pfts in clump + + do fp = 1,num_urbanp + p = filter_urbanp(fp) + g = pgridcell(p) + + local_secp1 = secs + nint((grc%londeg(g)/degpsec)/dtime)*dtime + local_secp1 = mod(local_secp1,isecspday) + + ! Solar incident + + fsds_vis_d(p) = forc_solad(g,1) + fsds_nir_d(p) = forc_solad(g,2) + fsds_vis_i(p) = forc_solai(g,1) + fsds_nir_i(p) = forc_solai(g,2) + ! Determine local noon incident solar + if (local_secp1 == noonsec) then + fsds_vis_d_ln(p) = forc_solad(g,1) + fsds_nir_d_ln(p) = forc_solad(g,2) + fsds_vis_i_ln(p) = forc_solai(g,1) + parveg_ln(p) = 0._r8 + else + fsds_vis_d_ln(p) = spval + fsds_nir_d_ln(p) = spval + fsds_vis_i_ln(p) = spval + parveg_ln(p) = spval + endif + + ! Solar reflected + ! per unit ground area (roof, road) and per unit wall area (sunwall, shadewall) + + fsr_vis_d(p) = albd(p,1) * forc_solad(g,1) + fsr_nir_d(p) = albd(p,2) * forc_solad(g,2) + fsr_vis_i(p) = albi(p,1) * forc_solai(g,1) + fsr_nir_i(p) = albi(p,2) * forc_solai(g,2) + + ! Determine local noon reflected solar + if (local_secp1 == noonsec) then + fsr_vis_d_ln(p) = fsr_vis_d(p) + fsr_nir_d_ln(p) = fsr_nir_d(p) + else + fsr_vis_d_ln(p) = spval + fsr_nir_d_ln(p) = spval + endif + fsr(p) = fsr_vis_d(p) + fsr_nir_d(p) + fsr_vis_i(p) + fsr_nir_i(p) + + end do + + ! Loop over urban landunits in clump + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + ! Solar absorbed and longwave out and net + ! per unit ground area (roof, road) and per unit wall area (sunwall, shadewall) + ! Each urban pft has its own column - this is used in the logic below + + do p = pfti(l), pftf(l) + c = pcolumn(p) + if (ctype(c) == icol_roof) then + eflx_lwrad_out(p) = lwup_roof(fl) + eflx_lwrad_net(p) = lwnet_roof(fl) + eflx_lwrad_net_u(p) = lwnet_roof(fl) + sabg(p) = sabs_roof_dir(l,1)*forc_solad(g,1) + & + sabs_roof_dif(l,1)*forc_solai(g,1) + & + sabs_roof_dir(l,2)*forc_solad(g,2) + & + sabs_roof_dif(l,2)*forc_solai(g,2) + else if (ctype(c) == icol_sunwall) then + eflx_lwrad_out(p) = lwup_sunwall(fl) + eflx_lwrad_net(p) = lwnet_sunwall(fl) + eflx_lwrad_net_u(p) = lwnet_sunwall(fl) + sabg(p) = sabs_sunwall_dir(l,1)*forc_solad(g,1) + & + sabs_sunwall_dif(l,1)*forc_solai(g,1) + & + sabs_sunwall_dir(l,2)*forc_solad(g,2) + & + sabs_sunwall_dif(l,2)*forc_solai(g,2) + else if (ctype(c) == icol_shadewall) then + eflx_lwrad_out(p) = lwup_shadewall(fl) + eflx_lwrad_net(p) = lwnet_shadewall(fl) + eflx_lwrad_net_u(p) = lwnet_shadewall(fl) + sabg(p) = sabs_shadewall_dir(l,1)*forc_solad(g,1) + & + sabs_shadewall_dif(l,1)*forc_solai(g,1) + & + sabs_shadewall_dir(l,2)*forc_solad(g,2) + & + sabs_shadewall_dif(l,2)*forc_solai(g,2) + else if (ctype(c) == icol_road_perv) then + eflx_lwrad_out(p) = lwup_perroad(fl) + eflx_lwrad_net(p) = lwnet_perroad(fl) + eflx_lwrad_net_u(p) = lwnet_perroad(fl) + sabg(p) = sabs_perroad_dir(l,1)*forc_solad(g,1) + & + sabs_perroad_dif(l,1)*forc_solai(g,1) + & + sabs_perroad_dir(l,2)*forc_solad(g,2) + & + sabs_perroad_dif(l,2)*forc_solai(g,2) + else if (ctype(c) == icol_road_imperv) then + eflx_lwrad_out(p) = lwup_improad(fl) + eflx_lwrad_net(p) = lwnet_improad(fl) + eflx_lwrad_net_u(p) = lwnet_improad(fl) + sabg(p) = sabs_improad_dir(l,1)*forc_solad(g,1) + & + sabs_improad_dif(l,1)*forc_solai(g,1) + & + sabs_improad_dir(l,2)*forc_solad(g,2) + & + sabs_improad_dif(l,2)*forc_solai(g,2) + end if + sabv(p) = 0._r8 + fsa(p) = sabv(p) + sabg(p) + fsa_u(p) = fsa(p) + + end do ! end loop over urban pfts + + end do ! end loop over urban landunits + + end subroutine UrbanRadiation + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: view_factor +! +! !INTERFACE: + subroutine view_factor (lbl, ubl, num_urbanl, filter_urbanl, canyon_hwr) + +! +! !DESCRIPTION: +! View factors for road and one wall +! WALL | +! ROAD | +! wall | +! -----\ /----- - - |\----------/ +! | \ vsr / | | r | | \ vww / s +! | \ / | h o w | \ / k +! wall | \ / | wall | a | | \ / y +! |vwr \ / vwr| | d | |vrw \ / vsw +! ------\/------ - - |-----\/----- +! road wall | +! <----- w ----> | +! <---- h --->| +! +! vsr = view factor of sky for road vrw = view factor of road for wall +! vwr = view factor of one wall for road vww = view factor of opposing wall for wall +! vsw = view factor of sky for wall +! vsr + vwr + vwr = 1 vrw + vww + vsw = 1 +! +! Source: Masson, V. (2000) A physically-based scheme for the urban energy budget in +! atmospheric models. Boundary-Layer Meteorology 94:357-397 +! +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use clmtype +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer , intent(in) :: num_urbanl ! number of urban landunits + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + real(r8), intent(in) :: canyon_hwr(num_urbanl) ! ratio of building height to street width +! +! local pointers to original implicit out arguments (clmtype) +! + real(r8), pointer :: vf_sr(:) ! view factor of sky for road + real(r8), pointer :: vf_wr(:) ! view factor of one wall for road + real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall + real(r8), pointer :: vf_rw(:) ! view factor of road for one wall + real(r8), pointer :: vf_ww(:) ! view factor of opposing wall for one wall +! +! !CALLED FROM: +! subroutine UrbanAlbedo in this module +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! 03/2003, Mariana Vertenstein: Migrated to clm2.2 +! 01/2008, Erik Kluzek: Migrated to clm3.5.15 +! +! +! !LOCAL VARIABLES: +!EOP + integer :: l, fl ! indices + real(r8) :: sum ! sum of view factors for wall or road +!----------------------------------------------------------------------- + + ! Assign landunit level pointer + + vf_sr => lps%vf_sr + vf_wr => lps%vf_wr + vf_sw => lps%vf_sw + vf_rw => lps%vf_rw + vf_ww => lps%vf_ww + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + + ! road -- sky view factor -> 1 as building height -> 0 + ! and -> 0 as building height -> infinity + + vf_sr(l) = sqrt(canyon_hwr(fl)**2 + 1._r8) - canyon_hwr(fl) + vf_wr(l) = 0.5_r8 * (1._r8 - vf_sr(l)) + + ! one wall -- sky view factor -> 0.5 as building height -> 0 + ! and -> 0 as building height -> infinity + + vf_sw(l) = 0.5_r8 * (canyon_hwr(fl) + 1._r8 - sqrt(canyon_hwr(fl)**2+1._r8)) / canyon_hwr(fl) + vf_rw(l) = vf_sw(l) + vf_ww(l) = 1._r8 - vf_sw(l) - vf_rw(l) + + end do + + + ! error check -- make sure view factor sums to one for road and wall + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + + sum = vf_sr(l) + 2._r8*vf_wr(l) + if (abs(sum-1._r8) > 1.e-06_r8 ) then + write (iulog,*) 'urban road view factor error',sum + write (iulog,*) 'clm model is stopping' + call endrun() + endif + sum = vf_sw(l) + vf_rw(l) + vf_ww(l) + if (abs(sum-1._r8) > 1.e-06_r8 ) then + write (iulog,*) 'urban wall view factor error',sum + write (iulog,*) 'clm model is stopping' + call endrun() + endif + + end do + + end subroutine view_factor + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: incident_direct +! +! !INTERFACE: + subroutine incident_direct (lbl, ubl, num_urbanl, canyon_hwr, coszen, zen, sdir, sdir_road, sdir_sunwall, sdir_shadewall) +! +! !DESCRIPTION: +! Direct beam solar radiation incident on walls and road in urban canyon +! +! Sun +! / +! roof / +! ------ /--- - +! | / | | +! sunlit wall | / | shaded wall h +! | / | | +! -----/----- - +! road +! <--- w ---> +! +! Method: +! Road = Horizontal surface. Account for shading by wall. Integrate over all canyon orientations +! Wall (sunlit) = Adjust horizontal radiation for 90 degree surface. Account for shading by opposing wall. +! Integrate over all canyon orientations +! Wall (shaded) = 0 +! +! Conservation check: Total incoming direct beam (sdir) = sdir_road + (sdir_shadewall + sdir_sunwall)*canyon_hwr +! Multiplication by canyon_hwr scales wall fluxes (per unit wall area) to per unit ground area +! +! Source: Masson, V. (2000) A physically-based scheme for the urban energy budget in +! atmospheric models. Boundary-Layer Meteorology 94:357-397 +! +! This analytical solution from Masson (2000) agrees with the numerical solution to +! within 0.6 W/m**2 for sdir = 1000 W/m**2 and for all H/W from 0.1 to 10 by 0.1 +! and all solar zenith angles from 1 to 90 deg by 1 +! +! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_varcon , only : rpi + implicit none +! +! !ARGUMENTS: + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer , intent(in) :: num_urbanl ! number of urban landunits + real(r8), intent(in) :: canyon_hwr(num_urbanl) ! ratio of building height to street width + real(r8), intent(in) :: coszen(num_urbanl) ! cosine solar zenith angle + real(r8), intent(in) :: zen(num_urbanl) ! solar zenith angle (radians) + real(r8), intent(in) :: sdir(num_urbanl, numrad) ! direct beam solar radiation incident on horizontal surface + real(r8), intent(out) :: sdir_road(num_urbanl, numrad) ! direct beam solar radiation incident on road per unit incident flux + real(r8), intent(out) :: sdir_sunwall(num_urbanl, numrad) ! direct beam solar radiation (per unit wall area) incident on sunlit wall per unit incident flux + real(r8), intent(out) :: sdir_shadewall(num_urbanl, numrad) ! direct beam solar radiation (per unit wall area) incident on shaded wall per unit incident flux +! +! !CALLED FROM: +! subroutine UrbanAlbedo in this module +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! +! +! !LOCAL VARIABLES: +!EOP + integer :: l,i,ib ! indices +!KO logical :: numchk = .true. ! true => perform numerical check of analytical solution + logical :: numchk = .false. ! true => perform numerical check of analytical solution + real(r8) :: theta0(num_urbanl) ! critical canyon orientation for which road is no longer illuminated + real(r8) :: tanzen(num_urbanl) ! tan(zenith angle) + real(r8) :: swall_projected ! direct beam solar radiation (per unit ground area) incident on wall + real(r8) :: err1(num_urbanl) ! energy conservation error + real(r8) :: err2(num_urbanl) ! energy conservation error + real(r8) :: err3(num_urbanl) ! energy conservation error + real(r8) :: sumr ! sum of sroad for each orientation (0 <= theta <= pi/2) + real(r8) :: sumw ! sum of swall for each orientation (0 <= theta <= pi/2) + real(r8) :: num ! number of orientations + real(r8) :: theta ! canyon orientation relative to sun (0 <= theta <= pi/2) + real(r8) :: zen0 ! critical solar zenith angle for which sun begins to illuminate road +!----------------------------------------------------------------------- + + do l = 1,num_urbanl + if (coszen(l) > 0._r8) then + theta0(l) = asin(min( (1._r8/(canyon_hwr(l)*tan(max(zen(l),0.000001_r8)))), 1._r8 )) + tanzen(l) = tan(zen(l)) + end if + end do + + do ib = 1,numrad + + do l = 1,num_urbanl + if (coszen(l) > 0._r8) then + sdir_shadewall(l,ib) = 0._r8 + + ! incident solar radiation on wall and road integrated over all canyon orientations (0 <= theta <= pi/2) + + sdir_road(l,ib) = sdir(l,ib) * & + (2._r8*theta0(l)/rpi - 2./rpi*canyon_hwr(l)*tanzen(l)*(1._r8-cos(theta0(l)))) + sdir_sunwall(l,ib) = 2._r8 * sdir(l,ib) * ((1._r8/canyon_hwr(l))* & + (0.5_r8-theta0(l)/rpi) + (1._r8/rpi)*tanzen(l)*(1._r8-cos(theta0(l)))) + + ! conservation check for road and wall. need to use wall fluxes converted to ground area + + swall_projected = (sdir_shadewall(l,ib) + sdir_sunwall(l,ib)) * canyon_hwr(l) + err1(l) = sdir(l,ib) - (sdir_road(l,ib) + swall_projected) + else + sdir_road(l,ib) = 0._r8 + sdir_sunwall(l,ib) = 0._r8 + sdir_shadewall(l,ib) = 0._r8 + endif + end do + + do l = 1,num_urbanl + if (coszen(l) > 0._r8) then + if (abs(err1(l)) > 0.001_r8) then + write (iulog,*) 'urban direct beam solar radiation balance error',err1(l) + write (iulog,*) 'clm model is stopping' + call endrun() + endif + endif + end do + + ! numerical check of analytical solution + ! sum sroad and swall over all canyon orientations (0 <= theta <= pi/2) + + if (numchk) then + do l = 1,num_urbanl + if (coszen(l) > 0._r8) then + sumr = 0._r8 + sumw = 0._r8 + num = 0._r8 + do i = 1, 9000 + theta = i/100._r8 * rpi/180._r8 + zen0 = atan(1._r8/(canyon_hwr(l)*sin(theta))) + if (zen(l) >= zen0) then + sumr = sumr + 0._r8 + sumw = sumw + sdir(l,ib) / canyon_hwr(l) + else + sumr = sumr + sdir(l,ib) * (1._r8-canyon_hwr(l)*sin(theta)*tanzen(l)) + sumw = sumw + sdir(l,ib) * sin(theta)*tanzen(l) + end if + num = num + 1._r8 + end do + err2(l) = sumr/num - sdir_road(l,ib) + err3(l) = sumw/num - sdir_sunwall(l,ib) + endif + end do + do l = 1,num_urbanl + if (coszen(l) > 0._r8) then + if (abs(err2(l)) > 0.0006_r8 ) then + write (iulog,*) 'urban road incident direct beam solar radiation error',err2(l) + write (iulog,*) 'clm model is stopping' + call endrun + endif + if (abs(err3(l)) > 0.0006_r8 ) then + write (iulog,*) 'urban wall incident direct beam solar radiation error',err3(l) + write (iulog,*) 'clm model is stopping' + call endrun + end if + end if + end do + end if + + end do + + end subroutine incident_direct + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: incident_diffuse +! +! !INTERFACE: + subroutine incident_diffuse (lbl, ubl, num_urbanl, filter_urbanl, canyon_hwr, sdif, sdif_road, sdif_sunwall, sdif_shadewall) +! +! !DESCRIPTION: +! Diffuse solar radiation incident on walls and road in urban canyon +! Conservation check: Total incoming diffuse +! (sdif) = sdif_road + (sdif_shadewall + sdif_sunwall)*canyon_hwr +! Multiplication by canyon_hwr scales wall fluxes (per unit wall area) to per unit ground area +! +! !USES: + use shr_kind_mod, only: r8 => shr_kind_r8 + use clmtype +! +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer , intent(in) :: num_urbanl ! number of urban landunits + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + real(r8), intent(in) :: canyon_hwr(num_urbanl) ! ratio of building height to street width + real(r8), intent(in) :: sdif(num_urbanl, numrad) ! diffuse solar radiation incident on horizontal surface + real(r8), intent(out) :: sdif_road(num_urbanl, numrad) ! diffuse solar radiation incident on road + real(r8), intent(out) :: sdif_sunwall(num_urbanl, numrad) ! diffuse solar radiation (per unit wall area) incident on sunlit wall + real(r8), intent(out) :: sdif_shadewall(num_urbanl, numrad) ! diffuse solar radiation (per unit wall area) incident on shaded wall +! +! local pointers to original implicit in arguments (clmtype) +! + real(r8), pointer :: vf_sr(:) ! view factor of sky for road + real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall +! +! !CALLED FROM: +! subroutine UrbanAlbedo in this module +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! +! +! !LOCAL VARIABLES: +!EOP + integer :: l, fl, ib ! indices + real(r8) :: err(num_urbanl) ! energy conservation error (W/m**2) + real(r8) :: swall_projected ! diffuse solar radiation (per unit ground area) incident on wall (W/m**2) +!----------------------------------------------------------------------- + + ! Assign landunit level pointer + + vf_sr => lps%vf_sr + vf_sw => lps%vf_sw + + do ib = 1, numrad + + ! diffuse solar and conservation check. need to convert wall fluxes to ground area + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + sdif_road(fl,ib) = sdif(fl,ib) * vf_sr(l) + sdif_sunwall(fl,ib) = sdif(fl,ib) * vf_sw(l) + sdif_shadewall(fl,ib) = sdif(fl,ib) * vf_sw(l) + + swall_projected = (sdif_shadewall(fl,ib) + sdif_sunwall(fl,ib)) * canyon_hwr(fl) + err(fl) = sdif(fl,ib) - (sdif_road(fl,ib) + swall_projected) + end do + + ! error check + + do l = 1, num_urbanl + if (abs(err(l)) > 0.001_r8) then + write (iulog,*) 'urban diffuse solar radiation balance error',err(l) + write (iulog,*) 'clm model is stopping' + call endrun + endif + end do + + end do + + end subroutine incident_diffuse + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: net_solar +! +! !INTERFACE: + subroutine net_solar (lbl, ubl, num_urbanl, filter_urbanl, coszen, canyon_hwr, wtroad_perv, sdir, sdif, & + alb_improad_dir, alb_perroad_dir, alb_wall_dir, alb_roof_dir, & + alb_improad_dif, alb_perroad_dif, alb_wall_dif, alb_roof_dif, & + sdir_road, sdir_sunwall, sdir_shadewall, & + sdif_road, sdif_sunwall, sdif_shadewall, & + sref_improad_dir, sref_perroad_dir, sref_sunwall_dir, sref_shadewall_dir, sref_roof_dir, & + sref_improad_dif, sref_perroad_dif, sref_sunwall_dif, sref_shadewall_dif, sref_roof_dif) +! +! !DESCRIPTION: +! Solar radiation absorbed by road and both walls in urban canyon allowing +! for multiple reflection. +! +! !USES: + use shr_kind_mod, only : r8 => shr_kind_r8 + use clmtype +! +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer , intent(in) :: num_urbanl ! number of urban landunits + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + real(r8), intent(in) :: coszen(num_urbanl) ! cosine solar zenith angle + real(r8), intent(in) :: canyon_hwr(num_urbanl) ! ratio of building height to street width + real(r8), intent(in) :: wtroad_perv(num_urbanl) ! weight of pervious road wrt total road + real(r8), intent(in) :: sdir(num_urbanl, numrad) ! direct beam solar radiation incident on horizontal surface + real(r8), intent(in) :: sdif(num_urbanl, numrad) ! diffuse solar radiation on horizontal surface + real(r8), intent(in) :: alb_improad_dir(num_urbanl, numrad) ! direct impervious road albedo + real(r8), intent(in) :: alb_perroad_dir(num_urbanl, numrad) ! direct pervious road albedo + real(r8), intent(in) :: alb_wall_dir(num_urbanl, numrad) ! direct wall albedo + real(r8), intent(in) :: alb_roof_dir(num_urbanl, numrad) ! direct roof albedo + real(r8), intent(in) :: alb_improad_dif(num_urbanl, numrad) ! diffuse impervious road albedo + real(r8), intent(in) :: alb_perroad_dif(num_urbanl, numrad) ! diffuse pervious road albedo + real(r8), intent(in) :: alb_wall_dif(num_urbanl, numrad) ! diffuse wall albedo + real(r8), intent(in) :: alb_roof_dif(num_urbanl, numrad) ! diffuse roof albedo + real(r8), intent(in) :: sdir_road(num_urbanl, numrad) ! direct beam solar radiation incident on road per unit incident flux + real(r8), intent(in) :: sdir_sunwall(num_urbanl, numrad) ! direct beam solar radiation (per unit wall area) incident on sunlit wall per unit incident flux + real(r8), intent(in) :: sdir_shadewall(num_urbanl, numrad) ! direct beam solar radiation (per unit wall area) incident on shaded wall per unit incident flux + real(r8), intent(in) :: sdif_road(num_urbanl, numrad) ! diffuse solar radiation incident on road per unit incident flux + real(r8), intent(in) :: sdif_sunwall(num_urbanl, numrad) ! diffuse solar radiation (per unit wall area) incident on sunlit wall per unit incident flux + real(r8), intent(in) :: sdif_shadewall(num_urbanl, numrad) ! diffuse solar radiation (per unit wall area) incident on shaded wall per unit incident flux + real(r8), intent(inout) :: sref_improad_dir(num_urbanl, numrad) ! direct solar rad reflected by impervious road (per unit ground area) per unit incident flux + real(r8), intent(inout) :: sref_perroad_dir(num_urbanl, numrad) ! direct solar rad reflected by pervious road (per unit ground area) per unit incident flux + real(r8), intent(inout) :: sref_improad_dif(num_urbanl, numrad) ! diffuse solar rad reflected by impervious road (per unit ground area) per unit incident flux + real(r8), intent(inout) :: sref_perroad_dif(num_urbanl, numrad) ! diffuse solar rad reflected by pervious road (per unit ground area) per unit incident flux + real(r8), intent(inout) :: sref_sunwall_dir(num_urbanl, numrad) ! direct solar rad reflected by sunwall (per unit wall area) per unit incident flux + real(r8), intent(inout) :: sref_sunwall_dif(num_urbanl, numrad) ! diffuse solar rad reflected by sunwall (per unit wall area) per unit incident flux + real(r8), intent(inout) :: sref_shadewall_dir(num_urbanl, numrad) ! direct solar rad reflected by shadewall (per unit wall area) per unit incident flux + real(r8), intent(inout) :: sref_shadewall_dif(num_urbanl, numrad) ! diffuse solar rad reflected by shadewall (per unit wall area) per unit incident flux + real(r8), intent(inout) :: sref_roof_dir(num_urbanl, numrad) ! direct solar rad reflected by roof (per unit ground area) per unit incident flux + real(r8), intent(inout) :: sref_roof_dif(num_urbanl, numrad) ! diffuse solar rad reflected by roof (per unit ground area) per unit incident flux +! +! local pointers to original implicit in arguments (clmtype) +! + real(r8), pointer :: vf_sr(:) ! view factor of sky for road + real(r8), pointer :: vf_wr(:) ! view factor of one wall for road + real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall + real(r8), pointer :: vf_rw(:) ! view factor of road for one wall + real(r8), pointer :: vf_ww(:) ! view factor of opposing wall for one wall + real(r8), pointer :: sabs_roof_dir(:,:) ! direct solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_roof_dif(:,:) ! diffuse solar absorbed by roof per unit ground area per unit incident flux + real(r8), pointer :: sabs_sunwall_dir(:,:) ! direct solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_sunwall_dif(:,:) ! diffuse solar absorbed by sunwall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dir(:,:) ! direct solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_shadewall_dif(:,:) ! diffuse solar absorbed by shadewall per unit wall area per unit incident flux + real(r8), pointer :: sabs_improad_dir(:,:) ! direct solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_improad_dif(:,:) ! diffuse solar absorbed by impervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dir(:,:) ! direct solar absorbed by pervious road per unit ground area per unit incident flux + real(r8), pointer :: sabs_perroad_dif(:,:) ! diffuse solar absorbed by pervious road per unit ground area per unit incident flux +! +! !CALLED FROM: +! subroutine UrbanAlbedo in this module +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! +! +! !LOCAL VARIABLES +!EOP +! + real(r8) :: wtroad_imperv(num_urbanl) ! weight of impervious road wrt total road + real(r8) :: sabs_canyon_dir(num_urbanl) ! direct solar rad absorbed by canyon per unit incident flux + real(r8) :: sabs_canyon_dif(num_urbanl) ! diffuse solar rad absorbed by canyon per unit incident flux + real(r8) :: sref_canyon_dir(num_urbanl) ! direct solar reflected by canyon per unit incident flux + real(r8) :: sref_canyon_dif(num_urbanl) ! diffuse solar reflected by canyon per unit incident flux + + real(r8) :: improad_a_dir(num_urbanl) ! absorbed direct solar for impervious road after "n" reflections per unit incident flux + real(r8) :: improad_a_dif(num_urbanl) ! absorbed diffuse solar for impervious road after "n" reflections per unit incident flux + real(r8) :: improad_r_dir(num_urbanl) ! reflected direct solar for impervious road after "n" reflections per unit incident flux + real(r8) :: improad_r_dif(num_urbanl) ! reflected diffuse solar for impervious road after "n" reflections per unit incident flux + real(r8) :: improad_r_sky_dir(num_urbanl) ! improad_r_dir to sky per unit incident flux + real(r8) :: improad_r_sunwall_dir(num_urbanl) ! improad_r_dir to sunlit wall per unit incident flux + real(r8) :: improad_r_shadewall_dir(num_urbanl) ! improad_r_dir to shaded wall per unit incident flux + real(r8) :: improad_r_sky_dif(num_urbanl) ! improad_r_dif to sky per unit incident flux + real(r8) :: improad_r_sunwall_dif(num_urbanl) ! improad_r_dif to sunlit wall per unit incident flux + real(r8) :: improad_r_shadewall_dif(num_urbanl) ! improad_r_dif to shaded wall per unit incident flux + + real(r8) :: perroad_a_dir(num_urbanl) ! absorbed direct solar for pervious road after "n" reflections per unit incident flux + real(r8) :: perroad_a_dif(num_urbanl) ! absorbed diffuse solar for pervious road after "n" reflections per unit incident flux + real(r8) :: perroad_r_dir(num_urbanl) ! reflected direct solar for pervious road after "n" reflections per unit incident flux + real(r8) :: perroad_r_dif(num_urbanl) ! reflected diffuse solar for pervious road after "n" reflections per unit incident flux + real(r8) :: perroad_r_sky_dir(num_urbanl) ! perroad_r_dir to sky per unit incident flux + real(r8) :: perroad_r_sunwall_dir(num_urbanl) ! perroad_r_dir to sunlit wall per unit incident flux + real(r8) :: perroad_r_shadewall_dir(num_urbanl) ! perroad_r_dir to shaded wall per unit incident flux + real(r8) :: perroad_r_sky_dif(num_urbanl) ! perroad_r_dif to sky per unit incident flux + real(r8) :: perroad_r_sunwall_dif(num_urbanl) ! perroad_r_dif to sunlit wall per unit incident flux + real(r8) :: perroad_r_shadewall_dif(num_urbanl) ! perroad_r_dif to shaded wall per unit incident flux + + real(r8) :: road_a_dir(num_urbanl) ! absorbed direct solar for total road after "n" reflections per unit incident flux + real(r8) :: road_a_dif(num_urbanl) ! absorbed diffuse solar for total road after "n" reflections per unit incident flux + real(r8) :: road_r_dir(num_urbanl) ! reflected direct solar for total road after "n" reflections per unit incident flux + real(r8) :: road_r_dif(num_urbanl) ! reflected diffuse solar for total road after "n" reflections per unit incident flux + real(r8) :: road_r_sky_dir(num_urbanl) ! road_r_dir to sky per unit incident flux + real(r8) :: road_r_sunwall_dir(num_urbanl) ! road_r_dir to sunlit wall per unit incident flux + real(r8) :: road_r_shadewall_dir(num_urbanl) ! road_r_dir to shaded wall per unit incident flux + real(r8) :: road_r_sky_dif(num_urbanl) ! road_r_dif to sky per unit incident flux + real(r8) :: road_r_sunwall_dif(num_urbanl) ! road_r_dif to sunlit wall per unit incident flux + real(r8) :: road_r_shadewall_dif(num_urbanl) ! road_r_dif to shaded wall per unit incident flux + + real(r8) :: sunwall_a_dir(num_urbanl) ! absorbed direct solar for sunlit wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: sunwall_a_dif(num_urbanl) ! absorbed diffuse solar for sunlit wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: sunwall_r_dir(num_urbanl) ! reflected direct solar for sunlit wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: sunwall_r_dif(num_urbanl) ! reflected diffuse solar for sunlit wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: sunwall_r_sky_dir(num_urbanl) ! sunwall_r_dir to sky per unit incident flux + real(r8) :: sunwall_r_road_dir(num_urbanl) ! sunwall_r_dir to road per unit incident flux + real(r8) :: sunwall_r_shadewall_dir(num_urbanl) ! sunwall_r_dir to opposing (shaded) wall per unit incident flux + real(r8) :: sunwall_r_sky_dif(num_urbanl) ! sunwall_r_dif to sky per unit incident flux + real(r8) :: sunwall_r_road_dif(num_urbanl) ! sunwall_r_dif to road per unit incident flux + real(r8) :: sunwall_r_shadewall_dif(num_urbanl) ! sunwall_r_dif to opposing (shaded) wall per unit incident flux + + real(r8) :: shadewall_a_dir(num_urbanl) ! absorbed direct solar for shaded wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: shadewall_a_dif(num_urbanl) ! absorbed diffuse solar for shaded wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: shadewall_r_dir(num_urbanl) ! reflected direct solar for shaded wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: shadewall_r_dif(num_urbanl) ! reflected diffuse solar for shaded wall (per unit wall area) after "n" reflections per unit incident flux + real(r8) :: shadewall_r_sky_dir(num_urbanl) ! shadewall_r_dir to sky per unit incident flux + real(r8) :: shadewall_r_road_dir(num_urbanl) ! shadewall_r_dir to road per unit incident flux + real(r8) :: shadewall_r_sunwall_dir(num_urbanl) ! shadewall_r_dir to opposing (sunlit) wall per unit incident flux + real(r8) :: shadewall_r_sky_dif(num_urbanl) ! shadewall_r_dif to sky per unit incident flux + real(r8) :: shadewall_r_road_dif(num_urbanl) ! shadewall_r_dif to road per unit incident flux + real(r8) :: shadewall_r_sunwall_dif(num_urbanl) ! shadewall_r_dif to opposing (sunlit) wall per unit incident flux + + real(r8) :: canyon_alb_dir(num_urbanl) ! direct canyon albedo + real(r8) :: canyon_alb_dif(num_urbanl) ! diffuse canyon albedo + + real(r8) :: stot(num_urbanl) ! sum of radiative terms + real(r8) :: stot_dir(num_urbanl) ! sum of direct radiative terms + real(r8) :: stot_dif(num_urbanl) ! sum of diffuse radiative terms + + integer :: l,fl,ib ! indices + integer :: iter_dir,iter_dif ! iteration counter + real(r8) :: crit ! convergence criterion + real(r8) :: err ! energy conservation error + integer :: pass + integer, parameter :: n = 50 ! number of interations + real(r8) :: sabs_road ! temporary for absorption over road + real(r8) :: sref_road ! temporary for reflected over road + real(r8), parameter :: errcrit = .00001_r8 ! error criteria +!----------------------------------------------------------------------- + + ! Assign landunit level pointer + + vf_sr => lps%vf_sr + vf_wr => lps%vf_wr + vf_sw => lps%vf_sw + vf_rw => lps%vf_rw + vf_ww => lps%vf_ww + sabs_roof_dir => lps%sabs_roof_dir + sabs_roof_dif => lps%sabs_roof_dif + sabs_sunwall_dir => lps%sabs_sunwall_dir + sabs_sunwall_dif => lps%sabs_sunwall_dif + sabs_shadewall_dir => lps%sabs_shadewall_dir + sabs_shadewall_dif => lps%sabs_shadewall_dif + sabs_improad_dir => lps%sabs_improad_dir + sabs_improad_dif => lps%sabs_improad_dif + sabs_perroad_dir => lps%sabs_perroad_dir + sabs_perroad_dif => lps%sabs_perroad_dif + + ! Calculate impervious road + + do l = 1,num_urbanl + wtroad_imperv(l) = 1._r8 - wtroad_perv(l) + end do + + do ib = 1,numrad + do fl = 1,num_urbanl + if (coszen(fl) .gt. 0._r8) then + l = filter_urbanl(fl) + + ! initial absorption and reflection for road and both walls. + ! distribute reflected radiation to sky, road, and walls + ! according to appropriate view factor. radiation reflected to + ! road and walls will undergo multiple reflections within the canyon. + ! do separately for direct beam and diffuse radiation. + + ! direct beam + + road_a_dir(fl) = 0.0_r8 + road_r_dir(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_a_dir(fl) = (1._r8-alb_improad_dir(fl,ib)) * sdir_road(fl,ib) + improad_r_dir(fl) = alb_improad_dir(fl,ib) * sdir_road(fl,ib) + improad_r_sky_dir(fl) = improad_r_dir(fl) * vf_sr(l) + improad_r_sunwall_dir(fl) = improad_r_dir(fl) * vf_wr(l) + improad_r_shadewall_dir(fl) = improad_r_dir(fl) * vf_wr(l) + road_a_dir(fl) = road_a_dir(fl) + improad_a_dir(fl)*wtroad_imperv(fl) + road_r_dir(fl) = road_r_dir(fl) + improad_r_dir(fl)*wtroad_imperv(fl) + end if + + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_a_dir(fl) = (1._r8-alb_perroad_dir(fl,ib)) * sdir_road(fl,ib) + perroad_r_dir(fl) = alb_perroad_dir(fl,ib) * sdir_road(fl,ib) + perroad_r_sky_dir(fl) = perroad_r_dir(fl) * vf_sr(l) + perroad_r_sunwall_dir(fl) = perroad_r_dir(fl) * vf_wr(l) + perroad_r_shadewall_dir(fl) = perroad_r_dir(fl) * vf_wr(l) + road_a_dir(fl) = road_a_dir(fl) + perroad_a_dir(fl)*wtroad_perv(fl) + road_r_dir(fl) = road_r_dir(fl) + perroad_r_dir(fl)*wtroad_perv(fl) + end if + + road_r_sky_dir(fl) = road_r_dir(fl) * vf_sr(l) + road_r_sunwall_dir(fl) = road_r_dir(fl) * vf_wr(l) + road_r_shadewall_dir(fl) = road_r_dir(fl) * vf_wr(l) + + sunwall_a_dir(fl) = (1._r8-alb_wall_dir(fl,ib)) * sdir_sunwall(fl,ib) + sunwall_r_dir(fl) = alb_wall_dir(fl,ib) * sdir_sunwall(fl,ib) + sunwall_r_sky_dir(fl) = sunwall_r_dir(fl) * vf_sw(l) + sunwall_r_road_dir(fl) = sunwall_r_dir(fl) * vf_rw(l) + sunwall_r_shadewall_dir(fl) = sunwall_r_dir(fl) * vf_ww(l) + + shadewall_a_dir(fl) = (1._r8-alb_wall_dir(fl,ib)) * sdir_shadewall(fl,ib) + shadewall_r_dir(fl) = alb_wall_dir(fl,ib) * sdir_shadewall(fl,ib) + shadewall_r_sky_dir(fl) = shadewall_r_dir(fl) * vf_sw(l) + shadewall_r_road_dir(fl) = shadewall_r_dir(fl) * vf_rw(l) + shadewall_r_sunwall_dir(fl) = shadewall_r_dir(fl) * vf_ww(l) + + ! diffuse + + road_a_dif(fl) = 0.0_r8 + road_r_dif(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_a_dif(fl) = (1._r8-alb_improad_dif(fl,ib)) * sdif_road(fl,ib) + improad_r_dif(fl) = alb_improad_dif(fl,ib) * sdif_road(fl,ib) + improad_r_sky_dif(fl) = improad_r_dif(fl) * vf_sr(l) + improad_r_sunwall_dif(fl) = improad_r_dif(fl) * vf_wr(l) + improad_r_shadewall_dif(fl) = improad_r_dif(fl) * vf_wr(l) + road_a_dif(fl) = road_a_dif(fl) + improad_a_dif(fl)*wtroad_imperv(fl) + road_r_dif(fl) = road_r_dif(fl) + improad_r_dif(fl)*wtroad_imperv(fl) + end if + + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_a_dif(fl) = (1._r8-alb_perroad_dif(fl,ib)) * sdif_road(fl,ib) + perroad_r_dif(fl) = alb_perroad_dif(fl,ib) * sdif_road(fl,ib) + perroad_r_sky_dif(fl) = perroad_r_dif(fl) * vf_sr(l) + perroad_r_sunwall_dif(fl) = perroad_r_dif(fl) * vf_wr(l) + perroad_r_shadewall_dif(fl) = perroad_r_dif(fl) * vf_wr(l) + road_a_dif(fl) = road_a_dif(fl) + perroad_a_dif(fl)*wtroad_perv(fl) + road_r_dif(fl) = road_r_dif(fl) + perroad_r_dif(fl)*wtroad_perv(fl) + end if + + road_r_sky_dif(fl) = road_r_dif(fl) * vf_sr(l) + road_r_sunwall_dif(fl) = road_r_dif(fl) * vf_wr(l) + road_r_shadewall_dif(fl) = road_r_dif(fl) * vf_wr(l) + + sunwall_a_dif(fl) = (1._r8-alb_wall_dif(fl,ib)) * sdif_sunwall(fl,ib) + sunwall_r_dif(fl) = alb_wall_dif(fl,ib) * sdif_sunwall(fl,ib) + sunwall_r_sky_dif(fl) = sunwall_r_dif(fl) * vf_sw(l) + sunwall_r_road_dif(fl) = sunwall_r_dif(fl) * vf_rw(l) + sunwall_r_shadewall_dif(fl) = sunwall_r_dif(fl) * vf_ww(l) + + shadewall_a_dif(fl) = (1._r8-alb_wall_dif(fl,ib)) * sdif_shadewall(fl,ib) + shadewall_r_dif(fl) = alb_wall_dif(fl,ib) * sdif_shadewall(fl,ib) + shadewall_r_sky_dif(fl) = shadewall_r_dif(fl) * vf_sw(l) + shadewall_r_road_dif(fl) = shadewall_r_dif(fl) * vf_rw(l) + shadewall_r_sunwall_dif(fl) = shadewall_r_dif(fl) * vf_ww(l) + + ! initialize sum of direct and diffuse solar absorption and reflection for road and both walls + + if ( wtroad_imperv(fl) > 0.0_r8 ) sabs_improad_dir(l,ib) = improad_a_dir(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sabs_perroad_dir(l,ib) = perroad_a_dir(fl) + sabs_sunwall_dir(l,ib) = sunwall_a_dir(fl) + sabs_shadewall_dir(l,ib) = shadewall_a_dir(fl) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sabs_improad_dif(l,ib) = improad_a_dif(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sabs_perroad_dif(l,ib) = perroad_a_dif(fl) + sabs_sunwall_dif(l,ib) = sunwall_a_dif(fl) + sabs_shadewall_dif(l,ib) = shadewall_a_dif(fl) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sref_improad_dir(fl,ib) = improad_r_sky_dir(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sref_perroad_dir(fl,ib) = perroad_r_sky_dir(fl) + sref_sunwall_dir(fl,ib) = sunwall_r_sky_dir(fl) + sref_shadewall_dir(fl,ib) = shadewall_r_sky_dir(fl) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sref_improad_dif(fl,ib) = improad_r_sky_dif(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sref_perroad_dif(fl,ib) = perroad_r_sky_dif(fl) + sref_sunwall_dif(fl,ib) = sunwall_r_sky_dif(fl) + sref_shadewall_dif(fl,ib) = shadewall_r_sky_dif(fl) + endif + + end do + + ! absorption and reflection for walls and road with multiple reflections + ! (i.e., absorb and reflect initial reflection in canyon and allow for + ! subsequent scattering) + ! + ! (1) absorption and reflection of scattered solar radiation + ! road: reflected fluxes from walls need to be projected to ground area + ! wall: reflected flux from road needs to be projected to wall area + ! + ! (2) add absorbed radiation for ith reflection to total absorbed + ! + ! (3) distribute reflected radiation to sky, road, and walls according to view factors + ! + ! (4) add solar reflection to sky for ith reflection to total reflection + ! + ! (5) stop iteration when absorption for ith reflection is less than some nominal amount. + ! small convergence criteria is required to ensure solar radiation is conserved + ! + ! do separately for direct beam and diffuse + + do fl = 1,num_urbanl + if (coszen(fl) .gt. 0._r8) then + l = filter_urbanl(fl) + + ! reflected direct beam + + do iter_dir = 1, n + ! step (1) + + stot(fl) = (sunwall_r_road_dir(fl) + shadewall_r_road_dir(fl))*canyon_hwr(fl) + + road_a_dir(fl) = 0.0_r8 + road_r_dir(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_a_dir(fl) = (1._r8-alb_improad_dir(fl,ib)) * stot(fl) + improad_r_dir(fl) = alb_improad_dir(fl,ib) * stot(fl) + road_a_dir(fl) = road_a_dir(fl) + improad_a_dir(fl)*wtroad_imperv(fl) + road_r_dir(fl) = road_r_dir(fl) + improad_r_dir(fl)*wtroad_imperv(fl) + end if + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_a_dir(fl) = (1._r8-alb_perroad_dir(fl,ib)) * stot(fl) + perroad_r_dir(fl) = alb_perroad_dir(fl,ib) * stot(fl) + road_a_dir(fl) = road_a_dir(fl) + perroad_a_dir(fl)*wtroad_perv(fl) + road_r_dir(fl) = road_r_dir(fl) + perroad_r_dir(fl)*wtroad_perv(fl) + end if + + stot(fl) = road_r_sunwall_dir(fl)/canyon_hwr(fl) + shadewall_r_sunwall_dir(fl) + sunwall_a_dir(fl) = (1._r8-alb_wall_dir(fl,ib)) * stot(fl) + sunwall_r_dir(fl) = alb_wall_dir(fl,ib) * stot(fl) + + stot(fl) = road_r_shadewall_dir(fl)/canyon_hwr(fl) + sunwall_r_shadewall_dir(fl) + shadewall_a_dir(fl) = (1._r8-alb_wall_dir(fl,ib)) * stot(fl) + shadewall_r_dir(fl) = alb_wall_dir(fl,ib) * stot(fl) + + ! step (2) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sabs_improad_dir(l,ib) = sabs_improad_dir(l,ib) + improad_a_dir(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sabs_perroad_dir(l,ib) = sabs_perroad_dir(l,ib) + perroad_a_dir(fl) + sabs_sunwall_dir(l,ib) = sabs_sunwall_dir(l,ib) + sunwall_a_dir(fl) + sabs_shadewall_dir(l,ib) = sabs_shadewall_dir(l,ib) + shadewall_a_dir(fl) + + ! step (3) + + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_r_sky_dir(fl) = improad_r_dir(fl) * vf_sr(l) + improad_r_sunwall_dir(fl) = improad_r_dir(fl) * vf_wr(l) + improad_r_shadewall_dir(fl) = improad_r_dir(fl) * vf_wr(l) + end if + + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_r_sky_dir(fl) = perroad_r_dir(fl) * vf_sr(l) + perroad_r_sunwall_dir(fl) = perroad_r_dir(fl) * vf_wr(l) + perroad_r_shadewall_dir(fl) = perroad_r_dir(fl) * vf_wr(l) + end if + + road_r_sky_dir(fl) = road_r_dir(fl) * vf_sr(l) + road_r_sunwall_dir(fl) = road_r_dir(fl) * vf_wr(l) + road_r_shadewall_dir(fl) = road_r_dir(fl) * vf_wr(l) + + sunwall_r_sky_dir(fl) = sunwall_r_dir(fl) * vf_sw(l) + sunwall_r_road_dir(fl) = sunwall_r_dir(fl) * vf_rw(l) + sunwall_r_shadewall_dir(fl) = sunwall_r_dir(fl) * vf_ww(l) + + shadewall_r_sky_dir(fl) = shadewall_r_dir(fl) * vf_sw(l) + shadewall_r_road_dir(fl) = shadewall_r_dir(fl) * vf_rw(l) + shadewall_r_sunwall_dir(fl) = shadewall_r_dir(fl) * vf_ww(l) + + ! step (4) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sref_improad_dir(fl,ib) = sref_improad_dir(fl,ib) + improad_r_sky_dir(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sref_perroad_dir(fl,ib) = sref_perroad_dir(fl,ib) + perroad_r_sky_dir(fl) + sref_sunwall_dir(fl,ib) = sref_sunwall_dir(fl,ib) + sunwall_r_sky_dir(fl) + sref_shadewall_dir(fl,ib) = sref_shadewall_dir(fl,ib) + shadewall_r_sky_dir(fl) + + ! step (5) + + crit = max(road_a_dir(fl), sunwall_a_dir(fl), shadewall_a_dir(fl)) + if (crit < errcrit) exit + end do + if (iter_dir >= n) then + write (iulog,*) 'urban net solar radiation error: no convergence, direct beam' + write (iulog,*) 'clm model is stopping' + call endrun + endif + + ! reflected diffuse + + do iter_dif = 1, n + ! step (1) + + stot(fl) = (sunwall_r_road_dif(fl) + shadewall_r_road_dif(fl))*canyon_hwr(fl) + road_a_dif(fl) = 0.0_r8 + road_r_dif(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_a_dif(fl) = (1._r8-alb_improad_dif(fl,ib)) * stot(fl) + improad_r_dif(fl) = alb_improad_dif(fl,ib) * stot(fl) + road_a_dif(fl) = road_a_dif(fl) + improad_a_dif(fl)*wtroad_imperv(fl) + road_r_dif(fl) = road_r_dif(fl) + improad_r_dif(fl)*wtroad_imperv(fl) + end if + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_a_dif(fl) = (1._r8-alb_perroad_dif(fl,ib)) * stot(fl) + perroad_r_dif(fl) = alb_perroad_dif(fl,ib) * stot(fl) + road_a_dif(fl) = road_a_dif(fl) + perroad_a_dif(fl)*wtroad_perv(fl) + road_r_dif(fl) = road_r_dif(fl) + perroad_r_dif(fl)*wtroad_perv(fl) + end if + + stot(fl) = road_r_sunwall_dif(fl)/canyon_hwr(fl) + shadewall_r_sunwall_dif(fl) + sunwall_a_dif(fl) = (1._r8-alb_wall_dif(fl,ib)) * stot(fl) + sunwall_r_dif(fl) = alb_wall_dif(fl,ib) * stot(fl) + + stot(fl) = road_r_shadewall_dif(fl)/canyon_hwr(fl) + sunwall_r_shadewall_dif(fl) + shadewall_a_dif(fl) = (1._r8-alb_wall_dif(fl,ib)) * stot(fl) + shadewall_r_dif(fl) = alb_wall_dif(fl,ib) * stot(fl) + + ! step (2) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sabs_improad_dif(l,ib) = sabs_improad_dif(l,ib) + improad_a_dif(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sabs_perroad_dif(l,ib) = sabs_perroad_dif(l,ib) + perroad_a_dif(fl) + sabs_sunwall_dif(l,ib) = sabs_sunwall_dif(l,ib) + sunwall_a_dif(fl) + sabs_shadewall_dif(l,ib) = sabs_shadewall_dif(l,ib) + shadewall_a_dif(fl) + + ! step (3) + + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_r_sky_dif(fl) = improad_r_dif(fl) * vf_sr(l) + improad_r_sunwall_dif(fl) = improad_r_dif(fl) * vf_wr(l) + improad_r_shadewall_dif(fl) = improad_r_dif(fl) * vf_wr(l) + end if + + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_r_sky_dif(fl) = perroad_r_dif(fl) * vf_sr(l) + perroad_r_sunwall_dif(fl) = perroad_r_dif(fl) * vf_wr(l) + perroad_r_shadewall_dif(fl) = perroad_r_dif(fl) * vf_wr(l) + end if + + road_r_sky_dif(fl) = road_r_dif(fl) * vf_sr(l) + road_r_sunwall_dif(fl) = road_r_dif(fl) * vf_wr(l) + road_r_shadewall_dif(fl) = road_r_dif(fl) * vf_wr(l) + + sunwall_r_sky_dif(fl) = sunwall_r_dif(fl) * vf_sw(l) + sunwall_r_road_dif(fl) = sunwall_r_dif(fl) * vf_rw(l) + sunwall_r_shadewall_dif(fl) = sunwall_r_dif(fl) * vf_ww(l) + + shadewall_r_sky_dif(fl) = shadewall_r_dif(fl) * vf_sw(l) + shadewall_r_road_dif(fl) = shadewall_r_dif(fl) * vf_rw(l) + shadewall_r_sunwall_dif(fl) = shadewall_r_dif(fl) * vf_ww(l) + + ! step (4) + + if ( wtroad_imperv(fl) > 0.0_r8 ) sref_improad_dif(fl,ib) = sref_improad_dif(fl,ib) + improad_r_sky_dif(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) sref_perroad_dif(fl,ib) = sref_perroad_dif(fl,ib) + perroad_r_sky_dif(fl) + sref_sunwall_dif(fl,ib) = sref_sunwall_dif(fl,ib) + sunwall_r_sky_dif(fl) + sref_shadewall_dif(fl,ib) = sref_shadewall_dif(fl,ib) + shadewall_r_sky_dif(fl) + + ! step (5) + + crit = max(road_a_dif(fl), sunwall_a_dif(fl), shadewall_a_dif(fl)) + if (crit < errcrit) exit + end do + if (iter_dif >= n) then + write (iulog,*) 'urban net solar radiation error: no convergence, diffuse' + write (iulog,*) 'clm model is stopping' + call endrun() + endif + + ! total reflected by canyon - sum of solar reflection to sky from canyon. + ! project wall fluxes to horizontal surface + + sref_canyon_dir(fl) = 0.0_r8 + sref_canyon_dif(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + sref_canyon_dir(fl) = sref_canyon_dir(fl) + sref_improad_dir(fl,ib)*wtroad_imperv(fl) + sref_canyon_dif(fl) = sref_canyon_dif(fl) + sref_improad_dif(fl,ib)*wtroad_imperv(fl) + end if + if ( wtroad_perv(fl) > 0.0_r8 ) then + sref_canyon_dir(fl) = sref_canyon_dir(fl) + sref_perroad_dir(fl,ib)*wtroad_perv(fl) + sref_canyon_dif(fl) = sref_canyon_dif(fl) + sref_perroad_dif(fl,ib)*wtroad_perv(fl) + end if + sref_canyon_dir(fl) = sref_canyon_dir(fl) + (sref_sunwall_dir(fl,ib) + sref_shadewall_dir(fl,ib))*canyon_hwr(fl) + sref_canyon_dif(fl) = sref_canyon_dif(fl) + (sref_sunwall_dif(fl,ib) + sref_shadewall_dif(fl,ib))*canyon_hwr(fl) + + ! total absorbed by canyon. project wall fluxes to horizontal surface + + sabs_canyon_dir(fl) = 0.0_r8 + sabs_canyon_dif(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + sabs_canyon_dir(fl) = sabs_canyon_dir(fl) + sabs_improad_dir(l,ib)*wtroad_imperv(fl) + sabs_canyon_dif(fl) = sabs_canyon_dif(fl) + sabs_improad_dif(l,ib)*wtroad_imperv(fl) + end if + if ( wtroad_perv(fl) > 0.0_r8 ) then + sabs_canyon_dir(fl) = sabs_canyon_dir(fl) + sabs_perroad_dir(l,ib)*wtroad_perv(fl) + sabs_canyon_dif(fl) = sabs_canyon_dif(fl) + sabs_perroad_dif(l,ib)*wtroad_perv(fl) + end if + sabs_canyon_dir(fl) = sabs_canyon_dir(fl) + (sabs_sunwall_dir(l,ib) + sabs_shadewall_dir(l,ib))*canyon_hwr(fl) + sabs_canyon_dif(fl) = sabs_canyon_dif(fl) + (sabs_sunwall_dif(l,ib) + sabs_shadewall_dif(l,ib))*canyon_hwr(fl) + + ! conservation check. note: previous conservation checks confirm partioning of total direct + ! beam and diffuse radiation from atmosphere to road and walls is conserved as + ! sdir (from atmosphere) = sdir_road + (sdir_sunwall + sdir_shadewall)*canyon_hwr + ! sdif (from atmosphere) = sdif_road + (sdif_sunwall + sdif_shadewall)*canyon_hwr + + stot_dir(fl) = sdir_road(fl,ib) + (sdir_sunwall(fl,ib) + sdir_shadewall(fl,ib))*canyon_hwr(fl) + stot_dif(fl) = sdif_road(fl,ib) + (sdif_sunwall(fl,ib) + sdif_shadewall(fl,ib))*canyon_hwr(fl) + + err = stot_dir(fl) + stot_dif(fl) & + - (sabs_canyon_dir(fl) + sabs_canyon_dif(fl) + sref_canyon_dir(fl) + sref_canyon_dif(fl)) + if (abs(err) > 0.001_r8 ) then + write(iulog,*)'urban net solar radiation balance error for ib=',ib,' err= ',err + write(iulog,*)' l= ',l,' ib= ',ib + write(iulog,*)' stot_dir = ',stot_dir(fl) + write(iulog,*)' stot_dif = ',stot_dif(fl) + write(iulog,*)' sabs_canyon_dir = ',sabs_canyon_dir(fl) + write(iulog,*)' sabs_canyon_dif = ',sabs_canyon_dif(fl) + write(iulog,*)' sref_canyon_dir = ',sref_canyon_dir(fl) + write(iulog,*)' sref_canyon_dif = ',sref_canyon_dir(fl) + write(iulog,*) 'clm model is stopping' + call endrun() + endif + + ! canyon albedo + + canyon_alb_dif(fl) = sref_canyon_dif(fl) / max(stot_dif(fl), 1.e-06_r8) + canyon_alb_dir(fl) = sref_canyon_dir(fl) / max(stot_dir(fl), 1.e-06_r8) + end if + + end do ! end of landunit loop + + ! Refected and absorbed solar radiation per unit incident radiation for roof + + do fl = 1,num_urbanl + if (coszen(fl) .gt. 0._r8) then + l = filter_urbanl(fl) + sref_roof_dir(fl,ib) = alb_roof_dir(fl,ib) * sdir(fl,ib) + sref_roof_dif(fl,ib) = alb_roof_dif(fl,ib) * sdif(fl,ib) + sabs_roof_dir(l,ib) = sdir(fl,ib) - sref_roof_dir(fl,ib) + sabs_roof_dif(l,ib) = sdif(fl,ib) - sref_roof_dif(fl,ib) + end if + end do + + end do ! end of radiation band loop + + end subroutine net_solar + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: net_longwave +! +! !INTERFACE: + subroutine net_longwave (lbl, ubl, num_urbanl, filter_urbanl, canyon_hwr, wtroad_perv, & + lwdown, em_roof, em_improad, em_perroad, em_wall, & + t_roof, t_improad, t_perroad, t_sunwall, t_shadewall, & + lwnet_roof, lwnet_improad, lwnet_perroad, lwnet_sunwall, lwnet_shadewall, lwnet_canyon, & + lwup_roof, lwup_improad, lwup_perroad, lwup_sunwall, lwup_shadewall, lwup_canyon) +! +! !DESCRIPTION: +! Net longwave radiation for road and both walls in urban canyon allowing for +! multiple reflection. Also net longwave radiation for urban roof. +! +! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use clm_varcon , only : sb + use clmtype +! +! !ARGUMENTS: + implicit none + integer , intent(in) :: num_urbanl ! number of urban landunits + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + real(r8), intent(in) :: canyon_hwr(num_urbanl) ! ratio of building height to street width + real(r8), intent(in) :: wtroad_perv(num_urbanl) ! weight of pervious road wrt total road + + real(r8), intent(in) :: lwdown(num_urbanl) ! atmospheric longwave radiation (W/m**2) + real(r8), intent(in) :: em_roof(num_urbanl) ! roof emissivity + real(r8), intent(in) :: em_improad(num_urbanl) ! impervious road emissivity + real(r8), intent(in) :: em_perroad(num_urbanl) ! pervious road emissivity + real(r8), intent(in) :: em_wall(num_urbanl) ! wall emissivity + + real(r8), intent(in) :: t_roof(num_urbanl) ! roof temperature (K) + real(r8), intent(in) :: t_improad(num_urbanl) ! impervious road temperature (K) + real(r8), intent(in) :: t_perroad(num_urbanl) ! ervious road temperature (K) + real(r8), intent(in) :: t_sunwall(num_urbanl) ! sunlit wall temperature (K) + real(r8), intent(in) :: t_shadewall(num_urbanl) ! shaded wall temperature (K) + + real(r8), intent(out) :: lwnet_roof(num_urbanl) ! net (outgoing-incoming) longwave radiation, roof (W/m**2) + real(r8), intent(out) :: lwnet_improad(num_urbanl) ! net (outgoing-incoming) longwave radiation, impervious road (W/m**2) + real(r8), intent(out) :: lwnet_perroad(num_urbanl) ! net (outgoing-incoming) longwave radiation, pervious road (W/m**2) + real(r8), intent(out) :: lwnet_sunwall(num_urbanl) ! net (outgoing-incoming) longwave radiation (per unit wall area), sunlit wall (W/m**2) + real(r8), intent(out) :: lwnet_shadewall(num_urbanl) ! net (outgoing-incoming) longwave radiation (per unit wall area), shaded wall (W/m**2) + real(r8), intent(out) :: lwnet_canyon(num_urbanl) ! net (outgoing-incoming) longwave radiation for canyon, per unit ground area (W/m**2) + + real(r8), intent(out) :: lwup_roof(num_urbanl) ! upward longwave radiation, roof (W/m**2) + real(r8), intent(out) :: lwup_improad(num_urbanl) ! upward longwave radiation, impervious road (W/m**2) + real(r8), intent(out) :: lwup_perroad(num_urbanl) ! upward longwave radiation, pervious road (W/m**2) + real(r8), intent(out) :: lwup_sunwall(num_urbanl) ! upward longwave radiation (per unit wall area), sunlit wall (W/m**2) + real(r8), intent(out) :: lwup_shadewall(num_urbanl) ! upward longwave radiation (per unit wall area), shaded wall (W/m**2) + real(r8), intent(out) :: lwup_canyon(num_urbanl) ! upward longwave radiation for canyon, per unit ground area (W/m**2) +! +! local pointers to original implicit in arguments (clmtype) +! + real(r8), pointer :: vf_sr(:) ! view factor of sky for road + real(r8), pointer :: vf_wr(:) ! view factor of one wall for road + real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall + real(r8), pointer :: vf_rw(:) ! view factor of road for one wall + real(r8), pointer :: vf_ww(:) ! view factor of opposing wall for one wall +! +! !CALLED FROM: +! subroutine UrbanRadiation in this module +! +! !REVISION HISTORY: +! Author: Gordon Bonan +! +! +! !LOCAL VARIABLES: +!EOP + real(r8) :: lwdown_road(num_urbanl) ! atmospheric longwave radiation for total road (W/m**2) + real(r8) :: lwdown_sunwall(num_urbanl) ! atmospheric longwave radiation (per unit wall area) for sunlit wall (W/m**2) + real(r8) :: lwdown_shadewall(num_urbanl) ! atmospheric longwave radiation (per unit wall area) for shaded wall (W/m**2) + real(r8) :: lwtot(num_urbanl) ! incoming longwave radiation (W/m**2) + + real(r8) :: improad_a(num_urbanl) ! absorbed longwave for improad (W/m**2) + real(r8) :: improad_r(num_urbanl) ! reflected longwave for improad (W/m**2) + real(r8) :: improad_r_sky(num_urbanl) ! improad_r to sky (W/m**2) + real(r8) :: improad_r_sunwall(num_urbanl) ! improad_r to sunlit wall (W/m**2) + real(r8) :: improad_r_shadewall(num_urbanl) ! improad_r to shaded wall (W/m**2) + real(r8) :: improad_e(num_urbanl) ! emitted longwave for improad (W/m**2) + real(r8) :: improad_e_sky(num_urbanl) ! improad_e to sky (W/m**2) + real(r8) :: improad_e_sunwall(num_urbanl) ! improad_e to sunlit wall (W/m**2) + real(r8) :: improad_e_shadewall(num_urbanl) ! improad_e to shaded wall (W/m**2) + + real(r8) :: perroad_a(num_urbanl) ! absorbed longwave for perroad (W/m**2) + real(r8) :: perroad_r(num_urbanl) ! reflected longwave for perroad (W/m**2) + real(r8) :: perroad_r_sky(num_urbanl) ! perroad_r to sky (W/m**2) + real(r8) :: perroad_r_sunwall(num_urbanl) ! perroad_r to sunlit wall (W/m**2) + real(r8) :: perroad_r_shadewall(num_urbanl) ! perroad_r to shaded wall (W/m**2) + real(r8) :: perroad_e(num_urbanl) ! emitted longwave for perroad (W/m**2) + real(r8) :: perroad_e_sky(num_urbanl) ! perroad_e to sky (W/m**2) + real(r8) :: perroad_e_sunwall(num_urbanl) ! perroad_e to sunlit wall (W/m**2) + real(r8) :: perroad_e_shadewall(num_urbanl) ! perroad_e to shaded wall (W/m**2) + + real(r8) :: road_a(num_urbanl) ! absorbed longwave for total road (W/m**2) + real(r8) :: road_r(num_urbanl) ! reflected longwave for total road (W/m**2) + real(r8) :: road_r_sky(num_urbanl) ! total road_r to sky (W/m**2) + real(r8) :: road_r_sunwall(num_urbanl) ! total road_r to sunlit wall (W/m**2) + real(r8) :: road_r_shadewall(num_urbanl) ! total road_r to shaded wall (W/m**2) + real(r8) :: road_e(num_urbanl) ! emitted longwave for total road (W/m**2) + real(r8) :: road_e_sky(num_urbanl) ! total road_e to sky (W/m**2) + real(r8) :: road_e_sunwall(num_urbanl) ! total road_e to sunlit wall (W/m**2) + real(r8) :: road_e_shadewall(num_urbanl) ! total road_e to shaded wall (W/m**2) + + real(r8) :: sunwall_a(num_urbanl) ! absorbed longwave (per unit wall area) for sunlit wall (W/m**2) + real(r8) :: sunwall_r(num_urbanl) ! reflected longwave (per unit wall area) for sunlit wall (W/m**2) + real(r8) :: sunwall_r_sky(num_urbanl) ! sunwall_r to sky (W/m**2) + real(r8) :: sunwall_r_road(num_urbanl) ! sunwall_r to road (W/m**2) + real(r8) :: sunwall_r_shadewall(num_urbanl) ! sunwall_r to opposing (shaded) wall (W/m**2) + real(r8) :: sunwall_e(num_urbanl) ! emitted longwave (per unit wall area) for sunlit wall (W/m**2) + real(r8) :: sunwall_e_sky(num_urbanl) ! sunwall_e to sky (W/m**2) + real(r8) :: sunwall_e_road(num_urbanl) ! sunwall_e to road (W/m**2) + real(r8) :: sunwall_e_shadewall(num_urbanl) ! sunwall_e to opposing (shaded) wall (W/m**2) + + real(r8) :: shadewall_a(num_urbanl) ! absorbed longwave (per unit wall area) for shaded wall (W/m**2) + real(r8) :: shadewall_r(num_urbanl) ! reflected longwave (per unit wall area) for shaded wall (W/m**2) + real(r8) :: shadewall_r_sky(num_urbanl) ! shadewall_r to sky (W/m**2) + real(r8) :: shadewall_r_road(num_urbanl) ! shadewall_r to road (W/m**2) + real(r8) :: shadewall_r_sunwall(num_urbanl) ! shadewall_r to opposing (sunlit) wall (W/m**2) + real(r8) :: shadewall_e(num_urbanl) ! emitted longwave (per unit wall area) for shaded wall (W/m**2) + real(r8) :: shadewall_e_sky(num_urbanl) ! shadewall_e to sky (W/m**2) + real(r8) :: shadewall_e_road(num_urbanl) ! shadewall_e to road (W/m**2) + real(r8) :: shadewall_e_sunwall(num_urbanl) ! shadewall_e to opposing (sunlit) wall (W/m**2) + integer :: l,fl,iter ! indices + integer, parameter :: n = 50 ! number of interations + real(r8) :: crit ! convergence criterion (W/m**2) + real(r8) :: err ! energy conservation error (W/m**2) + real(r8) :: wtroad_imperv(num_urbanl) ! weight of impervious road wrt total road +!----------------------------------------------------------------------- + + ! Assign landunit level pointer + + vf_sr => lps%vf_sr + vf_wr => lps%vf_wr + vf_sw => lps%vf_sw + vf_rw => lps%vf_rw + vf_ww => lps%vf_ww + + ! Calculate impervious road + + do l = 1,num_urbanl + wtroad_imperv(l) = 1._r8 - wtroad_perv(l) + end do + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + ! atmospheric longwave radiation incident on walls and road in urban canyon. + ! check for conservation (need to convert wall fluxes to ground area). + ! lwdown (from atmosphere) = lwdown_road + (lwdown_sunwall + lwdown_shadewall)*canyon_hwr + + lwdown_road(fl) = lwdown(fl) * vf_sr(l) + lwdown_sunwall(fl) = lwdown(fl) * vf_sw(l) + lwdown_shadewall(fl) = lwdown(fl) * vf_sw(l) + + err = lwdown(fl) - (lwdown_road(fl) + (lwdown_shadewall(fl) + lwdown_sunwall(fl))*canyon_hwr(fl)) + if (abs(err) > 0.10_r8 ) then + write (iulog,*) 'urban incident atmospheric longwave radiation balance error',err + write (iulog,*) 'clm model is stopping' + call endrun + endif + end do + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + + ! initial absorption, reflection, and emission for road and both walls. + ! distribute reflected and emitted radiation to sky, road, and walls according + ! to appropriate view factor. radiation reflected to road and walls will + ! undergo multiple reflections within the canyon. + + road_a(fl) = 0.0_r8 + road_r(fl) = 0.0_r8 + road_e(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_a(fl) = em_improad(fl) * lwdown_road(fl) + improad_r(fl) = (1._r8-em_improad(fl)) * lwdown_road(fl) + improad_r_sky(fl) = improad_r(fl) * vf_sr(l) + improad_r_sunwall(fl) = improad_r(fl) * vf_wr(l) + improad_r_shadewall(fl) = improad_r(fl) * vf_wr(l) + improad_e(fl) = em_improad(fl) * sb * (t_improad(fl)**4) + improad_e_sky(fl) = improad_e(fl) * vf_sr(l) + improad_e_sunwall(fl) = improad_e(fl) * vf_wr(l) + improad_e_shadewall(fl) = improad_e(fl) * vf_wr(l) + road_a(fl) = road_a(fl) + improad_a(fl)*wtroad_imperv(fl) + road_r(fl) = road_r(fl) + improad_r(fl)*wtroad_imperv(fl) + road_e(fl) = road_e(fl) + improad_e(fl)*wtroad_imperv(fl) + end if + + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_a(fl) = em_perroad(fl) * lwdown_road(fl) + perroad_r(fl) = (1._r8-em_perroad(fl)) * lwdown_road(fl) + perroad_r_sky(fl) = perroad_r(fl) * vf_sr(l) + perroad_r_sunwall(fl) = perroad_r(fl) * vf_wr(l) + perroad_r_shadewall(fl) = perroad_r(fl) * vf_wr(l) + perroad_e(fl) = em_perroad(fl) * sb * (t_perroad(fl)**4) + perroad_e_sky(fl) = perroad_e(fl) * vf_sr(l) + perroad_e_sunwall(fl) = perroad_e(fl) * vf_wr(l) + perroad_e_shadewall(fl) = perroad_e(fl) * vf_wr(l) + road_a(fl) = road_a(fl) + perroad_a(fl)*wtroad_perv(fl) + road_r(fl) = road_r(fl) + perroad_r(fl)*wtroad_perv(fl) + road_e(fl) = road_e(fl) + perroad_e(fl)*wtroad_perv(fl) + end if + + road_r_sky(fl) = road_r(fl) * vf_sr(l) + road_r_sunwall(fl) = road_r(fl) * vf_wr(l) + road_r_shadewall(fl) = road_r(fl) * vf_wr(l) + road_e_sky(fl) = road_e(fl) * vf_sr(l) + road_e_sunwall(fl) = road_e(fl) * vf_wr(l) + road_e_shadewall(fl) = road_e(fl) * vf_wr(l) + + sunwall_a(fl) = em_wall(fl) * lwdown_sunwall(fl) + sunwall_r(fl) = (1._r8-em_wall(fl)) * lwdown_sunwall(fl) + sunwall_r_sky(fl) = sunwall_r(fl) * vf_sw(l) + sunwall_r_road(fl) = sunwall_r(fl) * vf_rw(l) + sunwall_r_shadewall(fl) = sunwall_r(fl) * vf_ww(l) + sunwall_e(fl) = em_wall(fl) * sb * (t_sunwall(fl)**4) + sunwall_e_sky(fl) = sunwall_e(fl) * vf_sw(l) + sunwall_e_road(fl) = sunwall_e(fl) * vf_rw(l) + sunwall_e_shadewall(fl) = sunwall_e(fl) * vf_ww(l) + + shadewall_a(fl) = em_wall(fl) * lwdown_shadewall(fl) + shadewall_r(fl) = (1._r8-em_wall(fl)) * lwdown_shadewall(fl) + shadewall_r_sky(fl) = shadewall_r(fl) * vf_sw(l) + shadewall_r_road(fl) = shadewall_r(fl) * vf_rw(l) + shadewall_r_sunwall(fl) = shadewall_r(fl) * vf_ww(l) + shadewall_e(fl) = em_wall(fl) * sb * (t_shadewall(fl)**4) + shadewall_e_sky(fl) = shadewall_e(fl) * vf_sw(l) + shadewall_e_road(fl) = shadewall_e(fl) * vf_rw(l) + shadewall_e_sunwall(fl) = shadewall_e(fl) * vf_ww(l) + + ! initialize sum of net and upward longwave radiation for road and both walls + + if ( wtroad_imperv(fl) > 0.0_r8 ) lwnet_improad(fl) = improad_e(fl) - improad_a(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) lwnet_perroad(fl) = perroad_e(fl) - perroad_a(fl) + lwnet_sunwall(fl) = sunwall_e(fl) - sunwall_a(fl) + lwnet_shadewall(fl) = shadewall_e(fl) - shadewall_a(fl) + + if ( wtroad_imperv(fl) > 0.0_r8 ) lwup_improad(fl) = improad_r_sky(fl) + improad_e_sky(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) lwup_perroad(fl) = perroad_r_sky(fl) + perroad_e_sky(fl) + lwup_sunwall(fl) = sunwall_r_sky(fl) + sunwall_e_sky(fl) + lwup_shadewall(fl) = shadewall_r_sky(fl) + shadewall_e_sky(fl) + + end do + + ! now account for absorption and reflection within canyon of fluxes from road and walls + ! allowing for multiple reflections + ! + ! (1) absorption and reflection. note: emission from road and walls absorbed by walls and roads + ! only occurs in first iteration. zero out for later iterations. + ! + ! road: fluxes from walls need to be projected to ground area + ! wall: fluxes from road need to be projected to wall area + ! + ! (2) add net longwave for ith reflection to total net longwave + ! + ! (3) distribute reflected radiation to sky, road, and walls according to view factors + ! + ! (4) add upward longwave radiation to sky from road and walls for ith reflection to total + ! + ! (5) stop iteration when absorption for ith reflection is less than some nominal amount. + ! small convergence criteria is required to ensure radiation is conserved + + do fl = 1,num_urbanl + l = filter_urbanl(fl) + + do iter = 1, n + ! step (1) + + lwtot(fl) = (sunwall_r_road(fl) + sunwall_e_road(fl) & + + shadewall_r_road(fl) + shadewall_e_road(fl))*canyon_hwr(fl) + road_a(fl) = 0.0_r8 + road_r(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_r(fl) = (1._r8-em_improad(fl)) * lwtot(fl) + improad_a(fl) = em_improad(fl) * lwtot(fl) + road_a(fl) = road_a(fl) + improad_a(fl)*wtroad_imperv(fl) + road_r(fl) = road_r(fl) + improad_r(fl)*wtroad_imperv(fl) + end if + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_r(fl) = (1._r8-em_perroad(fl)) * lwtot(fl) + perroad_a(fl) = em_perroad(fl) * lwtot(fl) + road_a(fl) = road_a(fl) + perroad_a(fl)*wtroad_perv(fl) + road_r(fl) = road_r(fl) + perroad_r(fl)*wtroad_perv(fl) + end if + + lwtot(fl) = (road_r_sunwall(fl) + road_e_sunwall(fl))/canyon_hwr(fl) & + + (shadewall_r_sunwall(fl) + shadewall_e_sunwall(fl)) + sunwall_a(fl) = em_wall(fl) * lwtot(fl) + sunwall_r(fl) = (1._r8-em_wall(fl)) * lwtot(fl) + + lwtot(fl) = (road_r_shadewall(fl) + road_e_shadewall(fl))/canyon_hwr(fl) & + + (sunwall_r_shadewall(fl) + sunwall_e_shadewall(fl)) + shadewall_a(fl) = em_wall(fl) * lwtot(fl) + shadewall_r(fl) = (1._r8-em_wall(fl)) * lwtot(fl) + + sunwall_e_road(fl) = 0._r8 + shadewall_e_road(fl) = 0._r8 + road_e_sunwall(fl) = 0._r8 + shadewall_e_sunwall(fl) = 0._r8 + road_e_shadewall(fl) = 0._r8 + sunwall_e_shadewall(fl) = 0._r8 + + ! step (2) + + if ( wtroad_imperv(fl) > 0.0_r8 ) lwnet_improad(fl) = lwnet_improad(fl) - improad_a(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) lwnet_perroad(fl) = lwnet_perroad(fl) - perroad_a(fl) + lwnet_sunwall(fl) = lwnet_sunwall(fl) - sunwall_a(fl) + lwnet_shadewall(fl) = lwnet_shadewall(fl) - shadewall_a(fl) + + ! step (3) + + if ( wtroad_imperv(fl) > 0.0_r8 ) then + improad_r_sky(fl) = improad_r(fl) * vf_sr(l) + improad_r_sunwall(fl) = improad_r(fl) * vf_wr(l) + improad_r_shadewall(fl) = improad_r(fl) * vf_wr(l) + end if + + if ( wtroad_perv(fl) > 0.0_r8 ) then + perroad_r_sky(fl) = perroad_r(fl) * vf_sr(l) + perroad_r_sunwall(fl) = perroad_r(fl) * vf_wr(l) + perroad_r_shadewall(fl) = perroad_r(fl) * vf_wr(l) + end if + + road_r_sky(fl) = road_r(fl) * vf_sr(l) + road_r_sunwall(fl) = road_r(fl) * vf_wr(l) + road_r_shadewall(fl) = road_r(fl) * vf_wr(l) + + sunwall_r_sky(fl) = sunwall_r(fl) * vf_sw(l) + sunwall_r_road(fl) = sunwall_r(fl) * vf_rw(l) + sunwall_r_shadewall(fl) = sunwall_r(fl) * vf_ww(l) + + shadewall_r_sky(fl) = shadewall_r(fl) * vf_sw(l) + shadewall_r_road(fl) = shadewall_r(fl) * vf_rw(l) + shadewall_r_sunwall(fl) = shadewall_r(fl) * vf_ww(l) + + ! step (4) + + if ( wtroad_imperv(fl) > 0.0_r8 ) lwup_improad(fl) = lwup_improad(fl) + improad_r_sky(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) lwup_perroad(fl) = lwup_perroad(fl) + perroad_r_sky(fl) + lwup_sunwall(fl) = lwup_sunwall(fl) + sunwall_r_sky(fl) + lwup_shadewall(fl) = lwup_shadewall(fl) + shadewall_r_sky(fl) + + ! step (5) + + crit = max(road_a(fl), sunwall_a(fl), shadewall_a(fl)) + if (crit < .001_r8) exit + end do + if (iter >= n) then + write (iulog,*) 'urban net longwave radiation error: no convergence' + write (iulog,*) 'crit is ',crit,' should be < 0.001' + write (iulog,*) 'road_a(fl) is ',road_a(fl) + write (iulog,*) 'sunwall_a(fl) is ',sunwall_a(fl) + write (iulog,*) 'shadewall_a(fl) is ',shadewall_a(fl) + write (iulog,*) 'lwtot(fl) is ',lwtot(fl) + write (iulog,*) 'clm model is stopping' + call endrun + endif + + ! total net longwave radiation for canyon. project wall fluxes to horizontal surface + + lwnet_canyon(fl) = 0.0_r8 + if ( wtroad_imperv(fl) > 0.0_r8 ) lwnet_canyon(fl) = lwnet_canyon(fl) + lwnet_improad(fl)*wtroad_imperv(fl) + if ( wtroad_perv(fl) > 0.0_r8 ) lwnet_canyon(fl) = lwnet_canyon(fl) + lwnet_perroad(fl)*wtroad_perv(fl) + lwnet_canyon(fl) = lwnet_canyon(fl) + (lwnet_sunwall(fl) + lwnet_shadewall(fl))*canyon_hwr(fl) + + ! total emitted longwave for canyon. project wall fluxes to horizontal + + lwup_canyon(fl) = 0.0_r8 + if( wtroad_imperv(fl) > 0.0_r8 ) lwup_canyon(fl) = lwup_canyon(fl) + lwup_improad(fl)*wtroad_imperv(fl) + if( wtroad_perv(fl) > 0.0_r8 ) lwup_canyon(fl) = lwup_canyon(fl) + lwup_perroad(fl)*wtroad_perv(fl) + lwup_canyon(fl) = lwup_canyon(fl) + (lwup_sunwall(fl) + lwup_shadewall(fl))*canyon_hwr(fl) + + ! conservation check. note: previous conservation check confirms partioning of incident + ! atmospheric longwave radiation to road and walls is conserved as + ! lwdown (from atmosphere) = lwdown_improad + lwdown_perroad + (lwdown_sunwall + lwdown_shadewall)*canyon_hwr + + err = lwnet_canyon(fl) - (lwup_canyon(fl) - lwdown(fl)) + if (abs(err) > .10_r8 ) then + write (iulog,*) 'urban net longwave radiation balance error',err + write (iulog,*) 'clm model is stopping' + call endrun() + end if + + end do + + ! Net longwave radiation for roof + + do l = 1,num_urbanl + lwup_roof(l) = em_roof(l)*sb*(t_roof(l)**4) + (1._r8-em_roof(l))*lwdown(l) + lwnet_roof(l) = lwup_roof(l) - lwdown(l) + end do + + end subroutine net_longwave + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: UrbanClumpInit +! +! !INTERFACE: + subroutine UrbanClumpInit() +! +! !DESCRIPTION: +! Initialize urban surface dataset variables +! +! !USES: + use clmtype + use clm_varcon , only : spval, icol_roof, icol_sunwall, icol_shadewall, & + icol_road_perv, icol_road_imperv, udens_base + use decompMod , only : get_proc_clumps, ldecomp + use filterMod , only : filter + use UrbanInputMod, only : urbinp +! +! !ARGUMENTS: + implicit none +! +! !CALLED FROM: +! subroutine initialize +! +! !REVISION HISTORY: +! Author: Mariana Vertenstein 04/2003 +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in arguments +! + integer , pointer :: coli(:) ! beginning column index for landunit + integer , pointer :: colf(:) ! ending column index for landunit + integer , pointer :: lgridcell(:) ! gridcell of corresponding landunit + integer , pointer :: ctype(:) ! column type + integer , pointer :: udenstype(:) ! urban density type +! +! +! !OTHER LOCAL VARIABLES +!EOP +! + integer :: nc,fl,ib,l,c,p,g ! indices + integer :: nclumps ! number of clumps on processor + integer :: num_urbanl ! number of per-clump urban landunits + integer :: ier ! error status + integer :: dindx ! urban density type index +!----------------------------------------------------------------------- + + ! Assign local pointers to derived type members (landunit-level) + + coli =>lun%coli + colf =>lun%colf + lgridcell =>lun%gridcell + udenstype =>lun%udenstype + + ! Assign local pointers to derived type members (column-level) + + ctype => col%itype + + ! Allocate memory + + nclumps = get_proc_clumps() + allocate(urban_clump(nclumps), stat=ier) + if (ier /= 0) then + write (iulog,*) 'UrbanInit: allocation error for urban clumps'; call endrun() + end if + + ! Loop over all clumps on this processor + + do nc = 1, nclumps + + ! Determine number of urban landunits in clump + + num_urbanl = filter(nc)%num_urbanl + + ! Consistency check for urban columns + + do fl = 1,num_urbanl + l = filter(nc)%urbanl(fl) + do c = coli(l),colf(l) + if ( ctype(c) /= icol_roof .and. & + ctype(c) /= icol_sunwall .and. ctype(c) /= icol_shadewall .and. & + ctype(c) /= icol_road_perv .and. ctype(c) /= icol_road_imperv) then + write(iulog,*)'error in urban column types for landunit = ',l + write(iulog,*)'ctype= ',ctype(c) + call endrun() + endif + end do + end do + + ! Allocate memory for urban clump clumponents + + if (num_urbanl > 0) then + allocate( urban_clump(nc)%canyon_hwr (num_urbanl), & + urban_clump(nc)%wtroad_perv (num_urbanl), & + urban_clump(nc)%ht_roof (num_urbanl), & + urban_clump(nc)%wtlunit_roof (num_urbanl), & + urban_clump(nc)%wind_hgt_canyon (num_urbanl), & + urban_clump(nc)%em_roof (num_urbanl), & + urban_clump(nc)%em_improad (num_urbanl), & + urban_clump(nc)%em_perroad (num_urbanl), & + urban_clump(nc)%em_wall (num_urbanl), & + urban_clump(nc)%alb_roof_dir (num_urbanl,numrad), & + urban_clump(nc)%alb_roof_dif (num_urbanl,numrad), & + urban_clump(nc)%alb_improad_dir (num_urbanl,numrad), & + urban_clump(nc)%alb_perroad_dir (num_urbanl,numrad), & + urban_clump(nc)%alb_improad_dif (num_urbanl,numrad), & + urban_clump(nc)%alb_perroad_dif (num_urbanl,numrad), & + urban_clump(nc)%alb_wall_dir (num_urbanl,numrad), & + urban_clump(nc)%alb_wall_dif (num_urbanl,numrad), stat=ier ) + if (ier /= 0) then + write(iulog,*)'UrbanClumpInit: allocation error for urban derived type'; call endrun() + endif + end if + + ! Set constants in derived type values for urban clump + + do fl = 1,num_urbanl + l = filter(nc)%urbanl(fl) + g =lun%gridcell(l) + dindx = udenstype(l) - udens_base + urban_clump(nc)%canyon_hwr (fl) = urbinp%canyon_hwr (g,dindx) + urban_clump(nc)%wtroad_perv (fl) = urbinp%wtroad_perv (g,dindx) + urban_clump(nc)%ht_roof (fl) = urbinp%ht_roof (g,dindx) + urban_clump(nc)%wtlunit_roof (fl) = urbinp%wtlunit_roof (g,dindx) + urban_clump(nc)%wind_hgt_canyon(fl) = urbinp%wind_hgt_canyon(g,dindx) + do ib = 1,numrad + urban_clump(nc)%alb_roof_dir (fl,ib) = urbinp%alb_roof_dir (g,dindx,ib) + urban_clump(nc)%alb_roof_dif (fl,ib) = urbinp%alb_roof_dif (g,dindx,ib) + urban_clump(nc)%alb_improad_dir(fl,ib) = urbinp%alb_improad_dir(g,dindx,ib) + urban_clump(nc)%alb_perroad_dir(fl,ib) = urbinp%alb_perroad_dir(g,dindx,ib) + urban_clump(nc)%alb_improad_dif(fl,ib) = urbinp%alb_improad_dif(g,dindx,ib) + urban_clump(nc)%alb_perroad_dif(fl,ib) = urbinp%alb_perroad_dif(g,dindx,ib) + urban_clump(nc)%alb_wall_dir (fl,ib) = urbinp%alb_wall_dir (g,dindx,ib) + urban_clump(nc)%alb_wall_dif (fl,ib) = urbinp%alb_wall_dif (g,dindx,ib) + end do + urban_clump(nc)%em_roof (fl) = urbinp%em_roof (g,dindx) + urban_clump(nc)%em_improad(fl) = urbinp%em_improad(g,dindx) + urban_clump(nc)%em_perroad(fl) = urbinp%em_perroad(g,dindx) + urban_clump(nc)%em_wall (fl) = urbinp%em_wall (g,dindx) + end do + end do ! end of loop over clumps + + end subroutine UrbanClumpInit + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: UrbanFluxes +! +! !INTERFACE: + subroutine UrbanFluxes (nc, lbp, ubp, lbl, ubl, lbc, ubc, & + num_nourbanl, filter_nourbanl, & + num_urbanl, filter_urbanl, & + num_urbanc, filter_urbanc, & + num_urbanp, filter_urbanp) +! +! !DESCRIPTION: +! Turbulent and momentum fluxes from urban canyon (consisting of roof, sunwall, +! shadewall, pervious and impervious road). + +! !USES: + use clmtype + use clm_varcon , only : cpair, vkc, spval, icol_roof, icol_sunwall, & + icol_shadewall, icol_road_perv, icol_road_imperv, & + grav, pondmx_urban, rpi, rgas, & + ht_wasteheat_factor, ac_wasteheat_factor, & + wasteheat_limit + use filterMod , only : filter + use FrictionVelocityMod, only : FrictionVelocity, MoninObukIni + use QSatMod , only : QSat + use clm_varpar , only : maxpatch_urb, nlevurb, nlevgrnd + use clm_time_manager , only : get_curr_date, get_step_size, get_nstep + use clm_atmlnd , only : clm_a2l + +! +! !ARGUMENTS: + implicit none + integer , intent(in) :: nc ! clump index + integer, intent(in) :: lbp, ubp ! pft-index bounds + integer, intent(in) :: lbl, ubl ! landunit-index bounds + integer, intent(in) :: lbc, ubc ! column-index bounds + integer , intent(in) :: num_nourbanl ! number of non-urban landunits in clump + integer , intent(in) :: filter_nourbanl(ubl-lbl+1) ! non-urban landunit filter + integer , intent(in) :: num_urbanl ! number of urban landunits in clump + integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter + integer , intent(in) :: num_urbanc ! number of urban columns in clump + integer , intent(in) :: filter_urbanc(ubc-lbc+1) ! urban column filter + integer , intent(in) :: num_urbanp ! number of urban pfts in clump + integer , intent(in) :: filter_urbanp(ubp-lbp+1) ! urban pft filter +! +! !CALLED FROM: +! subroutine clm_driver1 +! +! !REVISION HISTORY: +! Author: Keith Oleson 10/2005 +! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in arguments (urban clump) +! + real(r8), pointer :: ht_roof(:) ! height of urban roof (m) + real(r8), pointer :: wtlunit_roof(:) ! weight of roof with respect to landunit + real(r8), pointer :: canyon_hwr(:) ! ratio of building height to street width + real(r8), pointer :: wtroad_perv(:) ! weight of pervious road wrt total road + real(r8), pointer :: wind_hgt_canyon(:) ! height above road at which wind in canyon is to be computed (m) +! +! local pointers to original implicit in arguments (clmtype) +! + real(r8), pointer :: forc_u(:) ! atmospheric wind speed in east direction (m/s) + real(r8), pointer :: forc_v(:) ! atmospheric wind speed in north direction (m/s) + real(r8), pointer :: forc_rho(:) ! density (kg/m**3) + real(r8), pointer :: forc_hgt_u_pft(:) ! observational height of wind at pft-level (m) + real(r8), pointer :: forc_hgt_t_pft(:) ! observational height of temperature at pft-level (m) + real(r8), pointer :: forc_q(:) ! atmospheric specific humidity (kg/kg) + real(r8), pointer :: forc_t(:) ! atmospheric temperature (K) + real(r8), pointer :: forc_th(:) ! atmospheric potential temperature (K) + real(r8), pointer :: forc_pbot(:) ! atmospheric pressure (Pa) + + real(r8), pointer :: z_0_town(:) ! momentum roughness length of urban landunit (m) + real(r8), pointer :: z_d_town(:) ! displacement height of urban landunit (m) + + integer , pointer :: pgridcell(:) ! gridcell of corresponding pft + integer , pointer :: pcolumn(:) ! column of corresponding pft + integer , pointer :: lgridcell(:) ! gridcell of corresponding landunit + integer , pointer :: plandunit(:) ! pft's landunit index + integer , pointer :: ctype(:) ! column type + integer , pointer :: coli(:) ! beginning column index for landunit + integer , pointer :: colf(:) ! ending column index for landunit + integer , pointer :: pfti(:) ! beginning pft index for landunit + integer , pointer :: pftf(:) ! ending pft index for landunit + + real(r8), pointer :: taf(:) ! urban canopy air temperature (K) + real(r8), pointer :: qaf(:) ! urban canopy air specific humidity (kg/kg) + integer , pointer :: npfts(:) ! landunit's number of pfts (columns) + real(r8), pointer :: t_grnd(:) ! ground surface temperature (K) + real(r8), pointer :: qg(:) ! specific humidity at ground surface (kg/kg) + real(r8), pointer :: htvp(:) ! latent heat of evaporation (/sublimation) (J/kg) + real(r8), pointer :: dqgdT(:) ! temperature derivative of "qg" + real(r8), pointer :: eflx_traffic(:) ! traffic sensible heat flux (W/m**2) + real(r8), pointer :: eflx_traffic_factor(:) ! multiplicative urban traffic factor for sensible heat flux + real(r8), pointer :: eflx_wasteheat(:) ! sensible heat flux from urban heating/cooling sources of waste heat (W/m**2) + real(r8), pointer :: eflx_heat_from_ac(:) ! sensible heat flux put back into canyon due to removal by AC (W/m**2) + real(r8), pointer :: t_soisno(:,:) ! soil temperature (K) + real(r8), pointer :: eflx_urban_ac(:) ! urban air conditioning flux (W/m**2) + real(r8), pointer :: eflx_urban_heat(:) ! urban heating flux (W/m**2) + real(r8), pointer :: londeg(:) ! longitude (degrees) + real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2) + real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) + real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1) + real(r8), pointer :: snow_depth(:) ! snow height (m) + real(r8), pointer :: h2osno(:) ! snow water (mm H2O) + integer , pointer :: snl(:) ! number of snow layers + real(r8), pointer :: rootr_road_perv(:,:) ! effective fraction of roots in each soil layer for urban pervious road + real(r8), pointer :: soilalpha_u(:) ! Urban factor that reduces ground saturated specific humidity (-) +! +! local pointers to original implicit out arguments +! + real(r8), pointer :: dlrad(:) ! downward longwave radiation below the canopy (W/m**2) + real(r8), pointer :: ulrad(:) ! upward longwave radiation above the canopy (W/m**2) + real(r8), pointer :: cgrnds(:) ! deriv, of soil sensible heat flux wrt soil temp (W/m**2/K) + real(r8), pointer :: cgrndl(:) ! deriv of soil latent heat flux wrt soil temp (W/m**2/K) + real(r8), pointer :: cgrnd(:) ! deriv. of soil energy flux wrt to soil temp (W/m**2/K) + real(r8), pointer :: taux(:) ! wind (shear) stress: e-w (kg/m/s**2) + real(r8), pointer :: tauy(:) ! wind (shear) stress: n-s (kg/m/s**2) + real(r8), pointer :: eflx_sh_grnd(:) ! sensible heat flux from ground (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_tot(:) ! total sensible heat flux (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_tot_u(:) ! urban total sensible heat flux (W/m**2) [+ to atm] + real(r8), pointer :: qflx_evap_soi(:) ! soil evaporation (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_tran_veg(:) ! vegetation transpiration (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_evap_veg(:) ! vegetation evaporation (mm H2O/s) (+ = to atm) + real(r8), pointer :: qflx_evap_tot(:) ! qflx_evap_soi + qflx_evap_can + qflx_tran_veg + real(r8), pointer :: t_ref2m(:) ! 2 m height surface air temperature (K) + real(r8), pointer :: q_ref2m(:) ! 2 m height surface specific humidity (kg/kg) + real(r8), pointer :: t_ref2m_u(:) ! Urban 2 m height surface air temperature (K) + real(r8), pointer :: t_veg(:) ! vegetation temperature (K) + real(r8), pointer :: ram1(:) ! aerodynamical resistance (s/m) + real(r8), pointer :: rootr(:,:) ! effective fraction of roots in each soil layer + real(r8), pointer :: psnsun(:) ! sunlit leaf photosynthesis (umol CO2 /m**2/ s) + real(r8), pointer :: psnsha(:) ! shaded leaf photosynthesis (umol CO2 /m**2/ s) + real(r8), pointer :: t_building(:) ! internal building temperature (K) + real(r8), pointer :: rh_ref2m(:) ! 2 m height surface relative humidity (%) + real(r8), pointer :: rh_ref2m_u(:) ! Urban 2 m height surface relative humidity (%) + real(r8), pointer :: eflx_sh_snow(:) ! sensible heat flux from snow (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_soil(:) ! sensible heat flux from soil (W/m**2) [+ to atm] + real(r8), pointer :: eflx_sh_h2osfc(:) ! sensible heat flux from soil (W/m**2) [+ to atm] +! +! +! !OTHER LOCAL VARIABLES +!EOP +! + character(len=*), parameter :: sub="UrbanFluxes" + integer :: fp,fc,fl,f,p,c,l,g,j,pi,i ! indices + + real(r8) :: canyontop_wind(num_urbanl) ! wind at canyon top (m/s) + real(r8) :: canyon_u_wind(num_urbanl) ! u-component of wind speed inside canyon (m/s) + real(r8) :: canyon_wind(num_urbanl) ! net wind speed inside canyon (m/s) + real(r8) :: canyon_resistance(num_urbanl) ! resistance to heat and moisture transfer from canyon road/walls to canyon air (s/m) + + real(r8) :: ur(lbl:ubl) ! wind speed at reference height (m/s) + real(r8) :: ustar(lbl:ubl) ! friction velocity (m/s) + real(r8) :: ramu(lbl:ubl) ! aerodynamic resistance (s/m) + real(r8) :: rahu(lbl:ubl) ! thermal resistance (s/m) + real(r8) :: rawu(lbl:ubl) ! moisture resistance (s/m) + real(r8) :: temp1(lbl:ubl) ! relation for potential temperature profile + real(r8) :: temp12m(lbl:ubl) ! relation for potential temperature profile applied at 2-m + real(r8) :: temp2(lbl:ubl) ! relation for specific humidity profile + real(r8) :: temp22m(lbl:ubl) ! relation for specific humidity profile applied at 2-m + real(r8) :: thm_g(lbl:ubl) ! intermediate variable (forc_t+0.0098*forc_hgt_t) + real(r8) :: thv_g(lbl:ubl) ! virtual potential temperature (K) + real(r8) :: dth(lbl:ubl) ! diff of virtual temp. between ref. height and surface + real(r8) :: dqh(lbl:ubl) ! diff of humidity between ref. height and surface + real(r8) :: zldis(lbl:ubl) ! reference height "minus" zero displacement height (m) + real(r8) :: um(lbl:ubl) ! wind speed including the stablity effect (m/s) + real(r8) :: obu(lbl:ubl) ! Monin-Obukhov length (m) + real(r8) :: taf_numer(lbl:ubl) ! numerator of taf equation (K m/s) + real(r8) :: taf_denom(lbl:ubl) ! denominator of taf equation (m/s) + real(r8) :: qaf_numer(lbl:ubl) ! numerator of qaf equation (kg m/kg s) + real(r8) :: qaf_denom(lbl:ubl) ! denominator of qaf equation (m/s) + real(r8) :: wtas(lbl:ubl) ! sensible heat conductance for urban air to atmospheric air (m/s) + real(r8) :: wtaq(lbl:ubl) ! latent heat conductance for urban air to atmospheric air (m/s) + real(r8) :: wts_sum(lbl:ubl) ! sum of wtas, wtus_roof, wtus_road_perv, wtus_road_imperv, wtus_sunwall, wtus_shadewall + real(r8) :: wtq_sum(lbl:ubl) ! sum of wtaq, wtuq_roof, wtuq_road_perv, wtuq_road_imperv, wtuq_sunwall, wtuq_shadewall + real(r8) :: beta(lbl:ubl) ! coefficient of convective velocity + real(r8) :: zii(lbl:ubl) ! convective boundary layer height (m) + + real(r8) :: fm(lbl:ubl) ! needed for BGC only to diagnose 10m wind speed + + real(r8) :: wtus(lbc:ubc) ! sensible heat conductance for urban columns (m/s) + real(r8) :: wtuq(lbc:ubc) ! latent heat conductance for urban columns (m/s) + + integer :: iter ! iteration index + real(r8) :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(r8) :: tstar ! temperature scaling parameter + real(r8) :: qstar ! moisture scaling parameter + real(r8) :: thvstar ! virtual potential temperature scaling parameter + real(r8) :: wtus_roof(lbl:ubl) ! sensible heat conductance for roof (not scaled) (m/s) + real(r8) :: wtuq_roof(lbl:ubl) ! latent heat conductance for roof (not scaled) (m/s) + real(r8) :: wtus_road_perv(lbl:ubl) ! sensible heat conductance for pervious road (not scaled) (m/s) + real(r8) :: wtuq_road_perv(lbl:ubl) ! latent heat conductance for pervious road (not scaled) (m/s) + real(r8) :: wtus_road_imperv(lbl:ubl) ! sensible heat conductance for impervious road (not scaled) (m/s) + real(r8) :: wtuq_road_imperv(lbl:ubl) ! latent heat conductance for impervious road (not scaled) (m/s) + real(r8) :: wtus_sunwall(lbl:ubl) ! sensible heat conductance for sunwall (not scaled) (m/s) + real(r8) :: wtuq_sunwall(lbl:ubl) ! latent heat conductance for sunwall (not scaled) (m/s) + real(r8) :: wtus_shadewall(lbl:ubl) ! sensible heat conductance for shadewall (not scaled) (m/s) + real(r8) :: wtuq_shadewall(lbl:ubl) ! latent heat conductance for shadewall (not scaled) (m/s) + real(r8) :: t_sunwall_innerl(lbl:ubl) ! temperature of inner layer of sunwall (K) + real(r8) :: t_shadewall_innerl(lbl:ubl) ! temperature of inner layer of shadewall (K) + real(r8) :: t_roof_innerl(lbl:ubl) ! temperature of inner layer of roof (K) + real(r8) :: lngth_roof ! length of roof (m) + real(r8) :: wc ! convective velocity (m/s) + real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) :: eflx_sh_grnd_scale(lbp:ubp) ! scaled sensible heat flux from ground (W/m**2) [+ to atm] + real(r8) :: qflx_evap_soi_scale(lbp:ubp) ! scaled soil evaporation (mm H2O/s) (+ = to atm) + real(r8) :: eflx_wasteheat_roof(lbl:ubl) ! sensible heat flux from urban heating/cooling sources of waste heat for roof (W/m**2) + real(r8) :: eflx_wasteheat_sunwall(lbl:ubl) ! sensible heat flux from urban heating/cooling sources of waste heat for sunwall (W/m**2) + real(r8) :: eflx_wasteheat_shadewall(lbl:ubl) ! sensible heat flux from urban heating/cooling sources of waste heat for shadewall (W/m**2) + real(r8) :: eflx_heat_from_ac_roof(lbl:ubl) ! sensible heat flux put back into canyon due to heat removal by AC for roof (W/m**2) + real(r8) :: eflx_heat_from_ac_sunwall(lbl:ubl) ! sensible heat flux put back into canyon due to heat removal by AC for sunwall (W/m**2) + real(r8) :: eflx_heat_from_ac_shadewall(lbl:ubl) ! sensible heat flux put back into canyon due to heat removal by AC for shadewall (W/m**2) + real(r8) :: eflx(lbl:ubl) ! total sensible heat flux for error check (W/m**2) + real(r8) :: qflx(lbl:ubl) ! total water vapor flux for error check (kg/m**2/s) + real(r8) :: eflx_scale(lbl:ubl) ! sum of scaled sensible heat fluxes for urban columns for error check (W/m**2) + real(r8) :: qflx_scale(lbl:ubl) ! sum of scaled water vapor fluxes for urban columns for error check (kg/m**2/s) + real(r8) :: eflx_err(lbl:ubl) ! sensible heat flux error (W/m**2) + real(r8) :: qflx_err(lbl:ubl) ! water vapor flux error (kg/m**2/s) + real(r8) :: fwet_roof ! fraction of roof surface that is wet (-) + real(r8) :: fwet_road_imperv ! fraction of impervious road surface that is wet (-) + + integer, parameter :: niters = 3 ! maximum number of iterations for surface temperature + integer :: local_secp1(lbl:ubl) ! seconds into current date in local time (sec) + real(r8) :: dtime ! land model time step (sec) + integer :: year,month,day,secs ! calendar info for current time step + logical :: found ! flag in search loop + integer :: indexl ! index of first found in search loop + integer :: nstep ! time step number + real(r8) :: z_d_town_loc(lbl:ubl) ! temporary copy + real(r8) :: z_0_town_loc(lbl:ubl) ! temporary copy + real(r8), parameter :: lapse_rate = 0.0098_r8 ! Dry adiabatic lapse rate (K/m) + real(r8) :: e_ref2m ! 2 m height surface saturated vapor pressure [Pa] + real(r8) :: de2mdT ! derivative of 2 m height surface saturated vapor pressure on t_ref2m + real(r8) :: qsat_ref2m ! 2 m height surface saturated specific humidity [kg/kg] + real(r8) :: dqsat2mdT ! derivative of 2 m height surface saturated specific humidity on t_ref2m + +!----------------------------------------------------------------------- + + ! Assign pointers into module urban clumps + + if ( num_urbanl > 0 )then + ht_roof => urban_clump(nc)%ht_roof + wtlunit_roof => urban_clump(nc)%wtlunit_roof + canyon_hwr => urban_clump(nc)%canyon_hwr + wtroad_perv => urban_clump(nc)%wtroad_perv + wind_hgt_canyon => urban_clump(nc)%wind_hgt_canyon + end if + + ! Assign local pointers to multi-level derived type members (gridcell level) + + forc_t => clm_a2l%forc_t + forc_th => clm_a2l%forc_th + forc_u => clm_a2l%forc_u + forc_v => clm_a2l%forc_v + forc_rho => clm_a2l%forc_rho + forc_q => clm_a2l%forc_q + forc_pbot => clm_a2l%forc_pbot + londeg => grc%londeg + + ! Assign local pointers to derived type members (landunit level) + + pfti =>lun%pfti + pftf =>lun%pftf + coli =>lun%coli + colf =>lun%colf + lgridcell =>lun%gridcell + z_0_town =>lun%z_0_town + z_d_town =>lun%z_d_town + taf => lps%taf + qaf => lps%qaf + npfts =>lun%npfts + eflx_traffic => lef%eflx_traffic + eflx_traffic_factor => lef%eflx_traffic_factor + eflx_wasteheat => lef%eflx_wasteheat + eflx_heat_from_ac => lef%eflx_heat_from_ac + t_building => lps%t_building + + ! Assign local pointers to derived type members (column level) + + ctype => col%itype + t_grnd => ces%t_grnd + qg => cws%qg + htvp => cps%htvp + dqgdT => cws%dqgdT + t_soisno => ces%t_soisno + eflx_urban_ac => cef%eflx_urban_ac + eflx_urban_heat => cef%eflx_urban_heat + h2osoi_ice => cws%h2osoi_ice + h2osoi_liq => cws%h2osoi_liq + frac_sno => cps%frac_sno + snow_depth => cps%snow_depth + h2osno => cws%h2osno + snl => cps%snl + rootr_road_perv => cps%rootr_road_perv + soilalpha_u => cws%soilalpha_u + + ! Assign local pointers to derived type members (pft level) + + pgridcell =>pft%gridcell + pcolumn =>pft%column + plandunit =>pft%landunit + ram1 => pps%ram1 + dlrad => pef%dlrad + ulrad => pef%ulrad + cgrnds => pef%cgrnds + cgrndl => pef%cgrndl + cgrnd => pef%cgrnd + taux => pmf%taux + tauy => pmf%tauy + eflx_sh_grnd => pef%eflx_sh_grnd + eflx_sh_tot => pef%eflx_sh_tot + eflx_sh_tot_u => pef%eflx_sh_tot_u + qflx_evap_soi => pwf%qflx_evap_soi + qflx_tran_veg => pwf%qflx_tran_veg + qflx_evap_veg => pwf%qflx_evap_veg + qflx_evap_tot => pwf%qflx_evap_tot + t_ref2m => pes%t_ref2m + q_ref2m => pes%q_ref2m + t_ref2m_u => pes%t_ref2m_u + t_veg => pes%t_veg + rootr => pps%rootr + psnsun => pcf%psnsun + psnsha => pcf%psnsha + forc_hgt_u_pft => pps%forc_hgt_u_pft + forc_hgt_t_pft => pps%forc_hgt_t_pft + forc_hgt_u_pft => pps%forc_hgt_u_pft + forc_hgt_t_pft => pps%forc_hgt_t_pft + rh_ref2m => pes%rh_ref2m + rh_ref2m_u => pes%rh_ref2m_u + + eflx_sh_snow => pef%eflx_sh_snow + eflx_sh_soil => pef%eflx_sh_soil + eflx_sh_h2osfc => pef%eflx_sh_h2osfc + ! Define fields that appear on the restart file for non-urban landunits + + do fl = 1,num_nourbanl + l = filter_nourbanl(fl) + taf(l) = spval + qaf(l) = spval + end do + + ! Get time step + nstep = get_nstep() + + ! Set constants (same as in Biogeophysics1Mod) + beta(:) = 1._r8 ! Should be set to the same values as in Biogeophysics1Mod + zii(:) = 1000._r8 ! Should be set to the same values as in Biogeophysics1Mod + + ! Get current date + dtime = get_step_size() + call get_curr_date (year, month, day, secs) + + ! Compute canyontop wind using Masson (2000) + + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + local_secp1(l) = secs + nint((grc%londeg(g)/degpsec)/dtime)*dtime + local_secp1(l) = mod(local_secp1(l),isecspday) + + ! Error checks + + if (ht_roof(fl) - z_d_town(l) <= z_0_town(l)) then + write (iulog,*) 'aerodynamic parameter error in UrbanFluxes' + write (iulog,*) 'h_r - z_d <= z_0' + write (iulog,*) 'ht_roof, z_d_town, z_0_town: ', ht_roof(fl), z_d_town(l), & + z_0_town(l) + write (iulog,*) 'clm model is stopping' + call endrun() + end if + if (forc_hgt_u_pft(pfti(l)) - z_d_town(l) <= z_0_town(l)) then + write (iulog,*) 'aerodynamic parameter error in UrbanFluxes' + write (iulog,*) 'h_u - z_d <= z_0' + write (iulog,*) 'forc_hgt_u_pft, z_d_town, z_0_town: ', forc_hgt_u_pft(pfti(l)), z_d_town(l), & + z_0_town(l) + write (iulog,*) 'clm model is stopping' + call endrun() + end if + + ! Magnitude of atmospheric wind + + ur(l) = max(1.0_r8,sqrt(forc_u(g)*forc_u(g)+forc_v(g)*forc_v(g))) + + ! Canyon top wind + + canyontop_wind(fl) = ur(l) * & + log( (ht_roof(fl)-z_d_town(l)) / z_0_town(l) ) / & + log( (forc_hgt_u_pft(pfti(l))-z_d_town(l)) / z_0_town(l) ) + + ! U component of canyon wind + + if (canyon_hwr(fl) < 0.5_r8) then ! isolated roughness flow + canyon_u_wind(fl) = canyontop_wind(fl) * exp( -0.5_r8*canyon_hwr(fl)* & + (1._r8-(wind_hgt_canyon(fl)/ht_roof(fl))) ) + else if (canyon_hwr(fl) < 1.0_r8) then ! wake interference flow + canyon_u_wind(fl) = canyontop_wind(fl) * (1._r8+2._r8*(2._r8/rpi - 1._r8)* & + (ht_roof(fl)/(ht_roof(fl)/canyon_hwr(fl)) - 0.5_r8)) * & + exp(-0.5_r8*canyon_hwr(fl)*(1._r8-(wind_hgt_canyon(fl)/ht_roof(fl)))) + else ! skimming flow + canyon_u_wind(fl) = canyontop_wind(fl) * (2._r8/rpi) * & + exp(-0.5_r8*canyon_hwr(fl)*(1._r8-(wind_hgt_canyon(fl)/ht_roof(fl)))) + end if + + end do + +! Compute fluxes - Follows CLM approach for bare soils (Oleson et al 2004) + + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + thm_g(l) = forc_t(g) + lapse_rate*forc_hgt_t_pft(pfti(l)) + thv_g(l) = forc_th(g)*(1._r8+0.61_r8*forc_q(g)) + dth(l) = thm_g(l)-taf(l) + dqh(l) = forc_q(g)-qaf(l) + dthv = dth(l)*(1._r8+0.61_r8*forc_q(g))+0.61_r8*forc_th(g)*dqh(l) + zldis(l) = forc_hgt_u_pft(pfti(l)) - z_d_town(l) + + ! Initialize Monin-Obukhov length and wind speed including convective velocity + + call MoninObukIni(ur(l), thv_g(l), dthv, zldis(l), z_0_town(l), um(l), obu(l)) + + end do + + ! Initialize conductances + wtus_roof(:) = 0._r8 + wtus_road_perv(:) = 0._r8 + wtus_road_imperv(:) = 0._r8 + wtus_sunwall(:) = 0._r8 + wtus_shadewall(:) = 0._r8 + wtuq_roof(:) = 0._r8 + wtuq_road_perv(:) = 0._r8 + wtuq_road_imperv(:) = 0._r8 + wtuq_sunwall(:) = 0._r8 + wtuq_shadewall(:) = 0._r8 + + ! Make copies so that array sections are not passed in function calls to friction velocity + + do fl = 1, num_urbanl + l = filter_urbanl(fl) + z_d_town_loc(l) = z_d_town(l) + z_0_town_loc(l) = z_0_town(l) + end do + + ! Start stability iteration + + do iter = 1,niters + + ! Get friction velocity, relation for potential + ! temperature and humidity profiles of surface boundary layer. + + if (num_urbanl .gt. 0) then + call FrictionVelocity(lbl, ubl, num_urbanl, filter_urbanl, & + z_d_town_loc, z_0_town_loc, z_0_town_loc, z_0_town_loc, & + obu, iter, ur, um, ustar, & + temp1, temp2, temp12m, temp22m, fm, landunit_index=.true.) + end if + + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + ! Determine aerodynamic resistance to fluxes from urban canopy air to + ! atmosphere + + ramu(l) = 1._r8/(ustar(l)*ustar(l)/um(l)) + rahu(l) = 1._r8/(temp1(l)*ustar(l)) + rawu(l) = 1._r8/(temp2(l)*ustar(l)) + + ! Determine magnitude of canyon wind by using horizontal wind determined + ! previously and vertical wind from friction velocity (Masson 2000) + + canyon_wind(fl) = sqrt(canyon_u_wind(fl)**2._r8 + ustar(l)**2._r8) + + ! Determine canyon_resistance (currently this single resistance determines the + ! resistance from urban surfaces (roof, pervious and impervious road, sunlit and + ! shaded walls) to urban canopy air, since it is only dependent on wind speed + ! Also from Masson 2000. + + canyon_resistance(fl) = cpair * forc_rho(g) / (11.8_r8 + 4.2_r8*canyon_wind(fl)) + + end do + + ! This is the first term in the equation solutions for urban canopy air temperature + ! and specific humidity (numerator) and is a landunit quantity + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + taf_numer(l) = thm_g(l)/rahu(l) + taf_denom(l) = 1._r8/rahu(l) + qaf_numer(l) = forc_q(g)/rawu(l) + qaf_denom(l) = 1._r8/rawu(l) + + ! First term needed for derivative of heat fluxes + wtas(l) = 1._r8/rahu(l) + wtaq(l) = 1._r8/rawu(l) + + end do + + + ! Gather other terms for other urban columns for numerator and denominator of + ! equations for urban canopy air temperature and specific humidity + + do pi = 1,maxpatch_urb + do fl = 1,num_urbanl + l = filter_urbanl(fl) + if ( pi <= npfts(l) ) then + c = coli(l) + pi - 1 + + if (ctype(c) == icol_roof) then + + ! scaled sensible heat conductance + wtus(c) = wtlunit_roof(fl)/canyon_resistance(fl) + ! unscaled sensible heat conductance + wtus_roof(l) = 1._r8/canyon_resistance(fl) + + if (snow_depth(c) > 0._r8) then + fwet_roof = min(snow_depth(c)/0.05_r8, 1._r8) + else + fwet_roof = (max(0._r8, h2osoi_liq(c,1)+h2osoi_ice(c,1))/pondmx_urban)**0.666666666666_r8 + fwet_roof = min(fwet_roof,1._r8) + end if + if (qaf(l) > qg(c)) then + fwet_roof = 1._r8 + end if + ! scaled latent heat conductance + wtuq(c) = fwet_roof*(wtlunit_roof(fl)/canyon_resistance(fl)) + ! unscaled latent heat conductance + wtuq_roof(l) = fwet_roof*(1._r8/canyon_resistance(fl)) + + ! wasteheat from heating/cooling + if (trim(urban_hac) == urban_wasteheat_on) then + eflx_wasteheat_roof(l) = ac_wasteheat_factor * eflx_urban_ac(c) + & + ht_wasteheat_factor * eflx_urban_heat(c) + else + eflx_wasteheat_roof(l) = 0._r8 + end if + + ! If air conditioning on, always replace heat removed with heat into canyon + if (trim(urban_hac) == urban_hac_on .or. trim(urban_hac) == urban_wasteheat_on) then + eflx_heat_from_ac_roof(l) = abs(eflx_urban_ac(c)) + else + eflx_heat_from_ac_roof(l) = 0._r8 + end if + + else if (ctype(c) == icol_road_perv) then + + ! scaled sensible heat conductance + wtus(c) = wtroad_perv(fl)*(1._r8-wtlunit_roof(fl))/canyon_resistance(fl) + ! unscaled sensible heat conductance + if (wtroad_perv(fl) > 0._r8) then + wtus_road_perv(l) = 1._r8/canyon_resistance(fl) + else + wtus_road_perv(l) = 0._r8 + end if + + ! scaled latent heat conductance + wtuq(c) = wtroad_perv(fl)*(1._r8-wtlunit_roof(fl))/canyon_resistance(fl) + ! unscaled latent heat conductance + if (wtroad_perv(fl) > 0._r8) then + wtuq_road_perv(l) = 1._r8/canyon_resistance(fl) + else + wtuq_road_perv(l) = 0._r8 + end if + + else if (ctype(c) == icol_road_imperv) then + + ! scaled sensible heat conductance + wtus(c) = (1._r8-wtroad_perv(fl))*(1._r8-wtlunit_roof(fl))/canyon_resistance(fl) + ! unscaled sensible heat conductance + if ((1._r8-wtroad_perv(fl)) > 0._r8) then + wtus_road_imperv(l) = 1._r8/canyon_resistance(fl) + else + wtus_road_imperv(l) = 0._r8 + end if + + if (snow_depth(c) > 0._r8) then + fwet_road_imperv = min(snow_depth(c)/0.05_r8, 1._r8) + else + fwet_road_imperv = (max(0._r8, h2osoi_liq(c,1)+h2osoi_ice(c,1))/pondmx_urban)**0.666666666666_r8 + fwet_road_imperv = min(fwet_road_imperv,1._r8) + end if + if (qaf(l) > qg(c)) then + fwet_road_imperv = 1._r8 + end if + ! scaled latent heat conductance + wtuq(c) = fwet_road_imperv*(1._r8-wtroad_perv(fl))*(1._r8-wtlunit_roof(fl))/canyon_resistance(fl) + ! unscaled latent heat conductance + if ((1._r8-wtroad_perv(fl)) > 0._r8) then + wtuq_road_imperv(l) = fwet_road_imperv*(1._r8/canyon_resistance(fl)) + else + wtuq_road_imperv(l) = 0._r8 + end if + + else if (ctype(c) == icol_sunwall) then + + ! scaled sensible heat conductance + wtus(c) = canyon_hwr(fl)*(1._r8-wtlunit_roof(fl))/canyon_resistance(fl) + ! unscaled sensible heat conductance + wtus_sunwall(l) = 1._r8/canyon_resistance(fl) + + ! scaled latent heat conductance + wtuq(c) = 0._r8 + ! unscaled latent heat conductance + wtuq_sunwall(l) = 0._r8 + + ! wasteheat from heating/cooling + if (trim(urban_hac) == urban_wasteheat_on) then + eflx_wasteheat_sunwall(l) = ac_wasteheat_factor * eflx_urban_ac(c) + & + ht_wasteheat_factor * eflx_urban_heat(c) + else + eflx_wasteheat_sunwall(l) = 0._r8 + end if + + ! If air conditioning on, always replace heat removed with heat into canyon + if (trim(urban_hac) == urban_hac_on .or. trim(urban_hac) == urban_wasteheat_on) then + eflx_heat_from_ac_sunwall(l) = abs(eflx_urban_ac(c)) + else + eflx_heat_from_ac_sunwall(l) = 0._r8 + end if + + else if (ctype(c) == icol_shadewall) then + + ! scaled sensible heat conductance + wtus(c) = canyon_hwr(fl)*(1._r8-wtlunit_roof(fl))/canyon_resistance(fl) + ! unscaled sensible heat conductance + wtus_shadewall(l) = 1._r8/canyon_resistance(fl) + + ! scaled latent heat conductance + wtuq(c) = 0._r8 + ! unscaled latent heat conductance + wtuq_shadewall(l) = 0._r8 + + ! wasteheat from heating/cooling + if (trim(urban_hac) == urban_wasteheat_on) then + eflx_wasteheat_shadewall(l) = ac_wasteheat_factor * eflx_urban_ac(c) + & + ht_wasteheat_factor * eflx_urban_heat(c) + else + eflx_wasteheat_shadewall(l) = 0._r8 + end if + + ! If air conditioning on, always replace heat removed with heat into canyon + if (trim(urban_hac) == urban_hac_on .or. trim(urban_hac) == urban_wasteheat_on) then + eflx_heat_from_ac_shadewall(l) = abs(eflx_urban_ac(c)) + else + eflx_heat_from_ac_shadewall(l) = 0._r8 + end if + else + write(iulog,*) 'c, ctype, pi = ', c, ctype(c), pi + write(iulog,*) 'Column indices for: shadewall, sunwall, road_imperv, road_perv, roof: ' + write(iulog,*) icol_shadewall, icol_sunwall, icol_road_imperv, icol_road_perv, icol_roof + call endrun( sub//':: ERROR, ctype out of range' ) + end if + + taf_numer(l) = taf_numer(l) + t_grnd(c)*wtus(c) + taf_denom(l) = taf_denom(l) + wtus(c) + qaf_numer(l) = qaf_numer(l) + qg(c)*wtuq(c) + qaf_denom(l) = qaf_denom(l) + wtuq(c) + + end if + end do + end do + + ! Calculate new urban canopy air temperature and specific humidity + + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + ! Total waste heat and heat from AC is sum of heat for walls and roofs + ! accounting for different surface areas + eflx_wasteheat(l) = wtlunit_roof(fl)*eflx_wasteheat_roof(l) + & + (1._r8-wtlunit_roof(fl))*(canyon_hwr(fl)*(eflx_wasteheat_sunwall(l) + & + eflx_wasteheat_shadewall(l))) + + ! Limit wasteheat to ensure that we don't get any unrealistically strong + ! positive feedbacks due to AC in a warmer climate + eflx_wasteheat(l) = min(eflx_wasteheat(l),wasteheat_limit) + + eflx_heat_from_ac(l) = wtlunit_roof(fl)*eflx_heat_from_ac_roof(l) + & + (1._r8-wtlunit_roof(fl))*(canyon_hwr(fl)*(eflx_heat_from_ac_sunwall(l) + & + eflx_heat_from_ac_shadewall(l))) + + ! Calculate traffic heat flux + ! Only comes from impervious road + eflx_traffic(l) = (1._r8-wtlunit_roof(fl))*(1._r8-wtroad_perv(fl))* & + eflx_traffic_factor(l) + + taf(l) = taf_numer(l)/taf_denom(l) + qaf(l) = qaf_numer(l)/qaf_denom(l) + + wts_sum(l) = wtas(l) + wtus_roof(l) + wtus_road_perv(l) + & + wtus_road_imperv(l) + wtus_sunwall(l) + wtus_shadewall(l) + + wtq_sum(l) = wtaq(l) + wtuq_roof(l) + wtuq_road_perv(l) + & + wtuq_road_imperv(l) + wtuq_sunwall(l) + wtuq_shadewall(l) + + end do + + ! This section of code is not required if niters = 1 + ! Determine stability using new taf and qaf + ! TODO: Some of these constants replicate what is in FrictionVelocity and BareGround fluxes should consildate. EBK + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + + dth(l) = thm_g(l)-taf(l) + dqh(l) = forc_q(g)-qaf(l) + tstar = temp1(l)*dth(l) + qstar = temp2(l)*dqh(l) + thvstar = tstar*(1._r8+0.61_r8*forc_q(g)) + 0.61_r8*forc_th(g)*qstar + zeta = zldis(l)*vkc*grav*thvstar/(ustar(l)**2*thv_g(l)) + + if (zeta >= 0._r8) then !stable + zeta = min(2._r8,max(zeta,0.01_r8)) + um(l) = max(ur(l),0.1_r8) + else !unstable + zeta = max(-100._r8,min(zeta,-0.01_r8)) + wc = beta(l)*(-grav*ustar(l)*thvstar*zii(l)/thv_g(l))**0.333_r8 + um(l) = sqrt(ur(l)*ur(l) + wc*wc) + end if + + obu(l) = zldis(l)/zeta + end do + + end do ! end iteration + +! Determine fluxes from canyon surfaces + + do f = 1, num_urbanp + + p = filter_urbanp(f) + c = pcolumn(p) + g = pgridcell(p) + l = plandunit(p) + + ram1(p) = ramu(l) !pass value to global variable + + ! Upward and downward canopy longwave are zero + + ulrad(p) = 0._r8 + dlrad(p) = 0._r8 + + ! Derivative of sensible and latent heat fluxes with respect to + ! ground temperature + + if (ctype(c) == icol_roof) then + cgrnds(p) = forc_rho(g) * cpair * (wtas(l) + wtus_road_perv(l) + & + wtus_road_imperv(l) + wtus_sunwall(l) + wtus_shadewall(l)) * & + (wtus_roof(l)/wts_sum(l)) + cgrndl(p) = forc_rho(g) * (wtaq(l) + wtuq_road_perv(l) + & + wtuq_road_imperv(l) + wtuq_sunwall(l) + wtuq_shadewall(l)) * & + (wtuq_roof(l)/wtq_sum(l))*dqgdT(c) + else if (ctype(c) == icol_road_perv) then + cgrnds(p) = forc_rho(g) * cpair * (wtas(l) + wtus_roof(l) + & + wtus_road_imperv(l) + wtus_sunwall(l) + wtus_shadewall(l)) * & + (wtus_road_perv(l)/wts_sum(l)) + cgrndl(p) = forc_rho(g) * (wtaq(l) + wtuq_roof(l) + & + wtuq_road_imperv(l) + wtuq_sunwall(l) + wtuq_shadewall(l)) * & + (wtuq_road_perv(l)/wtq_sum(l))*dqgdT(c) + else if (ctype(c) == icol_road_imperv) then + cgrnds(p) = forc_rho(g) * cpair * (wtas(l) + wtus_roof(l) + & + wtus_road_perv(l) + wtus_sunwall(l) + wtus_shadewall(l)) * & + (wtus_road_imperv(l)/wts_sum(l)) + cgrndl(p) = forc_rho(g) * (wtaq(l) + wtuq_roof(l) + & + wtuq_road_perv(l) + wtuq_sunwall(l) + wtuq_shadewall(l)) * & + (wtuq_road_imperv(l)/wtq_sum(l))*dqgdT(c) + else if (ctype(c) == icol_sunwall) then + cgrnds(p) = forc_rho(g) * cpair * (wtas(l) + wtus_roof(l) + & + wtus_road_perv(l) + wtus_road_imperv(l) + wtus_shadewall(l)) * & + (wtus_sunwall(l)/wts_sum(l)) + cgrndl(p) = 0._r8 + else if (ctype(c) == icol_shadewall) then + cgrnds(p) = forc_rho(g) * cpair * (wtas(l) + wtus_roof(l) + & + wtus_road_perv(l) + wtus_road_imperv(l) + wtus_sunwall(l)) * & + (wtus_shadewall(l)/wts_sum(l)) + cgrndl(p) = 0._r8 + end if + cgrnd(p) = cgrnds(p) + cgrndl(p)*htvp(c) + + ! Surface fluxes of momentum, sensible and latent heat + + taux(p) = -forc_rho(g)*forc_u(g)/ramu(l) + tauy(p) = -forc_rho(g)*forc_v(g)/ramu(l) + + ! Use new canopy air temperature + dth(l) = taf(l) - t_grnd(c) + + if (ctype(c) == icol_roof) then + eflx_sh_grnd(p) = -forc_rho(g)*cpair*wtus_roof(l)*dth(l) + eflx_sh_snow(p) = 0._r8 + eflx_sh_soil(p) = 0._r8 + eflx_sh_h2osfc(p)= 0._r8 + else if (ctype(c) == icol_road_perv) then + eflx_sh_grnd(p) = -forc_rho(g)*cpair*wtus_road_perv(l)*dth(l) + eflx_sh_snow(p) = 0._r8 + eflx_sh_soil(p) = 0._r8 + eflx_sh_h2osfc(p)= 0._r8 + else if (ctype(c) == icol_road_imperv) then + eflx_sh_grnd(p) = -forc_rho(g)*cpair*wtus_road_imperv(l)*dth(l) + eflx_sh_snow(p) = 0._r8 + eflx_sh_soil(p) = 0._r8 + eflx_sh_h2osfc(p)= 0._r8 + else if (ctype(c) == icol_sunwall) then + eflx_sh_grnd(p) = -forc_rho(g)*cpair*wtus_sunwall(l)*dth(l) + eflx_sh_snow(p) = 0._r8 + eflx_sh_soil(p) = 0._r8 + eflx_sh_h2osfc(p)= 0._r8 + else if (ctype(c) == icol_shadewall) then + eflx_sh_grnd(p) = -forc_rho(g)*cpair*wtus_shadewall(l)*dth(l) + eflx_sh_snow(p) = 0._r8 + eflx_sh_soil(p) = 0._r8 + eflx_sh_h2osfc(p)= 0._r8 + end if + + eflx_sh_tot(p) = eflx_sh_grnd(p) + eflx_sh_tot_u(p) = eflx_sh_tot(p) + + dqh(l) = qaf(l) - qg(c) + + if (ctype(c) == icol_roof) then + qflx_evap_soi(p) = -forc_rho(g)*wtuq_roof(l)*dqh(l) + else if (ctype(c) == icol_road_perv) then + ! Evaporation assigned to soil term if dew or snow + ! or if no liquid water available in soil column + if (dqh(l) > 0._r8 .or. frac_sno(c) > 0._r8 .or. soilalpha_u(c) .le. 0._r8) then + qflx_evap_soi(p) = -forc_rho(g)*wtuq_road_perv(l)*dqh(l) + qflx_tran_veg(p) = 0._r8 + ! Otherwise, evaporation assigned to transpiration term + else + qflx_evap_soi(p) = 0._r8 + qflx_tran_veg(p) = -forc_rho(g)*wtuq_road_perv(l)*dqh(l) + end if + qflx_evap_veg(p) = qflx_tran_veg(p) + else if (ctype(c) == icol_road_imperv) then + qflx_evap_soi(p) = -forc_rho(g)*wtuq_road_imperv(l)*dqh(l) + else if (ctype(c) == icol_sunwall) then + qflx_evap_soi(p) = 0._r8 + else if (ctype(c) == icol_shadewall) then + qflx_evap_soi(p) = 0._r8 + end if + + ! SCALED sensible and latent heat flux for error check + eflx_sh_grnd_scale(p) = -forc_rho(g)*cpair*wtus(c)*dth(l) + qflx_evap_soi_scale(p) = -forc_rho(g)*wtuq(c)*dqh(l) + + end do + + ! Check to see that total sensible and latent heat equal the sum of + ! the scaled heat fluxes above + do fl = 1, num_urbanl + l = filter_urbanl(fl) + g = lgridcell(l) + eflx(l) = -(forc_rho(g)*cpair/rahu(l))*(thm_g(l) - taf(l)) + qflx(l) = -(forc_rho(g)/rawu(l))*(forc_q(g) - qaf(l)) + eflx_scale(l) = sum(eflx_sh_grnd_scale(pfti(l):pftf(l))) + qflx_scale(l) = sum(qflx_evap_soi_scale(pfti(l):pftf(l))) + eflx_err(l) = eflx_scale(l) - eflx(l) + qflx_err(l) = qflx_scale(l) - qflx(l) + end do + + found = .false. + do fl = 1, num_urbanl + l = filter_urbanl(fl) + if (abs(eflx_err(l)) > 0.01_r8) then + found = .true. + indexl = l + exit + end if + end do + if ( found ) then + write(iulog,*)'WARNING: Total sensible heat does not equal sum of scaled heat fluxes for urban columns ',& + ' nstep = ',nstep,' indexl= ',indexl,' eflx_err= ',eflx_err(indexl) + if (abs(eflx_err(indexl)) > .01_r8) then + write(iulog,*)'clm model is stopping - error is greater than .01 W/m**2' + write(iulog,*)'eflx_scale = ',eflx_scale(indexl) + write(iulog,*)'eflx_sh_grnd_scale: ',eflx_sh_grnd_scale(pfti(indexl):pftf(indexl)) + write(iulog,*)'eflx = ',eflx(indexl) + call endrun + end if + end if + + found = .false. + do fl = 1, num_urbanl + l = filter_urbanl(fl) + ! 4.e-9 kg/m**2/s = 0.01 W/m**2 + if (abs(qflx_err(l)) > 4.e-9_r8) then + found = .true. + indexl = l + exit + end if + end do + if ( found ) then + write(iulog,*)'WARNING: Total water vapor flux does not equal sum of scaled water vapor fluxes for urban columns ',& + ' nstep = ',nstep,' indexl= ',indexl,' qflx_err= ',qflx_err(indexl) + if (abs(qflx_err(indexl)) > 4.e-9_r8) then + write(iulog,*)'clm model is stopping - error is greater than 4.e-9 kg/m**2/s' + write(iulog,*)'qflx_scale = ',qflx_scale(indexl) + write(iulog,*)'qflx = ',qflx(indexl) + call endrun + end if + end if + + ! Gather terms required to determine internal building temperature + + do pi = 1,maxpatch_urb + do fl = 1,num_urbanl + l = filter_urbanl(fl) + if ( pi <= npfts(l) ) then + c = coli(l) + pi - 1 + + if (ctype(c) == icol_roof) then + t_roof_innerl(l) = t_soisno(c,nlevurb) + else if (ctype(c) == icol_sunwall) then + t_sunwall_innerl(l) = t_soisno(c,nlevurb) + else if (ctype(c) == icol_shadewall) then + t_shadewall_innerl(l) = t_soisno(c,nlevurb) + end if + + end if + end do + end do + + ! Calculate internal building temperature + do fl = 1, num_urbanl + l = filter_urbanl(fl) + + lngth_roof = (ht_roof(fl)/canyon_hwr(fl))*wtlunit_roof(fl)/(1._r8-wtlunit_roof(fl)) + t_building(l) = (ht_roof(fl)*(t_shadewall_innerl(l) + t_sunwall_innerl(l)) & + +lngth_roof*t_roof_innerl(l))/(2._r8*ht_roof(fl)+lngth_roof) + end do + + ! No roots for urban except for pervious road + + do j = 1, nlevgrnd + do f = 1, num_urbanp + p = filter_urbanp(f) + c = pcolumn(p) + if (ctype(c) == icol_road_perv) then + rootr(p,j) = rootr_road_perv(c,j) + else + rootr(p,j) = 0._r8 + end if + end do + end do + + do f = 1, num_urbanp + + p = filter_urbanp(f) + c = pcolumn(p) + g = pgridcell(p) + l = plandunit(p) + + ! Use urban canopy air temperature and specific humidity to represent + ! 2-m temperature and humidity + + t_ref2m(p) = taf(l) + q_ref2m(p) = qaf(l) + t_ref2m_u(p) = taf(l) + + ! 2 m height relative humidity + + call QSat(t_ref2m(p), forc_pbot(g), e_ref2m, de2mdT, qsat_ref2m, dqsat2mdT) + rh_ref2m(p) = min(100._r8, q_ref2m(p) / qsat_ref2m * 100._r8) + rh_ref2m_u(p) = rh_ref2m(p) + + ! Variables needed by history tape + + t_veg(p) = forc_t(g) + + ! Add the following to avoid NaN + + psnsun(p) = 0._r8 + psnsha(p) = 0._r8 + + end do + + end subroutine UrbanFluxes + +end module UrbanMod diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.datm/datm_comp_mod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.datm/datm_comp_mod.F90 new file mode 100644 index 0000000000..b7153ddbf7 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.datm/datm_comp_mod.F90 @@ -0,0 +1,1237 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_2_1/models/atm/datm/datm_comp_mod.F90 + +#ifdef AIX +@PROCESS ALIAS_SIZE(805306368) +#endif +module datm_comp_mod + +! !USES: + + use shr_const_mod + use shr_sys_mod + use shr_kind_mod , only: IN=>SHR_KIND_IN, R8=>SHR_KIND_R8, & + CS=>SHR_KIND_CS, CL=>SHR_KIND_CL + use shr_file_mod , only: shr_file_getunit, shr_file_getlogunit, shr_file_getloglevel, & + shr_file_setlogunit, shr_file_setloglevel, shr_file_setio, & + shr_file_freeunit + use shr_cal_mod , only: shr_cal_date2julian + use shr_mpi_mod , only: shr_mpi_bcast + use mct_mod + use esmf + use perf_mod + + use shr_strdata_mod + use shr_dmodel_mod + use shr_pcdf_mod + use datm_shr_mod + + use seq_cdata_mod + use seq_infodata_mod + use seq_timemgr_mod + use seq_comm_mct , only: seq_comm_inst, seq_comm_name, seq_comm_suffix + use seq_flds_mod , only: seq_flds_a2x_fields, & + seq_flds_x2a_fields +! +! !PUBLIC TYPES: + implicit none + private ! except + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: datm_comp_init + public :: datm_comp_run + public :: datm_comp_final + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + + !--- other --- + character(CS) :: myModelName = 'atm' ! user defined model name + integer(IN) :: mpicom + integer(IN) :: COMPID ! mct comp id + integer(IN) :: my_task ! my task in mpi communicator mpicom + integer(IN) :: npes ! total number of tasks + integer(IN),parameter :: master_task=0 ! task number of master task + integer(IN) :: logunit ! logging unit number + integer :: inst_index ! number of current instance (ie. 1) + character(len=16) :: inst_name ! fullname of current instance (ie. "lnd_0001") + character(len=16) :: inst_suffix ! char string associated with instance + ! (ie. "_0001" or "") + character(CL) :: atm_mode ! mode + integer(IN) :: dbug = 0 ! debug level (higher is more) + logical :: firstcall = .true. ! first call logical + logical :: scmMode = .false. ! single column mode + real(R8) :: scmLat = shr_const_SPVAL ! single column lat + real(R8) :: scmLon = shr_const_SPVAL ! single column lon + integer :: phase ! phase of method + logical :: read_restart ! start from restart + real(R8) :: orbEccen ! orb eccentricity (unit-less) + real(R8) :: orbMvelpp ! orb moving vernal eq (radians) + real(R8) :: orbLambm0 ! orb mean long of perhelion (radians) + real(R8) :: orbObliqr ! orb obliquity (radians) + real(R8) :: tbotmax ! units detector + real(R8) :: tdewmax ! units detector + real(R8) :: anidrmax ! existance detector + integer(IN) :: iradsw ! radiation logical + character(CL) :: factorFn ! file containing correction factors + + character(len=*),parameter :: rpfile = 'rpointer.atm' + character(len=*),parameter :: nullstr = 'undefined' + + real(R8),parameter :: aerodep_spval = 1.e29_r8 ! special aerosol deposition + real(R8),parameter :: tKFrz = SHR_CONST_TKFRZ + real(R8),parameter :: degtorad = SHR_CONST_PI/180.0_R8 + real(R8),parameter :: pstd = SHR_CONST_PSTD ! standard pressure ~ Pa + real(R8),parameter :: stebol = SHR_CONST_STEBOL ! Stefan-Boltzmann constant ~ W/m^2/K^4 + real(R8),parameter :: rdair = SHR_CONST_RDAIR ! dry air gas constant ~ J/K/kg + real(R8),parameter :: avg_c0 = 61.846_R8 + real(R8),parameter :: avg_c1 = 1.107_R8 + real(R8),parameter :: amp_c0 = -21.841_R8 + real(R8),parameter :: amp_c1 = -0.447_R8 + real(R8),parameter :: phs_c0 = 0.298_R8 + real(R8),parameter :: dLWarc = -5.000_R8 + real(R8) ,save :: dTarc(12) + data dTarc / 0.49_R8, 0.06_R8,-0.73_R8, -0.89_R8,-0.77_R8,-1.02_R8, & + & -1.99_R8,-0.91_R8, 1.72_R8, 2.30_R8, 1.81_R8, 1.06_R8/ + + integer(IN) :: kz,ku,kv,ktbot,kptem,kshum,kdens,kpbot,kpslv,klwdn + integer(IN) :: krc,krl,ksc,ksl,kswndr,kswndf,kswvdr,kswvdf,kswnet,kco2p,kco2d + integer(IN) :: kbid,kbod,kbiw,koid,kood,koiw,kdw1,kdw2,kdw3,kdw4,kdd1,kdd2,kdd3,kdd4 + integer(IN) :: kanidr,kanidf,kavsdr,kavsdf + integer(IN) :: stbot,swind,sz,spbot,sshum,stdew,srh,slwdn,sswdn,sswdndf,sswdndr + integer(IN) :: sprecc,sprecl,sprecn,sco2p,sco2d,sswup,sprec,starcf + + type(shr_strdata_type) :: SDATM + type(mct_rearr) :: rearr + type(mct_avect) :: avstrm ! av of data from stream + integer(IN), pointer :: imask(:) + real(R8), pointer :: yc(:) + real(R8), pointer :: windFactor(:) + real(R8), pointer :: winddFactor(:) + real(R8), pointer :: qsatFactor(:) + + integer(IN),parameter :: ktrans = 56 + character(16),parameter :: avofld(1:ktrans) = & + (/"Sa_z ","Sa_u ","Sa_v ","Sa_tbot ", & + "Sa_ptem ","Sa_shum ","Sa_dens ","Sa_pbot ", & + "Sa_pslv ","Faxa_lwdn ","Faxa_rainc ","Faxa_rainl ", & + "Faxa_snowc ","Faxa_snowl ","Faxa_swndr ","Faxa_swvdr ", & + "Faxa_swndf ","Faxa_swvdf ","Faxa_swnet ","Sa_co2prog ", & + "Sa_co2diag ","Faxa_bcphidry ","Faxa_bcphodry ","Faxa_bcphiwet ", & + "Faxa_ocphidry ","Faxa_ocphodry ","Faxa_ocphiwet ","Faxa_dstwet1 ", & + "Faxa_dstwet2 ","Faxa_dstwet3 ","Faxa_dstwet4 ","Faxa_dstdry1 ", & + "Faxa_dstdry2 ","Faxa_dstdry3 ","Faxa_dstdry4 ", & + "Sx_tref ","Sx_qref ","Sx_avsdr ","Sx_anidr ", & + "Sx_avsdf ","Sx_anidf ","Sx_t ","So_t ", & + "Sl_snowh ","Sf_lfrac ","Sf_ifrac ","Sf_ofrac ", & + "Faxx_taux ","Faxx_tauy ","Faxx_lat ","Faxx_sen ", & + "Faxx_lwup ","Faxx_evap ","Fall_fco2_lnd ","Faoo_fco2_ocn ", & + "Faoo_fdms_ocn " /) + character(16),parameter :: avifld(1:ktrans) = & + (/"z ","u ","v ","tbot ", & + "ptem ","shum ","dens ","pbot ", & + "pslv ","lwdn ","rainc ","rainl ", & + "snowc ","snowl ","swndr ","swvdr ", & + "swndf ","swvdf ","swnet ","co2prog ", & + "co2diag ","bcphidry ","bcphodry ","bcphiwet ", & + "ocphidry ","ocphodry ","ocphiwet ","dstwet1 ", & + "dstwet2 ","dstwet3 ","dstwet4 ","dstdry1 ", & + "dstdry2 ","dstdry3 ","dstdry4 ", & + "tref ","qref ","avsdr ","anidr ", & + "avsdf ","anidf ","ts ","to ", & + "snowhl ","lfrac ","ifrac ","ofrac ", & + "taux ","tauy ","lat ","sen ", & + "lwup ","evap ","co2lnd ","co2ocn ", & + "dms " /) + + integer(IN),parameter :: ktranss = 19 + character(16),parameter :: stofld(1:ktranss) = & + (/"strm_tbot ","strm_wind ","strm_z ","strm_pbot ", & + "strm_shum ","strm_tdew ","strm_rh ","strm_lwdn ", & + "strm_swdn ","strm_swdndf ","strm_swdndr ","strm_precc ", & + "strm_precl ","strm_precn ","strm_co2prog ","strm_co2diag ", & + "strm_swup ","strm_prec ","strm_tarcf " /) + character(16),parameter :: stifld(1:ktranss) = & + (/"tbot ","wind ","z ","pbot ", & + "shum ","tdew ","rh ","lwdn ", & + "swdn ","swdndf ","swdndr ","precc ", & + "precl ","precn ","co2prog ","co2diag ", & + "swup ","prec ","tarcf " /) + + character(CL), pointer :: ilist_av(:) ! input list for translation + character(CL), pointer :: olist_av(:) ! output list for translation + character(CL), pointer :: ilist_st(:) ! input list for translation + character(CL), pointer :: olist_st(:) ! output list for translation + integer(IN) , pointer :: count_av(:) + integer(IN) , pointer :: count_st(:) + + save + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CONTAINS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: datm_comp_init +! +! !DESCRIPTION: +! initialize data atm model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine datm_comp_init( EClock, cdata, x2a, a2x, NLFilename ) + use shr_pio_mod, only : shr_pio_getiosys, shr_pio_getiotype + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) , intent(in) :: EClock + type(seq_cdata) , intent(inout) :: cdata + type(mct_aVect) , intent(inout) :: x2a, a2x + character(len=*), optional , intent(in) :: NLFilename ! Namelist filename + +!EOP + + !--- local variables --- + integer(IN) :: n,k ! generic counters + integer(IN) :: ierr ! error code + integer(IN) :: gsize ! global size + integer(IN) :: lsize ! local size + integer(IN) :: shrlogunit, shrloglev ! original log unit and level + integer(IN) :: nunit ! unit number + integer(IN) :: kmask ! field reference + integer(IN) :: klat ! field reference + integer(IN) :: kfld ! fld index + integer(IN) :: cnt ! counter + logical :: atm_present ! flag + logical :: atm_prognostic ! flag + + type(seq_infodata_type), pointer :: infodata + type(mct_gsMap) , pointer :: gsMap + type(mct_gGrid) , pointer :: ggrid + + character(CL) :: filePath ! generic file path + character(CL) :: fileName ! generic file name + character(CS) :: timeName ! domain file: time variable name + character(CS) :: lonName ! domain file: lon variable name + character(CS) :: latName ! domain file: lat variable name + character(CS) :: maskName ! domain file: mask variable name + character(CS) :: areaName ! domain file: area variable name + + integer(IN) :: yearFirst ! first year to use in data stream + integer(IN) :: yearLast ! last year to use in data stream + integer(IN) :: yearAlign ! data year that aligns with yearFirst + + character(CL) :: atm_in ! dshr atm namelist + character(CL) :: decomp ! decomp strategy + character(CL) :: rest_file ! restart filename + character(CL) :: rest_file_strm ! restart filename for streams + character(CL) :: restfilm ! model restart file namelist + character(CL) :: restfils ! stream restart file namelist + logical :: exists ! filename existance + integer(IN) :: nu ! unit number + integer(IN) :: idt ! integer timestep + integer(IN) :: CurrentYMD ! model date + integer(IN) :: CurrentTOD ! model sec into model date + integer(IN) :: stepno ! step number + real(R8) :: nextsw_cday ! calendar of next atm sw + character(CL) :: flds_strm + logical :: presaero ! true => send valid prescribe aero fields to coupler + character(CL) :: calendar ! calendar type + + !----- define namelist ----- + namelist / datm_nml / & + atm_in, decomp, iradsw, factorFn, restfilm, restfils, presaero + + !--- formats --- + character(*), parameter :: F00 = "('(datm_comp_init) ',8a)" + character(*), parameter :: F0L = "('(datm_comp_init) ',a, l2)" + character(*), parameter :: F01 = "('(datm_comp_init) ',a,5i8)" + character(*), parameter :: F02 = "('(datm_comp_init) ',a,4es13.6)" + character(*), parameter :: F03 = "('(datm_comp_init) ',a,i8,a)" + character(*), parameter :: F04 = "('(datm_comp_init) ',2a,2i8,'s')" + character(*), parameter :: F05 = "('(datm_comp_init) ',a,2f10.4)" + character(*), parameter :: F90 = "('(datm_comp_init) ',73('='))" + character(*), parameter :: F91 = "('(datm_comp_init) ',73('-'))" + character(*), parameter :: subName = "(datm_comp_init) " +!------------------------------------------------------------------------------- + + + call t_startf('DATM_INIT') + + ! Set cdata pointers + + call seq_cdata_setptrs(cdata, ID=COMPID, mpicom=mpicom, & + gsMap=gsmap, dom=ggrid, infodata=infodata) + call seq_infodata_getData(infodata,atm_phase=phase) + + inst_name = seq_comm_name(COMPID) + inst_index = seq_comm_inst(COMPID) + inst_suffix = seq_comm_suffix(COMPID) + + if (phase == 1) then + ! Determine communicator groups and sizes + call mpi_comm_rank(mpicom, my_task, ierr) + call mpi_comm_size(mpicom, npes, ierr) + + !--- open log file --- + if (my_task == master_task) then + logUnit = shr_file_getUnit() + call shr_file_setIO('atm_modelio.nml'//trim(inst_suffix),logUnit) + else + logUnit = 6 + endif + endif + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (logUnit) + + if (phase == 1) then + + !---------------------------------------------------------------------------- + ! Set a Few Defaults + !---------------------------------------------------------------------------- + + call seq_infodata_getData(infodata,single_column=scmMode, & + & scmlat=scmlat, scmlon=scmLon) + call seq_infodata_GetData(infodata,orb_eccen=orbEccen,orb_mvelpp=orbMvelpp, & + orb_lambm0=orbLambm0,orb_obliqr=orbObliqr ) + + atm_present = .false. + atm_prognostic = .false. + call seq_infodata_GetData(infodata,read_restart=read_restart) + + ! TJH this prevents the need to have a COUPLER restart file. + ! TJH From an email to Bill Sacks from Tony Craig dated 2011/8/12 + ! TJH one line change to models/atm/datm/datm_comp_mod.F90 + + read_restart = .false. + + !---------------------------------------------------------------------------- + ! Read datm_in + !---------------------------------------------------------------------------- + + call t_startf('datm_readnml') + + filename = "datm_in"//trim(inst_suffix) + atm_in = "unset" + decomp = "1d" + iradsw = 0 + factorFn = 'null' + restfilm = trim(nullstr) + restfils = trim(nullstr) + presaero = .false. + if (my_task == master_task) then + nunit = shr_file_getUnit() ! get unused unit number + open (nunit,file=trim(filename),status="old",action="read") + read (nunit,nml=datm_nml,iostat=ierr) + close(nunit) + call shr_file_freeUnit(nunit) + if (ierr > 0) then + write(logunit,F01) 'ERROR: reading input namelist, '//trim(filename)//' iostat=',ierr + call shr_sys_abort(subName//': namelist read error '//trim(filename)) + end if + write(logunit,F00)' atm_in = ',trim(atm_in) + write(logunit,F00)' decomp = ',trim(decomp) + write(logunit,F01)' iradsw = ',iradsw + write(logunit,F00)' factorFn = ',trim(factorFn) + write(logunit,F00)' restfilm = ',trim(restfilm) + write(logunit,F00)' restfils = ',trim(restfils) + write(logunit,F0L)' presaero = ',presaero + write(logunit,F01) 'inst_index = ',inst_index + write(logunit,F00) 'inst_name = ',trim(inst_name) + write(logunit,F00) 'inst_suffix = ',trim(inst_suffix) + call shr_sys_flush(logunit) + endif + call shr_mpi_bcast(atm_in,mpicom,'atm_in') + call shr_mpi_bcast(decomp,mpicom,'decomp') + call shr_mpi_bcast(iradsw,mpicom,'iradsw') + call shr_mpi_bcast(factorFn,mpicom,'factorFn') + call shr_mpi_bcast(restfilm,mpicom,'restfilm') + call shr_mpi_bcast(restfils,mpicom,'restfils') + call shr_mpi_bcast(presaero,mpicom,'presaero') + + rest_file = trim(restfilm) + rest_file_strm = trim(restfils) + + !---------------------------------------------------------------------------- + ! Read dshr namelist + !---------------------------------------------------------------------------- + + call shr_strdata_readnml(SDATM,trim(atm_in),mpicom=mpicom) + call shr_sys_flush(shrlogunit) + + !---------------------------------------------------------------------------- + ! Initialize PIO + !---------------------------------------------------------------------------- + + call shr_strdata_pioinit(SDATM, shr_pio_getiosys(trim(inst_name)), & + shr_pio_getiotype(trim(inst_name))) + + !---------------------------------------------------------------------------- + ! Validate mode + !---------------------------------------------------------------------------- + + atm_mode = trim(SDATM%dataMode) + + ! check that we know how to handle the mode + + if (trim(atm_mode) == 'NULL' .or. & + trim(atm_mode) == 'CORE2_NYF' .or. & + trim(atm_mode) == 'CORE2_IAF' .or. & + trim(atm_mode) == 'WRF' .or. & + trim(atm_mode) == 'CLMNCEP' .or. & + trim(atm_mode) == 'CPLHIST' .or. & + trim(atm_mode) == 'COPYALL' ) then + if (my_task == master_task) then + write(logunit,F00) ' atm mode = ',trim(atm_mode) + call shr_sys_flush(logunit) + end if + else + write(logunit,F00) ' ERROR illegal atm mode = ',trim(atm_mode) + call shr_sys_abort() + endif + + call t_stopf('datm_readnml') + + !---------------------------------------------------------------------------- + ! Initialize datasets + !---------------------------------------------------------------------------- + + call t_startf('datm_strdata_init') + + if (trim(atm_mode) /= 'NULL') then + atm_present = .true. + call seq_timemgr_EClockGetData( EClock, dtime=idt, calendar=calendar ) + if (scmmode) then + if (my_task == master_task) & + write(logunit,F05) ' scm lon lat = ',scmlon,scmlat + call shr_strdata_init(SDATM,mpicom,compid,name='atm', & + scmmode=scmmode,scmlon=scmlon,scmlat=scmlat, & + calendar=calendar) + else + call shr_strdata_init(SDATM,mpicom,compid,name='atm', & + calendar=calendar) + endif + if (my_task == master_task) call shr_sys_flush(shrlogunit) + !--- overwrite mask and frac --- + k = mct_aVect_indexRA(SDATM%grid%data,'mask') + SDATM%grid%data%rAttr(k,:) = 1.0_R8 + k = mct_aVect_indexRA(SDATM%grid%data,'frac') + SDATM%grid%data%rAttr(k,:) = 1.0_R8 + + !--- set data needed for cosz t-interp method --- + + call shr_strdata_setOrbs(SDATM,orbEccen,orbMvelpp,orbLambm0,orbObliqr,idt) + endif + + if (my_task == master_task) then + call shr_strdata_print(SDATM,'ATM data') + call shr_sys_flush(shrlogunit) + endif + + call t_stopf('datm_strdata_init') + + !---------------------------------------------------------------------------- + ! Set flag to specify data components + !---------------------------------------------------------------------------- + + call seq_infodata_PutData(infodata, & + atm_present=atm_present, atm_prognostic=atm_prognostic, & + atm_nx=SDATM%nxg, atm_ny=SDATM%nyg ) + call seq_infodata_PutData( infodata, atm_aero=presaero) + + !---------------------------------------------------------------------------- + ! Initialize MCT global seg map, 1d decomp + !---------------------------------------------------------------------------- + + call t_startf('datm_initgsmaps') + if (my_task == master_task) write(logunit,F00) ' initialize gsmaps' + call shr_sys_flush(logunit) + + call shr_dmodel_gsmapcreate(gsmap,SDATM%nxg*SDATM%nyg,compid,mpicom,decomp) + call shr_sys_flush(shrlogunit) + lsize = mct_gsmap_lsize(gsmap,mpicom) + + if (atm_present) then + call mct_rearr_init(SDATM%gsmap,gsmap,mpicom,rearr) + endif + + call t_stopf('datm_initgsmaps') + + !---------------------------------------------------------------------------- + ! Initialize MCT domain + !---------------------------------------------------------------------------- + + call t_startf('datm_initmctdom') + if (my_task == master_task) write(logunit,F00) 'copy domains' + call shr_sys_flush(logunit) + + if (atm_present)then + call shr_dmodel_rearrGGrid(SDATM%grid, ggrid, gsmap, rearr, mpicom) + call shr_sys_flush(shrlogunit) + end if + + call t_stopf('datm_initmctdom') + + !---------------------------------------------------------------------------- + ! Initialize MCT attribute vectors + !---------------------------------------------------------------------------- + + call t_startf('datm_initmctavs') + if (my_task == master_task) write(logunit,F00) 'allocate AVs' + call shr_sys_flush(logunit) + + call mct_aVect_init(a2x, rList=seq_flds_a2x_fields, lsize=lsize) + call mct_aVect_zero(a2x) + + kz = mct_aVect_indexRA(a2x,'Sa_z') + ku = mct_aVect_indexRA(a2x,'Sa_u') + kv = mct_aVect_indexRA(a2x,'Sa_v') + ktbot = mct_aVect_indexRA(a2x,'Sa_tbot') + kptem = mct_aVect_indexRA(a2x,'Sa_ptem') + kshum = mct_aVect_indexRA(a2x,'Sa_shum') + kdens = mct_aVect_indexRA(a2x,'Sa_dens') + kpbot = mct_aVect_indexRA(a2x,'Sa_pbot') + kpslv = mct_aVect_indexRA(a2x,'Sa_pslv') + klwdn = mct_aVect_indexRA(a2x,'Faxa_lwdn') + krc = mct_aVect_indexRA(a2x,'Faxa_rainc') + krl = mct_aVect_indexRA(a2x,'Faxa_rainl') + ksc = mct_aVect_indexRA(a2x,'Faxa_snowc') + ksl = mct_aVect_indexRA(a2x,'Faxa_snowl') + kswndr= mct_aVect_indexRA(a2x,'Faxa_swndr') + kswndf= mct_aVect_indexRA(a2x,'Faxa_swndf') + kswvdr= mct_aVect_indexRA(a2x,'Faxa_swvdr') + kswvdf= mct_aVect_indexRA(a2x,'Faxa_swvdf') + kswnet= mct_aVect_indexRA(a2x,'Faxa_swnet') + kco2p = mct_aVect_indexRA(a2x,'Sa_co2prog',perrWith='quiet') + kco2d = mct_aVect_indexRA(a2x,'Sa_co2diag',perrWith='quiet') + + kbid = mct_aVect_indexRA(a2x,'Faxa_bcphidry') + kbod = mct_aVect_indexRA(a2x,'Faxa_bcphodry') + kbiw = mct_aVect_indexRA(a2x,'Faxa_bcphiwet') + koid = mct_aVect_indexRA(a2x,'Faxa_ocphidry') + kood = mct_aVect_indexRA(a2x,'Faxa_ocphodry') + koiw = mct_aVect_indexRA(a2x,'Faxa_ocphiwet') + kdd1 = mct_aVect_indexRA(a2x,'Faxa_dstdry1') + kdd2 = mct_aVect_indexRA(a2x,'Faxa_dstdry2') + kdd3 = mct_aVect_indexRA(a2x,'Faxa_dstdry3') + kdd4 = mct_aVect_indexRA(a2x,'Faxa_dstdry4') + kdw1 = mct_aVect_indexRA(a2x,'Faxa_dstwet1') + kdw2 = mct_aVect_indexRA(a2x,'Faxa_dstwet2') + kdw3 = mct_aVect_indexRA(a2x,'Faxa_dstwet3') + kdw4 = mct_aVect_indexRA(a2x,'Faxa_dstwet4') + + call mct_aVect_init(x2a, rList=seq_flds_x2a_fields, lsize=lsize) + call mct_aVect_zero(x2a) + + kanidr = mct_aVect_indexRA(x2a,'Sx_anidr') + kanidf = mct_aVect_indexRA(x2a,'Sx_anidf') + kavsdr = mct_aVect_indexRA(x2a,'Sx_avsdr') + kavsdf = mct_aVect_indexRA(x2a,'Sx_avsdf') + + !--- figure out what's on the streams --- + cnt = 0 + flds_strm = '' + do n = 1,SDATM%nstreams + do k = 1,ktranss + kfld = mct_aVect_indexRA(SDATM%avs(n),trim(stifld(k)),perrWith='quiet') + if (kfld > 0) then + cnt = cnt + 1 + if (cnt == 1) then + flds_strm = trim(stofld(k)) + else + flds_strm = trim(flds_strm)//':'//trim(stofld(k)) + endif + endif + enddo + enddo + if (my_task == master_task) write(logunit,F00) ' flds_strm = ',trim(flds_strm) + call shr_sys_flush(logunit) + + call mct_aVect_init(avstrm, rList=flds_strm, lsize=lsize) + call mct_aVect_zero(avstrm) + + stbot = mct_aVect_indexRA(avstrm,'strm_tbot',perrWith='quiet') + swind = mct_aVect_indexRA(avstrm,'strm_wind',perrWith='quiet') + sz = mct_aVect_indexRA(avstrm,'strm_z',perrWith='quiet') + spbot = mct_aVect_indexRA(avstrm,'strm_pbot',perrWith='quiet') + sshum = mct_aVect_indexRA(avstrm,'strm_shum',perrWith='quiet') + stdew = mct_aVect_indexRA(avstrm,'strm_tdew',perrWith='quiet') + srh = mct_aVect_indexRA(avstrm,'strm_rh',perrWith='quiet') + slwdn = mct_aVect_indexRA(avstrm,'strm_lwdn',perrWith='quiet') + sswdn = mct_aVect_indexRA(avstrm,'strm_swdn',perrWith='quiet') + sswdndf= mct_aVect_indexRA(avstrm,'strm_swdndf',perrWith='quiet') + sswdndr= mct_aVect_indexRA(avstrm,'strm_swdndr',perrWith='quiet') + sprecc = mct_aVect_indexRA(avstrm,'strm_precc',perrWith='quiet') + sprecl = mct_aVect_indexRA(avstrm,'strm_precl',perrWith='quiet') + sprecn = mct_aVect_indexRA(avstrm,'strm_precn',perrWith='quiet') + sco2p = mct_aVect_indexRA(avstrm,'strm_co2p',perrWith='quiet') + sco2d = mct_aVect_indexRA(avstrm,'strm_co2d',perrWith='quiet') + sswup = mct_aVect_indexRA(avstrm,'strm_swup',perrWith='quiet') + sprec = mct_aVect_indexRA(avstrm,'strm_prec',perrWith='quiet') + starcf = mct_aVect_indexRA(avstrm,'strm_tarcf',perrWith='quiet') + + allocate(imask(lsize)) + allocate(yc(lsize)) + allocate(windFactor(lsize)) + allocate(winddFactor(lsize)) + allocate(qsatFactor(lsize)) + + kmask = mct_aVect_indexRA(ggrid%data,'mask') + imask(:) = nint(ggrid%data%rAttr(kmask,:)) + klat = mct_aVect_indexRA(ggrid%data,'lat') + yc(:) = ggrid%data%rAttr(klat,:) + + call t_stopf('datm_initmctavs') + + !---------------------------------------------------------------------------- + ! Read restart + !---------------------------------------------------------------------------- + + if (read_restart) then + if (trim(rest_file) == trim(nullstr) .and. & + trim(rest_file_strm) == trim(nullstr)) then + if (my_task == master_task) then + write(logunit,F00) ' restart filenames from rpointer' + call shr_sys_flush(logunit) + inquire(file=trim(rpfile)//trim(inst_suffix),exist=exists) + if (.not.exists) then + write(logunit,F00) ' ERROR: rpointer file does not exist' + call shr_sys_abort(trim(subname)//' ERROR: rpointer file missing') + endif + nu = shr_file_getUnit() + open(nu,file=trim(rpfile)//trim(inst_suffix),form='formatted') + read(nu,'(a)') rest_file + read(nu,'(a)') rest_file_strm + close(nu) + call shr_file_freeUnit(nu) + inquire(file=trim(rest_file_strm),exist=exists) + endif + call shr_mpi_bcast(rest_file,mpicom,'rest_file') + call shr_mpi_bcast(rest_file_strm,mpicom,'rest_file_strm') + else + ! use namelist already read + if (my_task == master_task) then + write(logunit,F00) ' restart filenames from namelist ' + call shr_sys_flush(logunit) + inquire(file=trim(rest_file_strm),exist=exists) + endif + endif + call shr_mpi_bcast(exists,mpicom,'exists') +! if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file) +! call shr_pcdf_readwrite('read',trim(rest_file),mpicom,gsmap,rf1=somtp,rf1n='somtp') + if (exists) then + if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file_strm) + call shr_strdata_restRead(trim(rest_file_strm),SDATM,mpicom) + else + if (my_task == master_task) write(logunit,F00) ' file not found, skipping ',trim(rest_file_strm) + endif + call shr_sys_flush(logunit) + endif + + if (read_restart) then + call seq_timemgr_EClockGetData( EClock, curr_ymd=CurrentYMD, curr_tod=CurrentTOD) + call seq_timemgr_EClockGetData( EClock, stepno=stepno, dtime=idt ) + call seq_timemgr_EClockGetData( EClock, calendar=calendar ) + nextsw_cday = datm_shr_getNextRadCDay( CurrentYMD, CurrentTOD, stepno, idt, iradsw, calendar ) + else + call seq_timemgr_EClockGetData( EClock, curr_cday=nextsw_cday, stepno=stepno ) + endif + call seq_infodata_PutData(infodata, nextsw_cday=nextsw_cday ) + + else + + call seq_timemgr_EClockGetData( EClock, curr_ymd=CurrentYMD, curr_tod=CurrentTOD) + call seq_timemgr_EClockGetData( EClock, stepno=stepno, dtime=idt) + call seq_timemgr_EClockGetData( EClock, calendar=calendar ) + nextsw_cday = datm_shr_getNextRadCDay( CurrentYMD, CurrentTOD, stepno, idt, iradsw, calendar ) + call seq_infodata_PutData(infodata, nextsw_cday=nextsw_cday ) + + endif + + !---------------------------------------------------------------------------- + ! Set initial atm state, needed for CCSM atm initialization + !---------------------------------------------------------------------------- + + call t_adj_detailf(+2) + call datm_comp_run( EClock, cdata, x2a, a2x) + call t_adj_detailf(-2) + + !---------------------------------------------------------------------------- + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + if (my_task == master_task) write(logunit,F00) 'datm_comp_init done' + call shr_sys_flush(logunit) + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + call shr_sys_flush(logunit) + + call t_stopf('DATM_INIT') + +end subroutine datm_comp_init + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: datm_comp_run +! +! !DESCRIPTION: +! run method for dead atm model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine datm_comp_run( EClock, cdata, x2a, a2x) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) ,intent(in) :: EClock + type(seq_cdata) ,intent(inout) :: cdata + type(mct_aVect) ,intent(inout) :: x2a ! driver -> dead + type(mct_aVect) ,intent(inout) :: a2x ! dead -> driver + +!EOP + + !--- local --- + type(mct_gsMap) , pointer :: gsMap + type(mct_gGrid) , pointer :: ggrid + + integer(IN) :: CurrentYMD ! model date + integer(IN) :: CurrentTOD ! model sec into model date + integer(IN) :: yy,mm,dd ! year month day + integer(IN) :: n ! indices + integer(IN) :: lsize ! size of attr vect + integer(IN) :: shrlogunit, shrloglev ! original log unit and level + logical :: mssrmlf ! remove old data + integer(IN) :: idt ! integer timestep + real(R8) :: dt ! timestep + logical :: write_restart ! restart now + character(CL) :: case_name ! case name + character(CL) :: rest_file ! restart_file + character(CL) :: rest_file_strm ! restart_file + integer(IN) :: nu ! unit number + integer(IN) :: stepno ! step number + real(R8) :: nextsw_cday ! calendar of next atm sw + integer(IN) :: eday ! elapsed day + real(R8) :: rday ! elapsed day + real(R8) :: cosFactor ! cosine factor + real(R8) :: factor ! generic/temporary correction factor + real(R8) :: avg_alb ! average albedo + real(R8) :: tMin ! minimum temperature + character(CL) :: calendar ! calendar type + + !--- temporaries + real(R8) :: uprime,vprime,swndr,swndf,swvdr,swvdf,ratio_rvrf + real(R8) :: tbot,pbot,rtmp,vp,ea,e,qsat,frac,qsatT + + type(seq_infodata_type), pointer :: infodata + + character(*), parameter :: F00 = "('(datm_comp_run) ',8a)" + character(*), parameter :: F04 = "('(datm_comp_run) ',2a,2i8,'s')" + character(*), parameter :: subName = "(datm_comp_run) " +!------------------------------------------------------------------------------- + + call t_startf('DATM_RUN') + + call t_startf('datm_run1') + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (logUnit) + + call seq_cdata_setptrs(cdata, gsMap=gsmap, dom=ggrid) + + call seq_cdata_setptrs(cdata, infodata=infodata) + + call seq_timemgr_EClockGetData( EClock, curr_ymd=CurrentYMD, curr_tod=CurrentTOD) + call seq_timemgr_EClockGetData( EClock, curr_yr=yy, curr_mon=mm, curr_day=dd) + call seq_timemgr_EClockGetData( EClock, stepno=stepno, dtime=idt) + call seq_timemgr_EClockGetData( EClock, calendar=calendar) + dt = idt * 1.0_r8 + write_restart = seq_timemgr_RestartAlarmIsOn(EClock) + + call t_stopf('datm_run1') + + !-------------------- + ! ADVANCE ATM + !-------------------- + + call t_barrierf('datm_BARRIER',mpicom) + call t_startf('datm') + + nextsw_cday = datm_shr_getNextRadCDay( CurrentYMD, CurrentTOD, stepno, idt, iradsw, calendar ) + call seq_infodata_PutData(infodata, nextsw_cday=nextsw_cday ) + + !--- copy all fields from streams to a2x as default --- + + if (trim(atm_mode) /= 'NULL') then + call t_startf('datm_strdata_advance') + call shr_strdata_advance(SDATM,currentYMD,currentTOD,mpicom,'datm') + call t_stopf('datm_strdata_advance') + call t_barrierf('datm_scatter_BARRIER',mpicom) + call t_startf('datm_scatter') + if (trim(atm_mode) /= 'COPYALL') then + lsize = mct_avect_lsize(a2x) + do n = 1,lsize + a2x%rAttr(kbid,n) = aerodep_spval + a2x%rAttr(kbod,n) = aerodep_spval + a2x%rAttr(kbiw,n) = aerodep_spval + a2x%rAttr(koid,n) = aerodep_spval + a2x%rAttr(kood,n) = aerodep_spval + a2x%rAttr(koiw,n) = aerodep_spval + a2x%rAttr(kdd1,n) = aerodep_spval + a2x%rAttr(kdd2,n) = aerodep_spval + a2x%rAttr(kdd3,n) = aerodep_spval + a2x%rAttr(kdd4,n) = aerodep_spval + a2x%rAttr(kdw1,n) = aerodep_spval + a2x%rAttr(kdw2,n) = aerodep_spval + a2x%rAttr(kdw3,n) = aerodep_spval + a2x%rAttr(kdw4,n) = aerodep_spval + enddo + endif + if (firstcall) then + allocate(ilist_av(SDATM%nstreams)) + allocate(olist_av(SDATM%nstreams)) + allocate(ilist_st(SDATM%nstreams)) + allocate(olist_st(SDATM%nstreams)) + allocate(count_av(SDATM%nstreams)) + allocate(count_st(SDATM%nstreams)) + end if + do n = 1,SDATM%nstreams + if (firstcall) then + call shr_dmodel_translate_list(SDATM%avs(n),a2x,& + avifld,avofld,ilist_av(n),olist_av(n),count_av(n)) + end if + if (count_av(n) > 0) then + call shr_dmodel_translateAV_list(SDATM%avs(n),a2x,& + ilist_av(n),olist_av(n),rearr) + end if + enddo + do n = 1,SDATM%nstreams + if (firstcall) then + call shr_dmodel_translate_list(SDATM%avs(n),avstrm,& + stifld,stofld,ilist_st(n),olist_st(n),count_st(n)) + end if + if (count_st(n) > 0) then + call shr_dmodel_translateAV_list(SDATM%avs(n),avstrm,& + ilist_st(n),olist_st(n),rearr) + end if + enddo + + call t_stopf('datm_scatter') + else + call mct_aVect_zero(a2x) + endif + + call t_startf('datm_mode') + + select case (trim(atm_mode)) + + case('COPYALL') + ! do nothing extra + + case('CPLHIST') + ! do nothing extra + + case ('WRF') + lsize = mct_avect_lsize(a2x) + do n = 1,lsize + + !--- fabricate required swdn components from total swdn --- + a2x%rAttr(kswvdr,n) = avstrm%rAttr(sswdn,n)*(0.28_R8) + a2x%rAttr(kswndr,n) = avstrm%rAttr(sswdn,n)*(0.31_R8) + a2x%rAttr(kswvdf,n) = avstrm%rAttr(sswdn,n)*(0.24_R8) + a2x%rAttr(kswndf,n) = avstrm%rAttr(sswdn,n)*(0.17_R8) + + !--- just a diagnostic, not really needed + a2x%rAttr(kswnet,n) = avstrm%rAttr(sswdn,n)-avstrm%rAttr(sswup,n) + + !--- convert from hPa + a2x%rAttr(kpslv,n) = a2x%rAttr(kpslv,n)*100._R8 + a2x%rAttr(kpbot,n) = a2x%rAttr(kpbot,n)*100._R8 + +! !--- fix dens problem in dataset, should be about "1" +! if (a2x%rAttr(kdens,n) < 0.01) & +! a2x%rAttr(kdens,n) = a2x%rAttr(kdens,n)*10000._R8 + +! !--- set z to at least 10m +! a2x%rAttr(kz,n) = max(10.0_R8,a2x%rAttr(kz,n)) + !--- tcraig, file has terrain height on it, set to 10m + a2x%rAttr(kz,n) = 10.0_R8 + +! !--- compute theta from tbot and pbot as in WRF +! !--- tcraig now from WRF input data +! a2x%rAttr(kptem,n) = a2x%rAttr(ktbot,n) / ((a2x%rAttr(kpbot)/1.0e6)**0.2854) + + !--- convert to degK from degC + a2x%rAttr(ktbot,n) = a2x%rAttr(ktbot,n) + tKFrz + + enddo + + case('CORE2_NYF','CORE2_IAF') + if (firstcall) then + if (sprec < 1 .or. sswdn < 1) then + write(logunit,F00) 'ERROR: prec and swdn must be in streams for CORE2' + call shr_sys_abort(trim(subname)//'ERROR: prec and swdn must be in streams for CORE2') + endif + if (trim(atm_mode) == 'CORE2_IAF' ) then + if (starcf < 1 ) then + write(logunit,F00) 'ERROR: tarcf must be in an input stream for CORE2_IAF' + call shr_sys_abort(trim(subname)//'tarcf must be in an input stream for CORE2_IAF') + endif + endif + call datm_shr_CORE2getFactors(factorFn,windFactor,winddFactor,qsatFactor, & + mpicom,compid,gsmap,ggrid,SDATM%nxg,SDATM%nyg) + endif + ! call shr_cal_date2eday(currentYMD,eday,calendar) + ! rday = mod(eday,365) + real(currentTOD)/SHR_CONST_CDAY + call shr_cal_date2julian(currentYMD,currentTOD,rday,calendar) + rday = mod((rday - 1.0_R8),365.0_R8) + cosfactor = cos((2.0_R8*SHR_CONST_PI*rday)/365 - phs_c0) + + lsize = mct_avect_lsize(a2x) + do n = 1,lsize + a2x%rAttr(kz,n) = 10.0_R8 + + !--- correction to NCEP winds based on QSCAT --- + uprime = a2x%rAttr(ku,n)*windFactor(n) + vprime = a2x%rAttr(kv,n)*windFactor(n) + a2x%rAttr(ku,n) = uprime*cos(winddFactor(n)*degtorad)- & + vprime*sin(winddFactor(n)*degtorad) + a2x%rAttr(kv,n) = uprime*sin(winddFactor(n)*degtorad)+ & + vprime*cos(winddFactor(n)*degtorad) + + !--- density, tbot, & pslv taken directly from input stream, set pbot --- + ! a2x%rAttr(kdens,n) = + ! a2x%rAttr(ktbot,n) = + ! a2x%rAttr(kpslv,n) = + a2x%rAttr(kpbot,n) = a2x%rAttr(kpslv,n) + + !--- correction to NCEP Arctic & Antarctic air T & potential T --- + if ( yc(n) < -60.0_R8 ) then + tMin = (avg_c0 + avg_c1*yc(n)) + (amp_c0 + amp_c1*yc(n))*cosFactor + tKFrz + a2x%rAttr(ktbot,n) = max(a2x%rAttr(ktbot,n), tMin) + else if ( yc(n) > 60.0_R8 ) then + factor = MIN(1.0_R8, 0.1_R8*(yc(n)-60.0_R8) ) + a2x%rAttr(ktbot,n) = a2x%rAttr(ktbot,n) + factor * dTarc(mm) + endif + a2x%rAttr(kptem,n) = a2x%rAttr(ktbot,n) + + !--- correction to NCEP relative humidity for heat budget balance --- + a2x%rAttr(kshum,n) = a2x%rAttr(kshum,n) + qsatFactor(n) + + !--- Dupont correction to NCEP Arctic air T --- + !--- don't correct during summer months (July-September) + !--- ONLY correct when forcing year is 1997->2004 + if (trim(atm_mode) == 'CORE2_IAF' ) then + a2x%rAttr(ktbot,n) = a2x%rAttr(ktbot,n) + avstrm%rAttr(starcf,n) + a2x%rAttr(kptem,n) = a2x%rAttr(ktbot,n) + end if + + !------------------------------------------------------------------------- + ! PRECIPITATION DATA + !------------------------------------------------------------------------- + + avstrm%rAttr(sprec,n) = avstrm%rAttr(sprec,n)/86400.0_R8 ! convert mm/day to kg/m^2/s + + ! only correct satellite products, do not correct Serreze Arctic data + if ( yc(n) < 58. ) then + avstrm%rAttr(sprec,n) = avstrm%rAttr(sprec,n)*1.14168_R8 + endif + if ( yc(n) >= 58. .and. yc(n) < 68. ) then + factor = MAX(0.0_R8, 1.0_R8 - 0.1_R8*(yc(n)-58.0_R8) ) + avstrm%rAttr(sprec,n) = avstrm%rAttr(sprec,n)*(factor*(1.14168_R8 - 1.0_R8) + 1.0_R8) + endif + + a2x%rAttr(krc,n) = 0.0_R8 ! default zero + a2x%rAttr(ksc,n) = 0.0_R8 + if (a2x%rAttr(ktbot,n) < tKFrz ) then ! assign precip to rain/snow components + a2x%rAttr(krl,n) = 0.0_R8 + a2x%rAttr(ksl,n) = avstrm%rAttr(sprec,n) + else + a2x%rAttr(krl,n) = avstrm%rAttr(sprec,n) + a2x%rAttr(ksl,n) = 0.0_R8 + endif + + !------------------------------------------------------------------------- + ! RADIATION DATA + !------------------------------------------------------------------------- + + !--- fabricate required swdn components from net swdn --- + a2x%rAttr(kswvdr,n) = avstrm%rAttr(sswdn,n)*(0.28_R8) + a2x%rAttr(kswndr,n) = avstrm%rAttr(sswdn,n)*(0.31_R8) + a2x%rAttr(kswvdf,n) = avstrm%rAttr(sswdn,n)*(0.24_R8) + a2x%rAttr(kswndf,n) = avstrm%rAttr(sswdn,n)*(0.17_R8) + + !--- compute net short-wave based on LY08 latitudinally-varying albedo --- + avg_alb = ( 0.069 - 0.011*cos(2.0_R8*yc(n)*degtorad ) ) + a2x%rAttr(kswnet,n) = avstrm%rAttr(sswdn,n)*(1.0_R8 - avg_alb) + + !--- corrections to GISS sswdn for heat budget balancing --- + factor = 1.0_R8 + if ( -60.0_R8 < yc(n) .and. yc(n) < -50.0_R8 ) then + factor = 1.0_R8 - (yc(n) + 60.0_R8)*(0.05_R8/10.0_R8) + else if ( -50.0_R8 < yc(n) .and. yc(n) < 30.0_R8 ) then + factor = 0.95_R8 + else if ( 30.0_R8 < yc(n) .and. yc(n) < 40._R8 ) then + factor = 1.0_R8 - (40.0_R8 - yc(n))*(0.05_R8/10.0_R8) + endif + a2x%rAttr(kswnet,n) = a2x%rAttr(kswnet,n)*factor + a2x%rAttr(kswvdr,n) = a2x%rAttr(kswvdr,n)*factor + a2x%rAttr(kswndr,n) = a2x%rAttr(kswndr,n)*factor + a2x%rAttr(kswvdf,n) = a2x%rAttr(kswvdf,n)*factor + a2x%rAttr(kswndf,n) = a2x%rAttr(kswndf,n)*factor + + !--- correction to GISS lwdn in Arctic --- + if ( yc(n) > 60._R8 ) then + factor = MIN(1.0_R8, 0.1_R8*(yc(n)-60.0_R8) ) + a2x%rAttr(klwdn,n) = a2x%rAttr(klwdn,n) + factor * dLWarc + endif + + enddo ! lsize + + case('CLMNCEP') + if (firstcall) then + if (swind < 1 .or. stbot < 1) then + write(logunit,F00) ' ERROR: wind and tbot must be in streams for CLMNCEP' + call shr_sys_abort(trim(subname)//' ERROR: wind and tbot must be in streams for CLMNCEP') + endif + rtmp = maxval(a2x%rAttr(ktbot,:)) + call shr_mpi_max(rtmp,tbotmax,mpicom,'datm_tbot',all=.true.) + rtmp = maxval(x2a%rAttr(kanidr,:)) + call shr_mpi_max(rtmp,anidrmax,mpicom,'datm_ani',all=.true.) + if (stdew > 0) then + rtmp = maxval(avstrm%rAttr(stdew,:)) + call shr_mpi_max(rtmp,tdewmax,mpicom,'datm_tdew',all=.true.) + endif + if (my_task == master_task) & + write(logunit,*) trim(subname),' max values = ',tbotmax,tdewmax,anidrmax + endif + lsize = mct_avect_lsize(a2x) + do n = 1,lsize + !--- bottom layer height --- + if (sz < 1) a2x%rAttr(kz,n) = 30.0_R8 + + !--- temperature --- + if (tbotmax < 50.0_R8) a2x%rAttr(ktbot,n) = a2x%rAttr(ktbot,n) + tkFrz + a2x%rAttr(kptem,n) = a2x%rAttr(ktbot,n) + + !--- pressure --- + if (spbot < 1) a2x%rAttr(kpbot,n) = pstd + a2x%rAttr(kpslv,n) = a2x%rAttr(kpbot,n) + + !--- u, v wind velocity --- + a2x%rAttr(ku,n) = avstrm%rAttr(swind,n)/sqrt(2.0_R8) + a2x%rAttr(kv,n) = a2x%rAttr(ku,n) + + !--- specific humidity --- + tbot = a2x%rAttr(ktbot,n) + pbot = a2x%rAttr(kpbot,n) + if (sshum > 0) then + e = datm_shr_esat(tbot,tbot) + qsat = (0.622_R8 * e)/(pbot - 0.378_R8 * e) + if (qsat < a2x%rAttr(kshum,n)) then + a2x%rAttr(kshum,n) = qsat + endif + else if (srh > 0) then + e = avstrm%rAttr(srh,n) * 0.01_R8 * datm_shr_esat(tbot,tbot) + qsat = (0.622_R8 * e)/(pbot - 0.378_R8 * e) + a2x%rAttr(kshum,n) = qsat + else if (stdew > 0) then + if (tdewmax < 50.0_R8) avstrm%rAttr(stdew,n) = avstrm%rAttr(stdew,n) + tkFrz + e = datm_shr_esat(avstrm%rAttr(stdew,n),tbot) + qsat = (0.622_R8 * e)/(pbot - 0.378_R8 * e) + a2x%rAttr(kshum,n) = qsat + else + call shr_sys_abort(subname//'ERROR: cannot compute shum') + endif + + !--- density --- + vp = (a2x%rAttr(kshum,n)*pbot) / (0.622_R8 + 0.378_R8 * a2x%rAttr(kshum,n)) + a2x%rAttr(kdens,n) = (pbot - 0.378_R8 * vp) / (tbot*rdair) + + !--- downward longwave --- + if (slwdn < 1) then + e = a2x%rAttr(kpslv,n) * a2x%rAttr(kshum,n) / (0.622_R8 + 0.378_R8 * a2x%rAttr(kshum,n)) + ea = 0.70_R8 + 5.95e-05_R8 * 0.01_R8 * e * exp(1500.0_R8/tbot) + a2x%rAttr(klwdn,n) = ea * stebol * tbot**4 + endif + + !--- shortwave radiation --- + if (sswdndf > 0 .and. sswdndr > 0) then + a2x%rAttr(kswndr,n) = avstrm%rAttr(sswdndr,n) * 0.50_R8 + a2x%rAttr(kswvdr,n) = avstrm%rAttr(sswdndr,n) * 0.50_R8 + a2x%rAttr(kswndf,n) = avstrm%rAttr(sswdndf,n) * 0.50_R8 + a2x%rAttr(kswvdf,n) = avstrm%rAttr(sswdndf,n) * 0.50_R8 + elseif (sswdn > 0) then + ! relationship between incoming NIR or VIS radiation and ratio of + ! direct to diffuse radiation calculated based on one year's worth of + ! hourly CAM output from CAM version cam3_5_55 + swndr = avstrm%rAttr(sswdn,n) * 0.50_R8 + ratio_rvrf = min(0.99_R8,max(0.29548_R8 + 0.00504_R8*swndr & + -1.4957e-05_R8*swndr**2 + 1.4881e-08_R8*swndr**3,0.01_R8)) + a2x%rAttr(kswndr,n) = ratio_rvrf*swndr + swndf = avstrm%rAttr(sswdn,n) * 0.50_R8 + a2x%rAttr(kswndf,n) = (1._R8 - ratio_rvrf)*swndf + + swvdr = avstrm%rAttr(sswdn,n) * 0.50_R8 + ratio_rvrf = min(0.99_R8,max(0.17639_R8 + 0.00380_R8*swvdr & + -9.0039e-06_R8*swvdr**2 + 8.1351e-09_R8*swvdr**3,0.01_R8)) + a2x%rAttr(kswvdr,n) = ratio_rvrf*swvdr + swvdf = avstrm%rAttr(sswdn,n) * 0.50_R8 + a2x%rAttr(kswvdf,n) = (1._R8 - ratio_rvrf)*swvdf + else + call shr_sys_abort(subName//'ERROR: cannot compute short-wave down') + endif + + !--- swnet: a diagnostic quantity --- + if (anidrmax < 1.0e-8 .or. anidrmax > SHR_CONST_SPVAL * 0.9_R8) then + a2x%rAttr(kswnet,n) = 0.0_R8 + else + a2x%rAttr(kswnet,n) = (1.0_R8-x2a%rAttr(kanidr,n))*a2x%rAttr(kswndr,n) + & + (1.0_R8-x2a%rAttr(kavsdr,n))*a2x%rAttr(kswvdr,n) + & + (1.0_R8-x2a%rAttr(kanidf,n))*a2x%rAttr(kswndf,n) + & + (1.0_R8-x2a%rAttr(kavsdf,n))*a2x%rAttr(kswvdf,n) + endif + + !--- rain and snow --- + if (sprecc > 0 .and. sprecl > 0) then + a2x%rAttr(krc,n) = avstrm%rAttr(sprecc,n) + a2x%rAttr(krl,n) = avstrm%rAttr(sprecl,n) + elseif (sprecn > 0) then + a2x%rAttr(krc,n) = avstrm%rAttr(sprecn,n)*0.1_R8 + a2x%rAttr(krl,n) = avstrm%rAttr(sprecn,n)*0.9_R8 + else + call shr_sys_abort(subName//'ERROR: cannot compute rain and snow') + endif + + !--- split precip between rain & snow --- + !--- note: aribitrarily small negative values cause CLM to crash --- + frac = (tbot - tkFrz)*0.5_R8 ! ramp near freezing + frac = min(1.0_R8,max(0.0_R8,frac)) ! bound in [0,1] + a2x%rAttr(ksc,n) = max(0.0_R8, a2x%rAttr(krc,n)*(1.0_R8 - frac) ) + a2x%rAttr(ksl,n) = max(0.0_R8, a2x%rAttr(krl,n)*(1.0_R8 - frac) ) + a2x%rAttr(krc,n) = max(0.0_R8, a2x%rAttr(krc,n)*( frac) ) + a2x%rAttr(krl,n) = max(0.0_R8, a2x%rAttr(krl,n)*( frac) ) + + enddo + + end select + + call t_stopf('datm_mode') + + if (write_restart) then + call t_startf('datm_restart') + call seq_infodata_GetData( infodata, case_name=case_name) + write(rest_file,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.datm'//trim(inst_suffix)//'.r.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.nc' + write(rest_file_strm,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.datm'//trim(inst_suffix)//'.rs1.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.bin' + if (my_task == master_task) then + nu = shr_file_getUnit() + open(nu,file=trim(rpfile)//trim(inst_suffix),form='formatted') + write(nu,'(a)') rest_file + write(nu,'(a)') rest_file_strm + close(nu) + call shr_file_freeUnit(nu) + endif +! if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file),currentYMD,currentTOD +! call shr_pcdf_readwrite('write',trim(rest_file),mpicom,gsmap,clobber=.true., & +! rf1=somtp,rf1n='somtp') + if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file_strm),currentYMD,currentTOD + call shr_strdata_restWrite(trim(rest_file_strm),SDATM,mpicom,trim(case_name),'SDATM strdata') + call shr_sys_flush(logunit) + call t_stopf('datm_restart') + endif + + call t_stopf('datm') + + !---------------------------------------------------------------------------- + ! Log output for model date + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + call t_startf('datm_run2') + if (my_task == master_task) then + write(logunit,F04) trim(myModelName),': model date ', CurrentYMD,CurrentTOD + call shr_sys_flush(logunit) + end if + + firstcall = .false. + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + call shr_sys_flush(logunit) + call t_stopf('datm_run2') + + call t_stopf('DATM_RUN') + +end subroutine datm_comp_run + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: datm_comp_final +! +! !DESCRIPTION: +! finalize method for dead atm model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ +! +subroutine datm_comp_final() + + implicit none + +!EOP + + !--- formats --- + character(*), parameter :: F00 = "('(datm_comp_final) ',8a)" + character(*), parameter :: F91 = "('(datm_comp_final) ',73('-'))" + character(*), parameter :: subName = "(datm_comp_final) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call t_startf('DATM_FINAL') + + if (my_task == master_task) then + write(logunit,F91) + write(logunit,F00) trim(myModelName),': end of main integration loop' + write(logunit,F91) + end if + + call t_stopf('DATM_FINAL') + +end subroutine datm_comp_final +!=============================================================================== +!=============================================================================== + + +end module datm_comp_mod diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.dice/dice_comp_mod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.dice/dice_comp_mod.F90 new file mode 100644 index 0000000000..c892764979 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.dice/dice_comp_mod.F90 @@ -0,0 +1,937 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_2_1/models/ice/dice/dice_comp_mod.F90 + +#ifdef AIX +@PROCESS ALIAS_SIZE(805306368) +#endif +module dice_comp_mod + +! !USES: + + use shr_const_mod + use shr_sys_mod + use shr_kind_mod , only: IN=>SHR_KIND_IN, R8=>SHR_KIND_R8, & + CS=>SHR_KIND_CS, CL=>SHR_KIND_CL + use shr_file_mod , only: shr_file_getunit, shr_file_getlogunit, shr_file_getloglevel, & + shr_file_setlogunit, shr_file_setloglevel, shr_file_setio, & + shr_file_freeunit + use shr_mpi_mod , only: shr_mpi_bcast + use shr_flux_mod , only: shr_flux_atmIce + use shr_cal_mod , only: shr_cal_ymd2julian + use mct_mod + use esmf + use perf_mod + + use shr_strdata_mod + use shr_dmodel_mod + use shr_pcdf_mod + + use seq_cdata_mod + use seq_infodata_mod + use seq_timemgr_mod + use seq_comm_mct , only: seq_comm_inst, seq_comm_name, seq_comm_suffix + use seq_flds_mod , only: seq_flds_i2x_fields, & + seq_flds_x2i_fields +! +! !PUBLIC TYPES: + implicit none + private ! except + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: dice_comp_init + public :: dice_comp_run + public :: dice_comp_final + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + + !--- other --- + character(CS) :: myModelName = 'ice' ! user defined model name + integer(IN) :: mpicom + integer(IN) :: my_task ! my task in mpi communicator mpicom + integer(IN) :: npes ! total number of tasks + integer(IN),parameter :: master_task=0 ! task number of master task + integer(IN) :: logunit ! logging unit number + integer :: inst_index ! number of current instance (ie. 1) + character(len=16) :: inst_name ! fullname of current instance (ie. "lnd_0001") + character(len=16) :: inst_suffix ! char string associated with instance + ! (ie. "_0001" or "") + character(CL) :: ice_mode ! mode + integer(IN) :: dbug = 0 ! debug level (higher is more) + logical :: firstcall ! first call logical + logical :: scmMode = .false. ! single column mode + real(R8) :: scmLat = shr_const_SPVAL ! single column lat + real(R8) :: scmLon = shr_const_SPVAL ! single column lon + logical :: read_restart ! start from restart + real(R8) :: flux_swpf ! short-wave penatration factor + real(R8) :: flux_Qmin ! bound on melt rate + logical :: flux_Qacc ! activates water accumulation/melt wrt Q + real(R8) :: flux_Qacc0 ! initial water accumulation value + + character(len=*),parameter :: rpfile = 'rpointer.ice' + character(len=*),parameter :: nullstr = 'undefined' + + real(R8),parameter :: pi = shr_const_pi ! pi + real(R8),parameter :: spval = shr_const_spval ! flags invalid data + real(R8),parameter :: tFrz = shr_const_tkfrzsw ! temp of freezing salt-water + real(R8),parameter :: latice = shr_const_latice ! latent heat of fusion + real(R8),parameter :: cDay = shr_const_cDay ! sec in calendar day + real(R8),parameter :: waterMax = 1000.0_R8 ! wrt iFrac comp & frazil ice (kg/m^2) + + !----- surface albedo constants ------ + real(R8),parameter :: snwfrac = 0.286_R8 ! snow cover fraction ~ [0,1] + real(R8),parameter :: as_nidf = 0.950_R8 ! albedo: snow,near-infr,diffuse + real(R8),parameter :: as_vsdf = 0.700_R8 ! albedo: snow,visible ,diffuse + real(R8),parameter :: as_nidr = 0.960_R8 ! albedo: snow,near-infr,direct + real(R8),parameter :: as_vsdr = 0.800_R8 ! albedo: snow,visible ,direct + real(R8),parameter :: ai_nidf = 0.700_R8 ! albedo: ice, near-infr,diffuse + real(R8),parameter :: ai_vsdf = 0.500_R8 ! albedo: ice, visible ,diffuse + real(R8),parameter :: ai_nidr = 0.700_R8 ! albedo: ice, near-infr,direct + real(R8),parameter :: ai_vsdr = 0.500_R8 ! albedo: ice, visible ,direct + real(R8),parameter :: ax_nidf = ai_nidf*(1.0_R8-snwfrac) + as_nidf*snwfrac + real(R8),parameter :: ax_vsdf = ai_vsdf*(1.0_R8-snwfrac) + as_vsdf*snwfrac + real(R8),parameter :: ax_nidr = ai_nidr*(1.0_R8-snwfrac) + as_nidr*snwfrac + real(R8),parameter :: ax_vsdr = ai_vsdr*(1.0_R8-snwfrac) + as_vsdr*snwfrac + + integer(IN) :: kswvdr,kswndr,kswvdf,kswndf,kq,kz,kua,kva,kptem,kshum,kdens,ktbot + integer(IN) :: kiFrac,kt,kavsdr,kanidr,kavsdf,kanidf,kswnet,kmelth,kmeltw + integer(IN) :: ksen,klat,klwup,kevap,ktauxa,ktauya,ktref,kqref,kswpen,ktauxo,ktauyo,ksalt + + type(shr_strdata_type) :: SDICE + type(mct_rearr) :: rearr +! type(mct_avect) :: avstrm ! av of data from stream + integer(IN) , pointer :: imask(:) + real(R8) , pointer :: yc(:) + real(R8) , pointer :: water(:) +! real(R8) , pointer :: ifrac0(:) + + integer(IN),parameter :: ktrans = 42 + character(16),parameter :: avofld(1:ktrans) = & + (/"So_t ","So_s ","So_u ","So_v ", & + "So_dhdx ","So_dhdy ","Fioo_q ","Sa_z ", & + "Sa_u ","Sa_v ","Sa_ptem ","Sa_tbot ", & + "Sa_shum ","Sa_dens ","Faxa_swndr ","Faxa_swvdr ", & + "Faxa_swndf ","Faxa_swvdf ","Faxa_lwdn ","Faxa_rain ", & + "Faxa_snow ","Si_t ","Si_tref ","Si_qref ", & + "Si_ifrac ","Si_avsdr ","Si_anidr ","Si_avsdf ", & + "Si_anidf ","Faii_taux ","Faii_tauy ","Faii_lat ", & + "Faii_sen ","Faii_lwup ","Faii_evap ","Faii_swnet ", & + "Fioi_swpen ","Fioi_melth ","Fioi_meltw ","Fioi_salt ", & + "Fioi_taux ","Fioi_tauy " /) + + character(16),parameter :: avifld(1:ktrans) = & + (/"to ","s ","uo ","vo ", & + "dhdx ","dhdy ","q ","z ", & + "ua ","va ","ptem ","tbot ", & + "shum ","dens ","swndr ","swvdr ", & + "swndf ","swvdf ","lwdn ","rain ", & + "snow ","t ","tref ","qref ", & + "ifrac ","avsdr ","anidr ","avsdf ", & + "anidf ","tauxa ","tauya ","lat ", & + "sen ","lwup ","evap ","swnet ", & + "swpen ","melth ","meltw ","salt ", & + "tauxo ","tauyo " /) + + save + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CONTAINS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: dice_comp_init +! +! !DESCRIPTION: +! initialize data ice model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine dice_comp_init( EClock, cdata, x2i, i2x, NLFilename ) + use pio, only : iosystem_desc_t + use shr_pio_mod, only : shr_pio_getiosys, shr_pio_getiotype + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) , intent(in) :: EClock + type(seq_cdata) , intent(inout) :: cdata + type(mct_aVect) , intent(inout) :: x2i, i2x + character(len=*), optional , intent(in) :: NLFilename ! Namelist filename + +!EOP + + !--- local variables --- + integer(IN) :: n,k ! generic counters + integer(IN) :: ierr ! error code + integer(IN) :: COMPID ! comp id + integer(IN) :: gsize ! global size + integer(IN) :: lsize ! local size + integer(IN) :: shrlogunit, shrloglev ! original log unit and level + integer(IN) :: nunit ! unit number + integer(IN) :: kfld ! field reference + logical :: ice_present ! flag + logical :: ice_prognostic ! flag + + type(seq_infodata_type), pointer :: infodata + type(mct_gsMap) , pointer :: gsmap + type(mct_gGrid) , pointer :: ggrid + + character(CL) :: filePath ! generic file path + character(CL) :: fileName ! generic file name + character(CS) :: timeName ! domain file: time variable name + character(CS) :: lonName ! domain file: lon variable name + character(CS) :: latName ! domain file: lat variable name + character(CS) :: maskName ! domain file: mask variable name + character(CS) :: areaName ! domain file: area variable name + + integer(IN) :: yearFirst ! first year to use in data stream + integer(IN) :: yearLast ! last year to use in data stream + integer(IN) :: yearAlign ! data year that aligns with yearFirst + character(CL) :: calendar ! calendar type + + character(CL) :: ice_in ! dshr ice namelist + character(CL) :: decomp ! decomp strategy + character(CL) :: rest_file ! restart filename + character(CL) :: rest_file_strm ! restart filename for stream + character(CL) :: restfilm ! model restart file namelist + character(CL) :: restfils ! stream restart file namelist + logical :: exists ! file existance logical + integer(IN) :: nu ! unit number + type(iosystem_desc_t), pointer :: ice_pio_subsystem + + + !----- define namelist ----- + namelist / dice_nml / & + ice_in, decomp, flux_swpf, flux_Qmin, flux_Qacc, flux_Qacc0, restfilm, restfils + + !--- formats --- + character(*), parameter :: F00 = "('(dice_comp_init) ',8a)" + character(*), parameter :: F01 = "('(dice_comp_init) ',a,5i8)" + character(*), parameter :: F02 = "('(dice_comp_init) ',a,4es13.6)" + character(*), parameter :: F03 = "('(dice_comp_init) ',a,i8,a)" + character(*), parameter :: F04 = "('(dice_comp_init) ',2a,2i8,'s')" + character(*), parameter :: F05 = "('(dice_comp_init) ',a,2f10.4)" + character(*), parameter :: F06 = "('(dice_comp_init) ',a,5l3)" + character(*), parameter :: F90 = "('(dice_comp_init) ',73('='))" + character(*), parameter :: F91 = "('(dice_comp_init) ',73('-'))" + character(*), parameter :: subName = "(dice_comp_init) " +!------------------------------------------------------------------------------- + + + call t_startf('DICE_INIT') + + firstcall = .true. + + ! Set cdata pointers + + call seq_cdata_setptrs(cdata, ID=COMPID, mpicom=mpicom, & + gsMap=gsmap, dom=ggrid, infodata=infodata) + + ! Determine communicator groups and sizes + + call mpi_comm_rank(mpicom, my_task, ierr) + call mpi_comm_size(mpicom, npes, ierr) + + inst_name = seq_comm_name(COMPID) + inst_index = seq_comm_inst(COMPID) + inst_suffix = seq_comm_suffix(COMPID) + + !--- open log file --- + if (my_task == master_task) then + logUnit = shr_file_getUnit() + call shr_file_setIO('ice_modelio.nml'//trim(inst_suffix),logUnit) + else + logUnit = 6 + endif + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (logUnit) + + !---------------------------------------------------------------------------- + ! Set a Few Defaults + !---------------------------------------------------------------------------- + + call seq_infodata_getData(infodata,single_column=scmMode, & + & scmlat=scmlat, scmlon=scmLon) + + ice_present = .false. + ice_prognostic = .false. + call seq_infodata_GetData(infodata,read_restart=read_restart) + + !---------------------------------------------------------------------------- + ! Read dice_in + !---------------------------------------------------------------------------- + + call t_startf('dice_readnml') + + filename = "dice_in"//trim(inst_suffix) + ice_in = "unset" + decomp = "1d" + flux_swpf = 0.0_R8 ! no penetration + flux_Qmin = -300.0_R8 ! kg/s/m^2 + flux_Qacc = .false. ! no accumulation + flux_Qacc0 = 0.0_R8 ! no water + restfilm = trim(nullstr) + restfils = trim(nullstr) + if (my_task == master_task) then + nunit = shr_file_getUnit() ! get unused unit number + open (nunit,file=trim(filename),status="old",action="read") + read (nunit,nml=dice_nml,iostat=ierr) + close(nunit) + call shr_file_freeUnit(nunit) + if (ierr > 0) then + write(logunit,F01) 'ERROR: reading input namelist, '//trim(filename)//' iostat=',ierr + call shr_sys_abort(subName//': namelist read error '//trim(filename)) + end if + write(logunit,F00)' ice_in = ',trim(ice_in) + write(logunit,F00)' decomp = ',trim(decomp) + write(logunit,F02)' flux_swpf = ',flux_swpf + write(logunit,F02)' flux_Qmin = ',flux_Qmin + write(logunit,F06)' flux_Qacc = ',flux_Qacc + write(logunit,F02)' flux_Qacc0 = ',flux_Qacc0 + write(logunit,F00)' restfilm = ',trim(restfilm) + write(logunit,F00)' restfils = ',trim(restfils) + endif + call shr_mpi_bcast(ice_in ,mpicom,'ice_in') + call shr_mpi_bcast(decomp ,mpicom,'decomp') + call shr_mpi_bcast(flux_swpf ,mpicom,'flux_swpf') + call shr_mpi_bcast(flux_Qmin ,mpicom,'flux_Qmin') + call shr_mpi_bcast(flux_Qacc ,mpicom,'flux_Qacc') + call shr_mpi_bcast(flux_Qacc0,mpicom,'flux_Qacc0') + call shr_mpi_bcast(restfilm,mpicom,'restfilm') + call shr_mpi_bcast(restfils,mpicom,'restfils') + + rest_file = trim(restfilm) + rest_file_strm = trim(restfils) + + !---------------------------------------------------------------------------- + ! Read dshr namelist + !---------------------------------------------------------------------------- + + call shr_strdata_readnml(SDICE,trim(ice_in),mpicom=mpicom) + + !---------------------------------------------------------------------------- + ! Initialize IO + !---------------------------------------------------------------------------- + + + ice_pio_subsystem=>shr_pio_getiosys(trim(inst_name)) + + call shr_strdata_pioinit(SDICE, ice_pio_subsystem, shr_pio_getiotype(trim(inst_name))) + + !---------------------------------------------------------------------------- + ! Validate mode + !---------------------------------------------------------------------------- + + + ice_mode = trim(SDICE%dataMode) + + ! check that we know how to handle the mode + + if (trim(ice_mode) == 'NULL' .or. & + trim(ice_mode) == 'SSTDATA' .or. & + trim(ice_mode) == 'COPYALL') then + if (my_task == master_task) & + write(logunit,F00) ' ice mode = ',trim(ice_mode) + else + write(logunit,F00) ' ERROR illegal ice mode = ',trim(ice_mode) + call shr_sys_abort() + endif + + call t_stopf('dice_readnml') + + !---------------------------------------------------------------------------- + ! Initialize datasets + !---------------------------------------------------------------------------- + + call t_startf('dice_strdata_init') + + ice_present = .true. + call seq_timemgr_EClockGetData( EClock, calendar=calendar ) + if (scmmode) then + if (my_task == master_task) & + write(logunit,F05) ' scm lon lat = ',scmlon,scmlat + call shr_strdata_init(SDICE,mpicom,compid,name='ice', & + scmmode=scmmode,scmlon=scmlon,scmlat=scmlat, & + calendar=calendar) + else + call shr_strdata_init(SDICE,mpicom,compid,name='ice', & + calendar=calendar) + endif + + if (trim(ice_mode) == 'SSTDATA' .or. & + trim(ice_mode) == 'COPYALL') then + ice_prognostic = .true. + endif + + if (my_task == master_task) then + call shr_strdata_print(SDICE,'SDICE data') + endif + + call t_stopf('dice_strdata_init') + + !---------------------------------------------------------------------------- + ! Set flag to specify data components + !---------------------------------------------------------------------------- + + call seq_infodata_PutData(infodata, & + ice_present=ice_present, ice_prognostic=ice_prognostic, & + ice_nx=SDICE%nxg, ice_ny=SDICE%nyg ) + + !---------------------------------------------------------------------------- + ! Initialize MCT global seg map, 1d decomp + !---------------------------------------------------------------------------- + + call t_startf('dice_initgsmaps') + if (my_task == master_task) write(logunit,F00) ' initialize gsmaps' + call shr_sys_flush(logunit) + + call shr_dmodel_gsmapcreate(gsmap,SDICE%nxg*SDICE%nyg,compid,mpicom,decomp) + lsize = mct_gsmap_lsize(gsmap,mpicom) + + if (ice_present) then + call mct_rearr_init(SDICE%gsmap,gsmap,mpicom,rearr) + endif + + call t_stopf('dice_initgsmaps') + + !---------------------------------------------------------------------------- + ! Initialize MCT domain + !---------------------------------------------------------------------------- + + call t_startf('dice_initmctdom') + if (my_task == master_task) write(logunit,F00) 'copy domains' + call shr_sys_flush(logunit) + + if (ice_present) call shr_dmodel_rearrGGrid(SDICE%grid, ggrid, gsmap, rearr, mpicom) + + call t_stopf('dice_initmctdom') + + !---------------------------------------------------------------------------- + ! Initialize MCT attribute vectors + !---------------------------------------------------------------------------- + + call t_startf('dice_initmctavs') + if (my_task == master_task) write(logunit,F00) 'allocate AVs' + call shr_sys_flush(logunit) + + call mct_aVect_init(i2x, rList=seq_flds_i2x_fields, lsize=lsize) + call mct_aVect_zero(i2x) + + kiFrac = mct_aVect_indexRA(i2x,'Si_ifrac') + kt = mct_aVect_indexRA(i2x,'Si_t') + ktref = mct_aVect_indexRA(i2x,'Si_tref') + kqref = mct_aVect_indexRA(i2x,'Si_qref') + kavsdr = mct_aVect_indexRA(i2x,'Si_avsdr') + kanidr = mct_aVect_indexRA(i2x,'Si_anidr') + kavsdf = mct_aVect_indexRA(i2x,'Si_avsdf') + kanidf = mct_aVect_indexRA(i2x,'Si_anidf') + kswnet = mct_aVect_indexRA(i2x,'Faii_swnet') + ksen = mct_aVect_indexRA(i2x,'Faii_sen') + klat = mct_aVect_indexRA(i2x,'Faii_lat') + klwup = mct_aVect_indexRA(i2x,'Faii_lwup') + kevap = mct_aVect_indexRA(i2x,'Faii_evap') + ktauxa = mct_aVect_indexRA(i2x,'Faii_taux') + ktauya = mct_aVect_indexRA(i2x,'Faii_tauy') + kmelth = mct_aVect_indexRA(i2x,'Fioi_melth') + kmeltw = mct_aVect_indexRA(i2x,'Fioi_meltw') + kswpen = mct_aVect_indexRA(i2x,'Fioi_swpen') + ktauxo = mct_aVect_indexRA(i2x,'Fioi_taux') + ktauyo = mct_aVect_indexRA(i2x,'Fioi_tauy') + ksalt = mct_aVect_indexRA(i2x,'Fioi_salt') + + call mct_aVect_init(x2i, rList=seq_flds_x2i_fields, lsize=lsize) + call mct_aVect_zero(x2i) + + kswvdr = mct_aVect_indexRA(x2i,'Faxa_swvdr') + kswndr = mct_aVect_indexRA(x2i,'Faxa_swndr') + kswvdf = mct_aVect_indexRA(x2i,'Faxa_swvdf') + kswndf = mct_aVect_indexRA(x2i,'Faxa_swndf') + kq = mct_aVect_indexRA(x2i,'Fioo_q') + kz = mct_aVect_indexRA(x2i,'Sa_z') + kua = mct_aVect_indexRA(x2i,'Sa_u') + kva = mct_aVect_indexRA(x2i,'Sa_v') + kptem = mct_aVect_indexRA(x2i,'Sa_ptem') + kshum = mct_aVect_indexRA(x2i,'Sa_shum') + kdens = mct_aVect_indexRA(x2i,'Sa_dens') + ktbot = mct_aVect_indexRA(x2i,'Sa_tbot') + + ! call mct_aVect_init(avstrm, rList=flds_strm, lsize=lsize) + ! call mct_aVect_zero(avstrm) + + allocate(imask(lsize)) + allocate(yc(lsize)) + allocate(water(lsize)) + ! allocate(iFrac0(lsize)) + + kfld = mct_aVect_indexRA(ggrid%data,'mask') + imask(:) = nint(ggrid%data%rAttr(kfld,:)) + kfld = mct_aVect_indexRA(ggrid%data,'lat') + yc(:) = ggrid%data%rAttr(kfld,:) + + call t_stopf('dice_initmctavs') + + !---------------------------------------------------------------------------- + ! Read restart + !---------------------------------------------------------------------------- + +!*****POPDART Sept 27,2012 AliciaK +!*****hardcode read_restart so that dice does not look for rpointers +!**** or restart files + +! read_restart = .false. + +!******************* + + + if (read_restart) then + if (trim(rest_file) == trim(nullstr) .and. & + trim(rest_file_strm) == trim(nullstr)) then + if (my_task == master_task) then + write(logunit,F00) ' restart filenames from rpointer' + call shr_sys_flush(logunit) + inquire(file=trim(rpfile)//trim(inst_suffix),exist=exists) + if (.not.exists) then + write(logunit,F00) ' ERROR: rpointer file does not exist' + call shr_sys_abort(trim(subname)//' ERROR: rpointer file missing') + endif + nu = shr_file_getUnit() + open(nu,file=trim(rpfile)//trim(inst_suffix),form='formatted') + read(nu,'(a)') rest_file + read(nu,'(a)') rest_file_strm + close(nu) + call shr_file_freeUnit(nu) + inquire(file=trim(rest_file_strm),exist=exists) + endif + call shr_mpi_bcast(rest_file,mpicom,'rest_file') + call shr_mpi_bcast(rest_file_strm,mpicom,'rest_file_strm') + else + ! use namelist already read + if (my_task == master_task) then + write(logunit,F00) ' restart filenames from namelist ' + call shr_sys_flush(logunit) + inquire(file=trim(rest_file_strm),exist=exists) + endif + endif + call shr_mpi_bcast(exists,mpicom,'exists') + if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file) + call shr_pcdf_readwrite('read',SDICE%pio_subsystem, SDICE%io_type, & + trim(rest_file),mpicom,gsmap,rf1=water,rf1n='water') + if (exists) then + if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file_strm) + call shr_strdata_restRead(trim(rest_file_strm),SDICE,mpicom) + else + if (my_task == master_task) write(logunit,F00) ' file not found, skipping ',trim(rest_file_strm) + endif + call shr_sys_flush(logunit) + endif + + !---------------------------------------------------------------------------- + ! On initial call, x2i is unset, so set for use in run method + ! These values should have no impact on the solution!! + !---------------------------------------------------------------------------- + x2i%rAttr(kz,:) = 10.0_R8 + x2i%rAttr(kua,:) = 5.0_R8 + x2i%rAttr(kva,:) = 5.0_R8 + x2i%rAttr(kptem,:) = 260.0_R8 + x2i%rAttr(ktbot,:) = 260.0_R8 + x2i%rAttr(kshum,:) = 0.0014_R8 + x2i%rAttr(kdens,:) = 1.3_R8 + + !---------------------------------------------------------------------------- + ! Set initial ice state, needed for CCSM atm initialization + !---------------------------------------------------------------------------- + + call t_adj_detailf(+2) + call dice_comp_run( EClock, cdata, x2i, i2x) + call t_adj_detailf(-2) + + !---------------------------------------------------------------------------- + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + if (my_task == master_task) write(logunit,F00) 'dice_comp_init done' + call shr_sys_flush(logunit) + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + call shr_sys_flush(logunit) + + call t_stopf('DICE_INIT') + +end subroutine dice_comp_init + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: dice_comp_run +! +! !DESCRIPTION: +! run method for dead ice model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine dice_comp_run( EClock, cdata, x2i, i2x) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) ,intent(in) :: EClock + type(seq_cdata) ,intent(inout) :: cdata + type(mct_aVect) ,intent(inout) :: x2i ! driver -> dead + type(mct_aVect) ,intent(inout) :: i2x ! dead -> driver + +!EOP + + !--- local --- + type(mct_gsMap) , pointer :: gsmap + type(mct_gGrid) , pointer :: ggrid + + integer(IN) :: CurrentYMD ! model date + integer(IN) :: CurrentTOD ! model sec into model date + integer(IN) :: yy,mm,dd ! year month day + integer(IN) :: n ! indices + integer(IN) :: nf ! fields loop index + integer(IN) :: nl ! ice frac index + integer(IN) :: lsize ! size of attr vect + integer(IN) :: shrlogunit, shrloglev ! original log unit and level + logical :: glcrun_alarm ! is glc going to run now + logical :: newdata ! has newdata been read + logical :: mssrmlf ! remove old data + integer(IN) :: idt ! integer timestep + real(R8) :: dt ! timestep + real(R8) :: hn ! h field + logical :: write_restart ! restart now + character(CL) :: case_name ! case name + character(CL) :: rest_file ! restart_file + character(CL) :: rest_file_strm ! restart_file for stream + integer(IN) :: nu ! unit number + real(R8) :: qmeltall ! q that would melt all accumulated water + real(R8) :: cosarg ! for setting ice temp pattern + real(R8) :: jday, jday0 ! elapsed day counters + character(CS) :: calendar ! calendar type + + type(seq_infodata_type), pointer :: infodata + + character(*), parameter :: F00 = "('(dice_comp_run) ',8a)" + character(*), parameter :: F04 = "('(dice_comp_run) ',2a,2i8,'s')" + character(*), parameter :: subName = "(dice_comp_run) " +!------------------------------------------------------------------------------- + + call t_startf('DICE_RUN') + + call t_startf('dice_run1') + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (logUnit) + + call seq_cdata_setptrs(cdata, gsMap=gsmap, dom=ggrid) + + call seq_cdata_setptrs(cdata, infodata=infodata) + + call seq_timemgr_EClockGetData( EClock, curr_ymd=CurrentYMD, curr_tod=CurrentTOD) + call seq_timemgr_EClockGetData( EClock, curr_yr=yy, curr_mon=mm, curr_day=dd) + call seq_timemgr_EClockGetData( EClock, dtime=idt, calendar=calendar) + dt = idt * 1.0_r8 + write_restart = seq_timemgr_RestartAlarmIsOn(EClock) + + call t_stopf('dice_run1') + + !-------------------- + ! UNPACK + !-------------------- + + call t_startf('dice_unpack') + +! lsize = mct_avect_lsize(x2i) + + call t_stopf('dice_unpack') + + !-------------------- + ! ADVANCE ICE + !-------------------- + + call t_barrierf('dice_BARRIER',mpicom) + call t_startf('dice') + + !--- copy all fields from streams to i2x as default --- + + if (trim(ice_mode) /= 'NULL') then + call t_startf('dice_strdata_advance') + call shr_strdata_advance(SDICE,currentYMD,currentTOD,mpicom,'dice') + call t_stopf('dice_strdata_advance') + call t_barrierf('dice_scatter_BARRIER',mpicom) + call t_startf('dice_scatter') + do n = 1,SDICE%nstreams + call shr_dmodel_translateAV(SDICE%avs(n),i2x,avifld,avofld,rearr) + enddo + call t_stopf('dice_scatter') + else + call mct_aVect_zero(i2x) + endif + + call t_startf('dice_mode') + + select case (trim(ice_mode)) + + case('COPYALL') + ! do nothing extra + + case('SSTDATA') + if (firstcall .and. .not. read_restart) then +! iFrac0 = iFrac ! previous step's ice fraction + water = 0.0_R8 ! previous step's water accumulation + where (i2x%rAttr(kiFrac,:) > 0.0_R8) water(:) = flux_Qacc0 + endif + +! tcraig, feb 10, 2012, ymd2eday no longer exists, use ymd2julian instead +! this could be improved for use in gregorian calendar +! call shr_cal_ymd2eday(0,mm,dd,eDay ,calendar) ! model date +! call shr_cal_ymd2eday(0,09,01,eDay0,calendar) ! sept 1st +! cosArg = 2.0_R8*pi*(real(eDay,R8) + real(currentTOD,R8)/cDay - real(eDay0,R8))/365.0_R8 + call shr_cal_ymd2julian(0,mm,dd,currentTOD,jDay ,calendar) ! julian day for model + call shr_cal_ymd2julian(0, 9, 1,0 ,jDay0,calendar) ! julian day for Sept 1 + cosArg = 2.0_R8*pi*(jday - jday0)/365.0_R8 + + lsize = mct_avect_lsize(i2x) + + do n = 1,lsize + + !--- fix erroneous iFrac --- + i2x%rAttr(kiFrac,n) = min(1.0_R8,max(0.0_R8,i2x%rAttr(kiFrac,n))) + + !--- fabricate ice surface T, fix erroneous iFrac --- + if ( yc(n) > 0.0_R8) then + i2x%rAttr(kt,n) = 260.0_R8 + 10.0_R8*cos(cosArg) + else + i2x%rAttr(kt,n) = 260.0_R8 - 10.0_R8*cos(cosArg) + end if + + !--- set albedos (constant) --- + i2x%rAttr(kavsdr,n) = ax_vsdr + i2x%rAttr(kanidr,n) = ax_nidr + i2x%rAttr(kavsdf,n) = ax_vsdf + i2x%rAttr(kanidf,n) = ax_nidf + + !--- swnet is sent to cpl as a diagnostic quantity only --- + !--- newly recv'd swdn goes with previously sent albedo --- + !--- but albedos are (currently) time invariant --- + i2x%rAttr(kswnet,n) = (1.0_R8 - i2x%rAttr(kavsdr,n))*x2i%rAttr(kswvdr,n) & + & + (1.0_R8 - i2x%rAttr(kanidr,n))*x2i%rAttr(kswndr,n) & + & + (1.0_R8 - i2x%rAttr(kavsdf,n))*x2i%rAttr(kswvdf,n) & + & + (1.0_R8 - i2x%rAttr(kanidf,n))*x2i%rAttr(kswndf,n) + + !--- compute melt/freeze water balance, adjust iFrac ------------- + if ( .not. flux_Qacc ) then ! Q accumulation option is OFF + i2x%rAttr(kmelth,n) = min(x2i%rAttr(kq,n),0.0_R8 ) ! q<0 => melt potential + i2x%rAttr(kmelth,n) = max(i2x%rAttr(kmelth,n),Flux_Qmin ) ! limit the melt rate + i2x%rAttr(kmeltw,n) = -i2x%rAttr(kmelth,n)/latice ! corresponding water flux + + else ! Q accumulation option is ON + !-------------------------------------------------------------- + ! 1a) Q<0 & iFrac > 0 => infinite supply of water to melt + ! 1b) Q<0 & iFrac = 0 => melt accumulated water only + ! 2a) Q>0 & iFrac > 0 => zero-out accumulated water + ! 2b) Q>0 & iFrac = 0 => accumulated water + !-------------------------------------------------------------- + if ( x2i%rAttr(kq,n) < 0.0_R8 ) then ! Q<0 => melt + if (i2x%rAttr(kiFrac,n) > 0.0_R8 ) then + i2x%rAttr(kmelth,n) = i2x%rAttr(kiFrac,n)*max(x2i%rAttr(kq,n),Flux_Qmin) + i2x%rAttr(kmeltw,n) = -i2x%rAttr(kmelth,n)/latice + ! water(n) = < don't change this value > + else + Qmeltall = -water(n)*latice/dt + i2x%rAttr(kmelth,n) = max(x2i%rAttr(kq,n), Qmeltall, Flux_Qmin ) + i2x%rAttr(kmeltw,n) = -i2x%rAttr(kmelth,n)/latice + water(n) = water(n) - i2x%rAttr(kmeltw,n)*dt + end if + else ! Q>0 => freeze + if (i2x%rAttr(kiFrac,n) > 0.0_R8 ) then + i2x%rAttr(kmelth,n) = 0.0_R8 + i2x%rAttr(kmeltw,n) = 0.0_R8 + water(n) = 0.0_R8 + else + i2x%rAttr(kmelth,n) = 0.0_R8 + i2x%rAttr(kmeltw,n) = 0.0_R8 + water(n) = water(n) + dt*x2i%rAttr(kq,n)/latice + end if + end if + + if (water(n) < 1.0e-16_R8 ) water(n) = 0.0_R8 + + !--- non-zero water => non-zero iFrac --- + if (i2x%rAttr(kiFrac,n) <= 0.0_R8 .and. water(n) > 0.0_R8) then + i2x%rAttr(kiFrac,n) = min(1.0_R8,water(n)/waterMax) + ! i2x%rAttr(kT,n) = Tfrz ! T can be above freezing?!? + end if + + !--- cpl multiplies melth & meltw by iFrac --- + !--- divide by iFrac here => fixed quantity flux (not per area) --- + if (i2x%rAttr(kiFrac,n) > 0.0_R8) then + i2x%rAttr(kiFrac,n) = max( 0.01_R8, i2x%rAttr(kiFrac,n)) ! min iFrac + i2x%rAttr(kmelth,n) = i2x%rAttr(kmelth,n)/i2x%rAttr(kiFrac,n) + i2x%rAttr(kmeltw,n) = i2x%rAttr(kmeltw,n)/i2x%rAttr(kiFrac,n) + else + i2x%rAttr(kmelth,n) = 0.0_R8 + i2x%rAttr(kmeltw,n) = 0.0_R8 + end if + end if + + !--- modify T wrt iFrac: (iFrac -> 0) => (T -> Tfrz) --- + i2x%rAttr(kt,n) = Tfrz + i2x%rAttr(kiFrac,n)*(i2x%rAttr(kt,n)-Tfrz) + + end do + + !---------------------------------------------------------------------------- + ! compute atm/ice surface fluxes + !---------------------------------------------------------------------------- + call shr_flux_atmIce(iMask ,x2i%rAttr(kz,:) ,x2i%rAttr(kua,:) ,x2i%rAttr(kva,:), & + x2i%rAttr(kptem,:) ,x2i%rAttr(kshum,:) ,x2i%rAttr(kdens,:) ,x2i%rAttr(ktbot,:), & + i2x%rAttr(kt,:) ,i2x%rAttr(ksen,:) ,i2x%rAttr(klat,:) ,i2x%rAttr(klwup,:), & + i2x%rAttr(kevap,:) ,i2x%rAttr(ktauxa,:) ,i2x%rAttr(ktauya,:) ,i2x%rAttr(ktref,:), & + i2x%rAttr(kqref,:) ) + + !---------------------------------------------------------------------------- + ! compute ice/oce surface fluxes (except melth & meltw, see above) + !---------------------------------------------------------------------------- + do n=1,lsize + if (iMask(n) == 0) then + i2x%rAttr(kswpen,n) = spval + i2x%rAttr(kmelth,n) = spval + i2x%rAttr(kmeltw,n) = spval + i2x%rAttr(ksalt ,n) = spval + i2x%rAttr(ktauxo,n) = spval + i2x%rAttr(ktauyo,n) = spval + i2x%rAttr(kiFrac,n) = 0.0_R8 + else + !--- penetrating short wave --- + i2x%rAttr(kswpen,n) = max(0.0_R8, flux_swpf*i2x%rAttr(kswnet,n) ) ! must be non-negative + + !--- i/o surface stress ( = atm/ice stress) --- + i2x%rAttr(ktauxo,n) = i2x%rAttr(ktauxa,n) + i2x%rAttr(ktauyo,n) = i2x%rAttr(ktauya,n) + + !--- salt flux --- + i2x%rAttr(ksalt ,n) = 0.0_R8 + end if + +! !--- save ifrac for next timestep +! iFrac0(n) = i2x%rAttr(kiFrac,n) + end do + + + end select + + call t_stopf('dice_mode') + + if (write_restart) then + call t_startf('dice_restart') + call seq_infodata_GetData( infodata, case_name=case_name) + write(rest_file,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.dice'//trim(inst_suffix)//'.r.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.nc' + write(rest_file_strm,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.dice'//trim(inst_suffix)//'.rs1.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.bin' + if (my_task == master_task) then + nu = shr_file_getUnit() + open(nu,file=trim(rpfile)//trim(inst_suffix),form='formatted') + write(nu,'(a)') rest_file + write(nu,'(a)') rest_file_strm + close(nu) + call shr_file_freeUnit(nu) + endif + if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file),currentYMD,currentTOD + call shr_pcdf_readwrite('write',SDICE%pio_subsystem, SDICE%io_type, & + trim(rest_file),mpicom,gsmap,clobber=.true.,rf1=water,rf1n='water') + if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file_strm),currentYMD,currentTOD + call shr_strdata_restWrite(trim(rest_file_strm),SDICE,mpicom,trim(case_name),'SDICE strdata') + call shr_sys_flush(logunit) + call t_stopf('dice_restart') + endif + + call t_stopf('dice') + + !---------------------------------------------------------------------------- + ! Log output for model date + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + call t_startf('dice_run2') + if (my_task == master_task) then + write(logunit,F04) trim(myModelName),': model date ', CurrentYMD,CurrentTOD + call shr_sys_flush(logunit) + end if + firstcall = .false. + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + call shr_sys_flush(logunit) + call t_stopf('dice_run2') + + call t_stopf('DICE_RUN') + +end subroutine dice_comp_run + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: dice_comp_final +! +! !DESCRIPTION: +! finalize method for dead ice model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ +! +subroutine dice_comp_final() + + implicit none + +!EOP + + !--- formats --- + character(*), parameter :: F00 = "('(dice_comp_final) ',8a)" + character(*), parameter :: F91 = "('(dice_comp_final) ',73('-'))" + character(*), parameter :: subName = "(dice_comp_final) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call t_startf('DICE_FINAL') + + if (my_task == master_task) then + write(logunit,F91) + write(logunit,F00) trim(myModelName),': end of main integration loop' + write(logunit,F91) + end if + + call t_stopf('DICE_FINAL') + +end subroutine dice_comp_final +!=============================================================================== +!=============================================================================== + +end module dice_comp_mod diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.dlnd/dlnd_comp_mod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.dlnd/dlnd_comp_mod.F90 new file mode 100644 index 0000000000..91964b06c9 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.dlnd/dlnd_comp_mod.F90 @@ -0,0 +1,817 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_2_1/models/lnd/dlnd/dlnd_comp_mod.F90 + +#ifdef AIX +@PROCESS ALIAS_SIZE(805306368) +#endif +module dlnd_comp_mod + +! !USES: + + use shr_sys_mod + use shr_kind_mod , only: IN=>SHR_KIND_IN, R8=>SHR_KIND_R8, & + CS=>SHR_KIND_CS, CL=>SHR_KIND_CL + use shr_file_mod , only: shr_file_getunit, shr_file_getlogunit, shr_file_getloglevel, & + shr_file_setlogunit, shr_file_setloglevel, shr_file_setio, & + shr_file_freeunit + use shr_mpi_mod , only: shr_mpi_bcast + use mct_mod + use esmf + use perf_mod + + use shr_strdata_mod + use shr_dmodel_mod + + use seq_cdata_mod + use seq_infodata_mod + use seq_timemgr_mod + use seq_comm_mct , only: seq_comm_inst, seq_comm_name, seq_comm_suffix + use seq_flds_mod , only: seq_flds_l2x_fields, seq_flds_x2l_fields, & + seq_flds_x2s_fields, seq_flds_s2x_fields, & + glc_nec=>seq_flds_glc_nec +! +! !PUBLIC TYPES: + implicit none + private ! except + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: dlnd_comp_init + public :: dlnd_comp_run + public :: dlnd_comp_final + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + + !--- other --- + character(CS) :: myModelName = 'lnd' ! user defined model name + integer(IN) :: mpicom + integer(IN) :: my_task ! my task in mpi communicator mpicom + integer(IN) :: npes ! total number of tasks + integer(IN),parameter :: master_task=0 ! task number of master task + integer(IN) :: logunit ! logging unit number + integer :: inst_index ! number of current instance (ie. 1) + character(len=16) :: inst_name ! fullname of current instance (ie. "lnd_0001") + character(len=16) :: inst_suffix ! char string associated with instance + ! (ie. "_0001" or "") + character(CL) :: lnd_mode + character(CL) :: sno_mode + integer(IN) :: dbug = 0 ! debug level (higher is more) + logical :: scmMode = .false. ! single column mode + real(R8) :: scmLat = shr_const_SPVAL ! single column lat + real(R8) :: scmLon = shr_const_SPVAL ! single column lon + logical :: read_restart ! start from restart + + character(len=*),parameter :: rpfile = 'rpointer.lnd' + character(len=*),parameter :: nullstr = 'undefined' + + type(shr_strdata_type),save :: SDLND + type(shr_strdata_type),save :: SDSNO + + type(mct_rearr) :: rearr_l + type(mct_rearr) :: rearr_s + + !--- names of fields --- + integer(IN),parameter :: fld_len = 12 ! max character length of fields in avofld & avifld + integer(IN),parameter :: nflds_nosnow = 22 + ! fields other than snow fields: + character(fld_len),parameter :: avofld_nosnow(1:nflds_nosnow) = & + (/ "Sl_t ","Sl_tref ","Sl_qref ","Sl_avsdr ","Sl_anidr ", & + "Sl_avsdf ","Sl_anidf ","Sl_snowh ","Fall_taux ","Fall_tauy ", & + "Fall_lat ","Fall_sen ","Fall_lwup ","Fall_evap ","Fall_swnet ", & + "Sl_landfrac ","Sl_fv ","Sl_ram1 ", & + "Fall_flxdst1","Fall_flxdst2","Fall_flxdst3","Fall_flxdst4" /) + character(fld_len),parameter :: avifld_nosnow(1:nflds_nosnow) = & + (/ "t ","tref ","qref ","avsdr ","anidr ", & + "avsdf ","anidf ","snowh ","taux ","tauy ", & + "lat ","sen ","lwup ","evap ","swnet ", & + "lfrac ","fv ","ram1 ", & + "flddst1 ","flxdst2 ","flxdst3 ","flxdst4 " /) + + integer(IN), parameter :: nflds_snow = 3 ! number of snow fields in each elevation class + integer(IN), parameter :: nec_len = 2 ! length of elevation class index in field names + ! for these snow fields, the actual field names will have the elevation class index at + ! the end (e.g., Ss_tsrf01, tsrf01) + character(fld_len-nec_len),parameter :: avofld_snow(nflds_snow) = & + (/"Ss_tsrf ", "Ss_topo ", "Fgss_qice"/) + character(fld_len-nec_len),parameter :: avifld_snow(nflds_snow) = & + (/"tsrf", "topo", "qice"/) + + ! all fields: + character(fld_len),dimension(:),allocatable :: avofld + character(fld_len),dimension(:),allocatable :: avifld + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CONTAINS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: dlnd_comp_init +! +! !DESCRIPTION: +! initialize data lnd model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine dlnd_comp_init( EClock, cdata_l, x2l, l2x, & + cdata_s, x2s, s2x, NLFilename ) + + use shr_pio_mod, only : shr_pio_getiosys, shr_pio_getiotype + use pio, only : iosystem_desc_t + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) , intent(in) :: EClock + type(seq_cdata) , intent(inout) :: cdata_l + type(mct_aVect) , intent(inout) :: x2l, l2x + type(seq_cdata) , intent(inout) :: cdata_s + type(mct_aVect) , intent(inout) :: x2s, s2x + character(len=*), optional , intent(in) :: NLFilename ! Namelist filename + +!EOP + + !--- local variables --- + integer(IN) :: n,k ! generic counters + integer(IN) :: field_num ! field number + integer(IN) :: ierr ! error code + integer(IN) :: COMPID ! comp id + integer(IN) :: gsize ! global size + integer(IN) :: lsize_l, lsize_s ! local size + integer(IN) :: shrlogunit, shrloglev ! original log unit and level + integer(IN) :: nunit ! unit number + logical :: lnd_present ! flag + logical :: lnd_prognostic ! flag + logical :: sno_present ! flag + logical :: sno_prognostic ! flag + character(CL) :: calendar ! model calendar + + type(seq_infodata_type), pointer :: infodata + type(mct_gsMap) , pointer :: gsMap_l + type(mct_gGrid) , pointer :: dom_l + type(mct_gsMap) , pointer :: gsMap_s + type(mct_gGrid) , pointer :: dom_s + + character(CL) :: filePath ! generic file path + character(CL) :: fileName ! generic file name + character(CS) :: timeName ! domain file: time variable name + character(CS) :: lonName ! domain file: lon variable name + character(CS) :: latName ! domain file: lat variable name + character(CS) :: maskName ! domain file: mask variable name + character(CS) :: areaName ! domain file: area variable name + character(CS) :: nec_format ! format for nec_str + character(nec_len):: nec_str ! elevation class, as character string + + integer(IN) :: yearFirst ! first year to use in data stream + integer(IN) :: yearLast ! last year to use in data stream + integer(IN) :: yearAlign ! data year that aligns with yearFirst + + character(CL) :: lnd_in ! dshr lnd namelist + character(CL) :: sno_in ! dshr sno namelist + character(CL) :: decomp ! decomp strategy + character(CL) :: rest_file ! restart filename + character(CL) :: rest_file_strm_l ! restart filename for stream + character(CL) :: rest_file_strm_s ! restart filename for stream + character(CL) :: restfilm ! model restart file namelist + character(CL) :: restfilsl ! stream restart file namelist + character(CL) :: restfilsr ! stream restart file namelist + character(CL) :: restfilss ! stream restart file namelist + logical :: exists ! file existance logical + logical :: exists_l ! file existance logical + logical :: exists_s ! file existance logical + integer(IN) :: nu ! unit number + + type(iosystem_desc_t), pointer :: lnd_pio_subsys + integer(IN) :: lnd_pio_iotype + + !----- define namelist ----- + namelist / dlnd_nml / & + lnd_in, sno_in, decomp, restfilm, restfilsl, restfilss + + !--- formats --- + character(*), parameter :: F00 = "('(dlnd_comp_init) ',8a)" + character(*), parameter :: F01 = "('(dlnd_comp_init) ',a,5i8)" + character(*), parameter :: F02 = "('(dlnd_comp_init) ',a,4es13.6)" + character(*), parameter :: F03 = "('(dlnd_comp_init) ',a,i8,a)" + character(*), parameter :: F05 = "('(dlnd_comp_init) ',a,2f10.4)" + character(*), parameter :: F90 = "('(dlnd_comp_init) ',73('='))" + character(*), parameter :: F91 = "('(dlnd_comp_init) ',73('-'))" + character(*), parameter :: subName = "(dlnd_comp_init) " +!------------------------------------------------------------------------------- + + + call t_startf('DLND_INIT') + + ! Set cdata pointers + + call seq_cdata_setptrs(cdata_l, ID=COMPID, mpicom=mpicom, & + gsMap=gsMap_l, dom=dom_l, infodata=infodata) + + call seq_cdata_setptrs(cdata_s, & + gsMap=gsMap_s, dom=dom_s) + + ! Determine communicator groups and sizes + + call mpi_comm_rank(mpicom, my_task, ierr) + call mpi_comm_size(mpicom, npes, ierr) + + inst_name = seq_comm_name(COMPID) + inst_index = seq_comm_inst(COMPID) + inst_suffix = seq_comm_suffix(COMPID) + + !--- open log file --- + if (my_task == master_task) then + logUnit = shr_file_getUnit() + call shr_file_setIO('lnd_modelio.nml'//trim(inst_suffix),logUnit) + else + logUnit = 6 + endif + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (logUnit) + + !---------------------------------------------------------------------------- + ! Set a Few Defaults + !---------------------------------------------------------------------------- + + call seq_infodata_getData(infodata,single_column=scmMode, & + & scmlat=scmlat, scmlon=scmLon) + + lnd_present = .false. + lnd_prognostic = .false. + sno_present = .false. + sno_prognostic = .false. + call seq_infodata_GetData(infodata,read_restart=read_restart) + + !---------------------------------------------------------------------------- + ! Read dlnd_in + !---------------------------------------------------------------------------- + + call t_startf('dlnd_readnml') + + filename = "dlnd_in"//trim(inst_suffix) + lnd_in = "unset" + sno_in = "unset" + decomp = "1d" + restfilm = trim(nullstr) + restfilsl = trim(nullstr) + restfilsr = trim(nullstr) + restfilss = trim(nullstr) + if (my_task == master_task) then + nunit = shr_file_getUnit() ! get unused unit number + open (nunit,file=trim(filename),status="old",action="read") + read (nunit,nml=dlnd_nml,iostat=ierr) + close(nunit) + call shr_file_freeUnit(nunit) + if (ierr > 0) then + write(logunit,F01) 'ERROR: reading input namelist, '//trim(filename)//' iostat=',ierr + call shr_sys_abort(subName//': namelist read error '//trim(filename)) + end if + write(logunit,F00)' lnd_in = ',trim(lnd_in) + write(logunit,F00)' sno_in = ',trim(sno_in) + write(logunit,F00)' decomp = ',trim(decomp) + write(logunit,F00)' restfilm = ',trim(restfilm) + write(logunit,F00)' restfilsl = ',trim(restfilsl) + write(logunit,F00)' restfilsr = ',trim(restfilsr) + write(logunit,F00)' restfilss = ',trim(restfilss) + endif + call shr_mpi_bcast(lnd_in,mpicom,'lnd_in') + call shr_mpi_bcast(sno_in,mpicom,'sno_in') + call shr_mpi_bcast(decomp,mpicom,'decomp') + call shr_mpi_bcast(restfilm,mpicom,'restfilm') + call shr_mpi_bcast(restfilsl,mpicom,'restfilsl') + call shr_mpi_bcast(restfilsr,mpicom,'restfilsr') + call shr_mpi_bcast(restfilss,mpicom,'restfilss') + + rest_file = trim(restfilm) + rest_file_strm_l = trim(restfilsl) + rest_file_strm_s = trim(restfilss) + + !---------------------------------------------------------------------------- + ! Read dshr namelist + !---------------------------------------------------------------------------- + + call shr_strdata_readnml(SDLND,trim(lnd_in),mpicom=mpicom) + call shr_strdata_readnml(SDSNO,trim(sno_in),mpicom=mpicom) + + !---------------------------------------------------------------------------- + ! Validate mode + !---------------------------------------------------------------------------- + + lnd_mode = trim(SDLND%dataMode) + sno_mode = trim(SDSNO%dataMode) + + ! check that we know how to handle the mode + + if (trim(lnd_mode) == 'NULL' .or. & + trim(lnd_mode) == 'CPLHIST') then + if (my_task == master_task) & + write(logunit,F00) ' lnd mode = ',trim(lnd_mode) + else + write(logunit,F00) ' ERROR illegal lnd mode = ',trim(lnd_mode) + call shr_sys_abort() + endif + + if (trim(sno_mode) == 'NULL' .or. & + trim(sno_mode) == 'CPLHIST') then + if (my_task == master_task) & + write(logunit,F00) ' sno mode = ',trim(sno_mode) + else + write(logunit,F00) ' ERROR illegal sno mode = ',trim(sno_mode) + call shr_sys_abort() + endif + + call t_stopf('dlnd_readnml') + + !---------------------------------------------------------------------------- + ! Build avofld & avifld + !---------------------------------------------------------------------------- + + ! Start with non-snow fields + allocate(avofld(nflds_nosnow + glc_nec*nflds_snow)) + allocate(avifld(nflds_nosnow + glc_nec*nflds_snow)) + avofld(1:nflds_nosnow) = avofld_nosnow + avifld(1:nflds_nosnow) = avifld_nosnow + field_num = nflds_nosnow + + ! create a format string for nec_str; e.g., if nec_len=2, this will be '(i2.2)' + ! (without the quotes) + write(nec_format,'(a2, i0, a1, i0, a1)') "(i", nec_len, ".", nec_len, ")" + + ! Append each snow field + do k = 1, nflds_snow + do n = 1, glc_nec + ! nec_str will be something like '02' or '10' + write(nec_str,nec_format) n + + field_num = field_num + 1 + avofld(field_num) = trim(avofld_snow(k))//nec_str + avifld(field_num) = trim(avifld_snow(k))//nec_str + end do + end do + + !---------------------------------------------------------------------------- + ! Initialize datasets + !---------------------------------------------------------------------------- + + call t_startf('dlnd_strdata_init') + + lnd_pio_subsys => shr_pio_getiosys(trim(inst_name)) + lnd_pio_iotype = shr_pio_getiotype(trim(inst_name)) + + call seq_timemgr_EClockGetData( EClock, calendar=calendar ) + + if (trim(lnd_mode) /= 'NULL') then + lnd_present = .true. + call shr_strdata_pioinit(SDLND,lnd_pio_subsys,lnd_pio_iotype) + if (scmmode) then + if (my_task == master_task) & + write(logunit,F05) ' scm lon lat = ',scmlon,scmlat + call shr_strdata_init(SDLND,mpicom,compid,name='lnd', & + scmmode=scmmode,scmlon=scmlon,scmlat=scmlat, & + calendar=calendar) + else + call shr_strdata_init(SDLND,mpicom,compid,name='lnd', & + calendar=calendar) + endif + endif + + if (trim(sno_mode) /= 'NULL') then + sno_present = .true. + call shr_strdata_pioinit(SDSNO,lnd_pio_subsys,lnd_pio_iotype) + if (scmmode) then + call shr_strdata_init(SDSNO,mpicom,compid,name='sno', & + scmmode=scmmode,scmlon=scmlon,scmlat=scmlat, & + calendar=calendar) + else + call shr_strdata_init(SDSNO,mpicom,compid,name='sno', & + calendar=calendar) + endif + endif + + if (my_task == master_task) then + call shr_strdata_print(SDLND,'SDLND data') + call shr_strdata_print(SDSNO,'SDSNO data') + endif + + call t_stopf('dlnd_strdata_init') + + !---------------------------------------------------------------------------- + ! Set flag to specify data components + !---------------------------------------------------------------------------- + + call seq_infodata_PutData(infodata, & + lnd_present=lnd_present, lnd_prognostic=lnd_prognostic, & + sno_present=sno_present, sno_prognostic=sno_prognostic, & + lnd_nx=SDLND%nxg, lnd_ny=SDLND%nyg, & + sno_nx=SDSNO%nxg, sno_ny=SDSNO%nyg) + + if (.not. lnd_present .and. .not. sno_present) then + RETURN + end if + + !---------------------------------------------------------------------------- + ! Initialize MCT global seg map, 1d decomp + !---------------------------------------------------------------------------- + + call t_startf('dlnd_initgsmaps') + if (my_task == master_task) write(logunit,F00) ' initialize gsmaps' + call shr_sys_flush(logunit) + + call shr_dmodel_gsmapcreate(gsmap_l,SDLND%nxg*SDLND%nyg,compid,mpicom,decomp) + call shr_dmodel_gsmapcreate(gsmap_s,SDSNO%nxg*SDSNO%nyg,compid,mpicom,decomp) + lsize_l = mct_gsmap_lsize(gsmap_l,mpicom) + lsize_s = mct_gsmap_lsize(gsmap_s,mpicom) + + if (lnd_present) then + call mct_rearr_init(SDLND%gsmap,gsmap_l,mpicom,rearr_l) + endif + + if (sno_present) then + call mct_rearr_init(SDSNO%gsmap,gsmap_s,mpicom,rearr_s) + endif + + call t_stopf('dlnd_initgsmaps') + + !---------------------------------------------------------------------------- + ! Initialize MCT domain + !---------------------------------------------------------------------------- + + call t_startf('dlnd_initmctdom') + if (my_task == master_task) write(logunit,F00) 'copy domains' + call shr_sys_flush(logunit) + + if (lnd_present) call shr_dmodel_rearrGGrid(SDLND%grid, dom_l, gsmap_l, rearr_l, mpicom) + if (sno_present) call shr_dmodel_rearrGGrid(SDSNO%grid, dom_s, gsmap_s, rearr_s, mpicom) + + call t_stopf('dlnd_initmctdom') + + !---------------------------------------------------------------------------- + ! Initialize MCT attribute vectors + !---------------------------------------------------------------------------- + + call t_startf('dlnd_initmctavs') + if (my_task == master_task) write(logunit,F00) 'allocate AVs' + call shr_sys_flush(logunit) + + call mct_aVect_init(l2x, rList=seq_flds_l2x_fields, lsize=lsize_l) + call mct_aVect_zero(l2x) + + call mct_aVect_init(x2l, rList=seq_flds_x2l_fields, lsize=lsize_l) + call mct_aVect_zero(x2l) + + call mct_aVect_init(x2s, rList=seq_flds_x2s_fields, lsize=lsize_s) + call mct_aVect_zero(x2s) + + call mct_aVect_init(s2x, rList=seq_flds_s2x_fields, lsize=lsize_s) + call mct_aVect_zero(s2x) + call t_stopf('dlnd_initmctavs') + + !---------------------------------------------------------------------------- + ! Read restart + !---------------------------------------------------------------------------- + !*****POPDART Sept 27,2012 AliciaK + !*****hardcode read_restart so that dlnd does not look for rpointers + !**** or restart files + + write(6,*) "Setting read_restart to .false. in DLND" !ALICIAK + read_restart = .false. + + !******************* + + if (read_restart) then + if (trim(rest_file) == trim(nullstr) .and. & + trim(rest_file_strm_l) == trim(nullstr) .and. & + trim(rest_file_strm_s) == trim(nullstr)) then + if (my_task == master_task) then + write(logunit,F00) ' restart filenames from rpointer' + call shr_sys_flush(logunit) + inquire(file=trim(rpfile)//trim(inst_suffix),exist=exists) + if (.not.exists) then + write(logunit,F00) ' ERROR: rpointer file does not exist' + call shr_sys_abort(trim(subname)//' ERROR: rpointer file missing') + endif + nu = shr_file_getUnit() + open(nu,file=trim(rpfile)//trim(inst_suffix),form='formatted') + read(nu,'(a)') rest_file + read(nu,'(a)') rest_file_strm_l + read(nu,'(a)') rest_file_strm_s + close(nu) + call shr_file_freeUnit(nu) + inquire(file=trim(rest_file_strm_l),exist=exists_l) + inquire(file=trim(rest_file_strm_s),exist=exists_s) + endif + call shr_mpi_bcast(rest_file,mpicom,'rest_file') + call shr_mpi_bcast(rest_file_strm_l,mpicom,'rest_file_strm_l') + call shr_mpi_bcast(rest_file_strm_s,mpicom,'rest_file_strm_s') + else + ! use namelist already read + if (my_task == master_task) then + write(logunit,F00) ' restart filenames from namelist ' + call shr_sys_flush(logunit) + inquire(file=trim(rest_file_strm_l),exist=exists_l) + inquire(file=trim(rest_file_strm_s),exist=exists_s) + endif + endif + call shr_mpi_bcast(exists_l,mpicom,'exists_l') + call shr_mpi_bcast(exists_s,mpicom,'exists_s') + !if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file) + !call shr_pcdf_readwrite('read',trim(rest_file),mpicom,gsmap,rf1=somtp,rf1n='somtp') + if (exists_l) then + if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file_strm_l) + call shr_strdata_restRead(trim(rest_file_strm_l),SDLND,mpicom) + else + if (my_task == master_task) write(logunit,F00) ' file not found, skipping ',trim(rest_file_strm_l) + endif + if (exists_s) then + if (my_task == master_task) write(logunit,F00) ' reading ',trim(rest_file_strm_s) + call shr_strdata_restRead(trim(rest_file_strm_s),SDSNO,mpicom) + else + if (my_task == master_task) write(logunit,F00) ' file not found, skipping ',trim(rest_file_strm_s) + endif + call shr_sys_flush(logunit) + endif + + !---------------------------------------------------------------------------- + ! Set initial lnd state, needed for CCSM atm initialization + !---------------------------------------------------------------------------- + + call t_adj_detailf(+2) + call dlnd_comp_run( EClock, cdata_l, x2l, l2x, cdata_s, x2s, s2x) + call t_adj_detailf(-2) + + !---------------------------------------------------------------------------- + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + if (my_task == master_task) write(logunit,F00) 'dlnd_comp_init done' + call shr_sys_flush(logunit) + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + call shr_sys_flush(logunit) + + call t_stopf('DLND_INIT') + +end subroutine dlnd_comp_init + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: dlnd_comp_run +! +! !DESCRIPTION: +! run method for dead lnd model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine dlnd_comp_run( EClock, cdata_l, x2l, l2x, cdata_s, x2s, s2x) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Clock) ,intent(in) :: EClock + type(seq_cdata) ,intent(inout) :: cdata_l + type(mct_aVect) ,intent(inout) :: x2l + type(mct_aVect) ,intent(inout) :: l2x + type(seq_cdata) ,intent(inout) :: cdata_s + type(mct_aVect) ,intent(inout) :: x2s + type(mct_aVect) ,intent(inout) :: s2x + +!EOP + + !--- local --- + type(mct_gsMap) , pointer :: gsMap_l + type(mct_gGrid) , pointer :: dom_l + type(mct_gsMap) , pointer :: gsMap_s + type(mct_gGrid) , pointer :: dom_s + + integer(IN) :: CurrentYMD ! model date + integer(IN) :: CurrentTOD ! model sec into model date + integer(IN) :: yy,mm,dd ! year month day + integer(IN) :: n ! indices + integer(IN) :: nf ! fields loop index + integer(IN) :: nl ! land frac index + integer(IN) :: kl ! index of landfrac + integer(IN) :: lsize_l,lsize_s ! size of attr vect + integer(IN) :: shrlogunit, shrloglev ! original log unit and level + logical :: glcrun_alarm ! is glc going to run now + logical :: newdata ! has newdata been read + logical :: mssrmlf ! remove old data + logical :: write_restart ! restart now + character(CL) :: case_name ! case name + character(CL) :: rest_file ! restart_file + character(CL) :: rest_file_strm_l ! restart_file for stream + character(CL) :: rest_file_strm_s ! restart_file for stream + integer(IN) :: nu ! unit number + integer(IN) :: nflds_x2l + integer(IN) :: nflds_x2s + type(seq_infodata_type), pointer :: infodata + + character(*), parameter :: F00 = "('(dlnd_comp_run) ',8a)" + character(*), parameter :: F04 = "('(dlnd_comp_run) ',2a,2i8,'s')" + character(*), parameter :: subName = "(dlnd_comp_run) " +!------------------------------------------------------------------------------- + + call t_startf('DLND_RUN') + + call t_startf('dlnd_run1') + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + call shr_file_getLogUnit (shrlogunit) + call shr_file_getLogLevel(shrloglev) + call shr_file_setLogUnit (logUnit) + + call seq_cdata_setptrs(cdata_l, gsMap=gsMap_l, dom=dom_l) + call seq_cdata_setptrs(cdata_s, gsMap=gsMap_s, dom=dom_s) + + call seq_cdata_setptrs(cdata_l, infodata=infodata) + call seq_infodata_getData(infodata, glcrun_alarm=glcrun_alarm) + + call seq_timemgr_EClockGetData( EClock, curr_ymd=CurrentYMD, curr_tod=CurrentTOD) + call seq_timemgr_EClockGetData( EClock, curr_yr=yy, curr_mon=mm, curr_day=dd) + write_restart = seq_timemgr_RestartAlarmIsOn(EClock) + + lsize_l = mct_avect_lsize(x2l) + lsize_s = mct_avect_lsize(x2s) + nflds_x2l = mct_avect_nRattr(x2l) + nflds_x2s = mct_avect_nRattr(x2s) + + call t_stopf('dlnd_run1') + + !-------------------- + ! UNPACK + !-------------------- + + call t_startf('dlnd_unpack') + +! do nf=1,nflds_x2l +! do n=1,lsize_l +! ?? = x2l%rAttr(nf,n) +! enddo +! enddo + +! do nf=1,nflds_x2s +! do n=1,lsize_s +! ?? = x2s%rAttr(nf,n) +! enddo +! enddo + + call t_stopf('dlnd_unpack') + + !-------------------- + ! ADVANCE LAND + !-------------------- + + call t_barrierf('dlnd_l_BARRIER',mpicom) + call t_startf('dlnd_l') + + if (trim(lnd_mode) /= 'NULL') then + call t_startf('dlnd_l_strdata_advance') + call shr_strdata_advance(SDLND,currentYMD,currentTOD,mpicom,'dlnd_l') + call t_stopf('dlnd_l_strdata_advance') + call t_barrierf('dlnd_l_scatter_BARRIER',mpicom) + call t_startf('dlnd_l_scatter') + do n = 1,SDLND%nstreams + call shr_dmodel_translateAV(SDLND%avs(n),l2x,avifld,avofld,rearr_l) + enddo + call t_stopf('dlnd_l_scatter') + else + call mct_aVect_zero(l2x) + endif + + call t_stopf('dlnd_l') + + !-------------------- + ! ADVANCE SNO + !-------------------- + + call t_barrierf('dlnd_s_BARRIER',mpicom) + call t_startf('dlnd_s') + if (trim(sno_mode) /= 'NULL') then + call t_startf('dlnd_s_strdata_advance') + call shr_strdata_advance(SDSNO,currentYMD,currentTOD,mpicom,'dlnd_s') + call t_stopf('dlnd_s_strdata_advance') + call t_barrierf('dlnd_s_scatter_BARRIER',mpicom) + call t_startf('dlnd_s_scatter') + do n = 1,SDSNO%nstreams + call shr_dmodel_translateAV(SDSNO%avs(n),s2x,avifld,avofld,rearr_s) + enddo + call t_stopf('dlnd_s_scatter') + else + call mct_aVect_zero(s2x) + endif + call t_stopf('dlnd_s') + + if (write_restart) then + call t_startf('dlnd_restart') + call seq_infodata_GetData( infodata, case_name=case_name) + write(rest_file,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.dlnd'//trim(inst_suffix)//'.r.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.nc' + write(rest_file_strm_l,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.dlnd'//trim(inst_suffix)//'.rs1.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.bin' + write(rest_file_strm_s,"(2a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)") & + trim(case_name), '.dlnd'//trim(inst_suffix)//'.rs3.', & + yy,'-',mm,'-',dd,'-',currentTOD,'.bin' + if (my_task == master_task) then + nu = shr_file_getUnit() + open(nu,file=trim(rpfile)//trim(inst_suffix),form='formatted') + write(nu,'(a)') rest_file + write(nu,'(a)') rest_file_strm_l + write(nu,'(a)') rest_file_strm_s + close(nu) + call shr_file_freeUnit(nu) + endif + !if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file),currentYMD,currentTOD + !call shr_pcdf_readwrite('write',trim(rest_file),mpicom,gsmap,clobber=.true., & + ! rf1=somtp,rf1n='somtp') + if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file_strm_l),currentYMD,currentTOD + call shr_strdata_restWrite(trim(rest_file_strm_l),SDLND,mpicom,trim(case_name),'SDLND strdata') + if (my_task == master_task) write(logunit,F04) ' writing ',trim(rest_file_strm_s),currentYMD,currentTOD + call shr_strdata_restWrite(trim(rest_file_strm_s),SDSNO,mpicom,trim(case_name),'SDSNO strdata') + call shr_sys_flush(logunit) + call t_stopf('dlnd_restart') + endif + + !---------------------------------------------------------------------------- + ! Log output for model date + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + call t_startf('dlnd_run2') + if (my_task == master_task) then + write(logunit,F04) trim(myModelName),': model date ', CurrentYMD,CurrentTOD + call shr_sys_flush(logunit) + end if + + call shr_file_setLogUnit (shrlogunit) + call shr_file_setLogLevel(shrloglev) + call shr_sys_flush(logunit) + call t_stopf('dlnd_run2') + + call t_stopf('DLND_RUN') + +end subroutine dlnd_comp_run + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: dlnd_comp_final +! +! !DESCRIPTION: +! finalize method for dead lnd model +! +! !REVISION HISTORY: +! +! !INTERFACE: ------------------------------------------------------------------ +! +subroutine dlnd_comp_final() + + implicit none + +!EOP + + !--- formats --- + character(*), parameter :: F00 = "('(dlnd_comp_final) ',8a)" + character(*), parameter :: F91 = "('(dlnd_comp_final) ',73('-'))" + character(*), parameter :: subName = "(dlnd_comp_final) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call t_startf('DLND_FINAL') + + if (my_task == master_task) then + write(logunit,F91) + write(logunit,F00) trim(myModelName),': end of main integration loop' + write(logunit,F91) + end if + + call t_stopf('DLND_FINAL') + +end subroutine dlnd_comp_final +!=============================================================================== +!=============================================================================== + + +end module dlnd_comp_mod diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.pop2/forcing.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.pop2/forcing.F90 new file mode 100644 index 0000000000..d32a662145 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.pop2/forcing.F90 @@ -0,0 +1,646 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_2_1/models/ocn/pop2/source/forcing.F90 + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + + module forcing + +!BOP +! !MODULE: forcing +! +! !DESCRIPTION: +! This is the main driver module for all surface and interior +! forcing. It contains necessary forcing fields as well as +! necessary routines for call proper initialization and +! update routines for those fields. +! +! !REVISION HISTORY: +! SVN:$Id: forcing.F90 38321 2012-06-29 23:22:21Z mlevy@ucar.edu $ +! +! !USES: + + use constants + use blocks + use distribution + use domain + use grid + use ice, only: salice, tfreez, FW_FREEZE + use forcing_ws + use forcing_shf + use forcing_sfwf + use forcing_pt_interior + use forcing_s_interior + use forcing_ap + use forcing_coupled, only: set_combined_forcing, tavg_coupled_forcing, & + liceform, qsw_12hr_factor, qsw_distrb_iopt, qsw_distrb_iopt_cosz, & + tday00_interval_beg, interval_cum_dayfrac, QSW_COSZ_WGHT_NORM, & + QSW_COSZ_WGHT, compute_cosz + use forcing_tools + use passive_tracers, only: set_sflux_passive_tracers + use prognostic + use tavg + use movie, only: define_movie_field, movie_requested, update_movie_field + use time_management + use exit_mod +#ifdef CCSMCOUPLED + use shr_sys_mod, only: shr_sys_abort +#endif + + !*** ccsm + use sw_absorption, only: set_chl + use registry + use forcing_fields + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + + public :: init_forcing, & + set_surface_forcing, & + tavg_forcing, & + movie_forcing + +!EOP +!BOC + + integer (int_kind) :: & + tavg_SHF, &! tavg_id for surface heat flux + tavg_SHF_QSW, &! tavg_id for short-wave solar heat flux + tavg_SFWF, &! tavg_id for surface freshwater flux + tavg_SFWF_WRST, &! tavg_id for weak restoring freshwater flux + tavg_TAUX, &! tavg_id for wind stress in X direction + tavg_TAUX2, &! tavg_id for wind stress**2 in X direction + tavg_TAUY, &! tavg_id for wind stress in Y direction + tavg_TAUY2, &! tavg_id for wind stress**2 in Y direction + tavg_FW, &! tavg_id for freshwater flux + tavg_TFW_T, &! tavg_id for T flux due to freshwater flux + tavg_TFW_S, &! tavg_id for S flux due to freshwater flux + tavg_U10_SQR ! tavg_id for U10_SQR 10m wind speed squared from cpl + +!----------------------------------------------------------------------- +! +! movie ids +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + movie_SHF, &! movie id for surface heat flux + movie_SFWF, &! movie id for surface freshwater flux + movie_TAUX, &! movie id for wind stress in X direction + movie_TAUY ! movie id for wind stress in Y direction + +!EOC +!*********************************************************************** + + contains + +!*********************************************************************** +!BOP +! !IROUTINE: init_forcing +! !INTERFACE: + + subroutine init_forcing + +! !DESCRIPTION: +! Initializes forcing by calling a separate routines for +! wind stress, heat flux, fresh water flux, passive tracer flux, +! interior restoring, and atmospheric pressure. +! +! !REVISION HISTORY: +! same as module + +!----------------------------------------------------------------------- +! +! write out header for forcing options to stdout. +! +!----------------------------------------------------------------------- + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,'(a15)') 'Forcing options' + write(stdout,blank_fmt) + write(stdout,delim_fmt) + endif + +!----------------------------------------------------------------------- +! +! initialize forcing arrays +! +!----------------------------------------------------------------------- + + ATM_PRESS = c0 + FW = c0 + FW_OLD = c0 + SMF = c0 + SMFT = c0 + STF = c0 + TFW = c0 + +!----------------------------------------------------------------------- +! +! call individual initialization routines +! +!----------------------------------------------------------------------- + + call init_ws(SMF,SMFT,lsmft_avail) + + !*** NOTE: with bulk NCEP forcing init_shf must be called before + !*** init_sfwf + + call init_shf (STF) + call init_sfwf(STF) + call init_pt_interior + call init_s_interior + call init_ap(ATM_PRESS) + +!----------------------------------------------------------------------- +! +! define tavg diagnostic fields +! +!----------------------------------------------------------------------- + + call define_tavg_field(tavg_SHF, 'SHF', 2, & + long_name='Total Surface Heat Flux, Including SW', & + units='watt/m^2', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_SHF_QSW, 'SHF_QSW', 2, & + long_name='Solar Short-Wave Heat Flux', & + units='watt/m^2', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_SFWF,'SFWF',2, & + long_name='Virtual Salt Flux in FW Flux formulation', & + units='kg/m^2/s', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_SFWF_WRST,'SFWF_WRST',2, & + long_name='Virtual Salt Flux due to weak restoring', & + units='kg/m^2/s', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_TAUX,'TAUX',2, & + long_name='Windstress in grid-x direction', & + units='dyne/centimeter^2', grid_loc='2220', & + coordinates='ULONG ULAT time') + + call define_tavg_field(tavg_TAUX2,'TAUX2',2, & + long_name='Windstress**2 in grid-x direction', & + units='dyne^2/centimeter^4', grid_loc='2220', & + coordinates='ULONG ULAT time') + + call define_tavg_field(tavg_TAUY,'TAUY',2, & + long_name='Windstress in grid-y direction', & + units='dyne/centimeter^2', grid_loc='2220', & + coordinates='ULONG ULAT time') + + call define_tavg_field(tavg_TAUY2,'TAUY2',2, & + long_name='Windstress**2 in grid-y direction', & + units='dyne^2/centimeter^4', grid_loc='2220', & + coordinates='ULONG ULAT time') + + call define_tavg_field(tavg_FW,'FW',2, & + long_name='Freshwater Flux', & + units='centimeter/s', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_TFW_T,'TFW_T',2, & + long_name='T flux due to freshwater flux', & + units='watt/m^2', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_TFW_S,'TFW_S',2, & + long_name='S flux due to freshwater flux (kg of salt/m^2/s)', & + units='kg/m^2/s', grid_loc='2110', & + coordinates='TLONG TLAT time') + + call define_tavg_field(tavg_U10_SQR,'U10_SQR',2, & + long_name='10m wind speed squared', & + units='cm^2/^s', grid_loc='2110', & + coordinates='TLONG TLAT time') + +!----------------------------------------------------------------------- +! +! define movie diagnostic fields +! +!----------------------------------------------------------------------- + + call define_movie_field(movie_SHF,'SHF',0, & + long_name='Total Surface Heat Flux, Including SW', & + units='watt/m^2', grid_loc='2110') + + call define_movie_field(movie_SFWF,'SFWF',0, & + long_name='Virtual Salt Flux in FW Flux formulation', & + units='kg/m^2/s', grid_loc='2110') + + call define_movie_field(movie_TAUX,'TAUX',0, & + long_name='Windstress in grid-x direction', & + units='dyne/centimeter^2', grid_loc='2220') + + call define_movie_field(movie_TAUY,'TAUY',0, & + long_name='Windstress in grid-y direction', & + units='dyne/centimeter^2', grid_loc='2220') + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_forcing + + +!*********************************************************************** +!BOP +! !IROUTINE: set_surface_forcing +! !INTERFACE: + + subroutine set_surface_forcing + +! !DESCRIPTION: +! Calls surface forcing routines if necessary. +! If forcing does not depend on the ocean state, then update +! forcing if current time is greater than the appropriate +! interpolation time or if it is the first step. +! If forcing DOES depend on the ocean state, then call every +! timestep. interpolation check will be done within the set\_* +! routine. +! Interior restoring is assumed to take place every +! timestep and is set in subroutine tracer\_update, but +! updating the data fields must occur here outside +! any block loops. +! +! !REVISION HISTORY: +! same as module + + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + real (r8), dimension(nx_block,ny_block,max_blocks_clinic) :: & + TFRZ + integer (int_kind) :: index_qsw, iblock + real (r8) :: & + cosz_day, & + qsw_eps + + +#ifdef _HIRES + qsw_eps = -1.e-8_r8 +#else + qsw_eps = c0 +#endif + +!******POPDART AK ALICIAK... hardcoding the qsw crit to + +qsw_eps = -0.5e-1_r8 !ALICIAK + +!POPDART, this was done because negative sw values were in the +!the CPLHIST files from CAMDART and were crashing POP +!relaxing the critical value allowed the integration to continue. + +if (my_task == master_task) then +write(stdout,*) "THE QSW_CRIT HAS BEEN CHANGED FOR ASSIMILATION" !ALICIAK +endif +!************************************************ + +!----------------------------------------------------------------------- +! +! Get any interior restoring data and interpolate if necessary. +! +!----------------------------------------------------------------------- + + call get_pt_interior_data + call get_s_interior_data + +!----------------------------------------------------------------------- +! +! Call individual forcing update routines. +! +!----------------------------------------------------------------------- + + if (lsmft_avail) then + call set_ws(SMF,SMFT=SMFT) + else + call set_ws(SMF) + endif + + !*** NOTE: with bulk NCEP and partially-coupled forcing + !*** set_shf must be called before set_sfwf + + call set_shf(STF) + call set_sfwf(STF,FW,TFW) + + if ( shf_formulation == 'partially-coupled' .or. & + sfwf_formulation == 'partially-coupled' ) then + call set_combined_forcing(STF,FW,TFW) + endif + + +!----------------------------------------------------------------------- +! +! apply qsw 12hr if chosen +! +!----------------------------------------------------------------------- + + index_qsw = mod(nsteps_this_interval,nsteps_per_interval) + 1 + + if ( qsw_distrb_iopt == qsw_distrb_iopt_cosz ) then + cosz_day = tday00_interval_beg + interval_cum_dayfrac(index_qsw-1) & + - interval_cum_dayfrac(nsteps_per_interval) + + !$OMP PARALLEL DO PRIVATE(iblock) + do iblock = 1, nblocks_clinic + + call compute_cosz(cosz_day, iblock, QSW_COSZ_WGHT(:,:,iblock)) + + where (QSW_COSZ_WGHT_NORM(:,:,iblock) > c0) + QSW_COSZ_WGHT(:,:,iblock) = QSW_COSZ_WGHT(:,:,iblock) & + * QSW_COSZ_WGHT_NORM(:,:,iblock) + elsewhere + QSW_COSZ_WGHT(:,:,iblock) = c1 + endwhere + + SHF_QSW(:,:,iblock) = QSW_COSZ_WGHT(:,:,iblock) & + * SHF_COMP(:,:,iblock,shf_comp_qsw) + + enddo + !$OMP END PARALLEL DO + + else + + if (registry_match('lcoupled')) then + SHF_QSW = qsw_12hr_factor(index_qsw)*SHF_COMP(:,:,:,shf_comp_qsw) + endif + + endif + + if ( registry_match('lcoupled') & + .and. sfwf_formulation /= 'partially-coupled' & + .and. sfc_layer_type == sfc_layer_varthick .and. & + .not. lfw_as_salt_flx .and. liceform ) then + FW = SFWF_COMP(:,:,:, sfwf_comp_cpl) + TFW = TFW_COMP(:,:,:,:, tfw_comp_cpl) + endif + + if ( sfc_layer_type == sfc_layer_varthick .and. & + .not. lfw_as_salt_flx .and. liceform ) then + FW = FW + FW_FREEZE + + call tfreez(TFRZ,TRACER(:,:,1,2,curtime,:)) + + TFW(:,:,1,:) = TFW(:,:,1,:) + FW_FREEZE(:,:,:)*TFRZ(:,:,:) + TFW(:,:,2,:) = TFW(:,:,2,:) + FW_FREEZE(:,:,:)*salice + endif + + + call set_ap(ATM_PRESS) + + if (nt > 2) & + call set_sflux_passive_tracers(U10_SQR,IFRAC,ATM_PRESS,STF) + + call set_chl + +#ifdef CCSMCOUPLED + if (ANY(SHF_QSW < qsw_eps)) then + write(6,*) "AK AT END OF set_surface forcing" !ALICIAK POPDART AK + write(6,*) "AK THE minval is: ", MINVAL(SHF_QSW) !ALICIAK POPDART AK + write(6,*) "AK THE minloc is: ", MINLOC(SHF_QSW) !ALICIAK POPDART AK + call shr_sys_abort('(set_surface_forcing) ERROR: SHF_QSW < qsw_eps in set_surface_forcing') + endif +#endif + + +!----------------------------------------------------------------------- +!EOC + + end subroutine set_surface_forcing + +!*********************************************************************** +!BOP +! !IROUTINE: tavg_forcing +! !INTERFACE: + + subroutine tavg_forcing + +! !DESCRIPTION: +! This routine accumulates tavg diagnostics related to surface +! forcing. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + iblock ! block loop index + + type (block) :: & + this_block ! block information for current block + + real (r8), dimension(nx_block,ny_block) :: & + WORK ! local temp space for tavg diagnostics + +!----------------------------------------------------------------------- +! +! compute and accumulate tavg forcing diagnostics +! +!----------------------------------------------------------------------- + + !$OMP PARALLEL DO PRIVATE(iblock,this_block,WORK) + + do iblock = 1,nblocks_clinic + + this_block = get_block(blocks_clinic(iblock),iblock) + + if (accumulate_tavg_now(tavg_SHF)) then + where (KMT(:,:,iblock) > 0) + WORK = (STF(:,:,1,iblock)+SHF_QSW(:,:,iblock))/ & + hflux_factor ! W/m^2 + elsewhere + WORK = c0 + end where + + call accumulate_tavg_field(WORK,tavg_SHF,iblock,1) + endif + + if (accumulate_tavg_now(tavg_SHF_QSW)) then + where (KMT(:,:,iblock) > 0) + WORK = SHF_QSW(:,:,iblock)/hflux_factor ! W/m^2 + elsewhere + WORK = c0 + end where + + call accumulate_tavg_field(WORK,tavg_SHF_QSW,iblock,1) + endif + + if (accumulate_tavg_now(tavg_SFWF)) then + if (sfc_layer_type == sfc_layer_varthick .and. & + .not. lfw_as_salt_flx) then + where (KMT(:,:,iblock) > 0) + WORK = FW(:,:,iblock)*seconds_in_year*mpercm ! m/yr + elsewhere + WORK = c0 + end where + else + where (KMT(:,:,iblock) > 0) ! convert to kg(freshwater)/m^2/s + WORK = STF(:,:,2,iblock)/salinity_factor + elsewhere + WORK = c0 + end where + endif + + call accumulate_tavg_field(WORK,tavg_SFWF,iblock,1) + endif + + if (accumulate_tavg_now(tavg_SFWF_WRST)) then + if ( sfwf_formulation == 'partially-coupled' ) then + where (KMT(:,:,iblock) > 0) ! convert to kg(freshwater)/m^2/s + WORK = SFWF_COMP(:,:,iblock,sfwf_comp_wrest)/salinity_factor + elsewhere + WORK = c0 + end where + else + WORK = c0 + endif + call accumulate_tavg_field(WORK,tavg_SFWF_WRST,iblock,1) + endif + + call accumulate_tavg_field(SMF(:,:,1,iblock), tavg_TAUX,iblock,1) + call accumulate_tavg_field(SMF(:,:,1,iblock)**2, tavg_TAUX2,iblock,1) + call accumulate_tavg_field(SMF(:,:,2,iblock), tavg_TAUY,iblock,1) + call accumulate_tavg_field(SMF(:,:,2,iblock)**2, tavg_TAUY2,iblock,1) + call accumulate_tavg_field(FW (:,:,iblock), tavg_FW,iblock,1) + call accumulate_tavg_field(TFW(:,:,1,iblock)/hflux_factor, tavg_TFW_T,iblock,1) + call accumulate_tavg_field(TFW(:,:,2,iblock)*rho_sw*c10, tavg_TFW_S,iblock,1) + call accumulate_tavg_field(U10_SQR(:,:,iblock), tavg_U10_SQR,iblock,1) + + + end do + + !$OMP END PARALLEL DO + + if (registry_match('lcoupled')) call tavg_coupled_forcing + +!----------------------------------------------------------------------- +!EOC + + end subroutine tavg_forcing + + +!*********************************************************************** +!BOP +! !IROUTINE: movie_forcing +! !INTERFACE: + + subroutine movie_forcing + +! !DESCRIPTION: +! This routine accumulates movie diagnostics related to surface +! forcing. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + iblock ! block loop index + + type (block) :: & + this_block ! block information for current block + + real (r8), dimension(nx_block,ny_block) :: & + WORK ! local temp space for movie diagnostics + +!----------------------------------------------------------------------- +! +! compute and dump movie forcing diagnostics +! +!----------------------------------------------------------------------- + + !$OMP PARALLEL DO PRIVATE(iblock,this_block,WORK) + + do iblock = 1,nblocks_clinic + + this_block = get_block(blocks_clinic(iblock),iblock) + +!----------------------------------------------------------------------- +! +! dump movie diagnostics if requested +! +!----------------------------------------------------------------------- + + if (movie_requested(movie_SHF) ) then + where (KMT(:,:,iblock) > 0) + WORK = (STF(:,:,1,iblock)+SHF_QSW(:,:,iblock))/ & + hflux_factor ! W/m^2 + elsewhere + WORK = c0 + end where + call update_movie_field(WORK, movie_SHF, iblock, 1) + endif + + if (movie_requested(movie_SFWF) ) then + if (sfc_layer_type == sfc_layer_varthick .and. & + .not. lfw_as_salt_flx) then + where (KMT(:,:,iblock) > 0) + WORK = FW(:,:,iblock)*seconds_in_year*mpercm ! m/yr + elsewhere + WORK = c0 + end where + else + where (KMT(:,:,iblock) > 0) ! convert to kg(freshwater)/m^2/s + WORK = STF(:,:,2,iblock)/salinity_factor + elsewhere + WORK = c0 + end where + endif + call update_movie_field(WORK, movie_SFWF, iblock, 1) + endif + + if (movie_requested(movie_TAUX) ) then + call update_movie_field(SMF(:,:,1,iblock), & + movie_TAUX,iblock,1) + endif + + if (movie_requested(movie_TAUY) ) then + call update_movie_field(SMF(:,:,2,iblock), & + movie_TAUY,iblock,1) + endif + + + end do + + !$OMP END PARALLEL DO + +!----------------------------------------------------------------------- +!EOC + + end subroutine movie_forcing + + +!*********************************************************************** + + end module forcing + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.pop2/initial.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.pop2/initial.F90 new file mode 100644 index 0000000000..74e192dcce --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.pop2/initial.F90 @@ -0,0 +1,2233 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_2_1/models/ocn/pop2/source/initial.F90 + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + + module initial + +!BOP +! !MODULE: initial +! !DESCRIPTION: +! This module contains routines for initializing a POP simulation, +! mostly by calling individual initialization routines for each +! POP module. +! +! !REVISION HISTORY: +! SVN:$Id: initial.F90 44694 2013-03-12 19:58:14Z mlevy@ucar.edu $ +! +! !USES: + + use POP_KindsMod + use POP_ErrorMod + use POP_IOUnitsMod + use POP_SolversMod + use POP_ReductionsMod + + use kinds_mod, only: i4, i8, r8, int_kind, log_kind, char_len + use blocks, only: block, nx_block, ny_block, get_block + use domain_size + use domain, only: nblocks_clinic, blocks_clinic, init_domain_blocks, & + init_domain_distribution, distrb_clinic + use constants, only: radian, delim_fmt, blank_fmt, field_loc_center, blank_fmt, & + c0, ppt_to_salt, mpercm, c1, field_type_scalar, init_constants, & + stefan_boltzmann, latent_heat_vapor_mks, vonkar, emissivity, & + latent_heat_fusion, t0_kelvin, pi, ocn_ref_salinity, & + sea_ice_salinity, radius, cp_sw, grav, omega,cp_air, & + rho_fw, sound, rho_air, rho_sw, ndelim_fmt + use communicate, only: my_task, master_task, init_communicate + use budget_diagnostics, only: init_budget_diagnostics + use broadcast, only: broadcast_array, broadcast_scalar + use prognostic, only: init_prognostic, max_blocks_clinic, nx_global, & + ny_global, km, nt, TRACER, curtime, RHO, newtime, oldtime + use grid, only: init_grid1, init_grid2, kmt, kmt_g, n_topo_smooth, zt, & + fill_points, sfc_layer_varthick, sfc_layer_type, TLON, TLAT, partial_bottom_cells + use io + use io_tools + use baroclinic, only: init_baroclinic + use barotropic, only: init_barotropic + use pressure_grad, only: init_pressure_grad + use surface_hgt, only: init_surface_hgt + use vertical_mix, only: init_vertical_mix, vmix_itype, vmix_type_kpp + use vmix_kpp, only: bckgrnd_vdc2, linertial + use horizontal_mix, only: init_horizontal_mix + use advection, only: init_advection + use diagnostics, only: init_diagnostics + use state_mod, only: init_state, state, state_itype, state_type_mwjf, state_range_iopt, & + state_range_enforce + use time_management, only: first_step, init_time1, init_time2, & + dttxcel, dtuxcel, check_time_flag_int, & + get_time_flag_id, freq_opt_nhour + use topostress, only: init_topostress + use ice + use output, only: init_output + use tavg, only: ltavg_restart, tavg_id, set_in_tavg_contents,n_tavg_streams, tavg_streams + !use hydro_sections + !use current_meters + !use drifters + use forcing, only: init_forcing + use forcing_sfwf, only: sfwf_formulation, lms_balance, sfwf_data_type, lfw_as_salt_flx + use forcing_shf, only: luse_cpl_ifrac, OCN_WGT, shf_formulation, shf_data_type + use forcing_ws, only: ws_data_type + use sw_absorption, only: init_sw_absorption + use passive_tracers, only: init_passive_tracers, ecosys_on + use ecosys_mod, only: ecosys_qsw_distrb_const + use exit_mod, only: sigAbort, exit_pop, flushm + use restart, only: read_restart, restart_fmt, read_restart_filename + use ms_balance, only: init_ms_balance + use forcing_coupled, only: pop_init_coupled, pop_init_partially_coupled, & + qsw_distrb_iopt, qsw_distrb_iopt_const, ncouple_per_day, coupled_freq_iopt + use global_reductions, only: init_global_reductions, global_sum + use timers, only: init_timers + use registry + use qflux_mod, only: init_qflux + use niw_mixing + use tidal_mixing + use step_mod, only: init_step + use gather_scatter +#ifdef CCSMCOUPLED + use shr_ncread_mod + use shr_map_mod +#endif + use overflows + use overflow_type + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + + public :: pop_init_phase1, pop_init_phase2 + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- + + character (char_len) :: & + init_ts_file_fmt, &! format (bin or nc) for input file + exit_string ! exit_POP message string + + logical (log_kind), public :: &! context variables + lcoupled, &! T ==> pop is coupled to another system + lccsm, &! T ==> pop is being run in the ccsm context + b4b_flag, &! T ==> pop is being run in the "bit-for-bit" mode + ldata_assim, &! T ==> pop is being run in data assimilation mode !POPDART added by AK Sept 21,2012 + lccsm_control_compatible ! T ==> pop is being run with code that is b4b with the ccsm4 control run + ! this is a temporary flag that will be removed in ccsm4_0_1 + +!EOC +!*********************************************************************** + + contains +!*********************************************************************** +!BOP +! !IROUTINE: pop_init_phase1 +! !INTERFACE: + + subroutine pop_init_phase1(errorCode) + +! !DESCRIPTION: +! This routine is the first of a two-phase initialization process for +! a POP run. It calls various module initialization routines and sets up +! the initial temperature and salinity +! +! !REVISION HISTORY: +! same as module +! +! !OUTPUT PARAMETERS: + + integer (POP_i4), intent(out) :: & + errorCode ! returned error code + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + k, &! dummy vertical level index + ier ! error flag + +!----------------------------------------------------------------------- +! +! initialize message-passing or other communication protocol +! +!----------------------------------------------------------------------- + + errorCode = POP_Success + + call init_communicate + +!----------------------------------------------------------------------- +! +! initialize registry, which keeps track of which initialization +! routines have been called. This feature is used for error checking +! in routines whose calling order is important +! +!----------------------------------------------------------------------- + + call init_registry + +!----------------------------------------------------------------------- +! +! initialize constants and i/o stuff +! +!----------------------------------------------------------------------- + + call init_io + +#ifdef CCSMCOUPLED +!----------------------------------------------------------------------- +! +! temporary synching of old and new pop2 infrastructure for CCSM +! +!----------------------------------------------------------------------- + POP_stdout = stdout + POP_stderr = stderr + POP_stdin = stdin +#endif + +!----------------------------------------------------------------------- +! +! initialize context in which pop is being run +! +!----------------------------------------------------------------------- + + call init_context + +!----------------------------------------------------------------------- +! +! write version information to output log after output redirection +! +!----------------------------------------------------------------------- + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,'(a)') ' Parallel Ocean Program (POP) ' + write(stdout,'(a)') ' Based on Version 2.1alpha Jan 2005' + write(stdout,'(a)') ' Modified for CESM 2005-2010' + write(stdout,blank_fmt) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + call init_constants + +!----------------------------------------------------------------------- +! +! initialize timers +! +!----------------------------------------------------------------------- + + call init_timers + +!----------------------------------------------------------------------- +! +! initialize additional communication routines +! +!----------------------------------------------------------------------- + + call init_global_reductions + call POP_initReductions + +!----------------------------------------------------------------------- +! +! initialize overflows, part I +! +!----------------------------------------------------------------------- + + call init_overflows1 + +!----------------------------------------------------------------------- +! +! initialize domain and grid +! +!----------------------------------------------------------------------- + + call init_domain_blocks + call init_grid1 + call init_domain_distribution(KMT_G) + +!----------------------------------------------------------------------- +! +! initialize overflows, part II. placed here so KMT_G scatter to +! KMT can be done (and NOT in init_grid2) for possible KMT mods; then +! finish with domain and grid initialization +! +!----------------------------------------------------------------------- + + call init_overflows2 + + call init_grid2(errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_phase1: error initializing grid 2') + return + endif + +!----------------------------------------------------------------------- +! +! compute time step and initialize time-related quantities +! +!----------------------------------------------------------------------- + + call init_time1 + +!----------------------------------------------------------------------- +! +! initialize equation of state +! +!----------------------------------------------------------------------- + + call init_state + +!----------------------------------------------------------------------- +! +! calculate topographic stress (maximum entropy) velocities +! +!----------------------------------------------------------------------- + + call init_topostress(errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_phase1: error in init_topostress') + return + endif + +!----------------------------------------------------------------------- +! +! initialize niw driven mixing +! +!----------------------------------------------------------------------- + + call init_niw_mixing + +!----------------------------------------------------------------------- +! +! initialize tidally driven mixing +! +!----------------------------------------------------------------------- + + call init_tidal_mixing + + if ( overflows_interactive .and. .not.ltidal_mixing ) then + exit_string = 'FATAL ERROR: overflow code is validated only with tidal mixing' + call document ('pop_init_phase1', exit_string) + call exit_POP (sigAbort,exit_string,out_unit=stdout) + endif + +!----------------------------------------------------------------------- +! +! initialize barotropic elliptic solver +! +!----------------------------------------------------------------------- + + call POP_SolversInit(errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'POP_Init: error initializing solvers') + return + endif + +!----------------------------------------------------------------------- +! +! modify 9pt coefficients for barotropic solver for overflow use +! +!----------------------------------------------------------------------- + + call init_overflows3 + +!----------------------------------------------------------------------- +! +! initialize pressure gradient (pressure averaging) +! initialize baroclinic (reset to freezing) +! initialize barotropic (barotropic-related diagnostics) +! initialize surface_hgt (ssh-related diagnostics) +! +!----------------------------------------------------------------------- + + call init_pressure_grad + call init_baroclinic + call init_barotropic + call init_surface_hgt + +!----------------------------------------------------------------------- +! +! initialize prognostic fields +! +!----------------------------------------------------------------------- + + call init_prognostic + +!----------------------------------------------------------------------- +! +! initialize ice module +! +!----------------------------------------------------------------------- + + call init_ice + +!----------------------------------------------------------------------- +! +! set initial temperature and salinity profiles (includes read of +! restart file +! +!----------------------------------------------------------------------- + + call init_ts(errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_phase1: error in init_ts') + return + endif + +!----------------------------------------------------------------------- +! +! finish computing time-related quantities after restart info +! available +! +!----------------------------------------------------------------------- + + call init_time2 + + +!----------------------------------------------------------------------- +! +! initialize fields for surface forcing +! o init_ws +! o init_shf +! o init_sfwf +! o init_pt_interior +! o init_s_interior +! o init_ap +! +!----------------------------------------------------------------------- + + call init_forcing + +!----------------------------------------------------------------------- +! +! initialize generic aspects of coupled forcing (no coupling-specific +! references) +! +!----------------------------------------------------------------------- + + call pop_init_coupled + +!----------------------------------------------------------------------- +!EOC + + end subroutine pop_init_phase1 + + +!*********************************************************************** +!BOP +! !IROUTINE: pop_init_phase2 +! !INTERFACE: + + subroutine pop_init_phase2(errorCode) + +! !DESCRIPTION: +! This routine completes the two-phase initialization process for +! a POP run. +! +! !REVISION HISTORY: +! same as module +! +! !OUTPUT PARAMETERS: + + integer (POP_i4), intent(out) :: & + errorCode ! returned error code + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + k, &! dummy vertical level index + ier ! error flag + + +!----------------------------------------------------------------------- +! +! initialize passive tracer modules -- after call init_forcing_coupled +! do this independently of nt so that +! 1) consistency of nt and selected passive tracer modules +! can always be checked +! 2) passive_tavg_nonstd_vars gets allocated +! +!----------------------------------------------------------------------- + + errorCode = POP_Success + + call init_passive_tracers(init_ts_file_fmt, read_restart_filename, & + errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_phase2: error in init_passive_tracers') + return + endif + +!----------------------------------------------------------------------- +! +! initialize vertical mixing variables +! initialize horizontal mixing variables +! +!----------------------------------------------------------------------- + + call init_vertical_mix + + call init_horizontal_mix(errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_phase1: error in init_horizontal_mix') + return + endif + +!----------------------------------------------------------------------- +! +! initialize overflow regional values +! +!----------------------------------------------------------------------- + + call init_overflows5 + +!----------------------------------------------------------------------- +! +! initialize advection variables +! +!----------------------------------------------------------------------- + + call init_advection + +!----------------------------------------------------------------------- +! +! initialize shortwave absorption +! +!----------------------------------------------------------------------- + + call init_sw_absorption + +!----------------------------------------------------------------------- +! +! partial coupling forcing initialization +! +!----------------------------------------------------------------------- + + call pop_init_partially_coupled + +!----------------------------------------------------------------------- +! +! initialize time-averaged qflux information +! +!----------------------------------------------------------------------- + + call init_qflux + +!----------------------------------------------------------------------- +! +! initialize ms_balance +! +!----------------------------------------------------------------------- + + if (lcoupled .and. lms_balance) call init_ms_balance + +!----------------------------------------------------------------------- +! +! initialize diagnostics +! +!----------------------------------------------------------------------- + + call init_diagnostics + +!----------------------------------------------------------------------- +! +! initialize overflows output diagnostics filename +! +!----------------------------------------------------------------------- + + call init_overflows4 + +!----------------------------------------------------------------------- +! +! initialize output; subroutine init_output calls +! o init_restart +! o init_history +! o init_movie +! o init_tavg +! +!----------------------------------------------------------------------- + + call init_output + +!----------------------------------------------------------------------- +! +! initialize drifters, hydrographic sections and current meters +! +!----------------------------------------------------------------------- + + !call init_drifters + !call init_hydro_sections + !call init_current_meters + +!----------------------------------------------------------------------- +! +! initialize global budget diagnostics +! +!----------------------------------------------------------------------- + + call init_budget_diagnostics + +!----------------------------------------------------------------------- +! +! initialize step timers +! +!----------------------------------------------------------------------- + + call init_step + +!----------------------------------------------------------------------- +! +! check registry -- have any errors occured? +! +!----------------------------------------------------------------------- + + call trap_registry_failure + +!----------------------------------------------------------------------- +! +! check consistency of model options +! +!----------------------------------------------------------------------- + + call POP_check + +!----------------------------------------------------------------------- +! +! write model information into log file +! +!----------------------------------------------------------------------- + + call document_constants + + +!----------------------------------------------------------------------- +!EOC + + end subroutine pop_init_phase2 + + + +!*********************************************************************** +!BOP +! !IROUTINE: init_context +! !INTERFACE: + + subroutine init_context + +! !DESCRIPTION: +! This routine initializes the context in which POP is being run, +! including information about coupling and CCSM +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + + integer (int_kind) :: & + nml_error, &! namelist i/o error flag + number_of_fatal_errors + + namelist /context_nml/ lcoupled, lccsm, b4b_flag, lccsm_control_compatible + +!----------------------------------------------------------------------- +! +! read context_nml namelist to determine the context in which pop +! being run. check for errors and broadcast info to all processors +! +!----------------------------------------------------------------------- + + lcoupled = .false. + lccsm = .false. + b4b_flag = .false. + lccsm_control_compatible = .true. + + if (my_task == master_task) then + open (nml_in, file=nml_filename, status='old',iostat=nml_error) + if (nml_error /= 0) then + nml_error = -1 + else + nml_error = 1 + endif + do while (nml_error > 0) + read(nml_in, nml=context_nml,iostat=nml_error) + end do + if (nml_error == 0) close(nml_in) + endif + + call broadcast_scalar(nml_error, master_task) + if (nml_error /= 0) then + exit_string = 'FATAL ERROR: reading context_nml' + call document ('init_context', exit_string) + call exit_POP (sigAbort,exit_string,out_unit=stdout) + endif + + call broadcast_scalar(lcoupled, master_task) + call broadcast_scalar(lccsm, master_task) + call broadcast_scalar(b4b_flag, master_task) + call broadcast_scalar(lccsm_control_compatible, master_task) + +!----------------------------------------------------------------------- +! +! register information with the registry function, allowing other +! modules to access this information (avoids circular dependencies) +! +!----------------------------------------------------------------------- + if (lcoupled) call register_string('lcoupled') + if (lccsm) call register_string('lccsm') + if (b4b_flag) call register_string('b4b_flag') + if (lccsm_control_compatible) call register_string('lccsm_control_compatible') + +!----------------------------------------------------------------------- +! +! document the namelist information +! +!----------------------------------------------------------------------- + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,*) ' Context:' + write(stdout,blank_fmt) + write(stdout,*) ' context_nml namelist settings:' + write(stdout,blank_fmt) + write(stdout, context_nml) + write(stdout,blank_fmt) + endif + +!----------------------------------------------------------------------- +! +! error checking +! +!----------------------------------------------------------------------- + + number_of_fatal_errors = 0 + + if (.not. (lcoupled .eqv. lccsm)) then + exit_string = 'FATAL ERROR: presently, lcoupled and lccsm must have the same value' + call document ('init_context', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +#ifdef CCSMCOUPLED + if (.not. lcoupled) then + exit_string = 'FATAL ERROR: inconsistent options.' & + // ' Cpp option coupled is defined, but lcoupled = .false.' + call document ('init_context', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif +#else + if (lcoupled) then + exit_string = 'FATAL ERROR: inconsistent options.' & + // ' Cpp option coupled is not defined, but lcoupled = .true.' + call document ('init_context', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif +#endif + + if (number_of_fatal_errors > 0) & + call exit_POP(sigAbort,'ERROR: subroutine init_context -- see preceeding message') + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_context + +!*********************************************************************** +!BOP +! !IROUTINE: init_ts +! !INTERFACE: + + subroutine init_ts(errorCode) + +! !DESCRIPTION: +! Initializes temperature and salinity and +! initializes prognostic variables from restart if required +! +! !REVISION HISTORY: +! same as module +! +! !OUTPUT PARAMETERS: + + integer (POP_i4), intent(out) :: & + errorCode ! returned error code + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! namelist input +! +!----------------------------------------------------------------------- + + integer (int_kind) :: nml_error ! namelist i/o error flag + + character (char_len) :: & + init_ts_option, &! option for initializing t,s + init_ts_suboption, &! suboption for initializing t,s (rest or spunup) + init_ts_file, &! filename for input T,S file + init_ts_outfile, &! filename for output T,S file + init_ts_outfile_fmt ! format for output T,S file (bin or nc) + + namelist /init_ts_nml/ init_ts_option, init_ts_file, init_ts_file_fmt, & + init_ts_suboption, init_ts_outfile, & + init_ts_outfile_fmt + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + i,j,k,icnt, &! vertical level index + n, &! tracer index + kk, &! indices for interpolating levitus data + nu, &! i/o unit for mean profile file + iblock ! local block address + + integer (int_kind) :: & + m, &! overflows dummy loop index + ib,ie,jb,je ! local domain index boundaries + + integer (i4) :: & + PHCnx,PHCny,PHCnz + + integer (i4), dimension(:,:), allocatable :: & + PHC_msk,MASK_G + + logical (log_kind) :: & + lccsm_branch ,&! flag for ccsm 'ccsm_branch' restart + lccsm_hybrid ! flag for ccsm 'ccsm_hybrid' restart + + type (block) :: & + this_block ! block information for current block + + real (r8) :: & + sinterp, &! factor for interpolating levitus data + dpth_meters ! depth of level in meters + + real (r8), dimension(km) :: & + tinit, sinit ! mean initial state as function of depth + + type (datafile) :: & + in_file ! data file type for init ts file + + type (io_field_desc) :: & + io_temp, io_salt ! io field descriptors for input T,S + + type (io_dim) :: & + i_dim, j_dim, k_dim ! dimension descriptors + + real (r8), dimension(:,:,:,:), allocatable :: & + TEMP_DATA ! temp array for reading T,S data + + real (r8), dimension(:,:,:,:), allocatable :: & + PHC_ktop,PHC_kbot ! temp array for ncreading 3D PHC T,S data + + real (r8), dimension(:,:), allocatable :: & + dataSrc,dataDst, &! temp arrays for remapping PHC T,S data + PHC_x, &! lon array for PHC data + PHC_y, &! lat array for PHC data + PHC_kmod_T, &! PHC data on model zgrid + PHC_kmod_S, &! PHC data on model zgrid + MOD_T,MOD_S, &! 2D model init T,S data on model zgrid + tmpkt,tmpkb, &! 2D model init T,S data on model zgrid + TLON_G, &! global tlon array + TLAT_G ! global tlat array + + real (r8), dimension(:), allocatable :: & + tmp1,tmp2,PHC_z ! temp arrays + +#ifdef CCSMCOUPLED + type(shr_map_mapType) :: PHC_map ! used to map PHC data +#endif + + + !*** + !*** 1992 Levitus mean climatology for internal generation of t,s + !*** + + real (r8), dimension(33) :: & + depth_levitus = (/ & + 0.0_r8, 10.0_r8, 20.0_r8, & + 30.0_r8, 50.0_r8, 75.0_r8, & + 100.0_r8, 125.0_r8, 150.0_r8, & + 200.0_r8, 250.0_r8, 300.0_r8, & + 400.0_r8, 500.0_r8, 600.0_r8, & + 700.0_r8, 800.0_r8, 900.0_r8, & + 1000.0_r8, 1100.0_r8, 1200.0_r8, & + 1300.0_r8, 1400.0_r8, 1500.0_r8, & + 1750.0_r8, 2000.0_r8, 2500.0_r8, & + 3000.0_r8, 3500.0_r8, 4000.0_r8, & + 4500.0_r8, 5000.0_r8, 5500.0_r8 /) + + real (r8), dimension(33) :: & + tmean_levitus = (/ & + 18.27_r8, 18.22_r8, 18.09_r8, & + 17.87_r8, 17.17_r8, 16.11_r8, & + 15.07_r8, 14.12_r8, 13.29_r8, & + 11.87_r8, 10.78_r8, 9.94_r8, & + 8.53_r8, 7.35_r8, 6.38_r8, & + 5.65_r8, 5.06_r8, 4.57_r8, & + 4.13_r8, 3.80_r8, 3.51_r8, & + 3.26_r8, 3.05_r8, 2.86_r8, & + 2.47_r8, 2.19_r8, 1.78_r8, & + 1.49_r8, 1.26_r8, 1.05_r8, & + 0.91_r8, 0.87_r8, 1.00_r8 /) + + real (r8), dimension(33) :: & + smean_levitus = (/ & + 34.57_r8, 34.67_r8, 34.73_r8, & + 34.79_r8, 34.89_r8, 34.97_r8, & + 35.01_r8, 35.03_r8, 35.03_r8, & + 34.98_r8, 34.92_r8, 34.86_r8, & + 34.76_r8, 34.68_r8, 34.63_r8, & + 34.60_r8, 34.59_r8, 34.60_r8, & + 34.61_r8, 34.63_r8, 34.65_r8, & + 34.66_r8, 34.68_r8, 34.70_r8, & + 34.72_r8, 34.74_r8, 34.75_r8, & + 34.74_r8, 34.74_r8, 34.73_r8, & + 34.73_r8, 34.72_r8, 34.72_r8 /) + +!----------------------------------------------------------------------- +! +! read input namelist and broadcast +! +!----------------------------------------------------------------------- + + errorCode = POP_Success + + init_ts_suboption = 'rest' + init_ts_outfile = 'unknown_init_ts_outfile' + init_ts_outfile_fmt = 'bin' + ldata_assim = .false. !POPDART added by AK Sept 21,2012 + + if (my_task == master_task) then + open (nml_in, file=nml_filename, status='old',iostat=nml_error) + if (nml_error /= 0) then + nml_error = -1 + else + nml_error = 1 + endif + do while (nml_error > 0) + read(nml_in, nml=init_ts_nml,iostat=nml_error) + end do + if (nml_error == 0) close(nml_in) + endif + + call broadcast_scalar(nml_error, master_task) + if (nml_error /= 0) then + call exit_POP(sigAbort,'ERROR reading init_ts_nml') + endif + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,*) ' Initial T,S:' + write(stdout,blank_fmt) + write(stdout,*) ' init_ts_nml namelist settings:' + write(stdout,blank_fmt) + write(stdout,init_ts_nml) + write(stdout,blank_fmt) + if (trim(init_ts_option) == 'ccsm_startup' .and. & + trim(init_ts_suboption) == 'spunup') then + init_ts_option = 'ccsm_startup_spunup' + luse_pointer_files = .false. + endif + + select case (init_ts_option) + case ('ccsm_continue','restart', 'ccsm_branch', 'ccsm_hybrid') + !*****POPDART added by AK Sept 21,2012********* + if (trim(init_ts_suboption) == 'data_assim' ) then + ldata_assim = .true. + write(stdout,*) "AK: POPDART: Assume restarts followed an assimilation" + endif + !********************** + if (luse_pointer_files) then + write(stdout,*) ' In this case, the init_ts_file' /& + &/ ' name will be read from the pointer file.' + write(stdout,*) ' ' + endif + end select + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + call broadcast_scalar(init_ts_option , master_task) + call broadcast_scalar(ldata_assim , master_task) !POPDART added by AK sept 21,2012 + call broadcast_scalar(init_ts_suboption , master_task) + call broadcast_scalar(luse_pointer_files , master_task) + call broadcast_scalar(init_ts_file , master_task) + call broadcast_scalar(init_ts_file_fmt , master_task) + call broadcast_scalar(init_ts_outfile , master_task) + call broadcast_scalar(init_ts_outfile_fmt , master_task) + +!----------------------------------------------------------------------- +! +! initialize t,s or call restart based on init_ts_option +! +!----------------------------------------------------------------------- + + if (my_task == master_task) then ! TJH DEBUG on top of AK Sept 21 2012 + write(stdout,*) "DARTmessage: The init_ts_option is ", trim(init_ts_option) + write(stdout,*) "DARTmessage: The init_ts_suboption is ", trim(init_ts_suboption) + write(stdout,*) "DARTmessage: The ldata_assim value is ", ldata_assim + endif + + select case (init_ts_option) + +!----------------------------------------------------------------------- +! +! set initial state from restart file +! +!----------------------------------------------------------------------- + + case ('ccsm_continue', 'restart') + first_step = .false. + lccsm_branch = .false. + lccsm_hybrid = .false. + if (my_task == master_task .and. .not. luse_pointer_files) then + write(stdout,'(a35,a)') 'Initial T,S read from restart file:',& + trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout); call POP_IOUnitsFlush(stdout) + endif + + !******POPDART added by AK Sept 11,2013******************************* + !! If ldata_assim is true then the two time slices of POP states have + !! been modified by restart.F90:DART_modify_restart() to be identical. + !! Therefore, we must force the first step after data assimilation to + !! be forward euler. This happens when first_step = .true. + + if (ldata_assim) then + first_step = .true. + if (my_task == master_task) & + write(stdout,*) 'DART modification ... forward euler timestep.' + else + if (my_task == master_task) & + write(stdout,*) 'DART report ... standard timestep.' + endif + + !******POPDART added by AK Sept 21,2012******************************* + !! added the ldata_assim flag that changes read_restart + call read_restart(init_ts_file,lccsm_branch,lccsm_hybrid, & + init_ts_file_fmt, errorCode, ldata_assim=ldata_assim) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_ts: error in read_restart') + return + endif + + ltavg_restart = .true. + +!----------------------------------------------------------------------- +! +! set initial state from restart file +! +!----------------------------------------------------------------------- + + case ('ccsm_branch') + first_step = .false. + lccsm_branch = .true. + lccsm_hybrid = .false. + if (my_task == master_task .and. .not. luse_pointer_files) then + write(stdout,'(a40,a)') & + 'Initial T,S is a ccsm branch starting from the restart file:', & + trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + !******POPDART added by AK Sept 11,2013******************************* + !! If ldata_assim is true then the two time slices of POP states have + !! been modified by restart.F90:DART_modify_restart() to be identical. + !! Therefore, we must force the first step after data assimilation to + !! be forward euler. This happens when first_step = .true. + + if (ldata_assim) then + first_step = .true. + if (my_task == master_task) & + write(stdout,*) 'DART modification ... forward euler timestep.' + else + if (my_task == master_task) & + write(stdout,*) 'DART report ... standard timestep.' + endif + + call read_restart(init_ts_file,lccsm_branch,lccsm_hybrid, & + init_ts_file_fmt, errorCode, ldata_assim=ldata_assim) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_ts: error in read_restart') + return + endif + + ltavg_restart = .false. + + case ('ccsm_hybrid', 'branch') ! ccsm hybrid start or LANL branch start + first_step = .false. + lccsm_branch = .false. + lccsm_hybrid = .true. + if (my_task == master_task .and. .not. luse_pointer_files) then + write(stdout,'(a80,a)') & + 'Initial T,S ccsm_hybrid start from restart file:', & + trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + !******POPDART added by AK Sept 11,2013******************************* + !! If ldata_assim is true then the two time slices of POP states have + !! been modified by restart.F90:DART_modify_restart() to be identical. + !! Therefore, we must force the first step after data assimilation to + !! be forward euler. This happens when first_step = .true. + + if (ldata_assim) then + first_step = .true. + if (my_task == master_task) & + write(stdout,*) 'DART modification ... forward euler timestep.' + else + if (my_task == master_task) & + write(stdout,*) 'DART report ... standard timestep.' + endif + + call read_restart(init_ts_file,lccsm_branch,lccsm_hybrid, & + init_ts_file_fmt, errorCode, ldata_assim=ldata_assim) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_ts: error in read_restart') + return + endif + + ltavg_restart = .false. + + case ('ccsm_startup_spunup') + if(my_task == master_task ) then + write(stdout,*) ' ccsm_startup_spunup option' + write(stdout,*) ' init_ts_option = ', init_ts_option + endif + first_step = .false. + lccsm_branch = .false. + lccsm_hybrid = .true. + if (my_task == master_task .and. .not. luse_pointer_files) then + write(stdout,'(a80,a)') & + 'Initial T,S ccsm_startup run from spun-up restart file:', & + trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + call read_restart(init_ts_file,lccsm_branch,lccsm_hybrid, & + init_ts_file_fmt, errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_ts: error in read_restart') + return + endif + + ltavg_restart = .false. + !*** turn pointer file-creation back on + luse_pointer_files = .true. + +!----------------------------------------------------------------------- +! +! read full 3-d t,s from input file +! +!----------------------------------------------------------------------- + + case ('ccsm_startup', 'file') + first_step = .true. + + if (my_task == master_task) then + write(stdout,'(a31,a)') 'Initial 3-d T,S read from file:', & + trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + allocate(TEMP_DATA(nx_block,ny_block,km,max_blocks_clinic)) + + in_file = construct_file(init_ts_file_fmt, & + full_name=trim(init_ts_file), & + record_length = rec_type_dbl, & + recl_words=nx_global*ny_global) + call data_set(in_file,'open_read') + + i_dim = construct_io_dim('i',nx_global) + j_dim = construct_io_dim('j',ny_global) + k_dim = construct_io_dim('k',km) + + io_temp = construct_io_field('TEMPERATURE', & + dim1=i_dim, dim2=j_dim, dim3=k_dim, & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d3d_array=TEMP_DATA) + io_salt = construct_io_field('SALINITY', & + dim1=i_dim, dim2=j_dim, dim3=k_dim, & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d3d_array=TEMP_DATA) + + call data_set(in_file,'define',io_temp) + call data_set(in_file,'define',io_salt) + + call data_set(in_file,'read' ,io_temp) + do iblock=1,nblocks_clinic + TRACER(:,:,:,1,curtime,iblock) = TEMP_DATA(:,:,:,iblock) + end do + call data_set(in_file,'read' ,io_salt) + do iblock=1,nblocks_clinic + TRACER(:,:,:,2,curtime,iblock) = TEMP_DATA(:,:,:,iblock) + end do + + call destroy_io_field(io_temp) + call destroy_io_field(io_salt) + + deallocate(TEMP_DATA) + + call data_set(in_file,'close') + call destroy_file(in_file) + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,'(a12,a)') ' file read: ', trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + +!#################### temporary kludge for overflows #################### +!----------------------------------------------------------------------- +! fill any overflow-deepened points with T,S values from above +!----------------------------------------------------------------------- + + + if (overflows_on) then + ! fill any overflow-deepened points with T,S values from above + ! fill entire TRACER array for ghost (or halo) points + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + do j=1,ny_block + do i=1,nx_block + do n=1,num_ovf + do m=1,ovf(n)%num_kmt + if( ovf(n)%loc_kmt(m)%i.eq.this_block%i_glob(i).and.& + ovf(n)%loc_kmt(m)%j.eq.this_block%j_glob(j) ) then + if(ovf(n)%loc_kmt(m)%knew .gt. ovf(n)%loc_kmt(m)%korg) then + do k=ovf(n)%loc_kmt(m)%korg+1,ovf(n)%loc_kmt(m)%knew + ! use T,S from level above with slight increase in S + TRACER(i,j,k,1,curtime,iblock) = & + TRACER(i,j,k-1,1,curtime,iblock) + TRACER(i,j,k,2,curtime,iblock) = & + TRACER(i,j,k-1,2,curtime,iblock) * 1.001 + write(stdout,100) ovf(n)%loc_kmt(m)%i, & + ovf(n)%loc_kmt(m)%j,ovf(n)%loc_kmt(m)%korg, & + k,ovf(n)%loc_kmt(m)%knew + 100 format(' init_ts: T,S extended from ijKMT = ', & + 3(i4,1x),' to k=',i3,' until KMT_new=',i3) + enddo + endif + endif + end do + end do + enddo + enddo + enddo + endif + + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) +!################ end temporary kludge for overflows #################### + + + !$OMP PARALLEL DO PRIVATE(iblock, k, n) + do iblock = 1,nblocks_clinic + do n=1,nt + do k=1,km + where (k > KMT(:,:,iblock)) & + TRACER(:,:,k,n,curtime,iblock) = c0 + end do + end do + + !*** convert salinity to model units + TRACER(:,:,:,2,curtime,iblock) = & + TRACER(:,:,:,2,curtime,iblock)*ppt_to_salt + end do + !$OMP END PARALLEL DO + + if (n_topo_smooth > 0) then + do k=1,km + call fill_points(k,TRACER(:,:,k,1,curtime,:),errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_ts: error in fill_points for temp') + return + endif + + call fill_points(k,TRACER(:,:,k,2,curtime,:),errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'init_ts: error in fill_points for salt') + return + endif + + enddo + endif + + do iblock=1,nblocks_clinic + TRACER(:,:,:,:,newtime,iblock) = TRACER(:,:,:,:,curtime,iblock) + TRACER(:,:,:,:,oldtime,iblock) = TRACER(:,:,:,:,curtime,iblock) + end do + +!----------------------------------------------------------------------- +! +! set up t,s from input mean state as function of depth +! +!----------------------------------------------------------------------- + + case ('mean') + first_step = .true. + + !*** + !*** open input file and read t,s profile + !*** + + call get_unit(nu) + if (my_task == master_task) then + write(stdout,'(a40,a)') & + 'Initial mean T,S profile read from file:', & + trim(init_ts_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + open(nu, file=init_ts_file, status='old') + do k = 1,km + read(nu,*) tinit(k),sinit(k) + enddo + close (nu) + endif + call release_unit(nu) + + call broadcast_array(tinit, master_task) + call broadcast_array(sinit, master_task) + + !*** + !*** fill tracer array with appropriate values + !*** + + !$OMP PARALLEL DO PRIVATE(iblock, k) + do iblock = 1,nblocks_clinic + do k=1,km + where (k <= KMT(:,:,iblock)) + TRACER(:,:,k,1,curtime,iblock) = tinit(k) + TRACER(:,:,k,2,curtime,iblock) = sinit(k)*ppt_to_salt + endwhere + enddo + + TRACER(:,:,:,:,newtime,iblock)=TRACER(:,:,:,:,curtime,iblock) + TRACER(:,:,:,:,oldtime,iblock)=TRACER(:,:,:,:,curtime,iblock) + end do + !$OMP END PARALLEL DO + +!----------------------------------------------------------------------- +! +! set up initial profile from 1992 Levitus mean ocean data +! +!----------------------------------------------------------------------- + + case ('internal') + first_step = .true. + if (my_task == master_task) then + write(stdout,'(a63)') & + 'Initial T,S profile computed internally from 1992 Levitus data' + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + !$OMP PARALLEL DO PRIVATE(iblock, k, kk, & + !$OMP dpth_meters, sinterp, tinit, sinit) + + do iblock = 1,nblocks_clinic + do k=1,km + + dpth_meters = zt(k)*mpercm + + intrp_loop: do kk=1,32 + if (dpth_meters >= depth_levitus(kk) .and. & + dpth_meters < depth_levitus(kk+1)) exit intrp_loop + end do intrp_loop + + sinterp = (dpth_meters - depth_levitus(kk))/ & + (depth_levitus(kk+1) - depth_levitus(kk)) + + tinit(k) = (c1 - sinterp)*tmean_levitus(kk) + & + sinterp *tmean_levitus(kk+1) + sinit(k) = (c1 - sinterp)*smean_levitus(kk) + & + sinterp *smean_levitus(kk+1) + + where (k <= KMT(:,:,iblock)) + TRACER(:,:,k,1,curtime,iblock) = tinit(k) + TRACER(:,:,k,2,curtime,iblock) = sinit(k)*ppt_to_salt + endwhere + + enddo + + TRACER(:,:,:,:,newtime,iblock)=TRACER(:,:,:,:,curtime,iblock) + TRACER(:,:,:,:,oldtime,iblock)=TRACER(:,:,:,:,curtime,iblock) + enddo + !$OMP END PARALLEL DO + +!----------------------------------------------------------------------- +! +! remap PHC Levitus data to POP grid +! +!----------------------------------------------------------------------- + +#ifdef CCSMCOUPLED + case ('PHC') + first_step = .true. + + if (my_task == master_task) then + write(stdout,'(a63)') & + 'Initial T,S profile generated by 3D remapping of filled Levitus-PHC data' + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + + write(stdout,*) ' init_ts_option = PHC' + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + + + allocate (TLON_G(nx_global,ny_global),TLAT_G(nx_global,ny_global)) + call gather_global(TLON_G, TLON, master_task,distrb_clinic) + call gather_global(TLAT_G, TLAT, master_task,distrb_clinic) + + if (my_task == master_task) then + + call shr_ncread_varDimSizes(trim(init_ts_file),'TEMP',PHCnx,PHCny,PHCnz) + + allocate(MOD_T(nx_global,ny_global),MOD_S(nx_global,ny_global)) + allocate(PHC_kmod_T(PHCnx,PHCny),PHC_kmod_S(PHCnx,PHCny)) + allocate(PHC_ktop(PHCnx,PHCny,1,1),PHC_kbot(PHCnx,PHCny,1,1)) + allocate(tmpkt(PHCnx,PHCny),tmpkb(PHCnx,PHCny)) + allocate(PHC_x(PHCnx,PHCny),PHC_y(PHCnx,PHCny),PHC_msk(PHCnx,PHCny)) + allocate(tmp1(PHCnx),tmp2(PHCny),PHC_z(PHCnz)) + allocate (MASK_G(nx_global,ny_global)) + allocate(dataSrc(2,PHCnx*PHCny)) + allocate(dataDst(2,nx_global*ny_global)) + + PHC_msk(:,:) = 1 + MASK_G(:,:) = 1 + + call shr_ncread_tField(trim(init_ts_file),1,'lon',tmp1) + call shr_ncread_tField(trim(init_ts_file),1,'lat',tmp2) + call shr_ncread_tField(trim(init_ts_file),1,'depth',PHC_z) + + do j=1,PHCny + PHC_x(:,j) = tmp1/radian + enddo + do i=1,PHCnx + PHC_y(i,:) = tmp2/radian + enddo + + call shr_map_mapSet(PHC_map, PHC_x, PHC_y, PHC_msk, & + & TLON_G, TLAT_G, MASK_G, & + & name='phc_map',type='remap',algo='bilinear', & + & mask='dstmask',vect='scalar') + + !------------------------------------------------- + ! copy input data to arrays ordered for mapping + !------------------------------------------------- + + endif + + do k=1,km + if (my_task == master_task) then + dpth_meters = zt(k)*mpercm + + PHC_z_loop: do kk=1,PHCnz-1 + if (dpth_meters >= PHC_z(kk) .and. & + dpth_meters < PHC_z(kk+1)) exit PHC_z_loop + end do PHC_z_loop + + sinterp = (dpth_meters - depth_levitus(kk))/ & + (depth_levitus(kk+1) - depth_levitus(kk)) + + !------------------------------------------------- + ! do vertical remap of T + !------------------------------------------------- + call shr_ncread_field4dG(trim(init_ts_file),'TEMP', & + rfld=PHC_ktop, dim3='depth',dim3i=kk) + call shr_ncread_field4dG(trim(init_ts_file),'TEMP', & + rfld=PHC_kbot, dim3='depth',dim3i=kk+1) + tmpkt = reshape(PHC_ktop,(/PHCnx,PHCny/)) + tmpkb = reshape(PHC_kbot,(/PHCnx,PHCny/)) + PHC_kmod_T(:,:) = (c1 - sinterp)*tmpkt(:,:) + & + sinterp *tmpkb(:,:) + + !------------------------------------------------- + ! do vertical remap of S + !------------------------------------------------- + call shr_ncread_field4dG(trim(init_ts_file),'SALT', & + rfld=PHC_ktop, dim3='depth',dim3i=kk) + call shr_ncread_field4dG(trim(init_ts_file),'SALT', & + rfld=PHC_kbot, dim3='depth',dim3i=kk+1) + tmpkt = reshape(PHC_ktop,(/PHCnx,PHCny/)) + tmpkb = reshape(PHC_kbot,(/PHCnx,PHCny/)) + + PHC_kmod_S(:,:) = (c1 - sinterp)*tmpkt(:,:) + & + sinterp *tmpkb(:,:) + + !------------------------------------------------- + ! do horizontal remap of T & S + !------------------------------------------------- + icnt = 0 + do j=1,PHCny + do i=1,PHCnx + icnt = icnt + 1 + dataSrc(1,icnt) = PHC_kmod_T(i,j) + dataSrc(2,icnt) = PHC_kmod_S(i,j) + enddo + enddo + + call shr_map_mapData(dataSrc, dataDst, PHC_map) + + icnt = 0 + do j=1,ny_global + do i=1,nx_global + icnt = icnt + 1 + MOD_T(i,j) = dataDst(1,icnt) + MOD_S(i,j) = dataDst(2,icnt) + enddo + enddo + + endif + + call scatter_global(TRACER(:,:,k,1,curtime,:), MOD_T, & + master_task, distrb_clinic, field_loc_center, field_type_scalar) + call scatter_global(TRACER(:,:,k,2,curtime,:), MOD_S, & + master_task, distrb_clinic, field_loc_center, field_type_scalar) + + enddo + + deallocate(TLON_G,TLAT_G) + if (my_task == master_task) then + deallocate(MOD_T, MOD_S) + deallocate(PHC_kmod_T,PHC_kmod_S) + deallocate(PHC_ktop,PHC_kbot) + deallocate(tmpkt,tmpkb,PHC_z) + deallocate(PHC_x, PHC_y, PHC_msk, tmp1, tmp2) + deallocate(MASK_G, dataSrc, dataDst) + endif + + !$OMP PARALLEL DO PRIVATE(iblock, k, n) + do iblock = 1,nblocks_clinic + do n=1,nt + do k=1,km + where (k > KMT(:,:,iblock)) & + TRACER(:,:,k,n,curtime,iblock) = c0 + end do + end do + + !*** convert salinity to model units + TRACER(:,:,:,2,curtime,iblock) = & + TRACER(:,:,:,2,curtime,iblock)*ppt_to_salt + end do + !$OMP END PARALLEL DO + + do iblock=1,nblocks_clinic + TRACER(:,:,:,:,newtime,iblock) = TRACER(:,:,:,:,curtime,iblock) + TRACER(:,:,:,:,oldtime,iblock) = TRACER(:,:,:,:,curtime,iblock) + end do + + if (trim(init_ts_outfile) /= 'unknown_init_ts_outfile') then + if (my_task == master_task) then + write(stdout,*) 'remapped initial T & S written to',trim(init_ts_outfile) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + call write_init_ts(trim(init_ts_outfile),trim(init_ts_outfile_fmt)) + endif + +#endif +!----------------------------------------------------------------------- +! +! bad initialization option +! +!----------------------------------------------------------------------- + + case default + call exit_POP(sigAbort,'Unknown t,s initialization option') + end select + +!----------------------------------------------------------------------- +! +! check for appropriate initialization when overflows on and interactive +! +!----------------------------------------------------------------------- + + select case (init_ts_option) + case ('mean', 'internal', 'PHC') + if( overflows_on .and. overflows_interactive ) then + write(stdout,*) & + 'init_ts: ERROR initializing for interactive overflows' + write(stdout,*) & + 'initialization must be either ccsm_startup or file' + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + call exit_POP(sigAbort,'ERROR wrong initialization with overflows') + endif + end select + + +!----------------------------------------------------------------------- +! +! calculate RHO from TRACER at time levels curtime and oldtime +! +!----------------------------------------------------------------------- + + !$OMP PARALLEL DO PRIVATE(iblock, k, this_block) + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + + do k=1,km + call state(k,k,TRACER(:,:,k,1,curtime,iblock), & + TRACER(:,:,k,2,curtime,iblock), & + this_block, & + RHOOUT=RHO(:,:,k,curtime,iblock)) + call state(k,k,TRACER(:,:,k,1,oldtime,iblock), & + TRACER(:,:,k,2,oldtime,iblock), & + this_block, & + RHOOUT=RHO(:,:,k,oldtime,iblock)) + enddo + + enddo ! block loop + !$OMP END PARALLEL DO + +!----------------------------------------------------------------------- +! +! register init_ts +! +!----------------------------------------------------------------------- + call register_string('init_ts') + + call flushm (stdout) +!----------------------------------------------------------------------- +!EOC + + + end subroutine init_ts + +!*********************************************************************** +!BOP +! !IROUTINE: document_constants +! !INTERFACE: + + subroutine document_constants + +! !DESCRIPTION: +! This routine writes the values of POP model constants to the output log file + +! !REVISION HISTORY: +! same as module + +!EOP +!BOC + + if (my_task == master_task) then + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,*) ' Constants used in this run:' + write(stdout,blank_fmt) + + write(stdout,1020) 'grav', grav, 'cm/s^2' + write(stdout,1020) 'omega', omega, 'rad/s' + write(stdout,1020) 'radius', radius, 'cm' + write(stdout,1020) 'cp_sw', cp_sw, 'erg/g/K' + write(stdout,1020) 'cp_air', cp_air, 'J/kg/K' + write(stdout,1020) 'rho_air', rho_air, 'kg/m^3' + write(stdout,1020) 'rho_sw', rho_sw, 'g/cm^3' + write(stdout,1020) 'rho_fw', rho_fw, 'g/cm^3' + write(stdout,1020) 'sound', sound, 'cm/s' + write(stdout,1020) 'vonkar', vonkar, ' ' + write(stdout,1020) 'emissivity',emissivity, ' ' + write(stdout,1020) 'stefan_boltzmann', stefan_boltzmann, & + 'W/m^2/K^4' + write(stdout,1020) 'latent_heat_vapor_mks',latent_heat_vapor_mks, & + 'J/kg' + write(stdout,1020) 'latent_heat_fusion',latent_heat_fusion, & + 'erg/g' + write(stdout,1020) 'ocn_ref_salinity', ocn_ref_salinity, 'psu' + write(stdout,1020) 'sea_ice_salinity', sea_ice_salinity, 'psu' + write(stdout,1020) 'T0_Kelvin', T0_Kelvin, 'K' + write(stdout,1020) 'pi', pi, ' ' + + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + + endif + +1020 format (5x, a20, ' = ', 1pe25.15, 2x, a) + +!----------------------------------------------------------------------- +!EOC + + end subroutine document_constants + + +!*********************************************************************** +!BOP +! !IROUTINE: POP_check +! !INTERFACE: + + subroutine POP_check + +! !DESCRIPTION: +! This routine tests for consistency between model options, usually involving +! two or more modules, then writes warning and error messages to the output log file. +! If one or more error conditions are detected, the pop model will be shut down +! after all warning and error messages are printed. + +! !REVISION HISTORY: +! same as module + + +!EOP +!BOC + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character (char_len) :: & + string ! temporary string + + integer (int_kind) :: & + number_of_fatal_errors, &! counter for fatal error conditions + number_of_warnings, &! counter for warning messages + n, &! loop index + ns, &! streams loop index + temp_tavg_id, &! temporary tavg_id holder + coupled_flag ! flag for coupled_ts + + logical (log_kind) :: & + test_condition, &! logical test condition + lref_val, &! are any tracers specifying a non-zero ref_val + ISOP_test, &! temporary logical associated with ISOP + ISOP_on ! are any ISOP tavg fields selected? + + character (char_len), dimension(7) :: &! var names for diag_gm_bolus test + strings = (/'UISOP ' , 'VISOP ' , & + 'WISOP ' , & + 'ADVT_ISOP' , 'ADVS_ISOP' , & + 'VNT_ISOP ' , 'VNS_ISOP ' /) + + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,*)' POP_check: Check for Option Inconsistencies' + write(stdout,blank_fmt) + endif + + + !====================! + ! warning conditions ! + !====================! + + number_of_warnings = 0 + +!----------------------------------------------------------------------- +! +! 'varthick' and dtuxcel /= dttxcel(1) +! +!----------------------------------------------------------------------- + + if (my_task == master_task) then + if (sfc_layer_type == sfc_layer_varthick .and. & + dtuxcel /= dttxcel(1) ) then + exit_string = 'WARNING: Surface tracer and momentum timesteps are unequal; ' /& + &/'may cause instability when using variable-thickness surface layer.' + call document ('POP_check', exit_string) + number_of_warnings = number_of_warnings + 1 + endif + endif + +!----------------------------------------------------------------------- +! +! bulk-NCEP and marginal-seas balancing +! +!----------------------------------------------------------------------- + + if (my_task == master_task) then + if (sfwf_formulation == 'bulk-NCEP' .and. lms_balance) then + exit_string = 'WARNING: runoff and marginal seas balancing cannot ' /& + &/ 'be used with the bulk-NCEP option' + call document ('POP_check', exit_string) + number_of_warnings = number_of_warnings + 1 + endif + endif + +!----------------------------------------------------------------------- +! +! are time-averaging and coupling frequencies compatible? +! +!----------------------------------------------------------------------- + + coupled_flag = get_time_flag_id('coupled_ts') + + if (my_task == master_task) then + do ns=1,n_tavg_streams + if (check_time_flag_int(tavg_streams(ns)%field_flag, freq_opt=.true.) > 0 .and. & + check_time_flag_int(coupled_flag,freq_opt=.true.) > 0) then + + if (check_time_flag_int(tavg_streams(ns)%field_flag, freq_opt=.true.) /= & + check_time_flag_int(coupled_flag,freq_opt=.true.)) then + exit_string = 'WARNING: time-averaging and coupling frequency ' /& + &/ 'may be incompatible; tavg must be integer multiple of coupling freq' + call document ('POP_check', exit_string) + number_of_warnings = number_of_warnings + 1 + else + if ( mod(check_time_flag_int(tavg_streams(ns)%field_flag, freq=.true.), & + check_time_flag_int(coupled_flag,freq=.true.)) .ne. 0) then + exit_string = 'WARNING: time-averaging frequency is incompatible with ' /& + &/ ' the coupling frequency' + call document ('POP_check', exit_string) + number_of_warnings = number_of_warnings + 1 + endif + endif + endif + enddo ! ns + endif + + +!----------------------------------------------------------------------- +! +! Wrap up warning section with message +! +!----------------------------------------------------------------------- + + call broadcast_scalar(number_of_warnings, master_task) + + if (number_of_warnings == 0 ) then + if (my_task == master_task) then + exit_string = 'No warning messages generated' + call document ('POP_check', exit_string) + endif + endif + + + !========================! + ! fatal error conditions ! + !========================! + + + number_of_fatal_errors = 0 + +!----------------------------------------------------------------------- +! +! tidal mixing without KPP mixing +! +!----------------------------------------------------------------------- + + if (check_all(ltidal_mixing .and. vmix_itype /= vmix_type_kpp)) then + exit_string = & + 'FATAL ERROR: Tidally driven mixing is only allowed when KPP mixing is enabled' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! tidal mixing without bckgrnd_vdc2 = 0.0 +! +!----------------------------------------------------------------------- + + if (check_all(ltidal_mixing .and. bckgrnd_vdc2 /= c0)) then + exit_string = & + 'FATAL ERROR: bckgrnd_vdc2 must be zero when tidal_mixing option is enabled' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! diag_gm_bolus = .true., but ISOP variables not activated in tavg_contents file +! +!----------------------------------------------------------------------- + + if (registry_match('diag_gm_bolus') .and. my_task == master_task) then + ISOP_on = .true. + exit_string = 'FATAL ERROR: ' + + do n=1,7 + ISOP_test = .false. + string = trim(strings(n)) + ISOP_test = set_in_tavg_contents (tavg_id(trim(string),quiet=.true.)) + if (.not. ISOP_test) then + exit_string = trim(exit_string) // ' ' // trim(string) + ISOP_on = .false. + endif + enddo + + if (.not. ISOP_on) then + exit_string = trim(exit_string) /& + &/' must be activated in tavg_contents file when diag_gm_bolus = .T.' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + endif ! diag_gm_bolus + +!----------------------------------------------------------------------- +! +! luse_cpl_ifrac is true, but OCN_WGT is not allocated +! +!----------------------------------------------------------------------- + + if (check_all(luse_cpl_ifrac .and. .not. allocated(OCN_WGT))) then + exit_string = & + 'FATAL ERROR: cannot set luse_cpl_ifrac .true. without allocating OCN_WGT' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! ecosystem requests diurnal cycle, but base model is not using it +! +!----------------------------------------------------------------------- + + if (ecosys_on) then + + if ((.not. ecosys_qsw_distrb_const) .and. & + (qsw_distrb_iopt == qsw_distrb_iopt_const)) then + exit_string = & + 'FATAL ERROR: cannot set ecosys_qsw_distrb_const=.false. unless qsw_distrb_opt/=const' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + + endif + +!----------------------------------------------------------------------- +! +! untested forcing_coupled option +! +!----------------------------------------------------------------------- + + if (sfc_layer_type == sfc_layer_varthick .and. .not. lfw_as_salt_flx) then + exit_string = 'FATAL ERROR: untested/unsupported combination of options' + exit_string = trim(exit_string) /& + &/' (sfc_layer_type == sfc_layer_varthick .and. .not. lfw_as_salt_flx)' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! inertial mixing on +! +!----------------------------------------------------------------------- + + if (.not. lniw_mixing .and. linertial) then + exit_string = 'FATAL ERROR: inertial mixing option. ' + exit_string = trim(exit_string) /& + &/' This option is untested. DO NOT USE!' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! inertial mixing inconsistencies +! +!----------------------------------------------------------------------- + + if (linertial .and. (.not. registry_match('diag_gm_bolus') .or. partial_bottom_cells)) then + exit_string = 'FATAL ERROR: inertial mixing option inconsistency. ' + exit_string = trim(exit_string) /& + &/' diag_gm_bolus must be on and partial_bottom_cells must not be on' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! overflow check: if overflow active, horiz_grid_opt must be 'file' +! +!----------------------------------------------------------------------- + + if ( overflows_on ) then + if ( overflows_interactive .and. .not. registry_match('topography_opt_file') ) then + exit_string = 'FATAL ERROR: interactive overflows without topography option = file' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + endif + +!----------------------------------------------------------------------- +! +! overflow check: if overflow active, must set state_range_iopt = state_range_enforce +! and state_itype = state_type_mwjf for consistency +! +!----------------------------------------------------------------------- + + if ( overflows_on ) then + if ( .not. (state_range_iopt == state_range_enforce .and. state_itype == state_type_mwjf) ) then + exit_string = 'FATAL ERROR: if overflows are active, must have state_range_opt = enforce '/& + &/' and state_choice = mwjf for consistency. You can uncomment this and procede at your own risk.' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + endif + +!----------------------------------------------------------------------- +! +! near-inertial wave mixing without KPP mixing +! +!----------------------------------------------------------------------- + + if (check_all(lniw_mixing .and. vmix_itype /= vmix_type_kpp)) then + exit_string = & + 'FATAL ERROR: Near-inertial wave mixing is only allowed when KPP mixing is enabled' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! near-inertial wave mixing and not 2-hour coupling +! +!----------------------------------------------------------------------- + + test_condition = (coupled_freq_iopt == freq_opt_nhour .and. ncouple_per_day == 12) + if (check_all(lniw_mixing .and. .not. test_condition) ) then + call document ('POP_check', 'coupled_freq_iopt ', coupled_freq_iopt ) + call document ('POP_check', 'freq_opt_nhour ', freq_opt_nhour ) + call document ('POP_check', 'ncouple_per_day ', ncouple_per_day ) + call document ('POP_check', '(coupled_freq_iopt == freq_opt_nhour .and. ncouple_per_day == 2) ', & + (coupled_freq_iopt == freq_opt_nhour .and. ncouple_per_day == 2) ) + exit_string = & + 'FATAL ERROR: Near-inertial wave mixing is only allowed when coupling every two hours' + call document ('POP_check', exit_string) + number_of_fatal_errors = number_of_fatal_errors + 1 + endif + +!----------------------------------------------------------------------- +! +! Now that error messages have been written, stop if there are fatal errors +! +!----------------------------------------------------------------------- + + call broadcast_scalar(number_of_fatal_errors, master_task) + + if (number_of_fatal_errors > 0 ) then + call exit_POP (sigAbort, & + 'correct the error condition(s) listed above before continuing') + else + if (my_task == master_task) then + exit_string = 'No fatal error conditions detected' + call document ('POP_check', exit_string) + endif + endif + + +!----------------------------------------------------------------------- +!EOC + + end subroutine POP_check + + +!*********************************************************************** +!BOP +! !IROUTINE: write_init_ts +! !INTERFACE: + + subroutine write_init_ts(outfile, outfile_fmt) + +! !DESCRIPTION: +! This routine writes out initial TEMP and SALT mapped to +! POP grid for topography_opt='bathymetry' +! +! !REVISION HISTORY: +! same as module + +! !INPUT PARAMETERS: + + character (*), intent(in) :: & + outfile, &! input file name (with path) + outfile_fmt ! input file format (bin or nc) + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + type (datafile) :: & + ts_file ! io file type for viscosity file + + type (io_field_desc) :: & + TEMP_d, SALT_d ! descriptors for temp and salt fields + + type (io_dim) :: & + i_dim, j_dim, &! dimension descriptors for horiz dims + k_dim ! dimension descriptor for vertical levels + +!----------------------------------------------------------------------- +! +! construct io file type and open for writing +! +!----------------------------------------------------------------------- + + ts_file = construct_file(outfile_fmt, root_name=outfile, & + record_length=rec_type_dbl, & + recl_words=nx_global*ny_global) + + call data_set(ts_file, 'open') + +!----------------------------------------------------------------------- +! +! define variables to be written +! +!----------------------------------------------------------------------- + + !*** define dimensions + + i_dim = construct_io_dim('i', nx_global) + j_dim = construct_io_dim('j', ny_global) + k_dim = construct_io_dim('k', km) + + TEMP_d = construct_io_field('TEMP', dim1=i_dim, dim2=j_dim, dim3=k_dim, & + long_name='Potential Temperature', & + units ='degC', & + grid_loc ='3111', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d3d_array = TRACER(:,:,:,1,curtime,:)) + + SALT_d = construct_io_field('SALT', dim1=i_dim, dim2=j_dim, dim3=k_dim, & + long_name='Salinity', & + units ='gram/kilogram', & + grid_loc ='3111', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d3d_array = TRACER(:,:,:,2,curtime,:)) + + call data_set (ts_file, 'define', TEMP_d) + call data_set (ts_file, 'define', SALT_d) + +!----------------------------------------------------------------------- +! +! write arrays then clean up +! +!----------------------------------------------------------------------- + + call data_set (ts_file, 'write', TEMP_d) + call data_set (ts_file, 'write', SALT_d) + + call destroy_io_field (TEMP_d) + call destroy_io_field (SALT_d) + + call data_set (ts_file, 'close') + call destroy_file(ts_file) + +!----------------------------------------------------------------------- +!EOC + + end subroutine write_init_ts + + +!*********************************************************************** +!BOP +! !IROUTINE: check_all +! !INTERFACE: + + function check_all(condition) + +! !DESCRIPTION: +! Tests input logical condition on all processors; if any element is +! .true., check_all is set to .true. +! +! +! !REVISION HISTORY: +! same as module + +! !INPUT PARAMETERS: + + logical (log_kind), intent(in) :: & + condition ! logical condition to be checked + +! !OUTPUT PARAMETERS: + + logical (log_kind) :: & + check_all ! true if condition is true on any processor + + +!EOP +!BOC + +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + int_condition ! integer form of logical input condition + + + if (condition) then + int_condition = 1 + else + int_condition = 0 + endif + + check_all = (global_sum(int_condition,distrb_clinic) > 0) + +!----------------------------------------------------------------------- +!EOC + + end function check_all + +!*********************************************************************** + + end module initial + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.pop2/overflows.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.pop2/overflows.F90 new file mode 100644 index 0000000000..0786233113 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.pop2/overflows.F90 @@ -0,0 +1,6344 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_2_1/models/ocn/pop2/source/overflows.F90 + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + + MODULE overflows + +!testing out some changes here + +!BOP +! !MODULE: overflows +! !DESCRIPTION: +! This module contains data types and routines for computing +! parameterized overflows. Overflows are sub-grid scale flows +! along topography thought to be important for bottom water +! formation. +! +! !REVISION HISTORY: +! SVN: +! + +! !USES: + + use POP_KindsMod + use POP_ErrorMod + use POP_BlocksMod + use POP_CommMod + use POP_ConfigMod + use POP_DistributionMod + use POP_DomainSizeMod + use POP_FieldMod + use POP_GridHorzMod + use POP_HaloMod + use POP_RedistributeMod + + use POP_SolversMod + + + use blocks + use broadcast + use communicate + use constants + use domain + use exit_mod + use global_reductions + use grid + use io_types + use kinds_mod + use overflow_type + use ovf_utils + use prognostic + use time_management + use registry + use state_mod + + use timers, only: timer_start, timer_stop, get_timer + + !*** ccsm + use gather_scatter + use shr_sys_mod + + implicit none + private + save + + include 'mpif.h' + +! !PUBLIC MEMBER FUNCTIONS: + + public :: init_overflows1, & ! initial.F90 + init_overflows2, & ! initial.F90 + init_overflows_kmt, & + init_overflows_mask, & + init_overflows3, & ! initial.F90 + init_overflows4, & ! initial.F90 + init_overflows5, & ! initial.F90 + ovf_write_restart, & ! step_mod.F90 + ovf_read_restart, & ! init_overflows1 + ovf_read_broadcast, & + ovf_advt, & ! advection.F90 + ovf_wtkb_check, & ! advection.F90 + ovf_UV_check, & + ovf_Utlda, & ! baroclinic.F90 + ovf_driver, & ! step_mod.F90 + ovf_reg_avgs, & + ovf_transports, & + ovf_loc_prd, & + ovf_W, & + ovf_UV, & + ovf_rhs_brtrpc_momentum, & ! barotropic.F90 + ovf_brtrpc_renorm, & ! barotropic.F90 + ovf_rhs_brtrpc_continuity, & ! barotropic.F90 + ovf_solvers_9pt, & ! barotropic.F90 + ovf_HU, & + ovf_UV_solution ! step_mod.F90 + +! !PUBLIC DATA MEMBERS: + +!----------------------------------------------------------------------- +! list of nomenclature definitions +!----------------------------------------------------------------------- +! +! ovf = overflow +! inf = inflow (refering to inflow region) +! src = source (either region or grid box) +! ent = entrainment (either region or grid box) +! prd = product (either region or grid box) +! reg = region (for averaging density and tracers over region) +! adj = adjacent (for averaging density and tracers over adjacent boxes) +! num = number (usually refers to actual number used based on input) +! no. = number (usually refers to actual number used based on input) +! locs = locations (i.e. grid boxes) +! orient = orientation (1,2,3 or 4; refers to grid box sidewall) +! params = parameters +! ssb = shelf-slope break- shelf/slope transition to abyssal depth +! +!----------------------------------------------------------------------- +! define overflow types and parameters +!----------------------------------------------------------------------- + + + integer (POP_i4) :: & + errorCode + +!EOC +!----------------------------------------------------------------------- +! +! controls for frequency and output of diagnostics +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + ovf_diag_unit ! i/o unit for overflow output diagnostics file + + character (char_len) :: & + ccsm_diag_date + + logical (log_kind) :: & + lccsm = .false. + + character (10) :: & + cdate ! character date + +!----------------------------------------------------------------------- +! +! ovf timers +! +!----------------------------------------------------------------------- + + integer (int_kind) :: & + timer_ovf ! timer for ovf + + + + + +!*********************************************************************** + + contains + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows1 +! !INTERFACE: + + subroutine init_overflows1 + +! !DESCRIPTION: +! This routine is the first of four which together initialize the overflow +! parameterization. It reads the namelist and overflow_infile (text file +! containing ovf info). See info file comments for description of text file +! format. This routine also computes prd region limits based on prd input, +! writes out to stdout and overflows_diag_outfile, and then broadcasts ovf info +! to all processors. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + save + + namelist /overflows_nml/ overflows_on, overflows_interactive, & + overflows_infile, overflows_diag_outfile, & + overflows_restart_type, overflows_restfile + + integer (i4) :: & + index, &! overflow index + nu, &! unit for overflow input file + nml_error, &! namelist i/o error flag + ovf_error, &! ovf i/o error flag + num_req, &! number requested for error message + imin, &! i index for checking input order + jmin, &! j index for checking input order + kmin, &! k index for checking input number of levels + ornt ! orientation for checking constancy + + character (88) :: line ! temporary for line of text input/output + + integer (int_kind) :: & + n, &! ovf loop index + m, &! sub-ovf loop index + nn, &! tracer loop index + mp, &! sub-ovf sub-loop index + i,j, &! horizontal loop indices + k, &! vertical loop index + iblock, &! local block address + ib,ie,jb,je, &! local domain index boundaries + di,dj ! orientation adjustments in i,j + + type (block) :: & + this_block ! block information for current block + +!----------------------------------------------------------------------- +! read overflow namelist +!----------------------------------------------------------------------- + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,ndelim_fmt) + write(stdout,blank_fmt) + write(stdout,'(a11)') ' Overflows:' + write(stdout,blank_fmt) + call shr_sys_flush(stdout) + endif + + overflows_on = .false. + overflows_interactive = .false. + overflows_infile = 'unknown_ovf_infile' + overflows_diag_outfile = 'unknown_ovf_outfile' + overflows_restart_type = 'ccsm_startup' + overflows_restfile = 'unknown_ovf_restfile' + + if (my_task == master_task) then + open (nml_in, file=nml_filename, status='old',iostat=nml_error) + if (nml_error /= 0) then + nml_error = -1 + else + nml_error = 1 + endif + do while (nml_error > 0) + read(nml_in, nml=overflows_nml,iostat=nml_error) + end do + if (nml_error == 0) close(nml_in) + endif + + call broadcast_scalar(nml_error, master_task) + if (nml_error /= 0) then + call exit_POP(sigAbort,'ERROR reading overflows_nml') + endif + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,'(a33)') ' overflows_nml namelist settings:' + write(stdout,blank_fmt) + write(stdout,overflows_nml) + write(stdout,blank_fmt) + call shr_sys_flush(stdout) + endif + + call broadcast_scalar(overflows_on, master_task) + call broadcast_scalar(overflows_interactive, master_task) + call broadcast_scalar(overflows_infile, master_task) + call broadcast_scalar(overflows_diag_outfile, master_task) + call broadcast_scalar(overflows_restart_type, master_task) + call broadcast_scalar(overflows_restfile, master_task) + +!----------------------------------------------------------------------- +! if overflows off, exit +!----------------------------------------------------------------------- + + if( .not. overflows_on ) return + + + +! don't initialize the groups yet + ovf_groups%init = .false. + + +!----------------------------------------------------------------------- +! +! determine if this is a ccsm coupled run +!----------------------------------------------------------------------- + + lccsm = registry_match('lccsm') + +!----------------------------------------------------------------------- +! overflows on; read overflows info file if ccsm_startup; otherwise +! read restart data +!----------------------------------------------------------------------- + + if( overflows_restart_type == 'ccsm_startup' ) then + + ovf_error = 0 + call get_unit(nu) + +!----------------------------------------------------------------------- +! master task section +!----------------------------------------------------------------------- + + if (my_task == master_task) then + + open(nu, file=overflows_infile, status='old',iostat=ovf_error) + + write(stdout,2345) ovf_error + 2345 format(' after open nu ovf_error=',i5) + write(stdout,'(a41)') 'reading overflows_infile: contents echoed' + call shr_sys_flush(stdout) + + do m=1,40 + read(nu,'(a88)') line + write(stdout,'(a88)') line + end do + + read(nu,*) num_ovf + write(stdout,*) num_ovf + call shr_sys_flush(stdout) + if( num_ovf <= 0 .or. num_ovf > max_ovf ) then + ovf_error = 1 + num_req = num_ovf + goto 10 + endif + + do n=1,num_ovf + ovf(n)%interactive = overflows_interactive + read(nu,*) index,ovf(n)%name + write(stdout,*) index,ovf(n)%name + + read(nu,*) ovf(n)%ovf_params%lat + read(nu,*) ovf(n)%ovf_params%width + read(nu,*) ovf(n)%ovf_params%source_thick + read(nu,*) ovf(n)%ovf_params%distnc_str_ssb + read(nu,*) ovf(n)%ovf_params%bottom_slope + read(nu,*) ovf(n)%ovf_params%bottom_drag + + write(stdout,*) ovf(n)%ovf_params%lat + write(stdout,*) ovf(n)%ovf_params%width + write(stdout,*) ovf(n)%ovf_params%source_thick + write(stdout,*) ovf(n)%ovf_params%distnc_str_ssb + write(stdout,*) ovf(n)%ovf_params%bottom_slope + write(stdout,*) ovf(n)%ovf_params%bottom_drag + call shr_sys_flush(stdout) + +! kmt changes if any + read(nu,*) ovf(n)%num_kmt + write(stdout,*) ovf(n)%num_kmt + if( ovf(n)%num_kmt < 0 .or. ovf(n)%num_kmt > max_kmt ) then + ovf_error = 2 + num_req = ovf(n)%num_kmt + goto 10 + endif + do m=1,ovf(n)%num_kmt + read(nu,*) ovf(n)%loc_kmt(m)%i, & + ovf(n)%loc_kmt(m)%j, & + ovf(n)%loc_kmt(m)%korg, & + ovf(n)%loc_kmt(m)%knew + write(stdout,*) ovf(n)%loc_kmt(m)%i, & + ovf(n)%loc_kmt(m)%j, & + ovf(n)%loc_kmt(m)%korg, & + ovf(n)%loc_kmt(m)%knew + end do + call shr_sys_flush(stdout) + + read(nu,*) + +! inf,src and ent region limits + read(nu,*) ovf(n)%reg_inf%imin, & + ovf(n)%reg_inf%imax, & + ovf(n)%reg_inf%jmin, & + ovf(n)%reg_inf%jmax, & + ovf(n)%reg_inf%kmin, & + ovf(n)%reg_inf%kmax + read(nu,*) ovf(n)%reg_src%imin, & + ovf(n)%reg_src%imax, & + ovf(n)%reg_src%jmin, & + ovf(n)%reg_src%jmax, & + ovf(n)%reg_src%kmin, & + ovf(n)%reg_src%kmax + read(nu,*) ovf(n)%reg_ent%imin, & + ovf(n)%reg_ent%imax, & + ovf(n)%reg_ent%jmin, & + ovf(n)%reg_ent%jmax, & + ovf(n)%reg_ent%kmin, & + ovf(n)%reg_ent%kmax + + write(stdout,*) ovf(n)%reg_inf%imin, & + ovf(n)%reg_inf%imax, & + ovf(n)%reg_inf%jmin, & + ovf(n)%reg_inf%jmax, & + ovf(n)%reg_inf%kmin, & + ovf(n)%reg_inf%kmax + write(stdout,*) ovf(n)%reg_src%imin, & + ovf(n)%reg_src%imax, & + ovf(n)%reg_src%jmin, & + ovf(n)%reg_src%jmax, & + ovf(n)%reg_src%kmin, & + ovf(n)%reg_src%kmax + write(stdout,*) ovf(n)%reg_ent%imin, & + ovf(n)%reg_ent%imax, & + ovf(n)%reg_ent%jmin, & + ovf(n)%reg_ent%jmax, & + ovf(n)%reg_ent%kmin, & + ovf(n)%reg_ent%kmax + call shr_sys_flush(stdout) + +! src points + read(nu,*) ovf(n)%num_src + write(stdout,*) ovf(n)%num_src + if( ovf(n)%num_src <= 1 .or. ovf(n)%num_src > max_src ) then + ovf_error = 3 + num_req = ovf(n)%num_src + goto 10 + endif + do m=1,ovf(n)%num_src + read(nu,*) ovf(n)%loc_src(m)%i, & + ovf(n)%loc_src(m)%j, & + ovf(n)%loc_src(m)%k, & + ovf(n)%loc_src(m)%orient + if ( ovf(n)%loc_src(m)%orient .eq. 1 ) then + ovf(n)%loc_src(m)%i_adv = ovf(n)%loc_src(m)%i + 1 + ovf(n)%loc_src(m)%j_adv = ovf(n)%loc_src(m)%j + ovf(n)%loc_src(m)%i_u = ovf(n)%loc_src(m)%i + ovf(n)%loc_src(m)%j_u = ovf(n)%loc_src(m)%j +! some u corner points i_u,j_u zeroed because they are inactive + if( m == ovf(n)%num_src ) then + ovf(n)%loc_src(m)%i_u = 0 + ovf(n)%loc_src(m)%j_u = 0 + endif + else if( ovf(n)%loc_src(m)%orient .eq. 2 ) then + ovf(n)%loc_src(m)%i_adv = ovf(n)%loc_src(m)%i + ovf(n)%loc_src(m)%j_adv = ovf(n)%loc_src(m)%j + 1 + ovf(n)%loc_src(m)%i_u = ovf(n)%loc_src(m)%i - 1 + if(ovf(n)%loc_src(m)%i_u==0) ovf(n)%loc_src(m)%i_u = nx_global + ovf(n)%loc_src(m)%j_u = ovf(n)%loc_src(m)%j + if( m == 1 ) then + ovf(n)%loc_src(m)%i_u = 0 + ovf(n)%loc_src(m)%j_u = 0 + endif + else if( ovf(n)%loc_src(m)%orient .eq. 3 ) then + ovf(n)%loc_src(m)%i_adv = ovf(n)%loc_src(m)%i - 1 + if(ovf(n)%loc_src(m)%i_adv==0) ovf(n)%loc_src(m)%i_adv = nx_global + ovf(n)%loc_src(m)%j_adv = ovf(n)%loc_src(m)%j + ovf(n)%loc_src(m)%i_u = ovf(n)%loc_src(m)%i - 1 + if(ovf(n)%loc_src(m)%i_u==0) ovf(n)%loc_src(m)%i_u = nx_global + ovf(n)%loc_src(m)%j_u = ovf(n)%loc_src(m)%j - 1 + if( m == 1 ) then + ovf(n)%loc_src(m)%i_u = 0 + ovf(n)%loc_src(m)%j_u = 0 + endif + else if( ovf(n)%loc_src(m)%orient .eq. 4 ) then + ovf(n)%loc_src(m)%i_adv = ovf(n)%loc_src(m)%i + ovf(n)%loc_src(m)%j_adv = ovf(n)%loc_src(m)%j - 1 + ovf(n)%loc_src(m)%i_u = ovf(n)%loc_src(m)%i + ovf(n)%loc_src(m)%j_u = ovf(n)%loc_src(m)%j - 1 + if( m == ovf(n)%num_src ) then + ovf(n)%loc_src(m)%i_u = 0 + ovf(n)%loc_src(m)%j_u = 0 + endif + endif + write(stdout,*) ovf(n)%loc_src(m)%i, & + ovf(n)%loc_src(m)%j, & + ovf(n)%loc_src(m)%k, & + ovf(n)%loc_src(m)%orient + call shr_sys_flush(stdout) +! check order of ij, constancy of k and range of orient + if( m==1 ) then + imin = ovf(n)%loc_src(m)%i + jmin = ovf(n)%loc_src(m)%j + kmin = ovf(n)%loc_src(m)%k + if( ovf(n)%loc_src(m)%orient < 1 .or. & + ovf(n)%loc_src(m)%orient > 4 ) then + ovf_error = 11 + goto 10 + endif + ornt = ovf(n)%loc_src(m)%orient + else + if( ovf(n)%loc_src(m)%i < imin ) then + ovf_error = 7 + goto 10 + endif + if( ovf(n)%loc_src(m)%j < jmin ) then + ovf_error = 7 + goto 10 + endif + if( ovf(n)%loc_src(m)%i == imin .and. & + ovf(n)%loc_src(m)%j == jmin) then + ovf_error = 8 + goto 10 + endif + if( ovf(n)%loc_src(m)%i > imin .and. & + ovf(n)%loc_src(m)%j > jmin) then + ovf_error = 9 + goto 10 + endif + if( ovf(n)%loc_src(m)%k /= kmin ) then + ovf_error = 10 + goto 10 + endif + if( ovf(n)%loc_src(m)%orient < 1 .or. & + ovf(n)%loc_src(m)%orient > 4 ) then + ovf_error = 11 + goto 10 + endif + if( ovf(n)%loc_src(m)%orient /= ornt ) then + ovf_error = 12 + goto 10 + endif + imin = ovf(n)%loc_src(m)%i + jmin = ovf(n)%loc_src(m)%j + kmin = ovf(n)%loc_src(m)%k + ornt = ovf(n)%loc_src(m)%orient + endif + end do + +! ent points + read(nu,*) ovf(n)%num_ent + write(stdout,*) ovf(n)%num_ent + if( ovf(n)%num_ent <= 1 .or. ovf(n)%num_ent > max_ent ) then + ovf_error = 4 + num_req = ovf(n)%num_ent + goto 10 + endif + do m=1,ovf(n)%num_ent + read(nu,*) ovf(n)%loc_ent(m)%i, & + ovf(n)%loc_ent(m)%j, & + ovf(n)%loc_ent(m)%k, & + ovf(n)%loc_ent(m)%orient + if ( ovf(n)%loc_ent(m)%orient .eq. 1 ) then + ovf(n)%loc_ent(m)%i_adv = ovf(n)%loc_ent(m)%i + 1 + ovf(n)%loc_ent(m)%j_adv = ovf(n)%loc_ent(m)%j + ovf(n)%loc_ent(m)%i_u = ovf(n)%loc_ent(m)%i + ovf(n)%loc_ent(m)%j_u = ovf(n)%loc_ent(m)%j +! some u corner points i_u,j_u zeroed because they are inactive + if( m == ovf(n)%num_ent ) then + ovf(n)%loc_ent(m)%i_u = 0 + ovf(n)%loc_ent(m)%j_u = 0 + endif + else if( ovf(n)%loc_ent(m)%orient .eq. 2 ) then + ovf(n)%loc_ent(m)%i_adv = ovf(n)%loc_ent(m)%i + ovf(n)%loc_ent(m)%j_adv = ovf(n)%loc_ent(m)%j + 1 + ovf(n)%loc_ent(m)%i_u = ovf(n)%loc_ent(m)%i - 1 + if(ovf(n)%loc_ent(m)%i_u==0) ovf(n)%loc_ent(m)%i_u = nx_global + ovf(n)%loc_ent(m)%j_u = ovf(n)%loc_ent(m)%j + if( m == 1 ) then + ovf(n)%loc_ent(m)%i_u = 0 + ovf(n)%loc_ent(m)%j_u = 0 + endif + else if( ovf(n)%loc_ent(m)%orient .eq. 3 ) then + ovf(n)%loc_ent(m)%i_adv = ovf(n)%loc_ent(m)%i - 1 + if(ovf(n)%loc_ent(m)%i_adv==0) ovf(n)%loc_ent(m)%i_adv = nx_global + ovf(n)%loc_ent(m)%j_adv = ovf(n)%loc_ent(m)%j + ovf(n)%loc_ent(m)%i_u = ovf(n)%loc_ent(m)%i - 1 + if(ovf(n)%loc_ent(m)%i_u==0) ovf(n)%loc_ent(m)%i_u = nx_global + ovf(n)%loc_ent(m)%j_u = ovf(n)%loc_ent(m)%j - 1 + if( m == 1 ) then + ovf(n)%loc_ent(m)%i_u = 0 + ovf(n)%loc_ent(m)%j_u = 0 + endif + else if( ovf(n)%loc_ent(m)%orient .eq. 4 ) then + ovf(n)%loc_ent(m)%i_adv = ovf(n)%loc_ent(m)%i + ovf(n)%loc_ent(m)%j_adv = ovf(n)%loc_ent(m)%j - 1 + ovf(n)%loc_ent(m)%i_u = ovf(n)%loc_ent(m)%i + ovf(n)%loc_ent(m)%j_u = ovf(n)%loc_ent(m)%j - 1 + if( m == ovf(n)%num_ent ) then + ovf(n)%loc_ent(m)%i_u = 0 + ovf(n)%loc_ent(m)%j_u = 0 + endif + endif + write(stdout,*) ovf(n)%loc_ent(m)%i, & + ovf(n)%loc_ent(m)%j, & + ovf(n)%loc_ent(m)%k, & + ovf(n)%loc_ent(m)%orient + call shr_sys_flush(stdout) +! check order of ij, constancy of k and range of orient + if( m==1 ) then + imin = ovf(n)%loc_ent(m)%i + jmin = ovf(n)%loc_ent(m)%j + kmin = ovf(n)%loc_ent(m)%k + if( ovf(n)%loc_ent(m)%orient < 1 .or. & + ovf(n)%loc_ent(m)%orient > 4 ) then + ovf_error = 11 + goto 10 + endif + ornt = ovf(n)%loc_ent(m)%orient + else + if( ovf(n)%loc_ent(m)%i < imin ) then + ovf_error = 7 + goto 10 + endif + if( ovf(n)%loc_ent(m)%j < jmin ) then + ovf_error = 7 + goto 10 + endif + if( ovf(n)%loc_ent(m)%i == imin .and. & + ovf(n)%loc_ent(m)%j == jmin) then + ovf_error = 8 + goto 10 + endif + if( ovf(n)%loc_ent(m)%i > imin .and. & + ovf(n)%loc_ent(m)%j > jmin) then + ovf_error = 9 + goto 10 + endif + if( ovf(n)%loc_ent(m)%k /= kmin ) then + ovf_error = 10 + goto 10 + endif + if( ovf(n)%loc_ent(m)%orient < 1 .or. & + ovf(n)%loc_ent(m)%orient > 4 ) then + ovf_error = 11 + goto 10 + endif + if( ovf(n)%loc_ent(m)%orient /= ornt ) then + ovf_error = 12 + goto 10 + endif + imin = ovf(n)%loc_ent(m)%i + jmin = ovf(n)%loc_ent(m)%j + kmin = ovf(n)%loc_ent(m)%k + ornt = ovf(n)%loc_ent(m)%orient + endif + end do + call shr_sys_flush(stdout) + +! prd points + read(nu,*) ovf(n)%num_prd_sets + write(stdout,*) ovf(n)%num_prd_sets + if(ovf(n)%num_prd_sets<=0.or.ovf(n)%num_prd_sets>max_prd_sets) then + ovf_error = 5 + num_req = ovf(n)%num_prd_sets + goto 10 + endif + do m=1,ovf(n)%num_prd_sets + read(nu,*) ovf(n)%num_prd(m) + write(stdout,*) ovf(n)%num_prd(m) + if( ovf(n)%num_prd(m)<=1.or.ovf(n)%num_prd(m)>max_prd) then + ovf_error = 6 + num_req = ovf(n)%num_prd(m) + goto 10 + endif + do mp=1,ovf(n)%num_prd(m) + read(nu,*) ovf(n)%loc_prd(m,mp)%i, & + ovf(n)%loc_prd(m,mp)%j, & + ovf(n)%loc_prd(m,mp)%k, & + ovf(n)%loc_prd(m,mp)%orient + if ( ovf(n)%loc_prd(m,mp)%orient .eq. 1 ) then + ovf(n)%loc_prd(m,mp)%i_adv = ovf(n)%loc_prd(m,mp)%i + 1 + ovf(n)%loc_prd(m,mp)%j_adv = ovf(n)%loc_prd(m,mp)%j + ovf(n)%loc_prd(m,mp)%i_u = ovf(n)%loc_prd(m,mp)%i + ovf(n)%loc_prd(m,mp)%j_u = ovf(n)%loc_prd(m,mp)%j +! some u corner points i_u,j_u zeroed because they are inactive + if( mp == ovf(n)%num_prd(m) ) then + ovf(n)%loc_prd(m,mp)%i_u = 0 + ovf(n)%loc_prd(m,mp)%j_u = 0 + endif + else if( ovf(n)%loc_prd(m,mp)%orient .eq. 2 ) then + ovf(n)%loc_prd(m,mp)%i_adv = ovf(n)%loc_prd(m,mp)%i + ovf(n)%loc_prd(m,mp)%j_adv = ovf(n)%loc_prd(m,mp)%j + 1 + ovf(n)%loc_prd(m,mp)%i_u = ovf(n)%loc_prd(m,mp)%i - 1 + if(ovf(n)%loc_prd(m,mp)%i_u==0) ovf(n)%loc_prd(m,mp)%i_u = nx_global + ovf(n)%loc_prd(m,mp)%j_u = ovf(n)%loc_prd(m,mp)%j + if( mp == 1 ) then + ovf(n)%loc_prd(m,mp)%i_u = 0 + ovf(n)%loc_prd(m,mp)%j_u = 0 + endif + else if( ovf(n)%loc_prd(m,mp)%orient .eq. 3 ) then + ovf(n)%loc_prd(m,mp)%i_adv = ovf(n)%loc_prd(m,mp)%i - 1 + if(ovf(n)%loc_prd(m,mp)%i_adv==0) ovf(n)%loc_prd(m,mp)%i_adv = nx_global + ovf(n)%loc_prd(m,mp)%j_adv = ovf(n)%loc_prd(m,mp)%j + ovf(n)%loc_prd(m,mp)%i_u = ovf(n)%loc_prd(m,mp)%i - 1 + if(ovf(n)%loc_prd(m,mp)%i_u==0) ovf(n)%loc_prd(m,mp)%i_u = nx_global + ovf(n)%loc_prd(m,mp)%j_u = ovf(n)%loc_prd(m,mp)%j - 1 + if( mp == 1 ) then + ovf(n)%loc_prd(m,mp)%i_u = 0 + ovf(n)%loc_prd(m,mp)%j_u = 0 + endif + else if( ovf(n)%loc_prd(m,mp)%orient .eq. 4 ) then + ovf(n)%loc_prd(m,mp)%i_adv = ovf(n)%loc_prd(m,mp)%i + ovf(n)%loc_prd(m,mp)%j_adv = ovf(n)%loc_prd(m,mp)%j - 1 + ovf(n)%loc_prd(m,mp)%i_u = ovf(n)%loc_prd(m,mp)%i + ovf(n)%loc_prd(m,mp)%j_u = ovf(n)%loc_prd(m,mp)%j - 1 + if( mp == ovf(n)%num_prd(m) ) then + ovf(n)%loc_prd(m,mp)%i_u = 0 + ovf(n)%loc_prd(m,mp)%j_u = 0 + endif + endif + write(stdout,*) ovf(n)%loc_prd(m,mp)%i, & + ovf(n)%loc_prd(m,mp)%j, & + ovf(n)%loc_prd(m,mp)%k, & + ovf(n)%loc_prd(m,mp)%orient + call shr_sys_flush(stdout) +! check order of ij, constancy of k and range of orient + if( mp==1 ) then + imin = ovf(n)%loc_prd(m,mp)%i + jmin = ovf(n)%loc_prd(m,mp)%j + kmin = ovf(n)%loc_prd(m,mp)%k + if( ovf(n)%loc_prd(m,mp)%orient < 1 .or. & + ovf(n)%loc_prd(m,mp)%orient > 4 ) then + ovf_error = 11 + goto 10 + endif + ornt = ovf(n)%loc_prd(m,mp)%orient + else + if( ovf(n)%loc_prd(m,mp)%i < imin ) then + ovf_error = 7 + goto 10 + endif + if( ovf(n)%loc_prd(m,mp)%j < jmin ) then + ovf_error = 7 + goto 10 + endif + if( ovf(n)%loc_prd(m,mp)%i == imin .and. & + ovf(n)%loc_prd(m,mp)%j == jmin) then + ovf_error = 8 + goto 10 + endif + if( ovf(n)%loc_prd(m,mp)%i > imin .and. & + ovf(n)%loc_prd(m,mp)%j > jmin) then + ovf_error = 9 + goto 10 + endif + if( ovf(n)%loc_prd(m,mp)%k /= kmin ) then + ovf_error = 10 + goto 10 + endif + if( ovf(n)%loc_prd(m,mp)%orient < 1 .or. & + ovf(n)%loc_prd(m,mp)%orient > 4 ) then + ovf_error = 11 + goto 10 + endif + if( ovf(n)%loc_prd(m,mp)%orient /= ornt ) then + ovf_error = 12 + goto 10 + endif + imin = ovf(n)%loc_prd(m,mp)%i + jmin = ovf(n)%loc_prd(m,mp)%j + kmin = ovf(n)%loc_prd(m,mp)%k + ornt = ovf(n)%loc_prd(m,mp)%orient + endif + end do + call shr_sys_flush(stdout) + end do + +! find src adj limits + di = 0 + dj = 0 + if( ovf(n)%loc_src(1)%orient .eq. 1 ) di = +1 + if( ovf(n)%loc_src(1)%orient .eq. 2 ) dj = +1 + if( ovf(n)%loc_src(1)%orient .eq. 3 ) di = -1 + if( ovf(n)%loc_src(1)%orient .eq. 4 ) dj = -1 + ovf(n)%adj_src%imin = ovf(n)%loc_src(1)%i+di + ovf(n)%adj_src%jmin = ovf(n)%loc_src(1)%j+dj + ovf(n)%adj_src%kmin = ovf(n)%loc_src(1)%k + ovf(n)%adj_src%imax = ovf(n)%loc_src(1)%i+di + ovf(n)%adj_src%jmax = ovf(n)%loc_src(1)%j+dj + ovf(n)%adj_src%kmax = ovf(n)%loc_src(1)%k + do m=2,ovf(n)%num_src + di = 0 + dj = 0 + if( ovf(n)%loc_src(m)%orient .eq. 1 ) di = +1 + if( ovf(n)%loc_src(m)%orient .eq. 2 ) dj = +1 + if( ovf(n)%loc_src(m)%orient .eq. 3 ) di = -1 + if( ovf(n)%loc_src(m)%orient .eq. 4 ) dj = -1 + ovf(n)%adj_src%imin = min & + (ovf(n)%adj_src%imin,ovf(n)%loc_src(m)%i+di) + ovf(n)%adj_src%jmin = min & + (ovf(n)%adj_src%jmin,ovf(n)%loc_src(m)%j+dj) + ovf(n)%adj_src%kmin = min & + (ovf(n)%adj_src%kmin,ovf(n)%loc_src(m)%k) + ovf(n)%adj_src%imax = max & + (ovf(n)%adj_src%imax,ovf(n)%loc_src(m)%i+di) + ovf(n)%adj_src%jmax = max & + (ovf(n)%adj_src%jmax,ovf(n)%loc_src(m)%j+dj) + ovf(n)%adj_src%kmax = max & + (ovf(n)%adj_src%kmax,ovf(n)%loc_src(m)%k) + end do +! print src adj limits + write(stdout,13) & + ovf(n)%adj_src%imin, & + ovf(n)%adj_src%imax, & + ovf(n)%adj_src%jmin, & + ovf(n)%adj_src%jmax, & + ovf(n)%adj_src%kmin, & + ovf(n)%adj_src%kmax +13 format(' Computed source adjacent ijk min/max =',6(i4,2x)) + +! find ent adj limits + di = 0 + dj = 0 + if( ovf(n)%loc_ent(1)%orient .eq. 1 ) di = +1 + if( ovf(n)%loc_ent(1)%orient .eq. 2 ) dj = +1 + if( ovf(n)%loc_ent(1)%orient .eq. 3 ) di = -1 + if( ovf(n)%loc_ent(1)%orient .eq. 4 ) dj = -1 + ovf(n)%adj_ent%imin = ovf(n)%loc_ent(1)%i+di + ovf(n)%adj_ent%jmin = ovf(n)%loc_ent(1)%j+dj + ovf(n)%adj_ent%kmin = ovf(n)%loc_ent(1)%k + ovf(n)%adj_ent%imax = ovf(n)%loc_ent(1)%i+di + ovf(n)%adj_ent%jmax = ovf(n)%loc_ent(1)%j+dj + ovf(n)%adj_ent%kmax = ovf(n)%loc_ent(1)%k + do m=2,ovf(n)%num_ent + di = 0 + dj = 0 + if( ovf(n)%loc_ent(m)%orient .eq. 1 ) di = +1 + if( ovf(n)%loc_ent(m)%orient .eq. 2 ) dj = +1 + if( ovf(n)%loc_ent(m)%orient .eq. 3 ) di = -1 + if( ovf(n)%loc_ent(m)%orient .eq. 4 ) dj = -1 + ovf(n)%adj_ent%imin = min & + (ovf(n)%adj_ent%imin,ovf(n)%loc_ent(m)%i+di) + ovf(n)%adj_ent%jmin = min & + (ovf(n)%adj_ent%jmin,ovf(n)%loc_ent(m)%j+dj) + ovf(n)%adj_ent%kmin = min & + (ovf(n)%adj_ent%kmin,ovf(n)%loc_ent(m)%k) + ovf(n)%adj_ent%imax = max & + (ovf(n)%adj_ent%imax,ovf(n)%loc_ent(m)%i+di) + ovf(n)%adj_ent%jmax = max & + (ovf(n)%adj_ent%jmax,ovf(n)%loc_ent(m)%j+dj) + ovf(n)%adj_ent%kmax = max & + (ovf(n)%adj_ent%kmax,ovf(n)%loc_ent(m)%k) + end do +! print ent adj limits + write(stdout,14) & + ovf(n)%adj_ent%imin, & + ovf(n)%adj_ent%imax, & + ovf(n)%adj_ent%jmin, & + ovf(n)%adj_ent%jmax, & + ovf(n)%adj_ent%kmin, & + ovf(n)%adj_ent%kmax +14 format(' Computed entrainment adjacent ijk min/max =',6(i4,2x)) + +! find prd adj limits + do m=1,ovf(n)%num_prd_sets + di = 0 + dj = 0 + if( ovf(n)%loc_prd(m,1)%orient .eq. 1 ) di = +1 + if( ovf(n)%loc_prd(m,1)%orient .eq. 2 ) dj = +1 + if( ovf(n)%loc_prd(m,1)%orient .eq. 3 ) di = -1 + if( ovf(n)%loc_prd(m,1)%orient .eq. 4 ) dj = -1 + ovf(n)%adj_prd(m)%imin = ovf(n)%loc_prd(m,1)%i+di + ovf(n)%adj_prd(m)%jmin = ovf(n)%loc_prd(m,1)%j+dj + ovf(n)%adj_prd(m)%kmin = ovf(n)%loc_prd(m,1)%k + ovf(n)%adj_prd(m)%imax = ovf(n)%loc_prd(m,1)%i+di + ovf(n)%adj_prd(m)%jmax = ovf(n)%loc_prd(m,1)%j+dj + ovf(n)%adj_prd(m)%kmax = ovf(n)%loc_prd(m,1)%k + do mp=2,ovf(n)%num_prd(m) + di = 0 + dj = 0 + if( ovf(n)%loc_prd(m,mp)%orient .eq. 1 ) di = +1 + if( ovf(n)%loc_prd(m,mp)%orient .eq. 2 ) dj = +1 + if( ovf(n)%loc_prd(m,mp)%orient .eq. 3 ) di = -1 + if( ovf(n)%loc_prd(m,mp)%orient .eq. 4 ) dj = -1 + ovf(n)%adj_prd(m)%imin = min & + (ovf(n)%adj_prd(m)%imin,ovf(n)%loc_prd(m,mp)%i+di) + ovf(n)%adj_prd(m)%jmin = min & + (ovf(n)%adj_prd(m)%jmin,ovf(n)%loc_prd(m,mp)%j+dj) + ovf(n)%adj_prd(m)%kmin = min & + (ovf(n)%adj_prd(m)%kmin,ovf(n)%loc_prd(m,mp)%k) + ovf(n)%adj_prd(m)%imax = max & + (ovf(n)%adj_prd(m)%imax,ovf(n)%loc_prd(m,mp)%i+di) + ovf(n)%adj_prd(m)%jmax = max & + (ovf(n)%adj_prd(m)%jmax,ovf(n)%loc_prd(m,mp)%j+dj) + ovf(n)%adj_prd(m)%kmax = max & + (ovf(n)%adj_prd(m)%kmax,ovf(n)%loc_prd(m,mp)%k) + end do + end do +! print prd adj limits + do m=1,ovf(n)%num_prd_sets + write(stdout,15) m, & + ovf(n)%adj_prd(m)%imin, & + ovf(n)%adj_prd(m)%imax, & + ovf(n)%adj_prd(m)%jmin, & + ovf(n)%adj_prd(m)%jmax, & + ovf(n)%adj_prd(m)%kmin, & + ovf(n)%adj_prd(m)%kmax +15 format(' Computed product adjacent, set=',i3, & + ' ijk min/max =',6(i4,2x)) + end do + end do ! ovf loop + call shr_sys_flush(stdout) + +!----------------------------------------------------------------------- +! end master task section +!----------------------------------------------------------------------- + + close (nu) + endif ! master_task + call release_unit(nu) + +! error from goto 10 +10 continue + + call broadcast_scalar(ovf_error, master_task) + if (ovf_error /= 0) then + call broadcast_scalar(num_req, master_task) + write(stdout,*) 'ERROR on overflow input' + if( ovf_error == 1 ) then + write(stdout,*) 'Overflows on but number requested out of range' + write(stdout,*) 'Number requested = ',num_req + write(stdout,*) 'Must be > 0 and not greater than ',max_ovf + else if ( ovf_error == 2 ) then + write(stdout,*) 'Overflows on with kmt topography changes out of range' + write(stdout,*) 'Number requested = ',num_req + write(stdout,*) 'Must be >= 0 and not greater than ',max_kmt + else if ( ovf_error == 3 ) then + write(stdout,*) 'Overflows on with number source points out of range' + write(stdout,*) 'Number requested = ',num_req + write(stdout,*) 'Must be > 1 and not greater than ',max_src + else if ( ovf_error == 4 ) then + write(stdout,*) 'Overflows on with number entrainment points out of range' + write(stdout,*) 'Number requested = ',num_req + write(stdout,*) 'Must be > 1 and not greater than ',max_ent + else if ( ovf_error == 5 ) then + write(stdout,*) 'Overflows on with number of product sets out of range' + write(stdout,*) 'Number requested = ',num_req + write(stdout,*) 'Must be > 0 and not greater than ',max_prd_sets + else if ( ovf_error == 6 ) then + write(stdout,*) 'Overflows on with number of product points out of range' + write(stdout,*) 'Number requested = ',num_req + write(stdout,*) 'Must be > 1 and not greater than ',max_prd + else if ( ovf_error == 7 ) then + write(stdout,*) 'Overflows on with non-monotonic increasing i or j' + else if ( ovf_error == 8 ) then + write(stdout,*) 'Overflows on with no change in i and j' + else if ( ovf_error == 9 ) then + write(stdout,*) 'Overflows on with both i and j increasing' + else if ( ovf_error == 10 ) then + write(stdout,*) 'Overflows on with non-constant level k' + else if ( ovf_error == 11 ) then + write(stdout,*) 'Overflows on with orientation either < 0 or > 4' + else if ( ovf_error == 12 ) then + write(stdout,*) 'Overflows on with non-constant orientation' + endif + call shr_sys_flush(stdout) + call exit_POP(sigAbort,'ERROR reading overflows_infile') + endif ! ovf error + +!----------------------------------------------------------------------- +! broadcast overflows info to all processors +!----------------------------------------------------------------------- + + call broadcast_scalar(num_ovf, master_task) + do n=1,num_ovf + call broadcast_scalar(ovf(n)%interactive, master_task) + call broadcast_scalar(ovf(n)%name, master_task) +! ovf data + call broadcast_scalar(ovf(n)%ovf_params%lat, master_task) + call broadcast_scalar(ovf(n)%ovf_params%width, master_task) + call broadcast_scalar(ovf(n)%ovf_params%source_thick, master_task) + call broadcast_scalar(ovf(n)%ovf_params%distnc_str_ssb, master_task) + call broadcast_scalar(ovf(n)%ovf_params%bottom_slope, master_task) + call broadcast_scalar(ovf(n)%ovf_params%bottom_drag, master_task) +! kmt locations + call broadcast_scalar(ovf(n)%num_kmt, master_task) + do m=1,ovf(n)%num_kmt + call broadcast_scalar(ovf(n)%loc_kmt(m)%i, master_task) + call broadcast_scalar(ovf(n)%loc_kmt(m)%j, master_task) + call broadcast_scalar(ovf(n)%loc_kmt(m)%korg, master_task) + call broadcast_scalar(ovf(n)%loc_kmt(m)%knew, master_task) + end do +! regional boundaries +! inflow + call broadcast_scalar(ovf(n)%reg_inf%imin, master_task) + call broadcast_scalar(ovf(n)%reg_inf%imax, master_task) + call broadcast_scalar(ovf(n)%reg_inf%jmin, master_task) + call broadcast_scalar(ovf(n)%reg_inf%jmax, master_task) + call broadcast_scalar(ovf(n)%reg_inf%kmin, master_task) + call broadcast_scalar(ovf(n)%reg_inf%kmax, master_task) +! source + call broadcast_scalar(ovf(n)%reg_src%imin, master_task) + call broadcast_scalar(ovf(n)%reg_src%imax, master_task) + call broadcast_scalar(ovf(n)%reg_src%jmin, master_task) + call broadcast_scalar(ovf(n)%reg_src%jmax, master_task) + call broadcast_scalar(ovf(n)%reg_src%kmin, master_task) + call broadcast_scalar(ovf(n)%reg_src%kmax, master_task) +! entrainment + call broadcast_scalar(ovf(n)%reg_ent%imin, master_task) + call broadcast_scalar(ovf(n)%reg_ent%imax, master_task) + call broadcast_scalar(ovf(n)%reg_ent%jmin, master_task) + call broadcast_scalar(ovf(n)%reg_ent%jmax, master_task) + call broadcast_scalar(ovf(n)%reg_ent%kmin, master_task) + call broadcast_scalar(ovf(n)%reg_ent%kmax, master_task) +! src locs and orientation + call broadcast_scalar(ovf(n)%num_src, master_task) + do m=1,ovf(n)%num_src + call broadcast_scalar(ovf(n)%loc_src(m)%i, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%j, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%i_adv, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%j_adv, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%i_u, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%j_u, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%k, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%orient, master_task) + end do +! ent locs and orientation + call broadcast_scalar(ovf(n)%num_ent, master_task) + do m=1,ovf(n)%num_ent + call broadcast_scalar(ovf(n)%loc_ent(m)%i, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%j, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%i_adv, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%j_adv, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%i_u, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%j_u, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%k, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%orient, master_task) + end do +! prd locs and orientation + call broadcast_scalar(ovf(n)%num_prd_sets, master_task) + do m=1,ovf(n)%num_prd_sets + call broadcast_scalar(ovf(n)%num_prd(m), master_task) + do mp=1,ovf(n)%num_prd(m) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%i, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%j, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%i_adv, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%j_adv, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%i_u, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%j_u, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%k, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%orient, master_task) + end do + end do +! adjacent boundaries + call broadcast_scalar(ovf(n)%adj_src%imin, master_task) + call broadcast_scalar(ovf(n)%adj_src%imax, master_task) + call broadcast_scalar(ovf(n)%adj_src%jmin, master_task) + call broadcast_scalar(ovf(n)%adj_src%jmax, master_task) + call broadcast_scalar(ovf(n)%adj_src%kmin, master_task) + call broadcast_scalar(ovf(n)%adj_src%kmax, master_task) + call broadcast_scalar(ovf(n)%adj_ent%imin, master_task) + call broadcast_scalar(ovf(n)%adj_ent%imax, master_task) + call broadcast_scalar(ovf(n)%adj_ent%jmin, master_task) + call broadcast_scalar(ovf(n)%adj_ent%jmax, master_task) + call broadcast_scalar(ovf(n)%adj_ent%kmin, master_task) + call broadcast_scalar(ovf(n)%adj_ent%kmax, master_task) + do m=1,ovf(n)%num_prd_sets + call broadcast_scalar(ovf(n)%adj_prd(m)%imin, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%imax, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%jmin, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%jmax, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%kmin, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%kmax, master_task) + end do + end do ! ovf broadcast loop + +!----------------------------------------------------------------------- +! initialize overflow data for all processors, so no need to broadcast +!----------------------------------------------------------------------- + + do n=1,num_ovf + ovf(n)%Ms = c0 + ovf(n)%Ms_n = c0 + ovf(n)%Ms_nm1 = c0 + ovf(n)%Me = c0 + ovf(n)%Me_n = c0 + ovf(n)%Me_nm1 = c0 + ovf(n)%phi = c0 + ovf(n)%Mp = c0 + ovf(n)%Mp_n = c0 + ovf(n)%Mp_nm1 = c0 + ovf(n)%wght_reg%inf = c0 + ovf(n)%wght_reg%src = c0 + ovf(n)%wght_reg%ent = c0 + do m=1,ovf(n)%num_prd_sets + ovf(n)%wght_adj%prd(m) = c0 + end do + ovf(n)%rho_reg%inf = c0 + ovf(n)%rho_reg%src = c0 + ovf(n)%rho_reg%ent = c0 + do m=1,ovf(n)%num_prd_sets + ovf(n)%rho_adj%prd(m) = c0 + end do + ovf(n)%prd_set_n = 1 + ovf(n)%prd_set = 1 + do nn=1,nt + ovf(n)%trcr_reg%inf(nn) = c0 + ovf(n)%trcr_reg%src(nn) = c0 + ovf(n)%trcr_reg%ent(nn) = c0 + ovf(n)%trcr_adj%src(nn) = c0 + ovf(n)%trcr_adj%ent(nn) = c0 + ovf(n)%trcr_adj%prd(nn) = c0 + end do + do m=1,ovf(n)%num_src + do k=1,km + ovf(n)%loc_src(m)%Utlda(k) = c0 + ovf(n)%loc_src(m)%Vtlda(k) = c0 + end do + ovf(n)%loc_src(m)%Uovf_nm1 = c0 + ovf(n)%loc_src(m)%Uovf_n = c0 + ovf(n)%loc_src(m)%Uovf = c0 + ovf(n)%loc_src(m)%Wovf = c0 + end do + do m=1,ovf(n)%num_ent + do k=1,km + ovf(n)%loc_ent(m)%Utlda(k) = c0 + ovf(n)%loc_ent(m)%Vtlda(k) = c0 + end do + ovf(n)%loc_ent(m)%Uovf_nm1 = c0 + ovf(n)%loc_ent(m)%Uovf_n = c0 + ovf(n)%loc_ent(m)%Uovf = c0 + ovf(n)%loc_ent(m)%Wovf = c0 + end do + do m=1,ovf(n)%num_prd_sets + do mp=1,ovf(n)%num_prd(m) + do k=1,km + ovf(n)%loc_prd(m,mp)%Utlda(k) = c0 + ovf(n)%loc_prd(m,mp)%Vtlda(k) = c0 + end do + ovf(n)%loc_prd(m,mp)%Uovf_nm1 = c0 + ovf(n)%loc_prd(m,mp)%Uovf_n = c0 + ovf(n)%loc_prd(m,mp)%Uovf = c0 + ovf(n)%loc_prd(m,mp)%Wovf = c0 + end do + end do + end do ! ovf initialization loop for all processors + + else if( overflows_restart_type /= 'ccsm_startup' ) then + + call ovf_read_restart + call ovf_read_broadcast + + endif + + + + + + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_overflows1 + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows2 +! !INTERFACE: + + subroutine init_overflows2 + +! !DESCRIPTION: +! This routine continues the initialization of the overflows by +! scattering KMT_G to KMT, then modifying if desired, and finally +! computing overflow masks. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC + +!----------------------------------------------------------------------- +! +! scatter KMT_G to KMT if topography_opt = file +! +!----------------------------------------------------------------------- + + if (registry_match('topography_opt_file')) then + if (my_task == master_task) write(stdout,'(a30,a)') & + ' Reading topography from file:', trim(topography_filename) + call read_topography(topography_filename,.false.) + endif + + if (.not. overflows_on ) return + + +! don't initialize the groups yet + ovf_groups%init = .false. + + +!----------------------------------------------------------------------- +! +! modify KMT for overflows if desired and ccsm_startup run +! make kmt changes regardless of overflows_interactive +! +!----------------------------------------------------------------------- + + call init_overflows_kmt + +!----------------------------------------------------------------------- +! +! set overflow masks for regional averaging +! +!----------------------------------------------------------------------- + + call init_overflows_mask + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_overflows2 + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows_kmt +! !INTERFACE: + + subroutine init_overflows_kmt + +! !DESCRIPTION: +! This routine modifies kmt as required by overflows, if on +! and interactive. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC + +!---------------------------------------------------------------------- +! +! local variables +! +!---------------------------------------------------------------------- + + integer (int_kind) :: & + iblock,i,j,k,m,n, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + kmterr ! error index for kmt changes + + type (block) :: & + this_block ! block information for current block + +!---------------------------------------------------------------------- +! +! search through kmt and modify for overflows +! +!---------------------------------------------------------------------- + + kmterr = 0 + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + do i=ib,ie + do n=1,num_ovf + do m=1,ovf(n)%num_kmt + if( ovf(n)%loc_kmt(m)%i.eq.this_block%i_glob(i).and.& + ovf(n)%loc_kmt(m)%j.eq.this_block%j_glob(j) ) then + if (my_task == master_task) & + write(stdout,100) KMT(i,j,iblock),ovf(n)%loc_kmt(m)%i, & + ovf(n)%loc_kmt(m)%j,ovf(n)%loc_kmt(m)%knew + 100 format(' init_overflows_kmt: KMT = ',i5,& + ' at global (i,j) = ',2(i5,1x),& + ' changed to ',i5) + if( KMT(i,j,iblock) .ne. ovf(n)%loc_kmt(m)%korg ) then + kmterr = kmterr + 1 + endif + KMT(i,j,iblock) = ovf(n)%loc_kmt(m)%knew + endif + end do + end do + enddo + enddo + enddo + if (kmterr > 0) then + if (my_task == master_task) & + write(stdout,200) kmterr + 200 format(' init_overflows_kmt: kmt inconsistencies for ',i3,' points',/ & + ' original kmt not equal to actual kmt') + call shr_sys_flush(stdout) + call exit_POP(sigAbort,'ERROR kmt inconsistency for overflows') + endif + call shr_sys_flush(stdout) + + call POP_HaloUpdate(KMT, POP_haloClinic, POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0_POP_i4) + +!---------------------------------------------------------------------- +!EOC + + end subroutine init_overflows_kmt + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows_mask +! !INTERFACE: + + subroutine init_overflows_mask + +! !DESCRIPTION: +! This routine sets overflow masks for regional and adjacent averaging +! Need to do this on all procs +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC + +!---------------------------------------------------------------------- +! +! local variables +! +!---------------------------------------------------------------------- + + integer (int_kind) :: & + iblock,i,j,n,m, & ! dummy loop indices + ib,ie,jb,je ! local domain index boundaries + + type (block) :: & + this_block ! block information for current block + +!---------------------------------------------------------------------- +! +! set masks for regional averaging +! +!---------------------------------------------------------------------- + +!must go through ALL the overflows + do n=1,num_ovf + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je +! inflow region + if( ovf(n)%reg_inf%jmin .le. this_block%j_glob(j) .and. & + this_block%j_glob(j) .le. ovf(n)%reg_inf%jmax ) then + do i=ib,ie + ovf(n)%mask_reg%inf(i,j,iblock) = c0 + if( ovf(n)%reg_inf%imin .le. this_block%i_glob(i) .and. & + this_block%i_glob(i) .le. ovf(n)%reg_inf%imax ) then + ovf(n)%mask_reg%inf(i,j,iblock) = c1 + if (my_task == master_task) & + write(stdout,30) ovf(n)%name,this_block%i_glob(i), & + this_block%j_glob(j) + 30 format(' Overflow: ',a24, & + ' Inflow region mask at global (ij)=',2(i3,2x)) + endif + end do + endif ! inflow region +! source region + if( ovf(n)%reg_src%jmin .le. this_block%j_glob(j) .and. & + this_block%j_glob(j) .le. ovf(n)%reg_src%jmax ) then + do i=ib,ie + ovf(n)%mask_reg%src(i,j,iblock) = c0 + if( ovf(n)%reg_src%imin .le. this_block%i_glob(i) .and. & + this_block%i_glob(i) .le. ovf(n)%reg_src%imax ) then + ovf(n)%mask_reg%src(i,j,iblock) = c1 + if (my_task == master_task) & + write(stdout,31) ovf(n)%name,this_block%i_glob(i), & + this_block%j_glob(j) + 31 format(' Overflow: ',a24, & + ' Source region mask at global (ij)=',2(i3,2x)) + endif + end do + endif ! source region +! source adjacent + if( ovf(n)%adj_src%jmin .le. this_block%j_glob(j) .and. & + this_block%j_glob(j) .le. ovf(n)%adj_src%jmax ) then + do i=ib,ie + ovf(n)%mask_adj%src(i,j,iblock) = c0 + if( ovf(n)%adj_src%imin .le. this_block%i_glob(i) .and. & + this_block%i_glob(i) .le. ovf(n)%adj_src%imax ) then + ovf(n)%mask_adj%src(i,j,iblock) = c1 + if (my_task == master_task) & + write(stdout,32) ovf(n)%name,this_block%i_glob(i), & + this_block%j_glob(j) + 32 format(' Overflow: ',a24, & + ' Source adjacent mask at global (ij)=',2(i3,2x)) + endif + end do + endif ! source adjacent +! entrainment region + if( ovf(n)%reg_ent%jmin .le. this_block%j_glob(j) .and. & + this_block%j_glob(j) .le. ovf(n)%reg_ent%jmax ) then + do i=ib,ie + ovf(n)%mask_reg%ent(i,j,iblock) = c0 + if( ovf(n)%reg_ent%imin .le. this_block%i_glob(i) .and. & + this_block%i_glob(i) .le. ovf(n)%reg_ent%imax ) then + ovf(n)%mask_reg%ent(i,j,iblock) = c1 + if (my_task == master_task) & + write(stdout,33) ovf(n)%name,this_block%i_glob(i), & + this_block%j_glob(j) + 33 format(' Overflow: ',a24, & + ' Entrainment region mask at global (ij)=',2(i3,2x)) + endif + end do + endif ! entrainment region +! entrainment adjacent + if( ovf(n)%adj_ent%jmin .le. this_block%j_glob(j) .and. & + this_block%j_glob(j) .le. ovf(n)%adj_ent%jmax ) then + do i=ib,ie + ovf(n)%mask_adj%ent(i,j,iblock) = c0 + if( ovf(n)%adj_ent%imin .le. this_block%i_glob(i) .and. & + this_block%i_glob(i) .le. ovf(n)%adj_ent%imax ) then + ovf(n)%mask_adj%ent(i,j,iblock) = c1 + if (my_task == master_task) & + write(stdout,34) ovf(n)%name,this_block%i_glob(i), & + this_block%j_glob(j) + 34 format(' Overflow: ',a24, & + ' Entrainment adjacent mask at global (ij)=',2(i3,2x)) + endif + end do + endif ! entrainment adjacent + end do ! j loop +! product adjacent + do m=1,ovf(n)%num_prd_sets + do j=jb,je + if( ovf(n)%adj_prd(m)%jmin .le. this_block%j_glob(j) .and. & + this_block%j_glob(j) .le. ovf(n)%adj_prd(m)%jmax ) then + do i=ib,ie + ovf(n)%mask_adj%prd(i,j,iblock,m) = c0 + if( ovf(n)%adj_prd(m)%imin .le. this_block%i_glob(i) .and. & + this_block%i_glob(i) .le. ovf(n)%adj_prd(m)%imax ) then + ovf(n)%mask_adj%prd(i,j,iblock,m) = c1 + if (my_task == master_task) & + write(stdout,35) ovf(n)%name,this_block%i_glob(i), & + this_block%j_glob(j) + 35 format(' Overflow: ',a24, & + ' Product adjacent mask at global (ij)=',2(i3,2x)) + endif + end do + endif ! product adjacent + end do + end do + end do + end do + call shr_sys_flush(stdout) + +!---------------------------------------------------------------------- +!EOC + + end subroutine init_overflows_mask + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows3 +! !INTERFACE: + + subroutine init_overflows3 + +! !DESCRIPTION: +! This routine completes the initialization of the overflows by +! modifying the 9pt coefficients for the barotropic solution +! as required for each overflow grid box +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC + +!----------------------------------------------------------------------- +! +! modify 9pt coefficients for barotropic solver +! +!----------------------------------------------------------------------- + + if( overflows_on .and. overflows_interactive ) then + call ovf_solvers_9pt + endif + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_overflows3 + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows4 +! !INTERFACE: + + subroutine init_overflows4 + +! !DESCRIPTION: +! This routine creates the overflow output diagnostics filename, now +! that the initial model run time is known. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + character (char_len) :: & + string + + save + +!----------------------------------------------------------------------- +! if overflows off, exit +!----------------------------------------------------------------------- + + if (.not. overflows_on ) return + + +! don't initialize the groups yet +! ovf_groups%init = .false. + + +!----------------------------------------------------------------------- +! set up output file and unit for overflow diagnostics +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! define ccsm overflow diagnostics output filename +!----------------------------------------------------------------------- + if (lccsm) then + call ccsm_date_stamp (ccsm_diag_date, 'ymds') + string = overflows_diag_outfile + overflows_diag_outfile = trim(string)/& + &/'.'/& + &/trim(ccsm_diag_date) + else +!----------------------------------------------------------------------- +! append runid, initial date to output file names +! concatenation operator must be split across lines to avoid problems +! with preprocessors +!----------------------------------------------------------------------- + if (date_separator == ' ') then + cdate(1:4) = cyear + cdate(5:6) = cmonth + cdate(7:8) = cday + cdate(9:10)= ' ' + else + cdate(1:4) = cyear + cdate(5:5) = date_separator + cdate(6:7) = cmonth + cdate(8:8) = date_separator + cdate(9:10) = cday + endif + outfile_tmp = char_blank + outfile_tmp = trim(overflows_diag_outfile)/& + &/'.'/& + &/trim(runid)/& + &/'.'/& + &/trim(cdate) + overflows_diag_outfile = trim(outfile_tmp) + endif ! lccsm + + + call get_unit(ovf_diag_unit) + if (my_task == master_task) then + open(ovf_diag_unit, file=overflows_diag_outfile, status='unknown') + write(ovf_diag_unit,*)' ' + close(ovf_diag_unit) + + write(stdout,'(a,a)') & + 'Overflow diagnostics written to file: ', trim(overflows_diag_outfile) + endif + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_overflows4 + +!*********************************************************************** +!EOP +! !IROUTINE: init_overflows5 +! !INTERFACE: + + subroutine init_overflows5 + +! !DESCRIPTION: +! This routine computes regional aveages required at restart +! for overflow regions, using all available tracers, and also +! computes regional product values based on source and entrainment. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + save + + integer (int_kind) :: & + n ,& ! index of overflow + nn ! ovf tracer index + real (r8) :: & + phi ! entrainment parameter from actual ratio Me/Mp + + integer (int_kind) ovf_id + + + +!---------------------- +!initialize ovf timer (not calling in block loops) +!------------------------ + + call get_timer(timer_ovf,'OVF TIMER', 1, & + distrb_clinic%nprocs) + + +!----------------------------------------------------------------------- +! +! compute regional averages. +! +!----------------------------------------------------------------------- + + if( overflows_on .and. overflows_interactive ) then + call ovf_reg_avgs(oldtime) +! evaluate regional product values based on src,ent averages just computed +! src + + do n=1,ovf_groups%numMyGroups + ovf_id = ovf_groups%groupIds(n) + phi = ovf(ovf_id)%phi + do nn=1,nt + ovf(ovf_id)%trcr_reg%prd(nn) = ovf(ovf_id)%trcr_reg%src(nn) * (c1 - phi) & + + ovf(ovf_id)%trcr_reg%ent(nn) * phi + end do + enddo + endif + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_overflows5 + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_write_restart +! !INTERFACE: + + subroutine ovf_write_restart + + +! !DESCRIPTION: +! This routine writes the overflow restart file using +! selected data from overflow array. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + save + + integer (int_kind) :: & + mu, &! unit for ovf restart file + ovf_error, &! error flag + n, &! ovf loop index + m, &! sub-ovf loop index + nn, &! tracer loop index + mp, &! sub-ovf sub-loop index + num_posts, & + ierr, count, loc, ovf_id, i + + logical (log_kind), dimension(:), allocatable :: post_array + integer(i4), dimension(:), allocatable :: myRequests(:) + integer (i4), dimension(:,:), allocatable:: myStati(:,:) + + integer (int_kind), parameter :: len = 14 !length of buffer for a post + + real (r8), dimension(:), allocatable:: myRecvBuff(:), mySendBuff(:) + + + character (char_len) :: & + write_restart_filename, &! modified file name for restart file + ovf_restart_pointer_file, &! overflows rpointer filename + file_suffix, &! suffix to append to root filename + char_temp ! temporary character string + + character (10) :: &! for input year,month,day + cdate + + logical (log_kind) :: post + + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_write_restart called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! if overflows off, exit +!----------------------------------------------------------------------- + + if( .not. overflows_on ) return + + cdate(1:4) = cyear + cdate(5:6) = cmonth + cdate(7:8) = cday + cdate(9:10)= ' ' + + ovf_error = 0 + call get_unit(mu) + + write_restart_filename = char_blank + file_suffix = char_blank + + if (registry_match('lccsm')) then + call ccsm_date_stamp(char_temp, 'ymds') + file_suffix = trim(char_temp) + !*** must split concatenation operator to avoid preprocessor mangling + write_restart_filename = trim(overflows_restfile)/& + &/'.'/& + &/trim(file_suffix) + else + write_restart_filename = trim(overflows_restfile) + endif + + +!----------------------------------------------------------------------- +! master task section +!----------------------------------------------------------------------- + + if (my_task == master_task) then + + + !for any ovf groups that the master_task is not in, + !must post recv for the info + allocate(post_array(num_ovf)) + num_posts = num_ovf - ovf_groups%numMyGroups + if (num_posts > 0) then + allocate(myRecvBuff(len*num_posts)) + end if + + call ovf_print_init(len, num_posts, myRecvBuff, post_array) + + open(mu, file=write_restart_filename, status='unknown',iostat=ovf_error) + + write(stdout,987) mu,write_restart_filename + 987 format(' ovf_write_restart unit (mu) = ',i5,' file name = ',a64) + + write(stdout,99) cdate + 99 format(' ovf write restart cdate yyyymmdd = ',a10) + call shr_sys_flush(stdout) + + write(mu,100) cdate,num_ovf + 100 format(30x,' ! Overflow Restart File for yyyymmdd =',a10/ & + 2x,i10,20x,'! number of overflows') + + + !MAIN ovf loop + count = 0 + do n=1,num_ovf + + write(mu,101) ovf(n)%name + 101 format(2x,a26,' ! name of overflow') + +! ovf parameters + write(mu,102) ovf(n)%ovf_params%lat + 102 format(2x,1PE27.18,' ! latitude in degrees') + write(mu,103) ovf(n)%ovf_params%width + 103 format(2x,1PE27.18,' ! channel width in meters') + write(mu,105) ovf(n)%ovf_params%source_thick + 105 format(2x,1PE27.18,' ! source thickness in meters') + write(mu,106) ovf(n)%ovf_params%distnc_str_ssb + 106 format(2x,1PE27.18,' ! strait to shelf-slope break in meters') + write(mu,107) ovf(n)%ovf_params%bottom_slope + 107 format(2x,1PE27.18,' ! bottom slope dy/dx ') + write(mu,108) ovf(n)%ovf_params%bottom_drag + 108 format(2x,1PE27.18,' ! bottom drag coefficient') + +! kmt changes, if any + write(mu,1090) ovf(n)%num_kmt + 1090 format(2x,i10,20x,'! number of kmt changes') + do m=1,ovf(n)%num_kmt + write(mu,1091) ovf(n)%loc_kmt(m)%i + 1091 format(2x,i10,20x,'! i grid box index for kmt change') + write(mu,1092) ovf(n)%loc_kmt(m)%j + 1092 format(2x,i10,20x,'! j grid box index for kmt change') + write(mu,1093) ovf(n)%loc_kmt(m)%korg + 1093 format(2x,i10,20x,'! korg original grid box k index') + write(mu,1094) ovf(n)%loc_kmt(m)%knew + 1094 format(2x,i10,20x,'! knew new grid box k index') + end do + +! regional boundaries +! inflow + write(mu,110) ovf(n)%reg_inf%imin + 110 format(2x,i10,20x,'! inflow region imin') + write(mu,111) ovf(n)%reg_inf%imax + 111 format(2x,i10,20x,'! inflow region imax') + write(mu,112) ovf(n)%reg_inf%jmin + 112 format(2x,i10,20x,'! inflow region jmin') + write(mu,113) ovf(n)%reg_inf%jmax + 113 format(2x,i10,20x,'! inflow region jmax') + write(mu,114) ovf(n)%reg_inf%kmin + 114 format(2x,i10,20x,'! inflow region kmin') + write(mu,115) ovf(n)%reg_inf%kmax + 115 format(2x,i10,20x,'! inflow region kmax') +! source + write(mu,116) ovf(n)%reg_src%imin + 116 format(2x,i10,20x,'! source region imin') + write(mu,117) ovf(n)%reg_src%imax + 117 format(2x,i10,20x,'! source region imax') + write(mu,118) ovf(n)%reg_src%jmin + 118 format(2x,i10,20x,'! source region jmin') + write(mu,119) ovf(n)%reg_src%jmax + 119 format(2x,i10,20x,'! source region jmax') + write(mu,120) ovf(n)%reg_src%kmin + 120 format(2x,i10,20x,'! source region kmin') + write(mu,121) ovf(n)%reg_src%kmax + 121 format(2x,i10,20x,'! source region kmax') +! entrainment + write(mu,122) ovf(n)%reg_ent%imin + 122 format(2x,i10,20x,'! entrainment region imin') + write(mu,123) ovf(n)%reg_ent%imax + 123 format(2x,i10,20x,'! entrainment region imax') + write(mu,124) ovf(n)%reg_ent%jmin + 124 format(2x,i10,20x,'! entrainment region jmin') + write(mu,125) ovf(n)%reg_ent%jmax + 125 format(2x,i10,20x,'! entrainment region jmax') + write(mu,126) ovf(n)%reg_ent%kmin + 126 format(2x,i10,20x,'! entrainment region kmin') + write(mu,127) ovf(n)%reg_ent%kmax + 127 format(2x,i10,20x,'! entrainment region kmax') +! src locs and orientation + write(mu,128) ovf(n)%num_src + 128 format(2x,i10,20x,'! number of source grid boxes') + do m=1,ovf(n)%num_src + write(mu,129) ovf(n)%loc_src(m)%i + 129 format(2x,i10,20x,'! source box i') + write(mu,130) ovf(n)%loc_src(m)%j + 130 format(2x,i10,20x,'! source box j') + write(mu,131) ovf(n)%loc_src(m)%i_adv + 131 format(2x,i10,20x,'! source box i_adv') + write(mu,132) ovf(n)%loc_src(m)%j_adv + 132 format(2x,i10,20x,'! source box j_adv') + write(mu,133) ovf(n)%loc_src(m)%i_u + 133 format(2x,i10,20x,'! source box i_u') + write(mu,134) ovf(n)%loc_src(m)%j_u + 134 format(2x,i10,20x,'! source box j_u') + write(mu,135) ovf(n)%loc_src(m)%k + 135 format(2x,i10,20x,'! source box k') + write(mu,136) ovf(n)%loc_src(m)%orient + 136 format(2x,i10,20x,'! source box orient') + end do +! ent locs and orientation + write(mu,137) ovf(n)%num_ent + 137 format(2x,i10,20x,'! number of entrainment grid boxes') + do m=1,ovf(n)%num_ent + write(mu,138) ovf(n)%loc_ent(m)%i + 138 format(2x,i10,20x,'! entrainment box i') + write(mu,139) ovf(n)%loc_ent(m)%j + 139 format(2x,i10,20x,'! entrainment box j') + write(mu,140) ovf(n)%loc_ent(m)%i_adv + 140 format(2x,i10,20x,'! entrainment box i_adv') + write(mu,141) ovf(n)%loc_ent(m)%j_adv + 141 format(2x,i10,20x,'! entrainment box j_adv') + write(mu,142) ovf(n)%loc_ent(m)%i_u + 142 format(2x,i10,20x,'! entrainment box i_u') + write(mu,143) ovf(n)%loc_ent(m)%j_u + 143 format(2x,i10,20x,'! entrainment box j_u') + write(mu,144) ovf(n)%loc_ent(m)%k + 144 format(2x,i10,20x,'! entrainment box k') + write(mu,145) ovf(n)%loc_ent(m)%orient + 145 format(2x,i10,20x,'! entrainment box orient') + end do +! prd locs and orientation + write(mu,146) ovf(n)%num_prd_sets + 146 format(2x,i10,20x,'! number of product sets') + do m=1,ovf(n)%num_prd_sets + write(mu,147) ovf(n)%num_prd(m) + 147 format(2x,i10,20x, & + '! number of product grid boxes for this set') + do mp=1,ovf(n)%num_prd(m) + write(mu,148) ovf(n)%loc_prd(m,mp)%i + 148 format(2x,i10,20x,'! product box i') + write(mu,149) ovf(n)%loc_prd(m,mp)%j + 149 format(2x,i10,20x,'! product box j') + write(mu,150) ovf(n)%loc_prd(m,mp)%i_adv + 150 format(2x,i10,20x,'! product box i_adv') + write(mu,151) ovf(n)%loc_prd(m,mp)%j_adv + 151 format(2x,i10,20x,'! product box j_adv') + write(mu,152) ovf(n)%loc_prd(m,mp)%i_u + 152 format(2x,i10,20x,'! product box i_u') + write(mu,153) ovf(n)%loc_prd(m,mp)%j_u + 153 format(2x,i10,20x,'! product box j_u') + write(mu,154) ovf(n)%loc_prd(m,mp)%k + 154 format(2x,i10,20x,'! product box k') + write(mu,155) ovf(n)%loc_prd(m,mp)%orient + 155 format(2x,i10,20x,'! product box orient') + end do + end do +! adjacent boundaries +! src + write(mu,156) ovf(n)%adj_src%imin + 156 format(2x,i10,20x,'! source adjacent imin') + write(mu,157) ovf(n)%adj_src%imax + 157 format(2x,i10,20x,'! source adjacent imax') + write(mu,158) ovf(n)%adj_src%jmin + 158 format(2x,i10,20x,'! source adjacent jmin') + write(mu,159) ovf(n)%adj_src%jmax + 159 format(2x,i10,20x,'! source adjacent jmax') + write(mu,160) ovf(n)%adj_src%kmin + 160 format(2x,i10,20x,'! source adjacent kmin') + write(mu,161) ovf(n)%adj_src%kmax + 161 format(2x,i10,20x,'! source adjacent kmax') +!ent + write(mu,162) ovf(n)%adj_ent%imin + 162 format(2x,i10,20x,'! entrainment adjacent imin') + write(mu,163) ovf(n)%adj_ent%imax + 163 format(2x,i10,20x,'! entrainment adjacent imax') + write(mu,164) ovf(n)%adj_ent%jmin + 164 format(2x,i10,20x,'! entrainment adjacent jmin') + write(mu,165) ovf(n)%adj_ent%jmax + 165 format(2x,i10,20x,'! entrainment adjacent jmax') + write(mu,166) ovf(n)%adj_ent%kmin + 166 format(2x,i10,20x,'! entrainment adjacent kmin') + write(mu,167) ovf(n)%adj_ent%kmax + 167 format(2x,i10,20x,'! entrainment adjacent kmax') +!prd + do m=1,ovf(n)%num_prd_sets + write(mu,168) ovf(n)%adj_prd(m)%imin + 168 format(2x,i10,20x,'! product adjacent imin') + write(mu,169) ovf(n)%adj_prd(m)%imax + 169 format(2x,i10,20x,'! product adjacent imax') + write(mu,170) ovf(n)%adj_prd(m)%jmin + 170 format(2x,i10,20x,'! product adjacent jmin') + write(mu,171) ovf(n)%adj_prd(m)%jmax + 171 format(2x,i10,20x,'! product adjacent jmax') + write(mu,172) ovf(n)%adj_prd(m)%kmin + 172 format(2x,i10,20x,'! product adjacent kmin') + write(mu,173) ovf(n)%adj_prd(m)%kmax + 173 format(2x,i10,20x,'! product adjacent kmax') + end do + + +! transports + !! this information *could* be on other procs that are not the master_task + + if (post_array(n)) then !we posted a recv for this + count = count+1 + call ovf_print_get(count) + loc = (count-1)*len+1 + !now unpack + ovf(n)%Ms = myRecvBuff(loc) + ovf(n)%Ms_n = myRecvBuff(loc+1) + ovf(n)%Ms_nm1 = myRecvBuff(loc+2) + ovf(n)%Me = myRecvBuff(loc+3) + ovf(n)%Me_n = myRecvBuff(loc+4) + ovf(n)%Me_nm1 = myRecvBuff(loc+5) + ovf(n)%phi = myRecvBuff(loc+6) + ovf(n)%Mp = myRecvBuff(loc+7) + ovf(n)%Mp_n = myRecvBuff(loc+8) + ovf(n)%Mp_nm1 = myRecvBuff(loc+9) + ovf(n)%Tp = myRecvBuff(loc+10) + ovf(n)%Sp = myRecvBuff(loc+11) + ovf(n)%prd_set_n = int(myRecvBuff(loc+12), int_kind) + ovf(n)%prd_set = int(myRecvBuff(loc+13), int_kind) + +! print *, 'CHECK prd_set IAM = ', my_task, 'ovf_id=', n, & +! 'prd_set_n, prd_set', & +! ovf(n)%prd_set_n, " , ", ovf(n)%prd_set + + + end if + + write(mu,174) ovf(n)%Ms + 174 format(2x,1PE27.18,' ! source volume n+1 transport cm3/sec') + write(mu,175) ovf(n)%Ms_n + 175 format(2x,1PE27.18,' ! source volume n transport cm3/sec') + write(mu,176) ovf(n)%Ms_nm1 + 176 format(2x,1PE27.18,' ! source volume n-1 transport cm3/sec') + write(mu,177) ovf(n)%Me + 177 format(2x,1PE27.18,' ! entrainment volume n+1 transport cm3/sec') + write(mu,178) ovf(n)%Me_n + 178 format(2x,1PE27.18,' ! entrainment volume n transport cm3/sec') + write(mu,179) ovf(n)%Me_nm1 + 179 format(2x,1PE27.18,' ! entrainment volume n-1 transport cm3/sec') + write(mu,180) ovf(n)%phi + 180 format(2x,1PE27.18,' ! phi parameter') + write(mu,181) ovf(n)%Mp + 181 format(2x,1PE27.18,' ! product volume n+1 transport cm3/sec') + write(mu,182) ovf(n)%Mp_n + 182 format(2x,1PE27.18,' ! product volume n transport cm3/sec') + write(mu,183) ovf(n)%Mp_nm1 + 183 format(2x,1PE27.18,' ! product volume n-1 transport cm3/sec') + write(mu,184) ovf(n)%Tp + 184 format(2x,1PE27.18,' ! product temperature C') + write(mu,185) ovf(n)%Sp + 185 format(2x,1PE27.18,' ! product salinity') + write(mu,186) ovf(n)%prd_set_n + write(mu,186) ovf(n)%prd_set + 186 format(2x,i10,20x,'! product set index (first is previous time step)') + + end do ! ovf loop + + close(mu) + + ! clean up + deallocate(post_array) + if (num_posts > 0) then + deallocate(myRecvBuff) + endif + call ovf_print_finalize(num_posts) + + else ! my_task \= master_task + count = 0 + do n=1, ovf_groups%numMyGroups + if (ovf_groups%amMaster(n)) then + count = count + 1 + end if + end do + + call ovf_print_init(len, count) + + if (count > 0) then + allocate(mySendBuff(count*len)) + end if + + num_posts = 0 + do n=1, ovf_groups%numMyGroups + if (ovf_groups%amMaster(n)) then + ovf_id = ovf_groups%groupIds(n) + !send transport info to the master task with isend + num_posts = num_posts + 1 + !pack send buffer + loc = (num_posts-1)*len + 1 + mySendBuff(loc) = ovf(ovf_id)%Ms + mySendBuff(loc+1) = ovf(ovf_id)%Ms_n + mySendBuff(loc+2) = ovf(ovf_id)%Ms_nm1 + mySendBuff(loc+3) = ovf(ovf_id)%Me + mySendBuff(loc+4) = ovf(ovf_id)%Me_n + mySendBuff(loc+5) = ovf(ovf_id)%Me_nm1 + mySendBuff(loc+6) = ovf(ovf_id)%phi + mySendBuff(loc+7) = ovf(ovf_id)%Mp + mySendBuff(loc+8) = ovf(ovf_id)%Mp_n + mySendBuff(loc+9) = ovf(ovf_id)%Mp_nm1 + mySendBuff(loc+10) = ovf(ovf_id)%Tp + mySendBuff(loc+11) = ovf(ovf_id)%Sp + mySendBuff(loc+12) = real(ovf(ovf_id)%prd_set_n, r8) + mySendBuff(loc+13) = real(ovf(ovf_id)%prd_set, r8) + +! print *, 'CHECK prd_set IAM = ', my_task, 'ovf_id=', ovf_id, & +! 'prd_set_n, prd_set', & +! ovf(ovf_id)%prd_set_n, " , ", ovf(ovf_id)%prd_set + + call ovf_print_send(len, mySendBuff(loc:loc+len-1), num_posts, ovf_id) + end if + end do ! n loop + + !now clean up + call ovf_print_finalize(num_posts) + if (num_posts > 0) then + deallocate(mySendBuff) + endif + + endif + + call release_unit(mu) + +!----------------------------------------------------------------------- +! +! if pointer files are used, write filename to pointer file +! +!----------------------------------------------------------------------- + + if (luse_pointer_files) then + call get_unit(mu) + if (my_task == master_task) then + ovf_restart_pointer_file = trim(pointer_filename)/& + &/'.ovf' + open(mu, file=ovf_restart_pointer_file, form='formatted', status='unknown') + write(mu,'(a)') trim(write_restart_filename) + close(mu) + write(stdout,blank_fmt) + write(stdout,*) ' overflow restart pointer file written: ',trim(ovf_restart_pointer_file) + call POP_IOUnitsFlush(POP_stdout) + endif + call release_unit(mu) + endif + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_write_restart + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_read_restart +! !INTERFACE: + + subroutine ovf_read_restart + +! !DESCRIPTION: +! This routine reads the overflow restart file for +! selected data from overflow array. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + save + + integer (POP_i4) :: & + mu, &! unit for ovf restart file + ovf_error, &! error flag + n, &! ovf loop index + m, &! sub-ovf loop index + nn, &! tracer loop index + mp, &! sub-ovf sub-loop index + ntrcr, &! number of tracers on read + cindx,cindx2 ! indices into restart pointer character string + + character (POP_charLength) :: & + restart_pointer_file, &! file name for restart pointer file + read_overflows_restfile, &! local restart filename + cdate_label ! for input year,month,day + + logical (POP_logical), parameter :: prnt = .false. + + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_read_restart called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! if overflows off, exit +!----------------------------------------------------------------------- + + if( .not. overflows_on ) return + + ovf_error = 0 + +!----------------------------------------------------------------------- +! +! if pointer files are used, overflows pointer file must be read to get +! actual filenames - skip this for ccsm_branch initialization +! +! otherwise use input filename +!----------------------------------------------------------------------- + + errorCode = POP_Success + + read_overflows_restfile = char_blank + restart_pointer_file = char_blank + + if (luse_pointer_files) then + call get_unit(mu) + if (my_task == master_task) then + restart_pointer_file = pointer_filename + cindx = len_trim(pointer_filename) + 1 + cindx2= cindx + 3 + restart_pointer_file(cindx:cindx2) = '.ovf' + write(stdout,*) 'Reading overflow pointer file: ', trim(restart_pointer_file) + call POP_IOUnitsFlush(POP_stdout) + open(mu, file=trim(restart_pointer_file), form='formatted', status='old') + read(mu,'(a)') read_overflows_restfile + close(mu) + endif + call release_unit(mu) + call broadcast_scalar(read_overflows_restfile, master_task) + else + ! use overflows_restfile from namelist + read_overflows_restfile = trim(overflows_restfile) + endif + +!----------------------------------------------------------------------- +! read overflows restart file +!----------------------------------------------------------------------- + + call get_unit(mu) + if (my_task == master_task) then + + open(mu, file=read_overflows_restfile, status='unknown',iostat=ovf_error) + + write(stdout,987) mu,read_overflows_restfile + 987 format(' ovf_read_restart unit (mu) = ',i5,' file name = ',a) + + read(mu,99) cdate_label,num_ovf + 99 format(a80/2x,i10) + write(stdout,100) cdate_label,num_ovf + 100 format(' ovf read restart label =',/a80/ & + ' number of overflows = ',i5) + call shr_sys_flush(stdout) + + do n=1,num_ovf + read(mu,101) ovf(n)%name + 101 format(2x,a26) + +! ovf parameters + read(mu,102) ovf(n)%ovf_params%lat + 102 format(2x,1PE27.18) + read(mu,103) ovf(n)%ovf_params%width + 103 format(2x,1PE27.18) + read(mu,105) ovf(n)%ovf_params%source_thick + 105 format(2x,1PE27.18) + read(mu,106) ovf(n)%ovf_params%distnc_str_ssb + 106 format(2x,1PE27.18) + read(mu,107) ovf(n)%ovf_params%bottom_slope + 107 format(2x,1PE27.18) + read(mu,108) ovf(n)%ovf_params%bottom_drag + 108 format(2x,1PE27.18) +! kmt changes, if any +! GFORTRAN Compiler complains about constants in read format + read(mu,1090) ovf(n)%num_kmt +1090 format(2x,i10) + do m=1,ovf(n)%num_kmt + read(mu,1090) ovf(n)%loc_kmt(m)%i + read(mu,1090) ovf(n)%loc_kmt(m)%j + read(mu,1090) ovf(n)%loc_kmt(m)%korg + read(mu,1090) ovf(n)%loc_kmt(m)%knew + end do + +! regional boundaries +! inflow + read(mu,110) ovf(n)%reg_inf%imin + 110 format(2x,i10,20x) + read(mu,111) ovf(n)%reg_inf%imax + 111 format(2x,i10,20x) + read(mu,112) ovf(n)%reg_inf%jmin + 112 format(2x,i10,20x) + read(mu,113) ovf(n)%reg_inf%jmax + 113 format(2x,i10,20x) + read(mu,114) ovf(n)%reg_inf%kmin + 114 format(2x,i10,20x) + read(mu,115) ovf(n)%reg_inf%kmax + 115 format(2x,i10,20x) +! source + read(mu,116) ovf(n)%reg_src%imin + 116 format(2x,i10,20x) + read(mu,117) ovf(n)%reg_src%imax + 117 format(2x,i10,20x) + read(mu,118) ovf(n)%reg_src%jmin + 118 format(2x,i10,20x) + read(mu,119) ovf(n)%reg_src%jmax + 119 format(2x,i10,20x) + read(mu,120) ovf(n)%reg_src%kmin + 120 format(2x,i10,20x) + read(mu,121) ovf(n)%reg_src%kmax + 121 format(2x,i10,20x) +! entrainment + read(mu,122) ovf(n)%reg_ent%imin + 122 format(2x,i10,20x) + read(mu,123) ovf(n)%reg_ent%imax + 123 format(2x,i10,20x) + read(mu,124) ovf(n)%reg_ent%jmin + 124 format(2x,i10,20x) + read(mu,125) ovf(n)%reg_ent%jmax + 125 format(2x,i10,20x) + read(mu,126) ovf(n)%reg_ent%kmin + 126 format(2x,i10,20x) + read(mu,127) ovf(n)%reg_ent%kmax + 127 format(2x,i10,20x) +! src locs and orientation + read(mu,128) ovf(n)%num_src + 128 format(2x,i10,20x) + do m=1,ovf(n)%num_src + read(mu,129) ovf(n)%loc_src(m)%i + 129 format(2x,i10,20x) + read(mu,130) ovf(n)%loc_src(m)%j + 130 format(2x,i10,20x) + read(mu,131) ovf(n)%loc_src(m)%i_adv + 131 format(2x,i10,20x) + read(mu,132) ovf(n)%loc_src(m)%j_adv + 132 format(2x,i10,20x) + read(mu,133) ovf(n)%loc_src(m)%i_u + 133 format(2x,i10,20x) + read(mu,134) ovf(n)%loc_src(m)%j_u + 134 format(2x,i10,20x) + read(mu,135) ovf(n)%loc_src(m)%k + 135 format(2x,i10,20x) + read(mu,136) ovf(n)%loc_src(m)%orient + 136 format(2x,i10,20x) + end do +! ent locs and orientation + read(mu,137) ovf(n)%num_ent + 137 format(2x,i10,20x) + do m=1,ovf(n)%num_ent + read(mu,138) ovf(n)%loc_ent(m)%i + 138 format(2x,i10,20x) + read(mu,139) ovf(n)%loc_ent(m)%j + 139 format(2x,i10,20x) + read(mu,140) ovf(n)%loc_ent(m)%i_adv + 140 format(2x,i10,20x) + read(mu,141) ovf(n)%loc_ent(m)%j_adv + 141 format(2x,i10,20x) + read(mu,142) ovf(n)%loc_ent(m)%i_u + 142 format(2x,i10,20x) + read(mu,143) ovf(n)%loc_ent(m)%j_u + 143 format(2x,i10,20x) + read(mu,144) ovf(n)%loc_ent(m)%k + 144 format(2x,i10,20x) + read(mu,145) ovf(n)%loc_ent(m)%orient + 145 format(2x,i10,20x) + end do +! prd locs and orientation + read(mu,146) ovf(n)%num_prd_sets + 146 format(2x,i10,20x) + do m=1,ovf(n)%num_prd_sets + read(mu,147) ovf(n)%num_prd(m) + 147 format(2x,i10,20x) + do mp=1,ovf(n)%num_prd(m) + read(mu,148) ovf(n)%loc_prd(m,mp)%i + 148 format(2x,i10,20x) + read(mu,149) ovf(n)%loc_prd(m,mp)%j + 149 format(2x,i10,20x) + read(mu,150) ovf(n)%loc_prd(m,mp)%i_adv + 150 format(2x,i10,20x) + read(mu,151) ovf(n)%loc_prd(m,mp)%j_adv + 151 format(2x,i10,20x) + read(mu,152) ovf(n)%loc_prd(m,mp)%i_u + 152 format(2x,i10,20x) + read(mu,153) ovf(n)%loc_prd(m,mp)%j_u + 153 format(2x,i10,20x) + read(mu,154) ovf(n)%loc_prd(m,mp)%k + 154 format(2x,i10,20x) + read(mu,155) ovf(n)%loc_prd(m,mp)%orient + 155 format(2x,i10,20x) + end do + end do +! adjacent boundaries +! src + read(mu,156) ovf(n)%adj_src%imin + 156 format(2x,i10,20x) + read(mu,157) ovf(n)%adj_src%imax + 157 format(2x,i10,20x) + read(mu,158) ovf(n)%adj_src%jmin + 158 format(2x,i10,20x) + read(mu,159) ovf(n)%adj_src%jmax + 159 format(2x,i10,20x) + read(mu,160) ovf(n)%adj_src%kmin + 160 format(2x,i10,20x) + read(mu,161) ovf(n)%adj_src%kmax + 161 format(2x,i10,20x) +!ent + read(mu,162) ovf(n)%adj_ent%imin + 162 format(2x,i10,20x) + read(mu,163) ovf(n)%adj_ent%imax + 163 format(2x,i10,20x) + read(mu,164) ovf(n)%adj_ent%jmin + 164 format(2x,i10,20x) + read(mu,165) ovf(n)%adj_ent%jmax + 165 format(2x,i10,20x) + read(mu,166) ovf(n)%adj_ent%kmin + 166 format(2x,i10,20x) + read(mu,167) ovf(n)%adj_ent%kmax + 167 format(2x,i10,20x) +!prd + do m=1,ovf(n)%num_prd_sets + read(mu,168) ovf(n)%adj_prd(m)%imin + 168 format(2x,i10,20x) + read(mu,169) ovf(n)%adj_prd(m)%imax + 169 format(2x,i10,20x) + read(mu,170) ovf(n)%adj_prd(m)%jmin + 170 format(2x,i10,20x) + read(mu,171) ovf(n)%adj_prd(m)%jmax + 171 format(2x,i10,20x) + read(mu,172) ovf(n)%adj_prd(m)%kmin + 172 format(2x,i10,20x) + read(mu,173) ovf(n)%adj_prd(m)%kmax + 173 format(2x,i10,20x) + end do +! transports + read(mu,174) ovf(n)%Ms + 174 format(2x,1PE27.18) + read(mu,175) ovf(n)%Ms_n + 175 format(2x,1PE27.18) + read(mu,176) ovf(n)%Ms_nm1 + 176 format(2x,1PE27.18) + read(mu,177) ovf(n)%Me + 177 format(2x,1PE27.18) + read(mu,178) ovf(n)%Me_n + 178 format(2x,1PE27.18) + read(mu,179) ovf(n)%Me_nm1 + 179 format(2x,1PE27.18) + read(mu,180) ovf(n)%phi + 180 format(2x,1PE27.18) + read(mu,181) ovf(n)%Mp + 181 format(2x,1PE27.18) + read(mu,182) ovf(n)%Mp_n + 182 format(2x,1PE27.18) + read(mu,183) ovf(n)%Mp_nm1 + 183 format(2x,1PE27.18) + read(mu,184) ovf(n)%Tp + 184 format(2x,1PE27.18) + read(mu,185) ovf(n)%Sp + 185 format(2x,1PE27.18) + read(mu,186) ovf(n)%prd_set_n + read(mu,186) ovf(n)%prd_set + 186 format(2x,i10,20x) + + end do ! ovf loop + + close(mu) + endif ! my_task == master_task + + call release_unit(mu) + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_read_restart + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_read_broadcast +! !INTERFACE: + + subroutine ovf_read_broadcast + +! !DESCRIPTION: +! This routine broadcasts selected data in ovf array from the +! master_task to all processors. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + save + + integer (int_kind) :: & + n, &! ovf loop index + m, &! sub-ovf loop index + nn, &! tracer loop index + mp, &! sub-ovf sub-loop index + k ! vertical loop index + +!----------------------------------------------------------------------- +! if overflows off, exit +!----------------------------------------------------------------------- + + if( .not. overflows_on ) return + +!----------------------------------------------------------------------- +! broadcast overflows info to all processors +!----------------------------------------------------------------------- + + call broadcast_scalar(num_ovf, master_task) + do n=1,num_ovf + call broadcast_scalar(ovf(n)%name, master_task) +! ovf data + call broadcast_scalar(ovf(n)%ovf_params%lat, master_task) + call broadcast_scalar(ovf(n)%ovf_params%width, master_task) + call broadcast_scalar(ovf(n)%ovf_params%source_thick, master_task) + call broadcast_scalar(ovf(n)%ovf_params%distnc_str_ssb, master_task) + call broadcast_scalar(ovf(n)%ovf_params%bottom_slope, master_task) + call broadcast_scalar(ovf(n)%ovf_params%bottom_drag, master_task) +! kmt changes, if any + call broadcast_scalar(ovf(n)%num_kmt, master_task) + do m=1,ovf(n)%num_kmt + call broadcast_scalar(ovf(n)%loc_kmt(m)%i, master_task) + call broadcast_scalar(ovf(n)%loc_kmt(m)%j, master_task) + call broadcast_scalar(ovf(n)%loc_kmt(m)%korg, master_task) + call broadcast_scalar(ovf(n)%loc_kmt(m)%knew, master_task) + end do +! regional boundaries +! inflow + call broadcast_scalar(ovf(n)%reg_inf%imin, master_task) + call broadcast_scalar(ovf(n)%reg_inf%imax, master_task) + call broadcast_scalar(ovf(n)%reg_inf%jmin, master_task) + call broadcast_scalar(ovf(n)%reg_inf%jmax, master_task) + call broadcast_scalar(ovf(n)%reg_inf%kmin, master_task) + call broadcast_scalar(ovf(n)%reg_inf%kmax, master_task) +! source + call broadcast_scalar(ovf(n)%reg_src%imin, master_task) + call broadcast_scalar(ovf(n)%reg_src%imax, master_task) + call broadcast_scalar(ovf(n)%reg_src%jmin, master_task) + call broadcast_scalar(ovf(n)%reg_src%jmax, master_task) + call broadcast_scalar(ovf(n)%reg_src%kmin, master_task) + call broadcast_scalar(ovf(n)%reg_src%kmax, master_task) +! entrainment + call broadcast_scalar(ovf(n)%reg_ent%imin, master_task) + call broadcast_scalar(ovf(n)%reg_ent%imax, master_task) + call broadcast_scalar(ovf(n)%reg_ent%jmin, master_task) + call broadcast_scalar(ovf(n)%reg_ent%jmax, master_task) + call broadcast_scalar(ovf(n)%reg_ent%kmin, master_task) + call broadcast_scalar(ovf(n)%reg_ent%kmax, master_task) +! src locs and orientation + call broadcast_scalar(ovf(n)%num_src, master_task) + do m=1,ovf(n)%num_src + call broadcast_scalar(ovf(n)%loc_src(m)%i, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%j, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%i_adv, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%j_adv, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%i_u, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%j_u, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%k, master_task) + call broadcast_scalar(ovf(n)%loc_src(m)%orient, master_task) + end do +! ent locs and orientation + call broadcast_scalar(ovf(n)%num_ent, master_task) + do m=1,ovf(n)%num_ent + call broadcast_scalar(ovf(n)%loc_ent(m)%i, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%j, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%i_adv, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%j_adv, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%i_u, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%j_u, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%k, master_task) + call broadcast_scalar(ovf(n)%loc_ent(m)%orient, master_task) + end do +! prd locs and orientation + call broadcast_scalar(ovf(n)%num_prd_sets, master_task) + do m=1,ovf(n)%num_prd_sets + call broadcast_scalar(ovf(n)%num_prd(m), master_task) + do mp=1,ovf(n)%num_prd(m) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%i, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%j, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%i_adv, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%j_adv, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%i_u, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%j_u, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%k, master_task) + call broadcast_scalar(ovf(n)%loc_prd(m,mp)%orient, master_task) + end do + end do +! adjacent boundaries + call broadcast_scalar(ovf(n)%adj_src%imin, master_task) + call broadcast_scalar(ovf(n)%adj_src%imax, master_task) + call broadcast_scalar(ovf(n)%adj_src%jmin, master_task) + call broadcast_scalar(ovf(n)%adj_src%jmax, master_task) + call broadcast_scalar(ovf(n)%adj_src%kmin, master_task) + call broadcast_scalar(ovf(n)%adj_src%kmax, master_task) + call broadcast_scalar(ovf(n)%adj_ent%imin, master_task) + call broadcast_scalar(ovf(n)%adj_ent%imax, master_task) + call broadcast_scalar(ovf(n)%adj_ent%jmin, master_task) + call broadcast_scalar(ovf(n)%adj_ent%jmax, master_task) + call broadcast_scalar(ovf(n)%adj_ent%kmin, master_task) + call broadcast_scalar(ovf(n)%adj_ent%kmax, master_task) + do m=1,ovf(n)%num_prd_sets + call broadcast_scalar(ovf(n)%adj_prd(m)%imin, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%imax, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%jmin, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%jmax, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%kmin, master_task) + call broadcast_scalar(ovf(n)%adj_prd(m)%kmax, master_task) + end do +! transports + call broadcast_scalar(ovf(n)%Ms, master_task) + call broadcast_scalar(ovf(n)%Ms_n, master_task) + call broadcast_scalar(ovf(n)%Ms_nm1, master_task) + call broadcast_scalar(ovf(n)%Me, master_task) + call broadcast_scalar(ovf(n)%Me_n, master_task) + call broadcast_scalar(ovf(n)%Me_nm1, master_task) + call broadcast_scalar(ovf(n)%phi, master_task) + call broadcast_scalar(ovf(n)%Mp, master_task) + call broadcast_scalar(ovf(n)%Mp_n, master_task) + call broadcast_scalar(ovf(n)%Mp_nm1, master_task) + call broadcast_scalar(ovf(n)%Tp, master_task) + call broadcast_scalar(ovf(n)%Sp, master_task) + call broadcast_scalar(ovf(n)%prd_set_n, master_task) + call broadcast_scalar(ovf(n)%prd_set, master_task) + do nn=1,nt + call broadcast_scalar(ovf(n)%trcr_reg%inf(nn), master_task) + call broadcast_scalar(ovf(n)%trcr_reg%src(nn), master_task) + call broadcast_scalar(ovf(n)%trcr_reg%ent(nn), master_task) + call broadcast_scalar(ovf(n)%trcr_reg%prd(nn), master_task) + call broadcast_scalar(ovf(n)%trcr_adj%src(nn), master_task) + call broadcast_scalar(ovf(n)%trcr_adj%ent(nn), master_task) + call broadcast_scalar(ovf(n)%trcr_adj%prd(nn), master_task) + end do + + end do ! ovf broadcast loop for all processors + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_read_broadcast + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_advt +! !INTERFACE: + + subroutine ovf_advt(k,TRACER_E,TRACER_N,ntr,this_block, & + CE,CW,CN,CS) + +! !DESCRIPTION: +! Modify tracer grid interface value for advection for +! overflow points; orientation determines if E or N is modified +! !REVISION HISTORY: +! same as module +! +! ovf t-grid box ij showing advection grid boxes +! (i_adv,j_adv) set by orientation +! ij+1 +! +! ____2_____ +! y ^ | | +! | | | +! | i-1j 3| ij |1 i+1j +! +-----> | | +! x |__________| +! 4 +! +! ij-1 +! +! Note! Orientations are relative to overflow ij, while +! the advection boxes are offset as in the diagram above. +! Thus, the indices for TRACER_E and TRACER_N are reversed. +! For instance, orient=1 src, the advection box is i+1,j +! above, but when ij is that box (see below), then it is the +! western TRACER_E, or i-1j, that is overwritten. This is +! reversed from the center ij, because of the offset in the +! advection boxes relative to box ij. +! +! Note! ij loops include ghost points incase advection +! scheme requires them. + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + integer (int_kind), intent(in) :: & + k ! vertical index + real (r8), dimension(nx_block,ny_block), intent(inout) :: & + TRACER_E, & ! east gridbox interface tracer at level k + TRACER_N ! north gridbox interface tracer at level k + integer (int_kind), intent(in) :: & + ntr ! tracer index + type (block), intent(in) :: & + this_block ! block information for this block + + real (r8), dimension(nx_block,ny_block), intent(in) :: & + CN,CS,CE,CW ! stencil weights based on flux velocities + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + n,m,mp,i,j, & ! dummy loop indices + ksrc,kent,kprd ! overflow level indices + + integer (int_kind) :: & + iblock ! local block address for this block + + logical (log_kind), parameter :: prnt = .false. + + integer (int_kind) :: ovf_id + + +! turn off print 3 Nov 2008 +! if( prnt .and. my_task == master_task ) then +! write(stdout,*) 'ovf_advt called ' +! call shr_sys_flush(stdout) +! endif + + iblock = this_block%local_id + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + !must have the groups initilaized + if (.not. ovf_groups%init) then + call ovf_init_groups() + end if + + +! for each of MY overflows + do n=1,ovf_groups%numMyGroups + ovf_id = ovf_groups%groupIds(n) +! src + do m=1,ovf(ovf_id)%num_src ! source + ksrc = ovf(ovf_id)%loc_src(m)%k + if( k == ksrc ) then + do j=1,ny_block + if( ovf(ovf_id)%loc_src(m)%j_adv .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(ovf_id)%loc_src(m)%i_adv .eq. this_block%i_glob(i) ) then + if( prnt ) then + write(stdout,5) nsteps_total,n,ovf(ovf_id)%loc_src(m)%i_adv, & + ovf(ovf_id)%loc_src(m)%j_adv,ovf(ovf_id)%loc_src(m)%k, & + ovf(ovf_id)%loc_src(m)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1) + 5 format(' In ovf_advt src ',i5,1x,6(i3,1x),4(1pe15.8,1x)) + endif ! print + if( i > 1 ) then + if( ovf(ovf_id)%loc_src(m)%orient .eq. 1 ) then + TRACER_E(i-1,j) = ovf(ovf_id)%trcr_reg%src(ntr) + endif + endif + if( j > 1 ) then + if( ovf(ovf_id)%loc_src(m)%orient .eq. 2 ) then + TRACER_N(i,j-1) = ovf(ovf_id)%trcr_reg%src(ntr) + endif + endif + if( ovf(ovf_id)%loc_src(m)%orient .eq. 3 ) then + TRACER_E(i,j) = ovf(ovf_id)%trcr_reg%src(ntr) + endif + if( ovf(ovf_id)%loc_src(m)%orient .eq. 4 ) then + TRACER_N(i,j) = ovf(ovf_id)%trcr_reg%src(ntr) + endif + if( prnt ) then + write(stdout,10) nsteps_total,n,ovf(ovf_id)%loc_src(m)%i_adv, & + ovf(ovf_id)%loc_src(m)%j_adv,ovf(ovf_id)%loc_src(m)%k, & + ovf(ovf_id)%loc_src(m)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1), & + nsteps_total,n,ovf(ovf_id)%loc_src(m)%i_adv, & + ovf(ovf_id)%loc_src(m)%j_adv,ovf(ovf_id)%loc_src(m)%k, & + ovf(ovf_id)%loc_src(m)%orient,ntr, & + CE(i,j)*dz(ksrc)*TAREA(i,j,iblock),CW(i,j)*dz(ksrc)*TAREA(i,j,iblock), & + CN(i,j)*dz(ksrc)*TAREA(i,j,iblock),CS(i,j)*dz(ksrc)*TAREA(i,j,iblock), & + nsteps_total,n,ovf(ovf_id)%loc_src(m)%i_adv, & + ovf(ovf_id)%loc_src(m)%j_adv,ovf(ovf_id)%loc_src(m)%k, & + ovf(ovf_id)%loc_src(m)%orient,ntr, & + CE(i,j)*dz(ksrc)*TAREA(i,j,iblock)*TRACER_E(i,j), & + CW(i,j)*dz(ksrc)*TAREA(i,j,iblock)*TRACER_E(i-1,j) + 10 format(' Out ovf_advt src ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out ovf_advt src M ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out ovf_advt src CT',i5,1x,6(i3,1x),2(1pe15.8,1x)) + endif ! print + endif + end do ! i + endif + end do ! j + endif ! k + end do ! source +! ent + do m=1,ovf(ovf_id)%num_ent ! entrainment + kent = ovf(ovf_id)%loc_ent(m)%k + if( k == kent ) then + do j=1,ny_block + if( ovf(ovf_id)%loc_ent(m)%j_adv .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(ovf_id)%loc_ent(m)%i_adv .eq. this_block%i_glob(i) ) then + if( prnt ) then + write(stdout,15) nsteps_total,n,ovf(ovf_id)%loc_ent(m)%i_adv, & + ovf(ovf_id)%loc_ent(m)%j_adv,ovf(ovf_id)%loc_ent(m)%k, & + ovf(ovf_id)%loc_ent(m)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1) + 15 format(' In ovf_advt ent ',i5,1x,6(i3,1x),4(1pe15.8,1x)) + endif ! print + if( i > 1 ) then + if( ovf(ovf_id)%loc_ent(m)%orient .eq. 1 ) then + TRACER_E(i-1,j) = ovf(ovf_id)%trcr_reg%ent(ntr) + endif + endif + if( j > 1 ) then + if( ovf(ovf_id)%loc_ent(m)%orient .eq. 2 ) then + TRACER_N(i,j-1) = ovf(ovf_id)%trcr_reg%ent(ntr) + endif + endif + if( ovf(ovf_id)%loc_ent(m)%orient .eq. 3 ) then + TRACER_E(i,j) = ovf(ovf_id)%trcr_reg%ent(ntr) + endif + if( ovf(ovf_id)%loc_ent(m)%orient .eq. 4 ) then + TRACER_N(i,j) = ovf(ovf_id)%trcr_reg%ent(ntr) + endif + if( prnt ) then + write(stdout,20) nsteps_total,n,ovf(ovf_id)%loc_ent(m)%i_adv, & + ovf(ovf_id)%loc_ent(m)%j_adv,ovf(ovf_id)%loc_ent(m)%k, & + ovf(ovf_id)%loc_ent(m)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1), & + nsteps_total,n,ovf(ovf_id)%loc_ent(m)%i_adv, & + ovf(ovf_id)%loc_ent(m)%j_adv,ovf(ovf_id)%loc_ent(m)%k, & + ovf(ovf_id)%loc_ent(m)%orient,ntr, & + CE(i,j)*dz(kent)*TAREA(i,j,iblock),CW(i,j)*dz(kent)*TAREA(i,j,iblock), & + CN(i,j)*dz(kent)*TAREA(i,j,iblock),CS(i,j)*dz(kent)*TAREA(i,j,iblock), & + nsteps_total,n,ovf(ovf_id)%loc_ent(m)%i_adv, & + ovf(ovf_id)%loc_ent(m)%j_adv,ovf(ovf_id)%loc_ent(m)%k, & + ovf(ovf_id)%loc_ent(m)%orient,ntr, & + CE(i,j)*dz(kent)*TAREA(i,j,iblock)*TRACER_E(i,j), & + CW(i,j)*dz(kent)*TAREA(i,j,iblock)*TRACER_E(i-1,j) + 20 format(' Out ovf_advt ent ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out ovf_advt ent M ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out ovf_advt ent CT',i5,1x,6(i3,1x),2(1pe15.8,1x)) + endif ! print + endif + end do ! i + endif + end do ! j + endif ! k + end do ! entrainment +! prd + m = ovf(ovf_id)%prd_set ! product set for insertion + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for insertion + kprd = ovf(ovf_id)%loc_prd(m,mp)%k + if( k == kprd ) then + do j=1,ny_block + if( ovf(ovf_id)%loc_prd(m,mp)%j_adv .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(ovf_id)%loc_prd(m,mp)%i_adv .eq. this_block%i_glob(i) ) then + if( prnt ) then + write(stdout,25) nsteps_total,n,ovf(ovf_id)%loc_prd(m,mp)%i_adv, & + ovf(ovf_id)%loc_prd(m,mp)%j_adv,ovf(ovf_id)%loc_prd(m,mp)%k, & + ovf(ovf_id)%loc_prd(m,mp)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1) + 25 format(' In ovf_advt prd ',i5,1x,6(i3,1x),4(1pe15.8,1x)) + endif ! print + if( i > 1 ) then + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 1 ) then + TRACER_E(i-1,j) = ovf(ovf_id)%trcr_reg%prd(ntr) + endif + endif + if( j > 1 ) then + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 2 ) then + TRACER_N(i,j-1) = ovf(ovf_id)%trcr_reg%prd(ntr) + endif + endif + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 3 ) then + TRACER_E(i,j) = ovf(ovf_id)%trcr_reg%prd(ntr) + endif + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 4 ) then + TRACER_N(i,j) = ovf(ovf_id)%trcr_reg%prd(ntr) + endif + if( prnt ) then + write(stdout,35) nsteps_total,n,ovf(ovf_id)%loc_prd(m,mp)%i_adv, & + ovf(ovf_id)%loc_prd(m,mp)%j_adv,ovf(ovf_id)%loc_prd(m,mp)%k, & + ovf(ovf_id)%loc_prd(m,mp)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1), & + nsteps_total,n,ovf(ovf_id)%loc_prd(m,mp)%i_adv, & + ovf(ovf_id)%loc_prd(m,mp)%j_adv,ovf(ovf_id)%loc_prd(m,mp)%k, & + ovf(ovf_id)%loc_prd(m,mp)%orient,ntr, & + CE(i,j)*dz(kprd)*TAREA(i,j,iblock),CW(i,j)*dz(kprd)*TAREA(i,j,iblock), & + CN(i,j)*dz(kprd)*TAREA(i,j,iblock),CS(i,j)*dz(kprd)*TAREA(i,j,iblock), & + nsteps_total,n,ovf(ovf_id)%loc_prd(m,mp)%i_adv, & + ovf(ovf_id)%loc_prd(m,mp)%j_adv,ovf(ovf_id)%loc_prd(m,mp)%k, & + ovf(ovf_id)%loc_prd(m,mp)%orient,ntr, & + CE(i,j)*dz(kprd)*TAREA(i,j,iblock)*TRACER_E(i,j), & + CW(i,j)*dz(kprd)*TAREA(i,j,iblock)*TRACER_E(i-1,j) + 35 format(' Out ovf_advt prd ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out ovf_advt prd M ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out ovf_advt prd CT',i5,1x,6(i3,1x),2(1pe15.8,1x)) + endif ! print + endif + end do ! i + endif + end do ! j + endif ! k + end do ! product points for insertion set +! If prd set just moved and time averaging done previous time step + if( ovf(ovf_id)%prd_set .ne. ovf(ovf_id)%prd_set_n ) then + m = ovf(ovf_id)%prd_set_n ! product set for insertion + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for insertion + kprd = ovf(ovf_id)%loc_prd(m,mp)%k + if( k == kprd ) then + do j=1,ny_block + if( ovf(ovf_id)%loc_prd(m,mp)%j_adv .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(ovf_id)%loc_prd(m,mp)%i_adv .eq. this_block%i_glob(i) ) then + if( prnt ) then + write(stdout,26) nsteps_total,n,ovf(ovf_id)%loc_prd(m,mp)%i_adv, & + ovf(ovf_id)%loc_prd(m,mp)%j_adv,ovf(ovf_id)%loc_prd(m,mp)%k, & + ovf(ovf_id)%loc_prd(m,mp)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1) + 26 format(' In_n ovf_advt prd ',i5,1x,6(i3,1x),4(1pe15.8,1x)) + endif ! print + if( avg_ts_last ) then + if( i > 1 ) then + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 1 ) then + TRACER_E(i-1,j) = ovf(ovf_id)%trcr_reg%prd(ntr) + endif + endif + if( j > 1 ) then + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 2 ) then + TRACER_N(i,j-1) = ovf(ovf_id)%trcr_reg%prd(ntr) + endif + endif + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 3 ) then + TRACER_E(i,j) = ovf(ovf_id)%trcr_reg%prd(ntr) + endif + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 4 ) then + TRACER_N(i,j) = ovf(ovf_id)%trcr_reg%prd(ntr) + endif + endif + if( prnt ) then + write(stdout,36) nsteps_total,n,ovf(ovf_id)%loc_prd(m,mp)%i_adv, & + ovf(ovf_id)%loc_prd(m,mp)%j_adv,ovf(ovf_id)%loc_prd(m,mp)%k, & + ovf(ovf_id)%loc_prd(m,mp)%orient,ntr, & + TRACER_E(i,j),TRACER_E(i-1,j),TRACER_N(i,j),TRACER_N(i,j-1), & + nsteps_total,n,ovf(ovf_id)%loc_prd(m,mp)%i_adv, & + ovf(ovf_id)%loc_prd(m,mp)%j_adv,ovf(ovf_id)%loc_prd(m,mp)%k, & + ovf(ovf_id)%loc_prd(m,mp)%orient,ntr, & + CE(i,j)*dz(kprd)*TAREA(i,j,iblock),CW(i,j)*dz(kprd)*TAREA(i,j,iblock), & + CN(i,j)*dz(kprd)*TAREA(i,j,iblock),CS(i,j)*dz(kprd)*TAREA(i,j,iblock), & + nsteps_total,n,ovf(ovf_id)%loc_prd(m,mp)%i_adv, & + ovf(ovf_id)%loc_prd(m,mp)%j_adv,ovf(ovf_id)%loc_prd(m,mp)%k, & + ovf(ovf_id)%loc_prd(m,mp)%orient,ntr, & + CE(i,j)*dz(kprd)*TAREA(i,j,iblock)*TRACER_E(i,j), & + CW(i,j)*dz(kprd)*TAREA(i,j,iblock)*TRACER_E(i-1,j) + 36 format(' Out_n ovf_advt prd ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out_n ovf_advt prd M ',i5,1x,6(i3,1x),4(1pe15.8,1x)/ & + ' Out_n ovf_advt prd CT',i5,1x,6(i3,1x),2(1pe15.8,1x)) + endif ! print + endif + end do ! i + endif + end do ! j + endif ! k + end do ! product points for insertion set + endif + end do ! each overflow +! special diagnostic 11 nov 2008 + call ovf_UV_check + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_advt + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_wtkb_check +! !INTERFACE: + + subroutine ovf_wtkb_check(k,WTKB,this_block) + +! !DESCRIPTION: +! Print out wtkb for overflow gridboxes +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + integer (int_kind), intent(in) :: & + k ! vertical index + real (r8), dimension(nx_block,ny_block,nblocks_clinic), intent(in) :: & + WTKB ! WTKB = W at bottom of t-grid box + type (block), intent(in) :: & + this_block ! block information for this block + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + n,m,mp,i,j, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + iblock ! local block address for this block + logical (log_kind), parameter :: prnt = .false. + + integer (int_kind) ::ovf_id + + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_wtkb_check called ' + call shr_sys_flush(stdout) + endif + + iblock = this_block%local_id + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + !must have the groups initilaized + if (.not. ovf_groups%init) then + call ovf_init_groups() + end if + + +! for each of MY overflows + do n=1,ovf_groups%numMyGroups + ovf_id = ovf_groups%groupIds(n) + +! ovf ij +! src + do m=1,ovf(ovf_id)%num_src ! source + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_src(m)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_src(m)%i .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,10) n,nsteps_total,ovf(ovf_id)%loc_src(m)%i, & + ovf(ovf_id)%loc_src(m)%j,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 10 format(' ovf_wtkb_ch n=',i3, & + ' src t,i,j,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif + endif + end do ! i + endif + end do ! j + end do ! source +! ent + do m=1,ovf(ovf_id)%num_ent ! entrainment + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_ent(m)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_ent(m)%i .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,20) n,nsteps_total,ovf(ovf_id)%loc_ent(m)%i, & + ovf(ovf_id)%loc_ent(m)%j,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 20 format(' ovf_wtkb_ch n=',i3, & + ' ent t,i,j,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif + endif + end do ! i + endif + end do ! j + end do ! entrainment +! prd + m = ovf(ovf_id)%prd_set ! product set for insertion + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for insertion + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,30) n,nsteps_total,ovf(ovf_id)%loc_prd(m,mp)%i, & + ovf(ovf_id)%loc_prd(m,mp)%j,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 30 format(' ovf_wtkb_ch n=',i3, & + ' prd t,i,j,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif + endif + end do ! i + endif + end do ! j + end do ! product points for insertion set +! prd + do m=1,ovf(ovf_id)%num_prd_sets + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for insertion + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,31) n,nsteps_total,ovf(ovf_id)%loc_prd(m,mp)%i, & + ovf(ovf_id)%loc_prd(m,mp)%j,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 31 format(' ovf_wtkb_ch n=',i3, & + ' all prd t,i,j,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif + endif + end do ! i + endif + end do ! j + end do ! product points for insertion set + end do ! product sets +! ovf i_adv j_adv +! src + do m=1,ovf(ovf_id)%num_src ! source + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_src(m)%j_adv .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_src(m)%i_adv .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,40) n,nsteps_total,ovf(ovf_id)%loc_src(m)%i_adv, & + ovf(ovf_id)%loc_src(m)%j_adv,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 40 format(' ovf_wtkb_ch n=',i3, & + ' src t,i_adv,j_adv,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif ! k + endif + end do ! i + endif + end do ! j + end do ! source +! ent + do m=1,ovf(ovf_id)%num_ent ! entrainment + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_ent(m)%j_adv .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_ent(m)%i_adv .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,50) n,nsteps_total,ovf(ovf_id)%loc_ent(m)%i_adv, & + ovf(ovf_id)%loc_ent(m)%j_adv,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 50 format(' ovf_wtkb_ch n=',i3, & + ' ent t,i_adv,j_adv,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif ! k + endif + end do ! i + endif + end do ! j + end do ! entrainment +! prd + m = ovf(ovf_id)%prd_set ! product set for insertion + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for insertion + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j_adv .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i_adv .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,60) n,nsteps_total,ovf(ovf_id)%loc_prd(m,mp)%i_adv, & + ovf(ovf_id)%loc_prd(m,mp)%j_adv,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 60 format(' ovf_wtkb_ch n=',i3, & + ' prd t,i_adv,j_adv,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif ! k + endif + end do ! i + endif + end do ! j + end do ! product points for insertion set +! prd + do m=1,ovf(ovf_id)%num_prd_sets + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for insertion if moved + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j_adv .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i_adv .eq. this_block%i_glob(i) ) then + if( k == KMT(i,j,iblock) ) then + if( prnt ) then + write(stdout,61) n,nsteps_total,ovf(ovf_id)%loc_prd(m,mp)%i_adv, & + ovf(ovf_id)%loc_prd(m,mp)%j_adv,k,WTKB(i,j,iblock),TAREA(i,j,iblock)*WTKB(i,j,iblock) + 61 format(' ovf_wtkb_ch n=',i3, & + ' all prd t,i_adv,j_adv,k wtkb wtkb*tarea=',4(i4,1x),2(1pe12.5,2x)) + endif ! print + endif ! k + endif + end do ! i + endif + end do ! j + end do ! product points for insertion set + end do ! original product set if moved + end do ! each overflow + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_wtkb_check + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_UV_check +! !INTERFACE: + + subroutine ovf_UV_check + +! !DESCRIPTION: +! Print out column UVEL, VVEL for overflow gridboxes +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + n,m,mp,i,j,k, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + iblock, & ! local block address for this block + ksrc,kent,kprd ! overflow level indices + type (block) :: & + this_block ! block information for this block + logical (log_kind), parameter :: prnt = .false. + + integer (int_kind) :: ovf_id + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_UV_check called ' + call shr_sys_flush(stdout) + endif + + if( prnt ) then + write(stdout,5) nsteps_total + 5 format(' ovf_UV_check called at nsteps_total=',i6) +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + !must have the groups initilaized + if (.not. ovf_groups%init) then + call ovf_init_groups() + end if + + +! for each of MY overflows + do n=1,ovf_groups%numMyGroups + ovf_id = ovf_groups%groupIds(n) +! src + do m=1,ovf(ovf_id)%num_src ! source + ksrc = ovf(ovf_id)%loc_src(m)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + write(stdout,15) n,ovf(ovf_id)%loc_src(m)%i_u, & + ovf(ovf_id)%loc_src(m)%j_u + 15 format(' ovf_UV_check n=',i2,' src i_u j_u = ',2(i3,1x)) +! do k=1,ksrc + k=ksrc +! write(stdout,10) k,UVEL(i,j,k,oldtime,iblock), & +! UVEL(i,j,k,curtime,iblock),UVEL(i,j,k,newtime,iblock), & +! VVEL(i,j,k,oldtime,iblock), & +! VVEL(i,j,k,curtime,iblock),VVEL(i,j,k,newtime,iblock) + 10 format(' k old cur new UVEL= ',i2,1x,3(f9.5,1x), & + ' VVEL=',3(f9.5,1x)) +! end do ! k + endif + end do ! i + endif + end do ! j + enddo ! block + end do ! source +! ent + do m=1,ovf(ovf_id)%num_ent ! entrainment + kent = ovf(ovf_id)%loc_ent(m)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + write(stdout,25) n,ovf(ovf_id)%loc_ent(m)%i_u, & + ovf(ovf_id)%loc_ent(m)%j_u + 25 format(' ovf_UV_check n=',i2,' ent i_u j_u = ',2(i3,1x)) +! do k=1,kent + k=kent +! write(stdout,20) k,UVEL(i,j,k,oldtime,iblock), & +! UVEL(i,j,k,curtime,iblock),UVEL(i,j,k,newtime,iblock), & +! VVEL(i,j,k,oldtime,iblock), & +! VVEL(i,j,k,curtime,iblock),VVEL(i,j,k,newtime,iblock) + 20 format(' k old cur new UVEL= ',i2,1x,3(f9.5,1x), & + ' VVEL=',3(f9.5,1x)) +! end do ! k + endif + end do ! i + endif + end do ! j + enddo ! block + end do ! entrainment +! prd + do m=1,ovf(ovf_id)%num_prd_sets + do mp=1,ovf(ovf_id)%num_prd(m) + kprd = ovf(ovf_id)%loc_prd(m,mp)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + write(stdout,35) n,ovf(ovf_id)%loc_prd(m,mp)%i_u, & + ovf(ovf_id)%loc_prd(m,mp)%j_u + 35 format(' ovf_UV_check n=',i2,' prd i_u j_u = ',2(i3,1x)) +! do k=1,kprd + k=kprd + write(stdout,30) nsteps_total,n, & + ovf(ovf_id)%loc_prd(m,mp)%i_u,ovf(ovf_id)%loc_prd(m,mp)%j_u, & + k,UVEL(i,j,k,oldtime,iblock), & + UVEL(i,j,k,curtime,iblock),UVEL(i,j,k,newtime,iblock) + 30 format(' prd t,n,i,j,k old cur new UVEL= ',5(i4,1x),1x,3(f9.5,1x)) +! end do ! k + endif + end do ! i + endif + end do ! j + enddo ! block + end do ! product + end do + end do ! each overflow + endif ! print +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_UV_check + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_Utlda +! !INTERFACE: + + subroutine ovf_Utlda(iblock) + +! !DESCRIPTION: +! Save ovf sidewall unnormalized baroclinic velocities Utlda. Must be +! called AFTER the baroclinic solution Utlda is found but BEFORE the +! baroclinic velocities are normalized (i.e. vertical integral of +! baroclinic velocity from surface to bottom topography is zero). +! +! ij t-grid i_u,j_u u-grid +! +! assignment of U on u-grid +! orientation=1 i_u = i j_u = j +! =2 i_u = i-1 j_u = j +! =3 i_u = i-1 j_u = j-1 +! =4 i_u = i j_u = j-1 +! +! ovf t-grid box ij with u-grid +! corners and orientations +! 2 (i_u,j_u) +! i-1j __________ij +! y ^ | | +! | | | +! | 3 | ij | 1 +! +-----> | | +! x |__________| +! i-1j-1 ij-1 +! 4 +! for example, for ovf grid box ij, +! with product orientation 4, the Utlda +! in the above diagram would be ij-1 +! lower right corner +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + integer (int_kind), & + intent(in) :: & + iblock ! block index + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + i,j,k,n,m,mp, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + ksrc,kent,kprd ! overflow level indices + type (block) :: & + this_block ! block information for current block + logical (log_kind), parameter :: prnt = .false. + + integer (int_kind) :: ovf_id + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_Utlda called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- +!must have the groups initilaized + if (.not. ovf_groups%init) then + call ovf_init_groups() + end if + + +! for each of MY overflows + do n=1,ovf_groups%numMyGroups + ovf_id = ovf_groups%groupIds(n) +! src + do m=1,ovf(ovf_id)%num_src ! source + ksrc = ovf(ovf_id)%loc_src(m)%k + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + do k=1,ksrc-1 + ovf(ovf_id)%loc_src(m)%Utlda(k) = UVEL(i,j,k,newtime,iblock) + ovf(ovf_id)%loc_src(m)%Vtlda(k) = VVEL(i,j,k,newtime,iblock) + enddo + if(prnt) then + write(stdout,10) n,ovf(ovf_id)%loc_src(m)%i_u, & + ovf(ovf_id)%loc_src(m)%j_u, & + ovf(ovf_id)%loc_src(m)%orient,ksrc + 10 format(' ovf_Utlda n=',i3, & + ' src i_u j_u orient k=',4(i4,1x)) + do k=1,ksrc-1 + write(stdout,15) k,ovf(ovf_id)%loc_src(m)%Utlda(k), & + ovf(ovf_id)%loc_src(m)%Vtlda(k) + 15 format(' k=',i3,1x,'Utlda Vtlda= ',2(f9.5,2x)) + enddo + endif + endif + end do ! i + endif + end do ! j + end do ! source +! ent + do m=1,ovf(ovf_id)%num_ent ! entrainment + kent = ovf(ovf_id)%loc_ent(m)%k + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + do k=1,kent-1 + ovf(ovf_id)%loc_ent(m)%Utlda(k) = UVEL(i,j,k,newtime,iblock) + ovf(ovf_id)%loc_ent(m)%Vtlda(k) = VVEL(i,j,k,newtime,iblock) + enddo + if(prnt) then + write(stdout,20) n,ovf(ovf_id)%loc_ent(m)%i_u, & + ovf(ovf_id)%loc_ent(m)%j_u, & + ovf(ovf_id)%loc_ent(m)%orient,kent + 20 format(' ovf_Utlda n=',i3, & + ' ent i_u j_u orient k=',4(i4,1x)) + do k=1,kent-1 + write(stdout,25) k,ovf(ovf_id)%loc_ent(m)%Utlda(k), & + ovf(ovf_id)%loc_ent(m)%Vtlda(k) + 25 format(' k=',i3,1x,'Utlda Vtlda= ',2(f9.5,2x)) + enddo + endif + endif + end do ! i + endif + end do ! j + end do ! entrainment +! prd + do m=1,ovf(ovf_id)%num_prd_sets + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for each set + kprd = ovf(ovf_id)%loc_prd(m,mp)%k + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + do k=1,kprd-1 + ovf(ovf_id)%loc_prd(m,mp)%Utlda(k) = UVEL(i,j,k,newtime,iblock) + ovf(ovf_id)%loc_prd(m,mp)%Vtlda(k) = VVEL(i,j,k,newtime,iblock) + enddo + if(prnt) then + write(stdout,30) n,ovf(ovf_id)%loc_prd(m,mp)%i_u, & + ovf(ovf_id)%loc_prd(m,mp)%j_u, & + ovf(ovf_id)%loc_prd(m,mp)%orient,kprd + 30 format(' ovf_Utlda n=',i3, & + ' prd i_u j_u orient k=',4(i4,1x)) + do k=1,kprd-1 + write(stdout,35) k,ovf(ovf_id)%loc_prd(m,mp)%Utlda(k), & + ovf(ovf_id)%loc_prd(m,mp)%Vtlda(k) + 35 format(' k=',i3,1x,'Utlda Vtlda= ',2(f9.5,2x)) + enddo + endif + endif + end do ! i + endif + end do ! j + end do ! product points for each set + end do ! product sets + end do ! each overflow + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_Utlda + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_driver +! !INTERFACE: + + subroutine ovf_driver + +! !DESCRIPTION: +! This routine is the main overflow (ovf) driver, called +! in step_mod.F90 between baroclinic and barotropic drivers. +! It calls routines to compute ovf regional means, transports, +! product locations and sidewall velocity evaluation. +! +! !REVISION HISTORY: +! same as module + + logical (log_kind), parameter :: prnt = .false. + +!EOP +!BOC + + if(prnt) then + write(stdout,*) ' ovf_driver entered ' + call shr_sys_flush(stdout) + endif + + + call timer_start(timer_ovf) + +!---------------------------------------------------------------------- +! +! ovf regional averages +! +!---------------------------------------------------------------------- + + call ovf_reg_avgs(curtime) + +!---------------------------------------------------------------------- +! +! ovf transports +! +!---------------------------------------------------------------------- + + call ovf_transports + +!---------------------------------------------------------------------- +! +! ovf location of product +! +!---------------------------------------------------------------------- + + call ovf_loc_prd + +!---------------------------------------------------------------------- +! +! ovf top W evaluation +! +!---------------------------------------------------------------------- + + call ovf_W + +!---------------------------------------------------------------------- +! +! ovf sidewall UV evaluation +! +!---------------------------------------------------------------------- + + call ovf_UV + +!---------------------------------------------------------------------- +!EOC + + + call timer_stop(timer_ovf) + + + end subroutine ovf_driver + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_reg_avgs +! !INTERFACE: + + + + subroutine ovf_reg_avgs(time_level) + +! !DESCRIPTION: +! Evaluate the ovf regional averages + +! note: this is called initially outside of the ovf_driver + +! +! !REVISION HISTORY: +! same as module + +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + integer (int_kind) :: &! time indices for prognostic arrays + time_level ! current time level (n) + +!---------------------------------------------------------------------- +! +! local variables +! +!---------------------------------------------------------------------- + + integer (int_kind) :: & + iblock,k,n,nn,m ! dummy loop indices + + + type (block) :: & + this_block ! block information for current block + + real (r8), dimension(nx_block,ny_block,max_blocks_clinic) :: & + WRK ! temp work array + real (r8) vsum_reg_wght, & ! vertical sum regional weight + vsum_adj_wght ! vertical sum adjacent weight + + logical (log_kind), parameter :: prnt = .false. + + logical (log_kind) :: post + logical (log_kind), dimension(:), allocatable :: post_array + integer (int_kind) :: num_posts, ierr, count, loc, ovf_id, i + integer (int_kind), parameter :: len = 15 !length of buffer for a post + real (r8), dimension(:), allocatable:: myRecvBuff(:), mySendBuff(:) + + +!EOP +!BOC + + if(prnt) then + write(stdout,*) ' ovf_reg_avgs called ' + call shr_sys_flush(stdout) + endif + + !must have the groups initialized + if (.not. ovf_groups%init) then + call ovf_init_groups() + endif + + + !compute the averages + call ovf_utils_avgs(time_level) + + if (prnt) then + + if( my_task == master_task ) then + !for any ovf groups that the master_task is not in, + !must post recv for the info + allocate(post_array(num_ovf)) + num_posts = num_ovf - ovf_groups%numMyGroups + if (num_posts > 0) then + allocate(myRecvBuff(len*num_posts)) + endif + + call ovf_print_init(len, num_posts, myRecvBuff, post_array) + + count = 0 + do n=1,num_ovf + if (post_array(n)) then !we posted a recv for this + count = count+1 + call ovf_print_get(count) + loc = (count-1)*len+1 + !unpack + ovf(n)%trcr_reg%inf(1) = myRecvBuff(loc) + ovf(n)%trcr_reg%inf(2) = myRecvBuff(loc+1) + ovf(n)%rho_reg%inf = myRecvBuff(loc+2) + ovf(n)%trcr_reg%src(1) = myRecvBuff(loc+3) + ovf(n)%trcr_reg%src(2) = myRecvBuff(loc+4) + ovf(n)%rho_reg%src = myRecvBuff(loc+5) + ovf(n)%trcr_reg%ent(1) = myRecvBuff(loc+6) + ovf(n)%trcr_reg%ent(2) = myRecvBuff(loc+7) + ovf(n)%rho_reg%ent = myRecvBuff(loc+8) + + ovf(n)%trcr_adj%src(1) = myRecvBuff(loc+9) + ovf(n)%trcr_adj%src(2) = myRecvBuff(loc+10) + ovf(n)%trcr_adj%ent(1) = myRecvBuff(loc+11) + ovf(n)%trcr_adj%ent(2) = myRecvBuff(loc+12) + ovf(n)%rho_adj%prd(1) = myRecvBuff(loc+13) + ovf(n)%rho_adj%prd(2) = myRecvBuff(loc+14) + endif + + write(stdout,10) n,ovf(n)%trcr_reg%inf(1), & + (ovf(n)%trcr_reg%inf(2))*c1000,(ovf(n)%rho_reg%inf-c1)*c1000, & + ovf(n)%trcr_reg%src(1), & + (ovf(n)%trcr_reg%src(2))*c1000,(ovf(n)%rho_reg%src-c1)*c1000, & + ovf(n)%trcr_reg%ent(1), & + (ovf(n)%trcr_reg%ent(2))*c1000,(ovf(n)%rho_reg%ent-c1)*c1000 + 10 format(1x,'ovf reg',i3,1x,3(f6.3,1x),3(f6.3,1x),3(f6.3,1x)) + if( n.eq.1 ) then + write(stdout,11) n,ovf(n)%trcr_adj%src(1), & + (ovf(n)%trcr_adj%src(2))*c1000, & + ovf(n)%trcr_adj%ent(1), & + (ovf(n)%trcr_adj%ent(2))*c1000, & + (ovf(n)%rho_adj%prd(1)-c1)*c1000 + 11 format(1x,'ovf adj',i3,1x,2(f6.3,1x),1x,2(f6.3,1x),f6.3) + else + write(stdout,12) n,ovf(n)%trcr_adj%src(1), & + (ovf(n)%trcr_adj%src(2))*c1000, & + ovf(n)%trcr_adj%ent(1), & + (ovf(n)%trcr_adj%ent(2))*c1000, & + (ovf(n)%rho_adj%prd(1)-c1)*c1000, & + (ovf(n)%rho_adj%prd(2)-c1)*c1000 + 12 format(1x,'ovf adj',i3,1x,2(f6.3,1x),1x,2(f6.3,1x), & + f6.3,1x,f6.3) + endif + end do + + !clean up master + deallocate(post_array) + if (num_posts > 0) then + deallocate(myRecvBuff) + endif + call ovf_print_finalize(num_posts) + + else !not master - send info to master if I am group master + num_posts = 0 + do n=1, ovf_groups%numMyGroups + if (ovf_groups%amMaster(n)) then + num_posts = num_posts + 1 + end if + end do + + call ovf_print_init(len, num_posts) + + if (num_posts > 0) then + allocate(mySendBuff(num_posts * len)) + end if + + num_posts = 0 + do n=1, ovf_groups%numMyGroups + if (ovf_groups%amMaster(n)) then + ovf_id = ovf_groups%groupIds(n) + !send transport info to the master task with isend + num_posts = num_posts + 1 + loc = (num_posts-1)*len+1 + !pack send buffer + mySendBuff(loc) = ovf(ovf_id)%trcr_reg%inf(1) + mySendBuff(loc+1) = ovf(ovf_id)%trcr_reg%inf(2) + mySendBuff(loc+2) = ovf(ovf_id)%rho_reg%inf + mySendBuff(loc+3) = ovf(ovf_id)%trcr_reg%src(1) + mySendBuff(loc+4) = ovf(ovf_id)%trcr_reg%src(2) + mySendBuff(loc+5) = ovf(ovf_id)%rho_reg%src + mySendBuff(loc+6) = ovf(ovf_id)%trcr_reg%ent(1) + mySendBuff(loc+7) = ovf(ovf_id)%trcr_reg%ent(2) + mySendBuff(loc+8) = ovf(ovf_id)%rho_reg%ent + + mySendBuff(loc+9) = ovf(ovf_id)%trcr_adj%src(1) + mySendBuff(loc+10) = ovf(ovf_id)%trcr_adj%src(2) + mySendBuff(loc+11) = ovf(ovf_id)%trcr_adj%ent(1) + mySendBuff(loc+12) = ovf(ovf_id)%trcr_adj%ent(2) + mySendBuff(loc+13) = ovf(ovf_id)%rho_adj%prd(1) + mySendBuff(loc+14) = ovf(ovf_id)%rho_adj%prd(2) + + call ovf_print_send(len, mySendBuff(loc:loc+len-1), num_posts, ovf_id) + + endif + end do !n loop + + !now clean up + call ovf_print_finalize(num_posts) + if (num_posts > 0) then + deallocate(mySendBuff) + endif + + endif !end not master + endif ! prnt loop + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_reg_avgs + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_transports +! !INTERFACE: + + subroutine ovf_transports + +! !DESCRIPTION: +! Evaluate the ovf transports. For each overflow, set overflow parameters +! and evaluate transports. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + save + + integer (int_kind) :: & + n ,& ! ovf loop index + nn ,& ! ovf tracer index + m ,& ! product level + k_p ! product k level +! + real (r8) :: & + lat ,& ! inflow/source latitude for coriolis parameter (degrees) + fs ! coriolis parameter (/s) +! + real (r8) :: & + hu ,& ! upstream source thickness (cm) + hs ,& ! source water vertical thickness (cm) + Ws ,& ! source water width (cm) + xse ,& ! distance from source to entrainment (cm) + di ,& ! depth of inflow (cm) + ds ,& ! depth of source (cm) + de ,& ! depth of entrainment (cm) + dp ,& ! depth of product (cm) + alpha ,& ! continental slope between source to entrainment + cd ! bottom drag coefficient for spreading, entrained flow +! + real (r8) :: & + T_i ,& ! inflow mean temperature (C) + S_i ,& ! inflow mean salinity + T_s ,& ! source mean temperature (C) + S_s ,& ! source mean salinity + T_e ,& ! entrainment mean temperature (C) + S_e ,& ! entrainment mean salinity + T_p ,& ! product temperature (C) + S_p ! product salinity +! + real (r8) :: & + rho_i ,& ! inflow mass density (g/cm3) + rho_s ,& ! source mass density (g/cm3) + rho_e ,& ! entrainment mass density (g/cm3) + rho_sed ,& ! source at entrainment depth mass density (g/cm3) + rho_p ! product mass density (g/cm3) +! + real (r8) :: & + gp_s ,& ! source reduced gravity (cm/s2) + Ms ,& ! source mass flux (Sv) + As ,& ! source cross sectional area (cm2) + Us ! source speed (cm/s) +! + real (r8) :: & + gp_e ,& ! entrainment reduced gravity (cm/s2) + Me ,& ! entrainment mass flux (Sv) + Ue ,& ! entrainment speed (cm/s) + Ugeo ,& ! geostrophic entrainment speed (m/s) + Uavg ,& ! average source and geostrophic speed (cm/s) + a,b,c ,& ! parameters for quadratic solution + Wgeo ,& ! width of geostrophically spread source (cm) + Kgeo ,& ! geostrophic Ekman number + hgeo ,& ! depth of geostrophically spread source (cm) + Fgeo ,& ! Froude number of entrained flow + phi ,& ! entrainment parameter from actual ratio Me/Mp + Mp ! product mass flux (Sv) + + character (POP_charLength) :: & + string + + integer (POP_i4) :: & + ier + + integer (int_kind) :: ovf_id + + + integer (int_kind) :: num_posts, ierr, count, loc, r_n, r_m, indx + integer (int_kind), parameter :: len = 16 !length of buffer for a post + real (r8), dimension(:), allocatable:: myRecvBuff(:), mySendBuff(:) + + + logical (log_kind) :: post, found + logical (log_kind), dimension(:), allocatable :: post_array + +!EOP +!BOC +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +! open overflows_diag_outfile file +! append overflows diagnostics to end of overflows diagnostics output file +! +!----------------------------------------------------------------------- + + if (my_task == master_task .and. eod) then + open(ovf_diag_unit, file=overflows_diag_outfile, status='old', position='append') + endif + + !must have the groups initialized + if (.not. ovf_groups%init) then + call ovf_init_groups() + end if + + ! set up + if( my_task == master_task ) then + allocate(post_array(num_ovf)) + end if + + if (eod) then !end of day :) + if (my_task == master_task) then + num_posts = num_ovf - ovf_groups%numMyGroups + if (num_posts > 0) then + allocate(myRecvBuff(len*num_posts)) + end if + call ovf_print_init(len, num_posts, myRecvBuff, post_array) + else + num_posts = 0 + do n=1, ovf_groups%numMyGroups + if (ovf_groups%amMaster(n)) then + num_posts = num_posts + 1 + end if + end do + call ovf_print_init(len, num_posts) + if (num_posts > 0) then + allocate(mySendBuff(num_posts * len)) + end if + end if + else ! no printing - just see which are my groups + if( my_task == master_task ) then + post_array = .true. + do n=1, ovf_groups%numMyGroups + ovf_id = ovf_groups%groupIds(n) + post_array(ovf_id) = .false. + end do + end if + end if + + !do master seperate for easier printing + if( my_task == master_task ) then + count = 0 + do n=1,num_ovf + ovf_id = n; + post = post_array(n) ! post is true if master is not in group + if ( .not. post) then! master is part of this ovf + + ! set parameters + lat = ovf(ovf_id)%ovf_params%lat + fs = c2*omega*sin(lat*pi/180.0_r8) + hu = ovf(ovf_id)%ovf_params%source_thick + hs = hu*(c2/c3) + xse = ovf(ovf_id)%ovf_params%distnc_str_ssb + alpha = ovf(ovf_id)%ovf_params%bottom_slope + cd = ovf(ovf_id)%ovf_params%bottom_drag + di = p5*(zt(ovf(ovf_id)%reg_inf%kmin)+zt(ovf(ovf_id)%reg_inf%kmax)) + ds = zt(ovf(ovf_id)%loc_src(1)%k) + de = zt(ovf(ovf_id)%loc_ent(1)%k) + Ws = ovf(ovf_id)%ovf_params%width + ! set region T,S and compute densities + T_i = ovf(ovf_id)%trcr_reg%inf(1) + S_i = ovf(ovf_id)%trcr_reg%inf(2) + call state_singlept(T_i,S_i,ds,rho_i) + T_s = ovf(ovf_id)%trcr_reg%src(1) + S_s = ovf(ovf_id)%trcr_reg%src(2) + call state_singlept(T_s,S_s,ds,rho_s) + call state_singlept(T_s,S_s,de,rho_sed) + T_e = ovf(ovf_id)%trcr_reg%ent(1) + S_e = ovf(ovf_id)%trcr_reg%ent(2) + call state_singlept(T_e,S_e,de,rho_e) + ! compute inflow/source reduced gravity and source transport + gp_s = grav*(rho_s-rho_i)/rho_sw + ! if no source overflow, zero out transports + if( gp_s > c0 ) then + Ms = gp_s*hu*hu/(c2*fs) + As = hs*Ws + Us = Ms/As + ! compute overflow spreading and entrainment transport + gp_e = grav*(rho_sed-rho_e)/rho_sw + ! zero entrainment transport if gp_e < 0 + if( gp_e > c0 ) then + Ugeo = gp_e*alpha/fs + Uavg = p5*(Us+Ugeo) + a = fs*Ws/c2 + b = fs*Ws*hs/c2 + c2*cd*Uavg*xse - Ms*fs/(c2*Ugeo) + c = -fs*Ms*hs/(c2*Ugeo) + hgeo = (-b + sqrt(b*b-c4*a*c))/(c2*a) + Fgeo = Ugeo/sqrt(gp_e*hgeo) + phi = c1-Fgeo**(-c2/c3) + Me = Ms*phi/(c1-phi) + ! zero entrainment transport if phi < c0 + if( phi > c0 ) then + Mp = Ms + Me + else + Me = c0 + Mp = Ms + endif + else + Me = c0 + Mp = Ms + endif + else + Ms = c0 + Me = c0 + Mp = c0 + endif + ! time shift transports and set output in ovf array + ovf(ovf_id)%Ms_nm1 = ovf(ovf_id)%Ms_n + ovf(ovf_id)%Ms_n = ovf(ovf_id)%Ms + ovf(ovf_id)%Me_nm1 = ovf(ovf_id)%Me_n + ovf(ovf_id)%Me_n = ovf(ovf_id)%Me + ovf(ovf_id)%Mp_nm1 = ovf(ovf_id)%Mp_n + ovf(ovf_id)%Mp_n = ovf(ovf_id)%Mp + ovf(ovf_id)%Ms = Ms + ovf(ovf_id)%Me = Me + ovf(ovf_id)%Mp = Mp + ! recompute phi based on actual transports + phi = ovf(ovf_id)%Me / (ovf(ovf_id)%Mp + c1) + ! if time averaging time step, include last time step + if( avg_ts ) then + phi = (ovf(ovf_id)%Me_n + ovf(ovf_id)%Me) / (ovf(ovf_id)%Mp_n + ovf(ovf_id)%Mp + c1) + endif + ovf(ovf_id)%phi = phi + ! compute product T,S + T_p = T_s*(c1-phi) + T_e*phi + S_p = S_s*(c1-phi) + S_e*phi + ovf(ovf_id)%Tp = T_p + ovf(ovf_id)%Sp = S_p + do nn=1,nt + ovf(ovf_id)%trcr_adj%prd(nn) = ovf(ovf_id)%trcr_adj%src(nn) * (c1 - phi) & + + ovf(ovf_id)%trcr_adj%ent(nn) * phi + ovf(ovf_id)%trcr_reg%prd(nn) = ovf(ovf_id)%trcr_reg%src(nn) * (c1 - phi) & + + ovf(ovf_id)%trcr_reg%ent(nn) * phi + end do + ! product set for insertion + m = ovf(ovf_id)%prd_set + + if (eod) then + k_p = (ovf(ovf_id)%adj_prd(m)%kmin+ovf(ovf_id)%adj_prd(m)%kmax)/2 + write(ovf_diag_unit,1234) tday,n,phi,1.e-12*Ms,1.e-12*Me,1.e-12*Mp,m,zt(k_p)/100. + 1234 format(' ovf_tr: ',f7.1,1x,i2,25x,f7.4,2x,3(f7.4,1x),1x,i2,1x,f8.1) + write(ovf_diag_unit,1235) tday, n,T_i,S_i*c1000,T_s,S_s*c1000,T_e,S_e*c1000,T_p,S_p*c1000 + 1235 format(' ovf_TS: ',f7.1,1x,i2,1x,8(f7.4,1x)) + call shr_sys_flush(ovf_diag_unit) + endif ! eod - so print + + else !not in this ovf group - but if check if we can print + if (eod) then + count = count+1 + call ovf_print_get(count) + loc = (n-1)*len+1 + !unpack + r_n = int(myRecvBuff(loc+1)) + r_m = int(myRecvBuff(loc+6)) + + write(ovf_diag_unit,1234) myRecvBuff(loc),r_n, myRecvBuff(loc+2), & + myRecvBuff(loc+3),myRecvBuff(loc+4),myRecvBuff(loc+5), & + r_m, myRecvBuff(loc+7) +1236 format(' ovf_tr: ',f7.1,1x,i2,25x,f7.4,2x,3(f7.4,1x),1x,i2,1x,f8.1) + write(ovf_diag_unit,1235) myRecvBuff(loc), r_n, myRecvBuff(loc+8), & + myRecvBuff(loc+9),myRecvBuff(loc+10), myRecvBuff(loc+11), & + myRecvBuff(loc+12), myRecvBuff(loc+13), myRecvBuff(loc+14), & + myRecvBuff(loc+15) +1237 format(' ovf_TS: ',f7.1,1x,i2,1x,8(f7.4,1x)) + call shr_sys_flush(ovf_diag_unit) + end if ! eod - so print + end if + end do ! ovf loop + deallocate(post_array) + if (eod) then + if (num_posts > 0) then + deallocate(myRecvBuff) + endif + call ovf_print_finalize(num_posts) + end if + else ! not master + count = 0 + do n=1,ovf_groups%numMyGroups + ovf_id = ovf_groups%groupIds(n) + + ! set parameters + lat = ovf(ovf_id)%ovf_params%lat + fs = c2*omega*sin(lat*pi/180.0_r8) + hu = ovf(ovf_id)%ovf_params%source_thick + hs = hu*(c2/c3) + xse = ovf(ovf_id)%ovf_params%distnc_str_ssb + alpha = ovf(ovf_id)%ovf_params%bottom_slope + cd = ovf(ovf_id)%ovf_params%bottom_drag + di = p5*(zt(ovf(ovf_id)%reg_inf%kmin)+zt(ovf(ovf_id)%reg_inf%kmax)) + ds = zt(ovf(ovf_id)%loc_src(1)%k) + de = zt(ovf(ovf_id)%loc_ent(1)%k) + Ws = ovf(ovf_id)%ovf_params%width + ! set region T,S and compute densities + T_i = ovf(ovf_id)%trcr_reg%inf(1) + S_i = ovf(ovf_id)%trcr_reg%inf(2) + call state_singlept(T_i,S_i,ds,rho_i) + T_s = ovf(ovf_id)%trcr_reg%src(1) + S_s = ovf(ovf_id)%trcr_reg%src(2) + call state_singlept(T_s,S_s,ds,rho_s) + call state_singlept(T_s,S_s,de,rho_sed) + T_e = ovf(ovf_id)%trcr_reg%ent(1) + S_e = ovf(ovf_id)%trcr_reg%ent(2) + call state_singlept(T_e,S_e,de,rho_e) + ! compute inflow/source reduced gravity and source transport + gp_s = grav*(rho_s-rho_i)/rho_sw + ! if no source overflow, zero out transports + if( gp_s > c0 ) then + Ms = gp_s*hu*hu/(c2*fs) + As = hs*Ws + Us = Ms/As + ! compute overflow spreading and entrainment transport + gp_e = grav*(rho_sed-rho_e)/rho_sw + ! zero entrainment transport if gp_e < 0 + if( gp_e > c0 ) then + Ugeo = gp_e*alpha/fs + Uavg = p5*(Us+Ugeo) + a = fs*Ws/c2 + b = fs*Ws*hs/c2 + c2*cd*Uavg*xse - Ms*fs/(c2*Ugeo) + c = -fs*Ms*hs/(c2*Ugeo) + hgeo = (-b + sqrt(b*b-c4*a*c))/(c2*a) + Fgeo = Ugeo/sqrt(gp_e*hgeo) + phi = c1-Fgeo**(-c2/c3) + Me = Ms*phi/(c1-phi) + ! zero entrainment transport if phi < c0 + if( phi > c0 ) then + Mp = Ms + Me + else + Me = c0 + Mp = Ms + endif + else + Me = c0 + Mp = Ms + endif + else + Ms = c0 + Me = c0 + Mp = c0 + endif + ! time shift transports and set output in ovf array + ovf(ovf_id)%Ms_nm1 = ovf(ovf_id)%Ms_n + ovf(ovf_id)%Ms_n = ovf(ovf_id)%Ms + ovf(ovf_id)%Me_nm1 = ovf(ovf_id)%Me_n + ovf(ovf_id)%Me_n = ovf(ovf_id)%Me + ovf(ovf_id)%Mp_nm1 = ovf(ovf_id)%Mp_n + ovf(ovf_id)%Mp_n = ovf(ovf_id)%Mp + ovf(ovf_id)%Ms = Ms + ovf(ovf_id)%Me = Me + ovf(ovf_id)%Mp = Mp + ! recompute phi based on actual transports + phi = ovf(ovf_id)%Me / (ovf(ovf_id)%Mp + c1) + ! if time averaging time step, include last time step + if( avg_ts ) then + phi = (ovf(ovf_id)%Me_n + ovf(ovf_id)%Me) / (ovf(ovf_id)%Mp_n + ovf(ovf_id)%Mp + c1) + endif + ovf(ovf_id)%phi = phi + ! compute product T,S + T_p = T_s*(c1-phi) + T_e*phi + S_p = S_s*(c1-phi) + S_e*phi + ovf(ovf_id)%Tp = T_p + ovf(ovf_id)%Sp = S_p + do nn=1,nt + ovf(ovf_id)%trcr_adj%prd(nn) = ovf(ovf_id)%trcr_adj%src(nn) * (c1 - phi) & + + ovf(ovf_id)%trcr_adj%ent(nn) * phi + ovf(ovf_id)%trcr_reg%prd(nn) = ovf(ovf_id)%trcr_reg%src(nn) * (c1 - phi) & + + ovf(ovf_id)%trcr_reg%ent(nn) * phi + end do + ! product set for insertion + m = ovf(ovf_id)%prd_set + !if iam the group master, need to send the info to be printed + if (eod .and. ovf_groups%amMaster(n))then + + count = count +1 + loc = (count-1)*len+1 + + k_p = (ovf(ovf_id)%adj_prd(m)%kmin+ovf(ovf_id)%adj_prd(m)%kmax)/2 + mySendBuff(loc) = tday + mySendBuff(loc+1) = real(n,r8) + mySendBuff(loc+2) = phi + mySendBuff(loc+3) = 1.e-12*Ms + mySendBuff(loc+4) = 1.e-12*Me + mySendBuff(loc+5) = 1.e-12*Mp + mySendBuff(loc+6) = real(m,r8) + mySendBuff(loc+7) = zt(k_p)/100. + + mySendBuff(loc+8) = T_i + mySendBuff(loc+9) = S_i*c1000 + mySendBuff(loc+10) = T_s + mySendBuff(loc+11) = S_s*c1000 + mySendBuff(loc+12) = T_e + mySendBuff(loc+13) = S_e*c1000 + mySendBuff(loc+14) = T_p + mySendBuff(loc+15) = S_p*c1000 + + + call ovf_print_send(len, mySendBuff(loc:loc+len-1), & + count, ovf_id) + endif ! printing + end do ! n loop over overflows + if (eod) then + call ovf_print_finalize(num_posts) + if (num_posts > 0) then + deallocate(mySendBuff) + end if + end if + end if !not master_task + + + +!----------------------------------------------------------------------- +! +! close overflows_diag_outfile file +! +!----------------------------------------------------------------------- + + if (eod .and. my_task == master_task) then + close(ovf_diag_unit) + endif ! print_overflows_diag + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_transports + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_loc_prd +! !INTERFACE: + + subroutine ovf_loc_prd + +! !DESCRIPTION: +! Evaluate the ovf location of product. If product location has moved, +! set original sidewall velocities on the ugrid to zero and compute +! Uovf_n, Uovf_nm1 sidewall velocities on the u-grid at new product +! location using Mp_n, Mp_nm1 transport respectively. +! +! !REVISION HISTORY: +! same as module +! +! ovf t-grid box ij with u-grid +! corners and orientations +! product moves out of ij ovf box +! +! ^ +! +V | 2 +! | __________ ---> +U +! y ^ | | 1 +! | | | +! | | ij | +! +-----> | | +! x 3 |__________| +! -U <--- | +! 4 | -V + +!EOP +!BOC +!---------------------------------------------------------------------- +! local variables +!---------------------------------------------------------------------- + + integer (int_kind) :: & + m_neut_org, & ! original neutral product density set index + m_neut ! neutral product density set index + real (r8) :: & + T_p ,& ! product temperature (C) + S_p ,& ! product salinity + rho_p ,& ! product density at each product + ufrc ,& ! fraction of ovf velocity for each box + Uovf_n ,& ! U at n + Uovf_nm1 ! U at n-1 + integer (int_kind) :: & + iblock,i,j,n,m,mp, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + k_p,kprd ! overflow loop and level indices + type (block) :: & + this_block ! block information for current block + logical (log_kind), parameter :: prnt = .false. + + integer (int_kind) :: ovf_id + + + integer (int_kind) :: num_posts, ierr, count, loc, & + loc_start, num_len, tot_len + integer (int_kind), parameter :: len = 8 !length of buffer for a post + real (r8), dimension(:), allocatable:: myRecvBuff(:), mySendBuff(:) + real (r8) :: rb2, rb3, rb4, rb5, rb6, rb7, rb8 + integer (i4):: ib1, ib4, ib5, indx + + + logical (log_kind) :: post, found + logical (log_kind), dimension(:), allocatable :: post_array + + if(prnt .and. my_task == master_task) then + write(stdout,*) 'ovf_loc_prd called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop - loop through MY overflows +!----------------------------------------------------------------------- + + + + !must have the groups initialized + if (.not. ovf_groups%init) then + call ovf_init_groups() + end if + + if( my_task == master_task ) then + allocate(post_array(num_ovf)) + end if + + !set up for printing + if (prnt) then + count = 0 + do n=1,num_ovf + count = MAX(count, ovf(n)%num_prd_sets) + end do + tot_len = len*count + 1 !one spot to tell how long it is + if( my_task == master_task ) then + !for any ovf groups that the master_task is not in, + !must post recv for the info + num_posts = num_ovf - ovf_groups%numMyGroups + if (num_posts > 0) then + allocate(myRecvBuff(tot_len*num_posts)) + endif + call ovf_print_init(tot_len, num_posts, myRecvBuff, post_array) + else !not master + num_posts = 0 + do n=1, ovf_groups%numMyGroups + if (ovf_groups%amMaster(n)) then + num_posts = num_posts + 1 + end if + end do + call ovf_print_init(tot_len, num_posts) + if (num_posts > 0) then + allocate(mySendBuff(num_posts * tot_len)) + end if + end if + else ! not printing + if( my_task == master_task ) then + post_array = .true. + do n=1, ovf_groups%numMyGroups + ovf_id = ovf_groups%groupIds(n) + post_array(ovf_id) = .false. + end do + end if + end if + + + !seperate the master and slave loops to make printing easier - + ! this ends up in some code duplication in the two sections... + if( my_task == master_task ) then + count = 0 + do n=1,num_ovf !master goes through all because of possible printing + ovf_id = n; + post = post_array(n) ! post is true if master is not in group + if ( .not. post) then! master is part of this ovf + ! find new product location + T_p = ovf(ovf_id)%Tp + S_p = ovf(ovf_id)%Sp + m_neut_org = ovf(ovf_id)%prd_set + m_neut = 0 + if(ovf(ovf_id)%num_prd_sets .eq. 1) then + m_neut = 1 + k_p = (ovf(ovf_id)%adj_prd(1)%kmin + ovf(ovf_id)%adj_prd(1)%kmax)/2 + call state_singlept(T_p,S_p,zt(k_p),rho_p) + else +! search from deepest to shallowest to allow product water +! to go to the deepest possible level + do m=ovf(ovf_id)%num_prd_sets-1,1,-1 + k_p = (ovf(ovf_id)%adj_prd(m)%kmin + ovf(ovf_id)%adj_prd(m)%kmax)/2 + ! get product level for this set + + !this calculates rho_p based on temp, salinity, and depth + call state_singlept(T_p,S_p,zt(k_p),rho_p) + + if (prnt) then + if (m == 1) then + write(stdout,5) m, 0.0, & + (ovf(ovf_id)%rho_adj%prd(m)-c1)*c1000, & + k_p,T_p,S_p,zt(k_p),(rho_p-c1)*c1000 + else + write(stdout,5) m,(ovf(ovf_id)%rho_adj%prd(m-1)-c1)*c1000, & + (ovf(ovf_id)%rho_adj%prd(m)-c1)*c1000, & + k_p,T_p,S_p,zt(k_p),(rho_p-c1)*c1000 + end if + 5 format(' neutral lev search- m rho_adj_m-1 rho_adj_m ', & + 'k_p T_p S_p zt(k_p) rho_p =',/ & + 2x,i2,2x,2(f12.8,2x),4x,i2,4(f12.8,2x)) + endif + if(rho_p .gt. ovf(ovf_id)%rho_adj%prd(m)) then + m_neut = m+1 + goto 999 !exit loop + else + m_neut = m + endif + enddo + 999 continue + endif + ! error check + if( m_neut .eq. 0 ) then + write(stdout,10) T_p,S_p,rho_p + 10 format(' ovf_loc_prd: no prd lev found for T,S,rho=', & + 3(f10.5,2x)) + call shr_sys_flush(stdout) + call exit_POP(sigAbort,'ERROR no product level found') + endif + ovf(ovf_id)%prd_set_n = m_neut_org + ovf(ovf_id)%prd_set = m_neut + if (prnt) then + write(stdout,20) n,T_p,S_p*c1000,(rho_p-c1)*c1000,m_neut + 20 format(' For ovf = ',i3,' prd T,S,rho = ',3(f12.8,2x),' prd set =',i5) + endif + if( m_neut_org .ne. 0 .and. m_neut_org .ne. m_neut ) then +! product point has moved + if ( overflows_on) then + write(stdout,*) 'ovf_loc_prd: nsteps_total=',nsteps_total, & + ' ovf=',ovf_id,' swap ovf UV old/new ', & + 'prd set old/new=',m_neut_org,m_neut + call shr_sys_flush(stdout) + endif + ! compute Uovf_n, Uovf_nm1 velocities for product sidewall + m = ovf(ovf_id)%prd_set ! product set for insertion + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for each set + kprd = ovf(ovf_id)%loc_prd(m,mp)%k + ufrc = c1/real(ovf(ovf_id)%num_prd(m)-1) + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 1 ) then + Uovf_nm1 = ovf(ovf_id)%Mp_nm1*ufrc/(dz(kprd)*DYU(i,j,iblock)) + Uovf_n = ovf(ovf_id)%Mp_n *ufrc/(dz(kprd)*DYU(i,j,iblock)) + endif + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 2 ) then + Uovf_nm1 = ovf(ovf_id)%Mp_nm1*ufrc/(dz(kprd)*DXU(i,j,iblock)) + Uovf_n = ovf(ovf_id)%Mp_n *ufrc/(dz(kprd)*DXU(i,j,iblock)) + endif + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 3 ) then + Uovf_nm1 = ovf(ovf_id)%Mp_nm1*ufrc/(dz(kprd)*DYU(i,j,iblock)) + Uovf_n = ovf(ovf_id)%Mp_n *ufrc/(dz(kprd)*DYU(i,j,iblock)) + endif + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 4 ) then + Uovf_nm1 = ovf(ovf_id)%Mp_nm1*ufrc/(dz(kprd)*DXU(i,j,iblock)) + Uovf_n = ovf(ovf_id)%Mp_n *ufrc/(dz(kprd)*DXU(i,j,iblock)) + endif + ovf(ovf_id)%loc_prd(m,mp)%Uovf_nm1 = Uovf_nm1 + ovf(ovf_id)%loc_prd(m,mp)%Uovf_n = Uovf_n + if(prnt) then + write(stdout,30) ovf(ovf_id)%loc_prd(m,mp)%i,ovf(ovf_id)%loc_prd(m,mp)%j, & + ovf(ovf_id)%loc_prd(m,mp)%k,ovf(ovf_id)%Mp_nm1,ufrc,dz(kprd),Uovf_nm1 + 30 format(' loc_prd ijk=',3(i4,1x),'Mp_nm1 uf dz=',3(1pe10.3,1x), & + 'Uovf_nm1=',1pe10.3) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for each set + if( overflows_interactive ) then +! zero out original product sidewall U + m = m_neut_org + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for each set + ! prd set original Uold sidewalls to zero + kprd = ovf(ovf_id)%loc_prd(m,mp)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + UVEL(i,j,kprd,newtime,iblock) = c0 + VVEL(i,j,kprd,newtime,iblock) = c0 + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for each set + endif ! interactive overflows + endif ! product point has moved + + else !master not in this ovf - but may need to print (?) + if (prnt) then + count = count+1 + call ovf_print_get(count) + loc = (count-1)*tot_len+1 + num_len = myRecvBuff(count*tot_len) + !unpack and print + do i = 1, num_len - 1 + ib1 = int(myRecvBuff(loc)) + rb2 = myRecvBuff(loc+1) + rb3 = myRecvBuff(loc+2) + ib4 = int(myRecvBuff(loc+3)) + rb5 = myRecvBuff(loc+4) + rb6 = myRecvBuff(loc+5) + rb7 = myRecvBuff(loc+6) + rb8 = myRecvBuff(loc+7) + write(stdout,50) ib1, rb2, rb3, ib4, rb5, rb6, rb7, rb8 +50 format(' neutral lev search- m rho_adj_m-1 rho_adj_m ', & + 'k_p T_p S_p zt(k_p) rho_p =',/ & + 2x,i2,2x,2(f12.8,2x),4x,i2,4(f12.8,2x)) + loc = loc + len !advance for next one + end do ! i + ib1 = int(myRecvBuff(loc)) + rb2 = myRecvBuff(loc+1) + rb3 = myRecvBuff(loc+2) + rb4 = myRecvBuff(loc+3) + ib5 = int( myRecvBuff(loc+4)) + write(stdout,200) ib1, rb2, rb3, rb4, ib5 +200 format(' For ovf = ',i3,' prd T,S,rho = ',3(f12.8,2x),' prd set =',i5) + end if !print + end if !end of master not in ovf + end do !ovf loop + !clean up + deallocate(post_array) + if (prnt) then + if (num_posts > 0) then + deallocate(myRecvBuff) + endif + call ovf_print_finalize(num_posts) + end if + + else ! not master loop + num_posts = 0 + do n=1, ovf_groups%numMyGroups + loc_start = -1 + num_len= 0 + ovf_id = ovf_groups%groupIds(n) + ! find new product location + T_p = ovf(ovf_id)%Tp + S_p = ovf(ovf_id)%Sp + m_neut_org = ovf(ovf_id)%prd_set + m_neut = 0 + if(ovf(ovf_id)%num_prd_sets .eq. 1) then + m_neut = 1 + k_p = (ovf(ovf_id)%adj_prd(1)%kmin + ovf(ovf_id)%adj_prd(1)%kmax)/2 + call state_singlept(T_p,S_p,zt(k_p),rho_p) + else + ! search from deepest to shallowest to allow product water + ! to go to the deepest possible level + do m=ovf(ovf_id)%num_prd_sets-1,1,-1 + k_p = (ovf(ovf_id)%adj_prd(m)%kmin + ovf(ovf_id)%adj_prd(m)%kmax)/2 + ! get product level for this set + + !this calculates rho_p based on temp, salinity, and depth + call state_singlept(T_p,S_p,zt(k_p),rho_p) + + if (prnt .and. ovf_groups%amMaster(n)) then + + num_len = num_len + 1 + loc = (num_posts)*tot_len + (num_len - 1)*len + 1 + + if ( loc_start < 0) then !first time for this ovf + loc_start = loc + endif + mySendBuff(loc) = real(m, r8) !int + if (m==1) then + mySendBuff(loc+1) =0.0 !can't do m-1 + else + mySendBuff(loc+1) = (ovf(ovf_id)%rho_adj%prd(m-1)-c1)*c1000 + end if + mySendBuff(loc+2) = (ovf(ovf_id)%rho_adj%prd(m)-c1)*c1000 + mySendBuff(loc+3) = real(k_p,r8) !int + mySendBuff(loc+4) = T_p + mySendBuff(loc+5) = S_p + mySendBuff(loc+6) = zt(k_p) + mySendBuff(loc+7) = (rho_p-c1)*c1000 + + endif ! print master + + if(rho_p .gt. ovf(ovf_id)%rho_adj%prd(m)) then + m_neut = m+1 + goto 998 !exit loop + else + m_neut = m + endif + enddo +998 continue + endif !num prod sets + !error check + if( m_neut .eq. 0 ) then + write(stdout,101) T_p,S_p,rho_p +101 format(' ovf_loc_prd: no prd lev found for T,S,rho=', & + 3(f10.5,2x)) + call shr_sys_flush(stdout) + call exit_POP(sigAbort,'ERROR no product level found') + endif + ovf(ovf_id)%prd_set_n = m_neut_org + ovf(ovf_id)%prd_set = m_neut + if (prnt .and. ovf_groups%amMaster(n)) then + num_len = num_len+1 + loc = (num_posts)*tot_len + (num_len - 1)*len + 1 + + if (loc_start == -1) then !first time for this ovf + loc_start = loc; + endif + !pack pack buffer and send here + mySendBuff(loc) = real(ovf_id, r8) !int + mySendBuff(loc+1) =T_p + mySendBuff(loc+2) =S_p*c1000 + mySendBuff(loc+3) = (rho_p-c1)*c1000 + mySendBuff(loc+4) = real(m_neut, r8) !int + + num_posts = num_posts + 1 !increment here because we do this one once each ovf + + !indicate num items sent to master in last location + mySendBuff(tot_len*num_posts) = real(num_len, r8) + + call ovf_print_send(tot_len, mySendBuff(loc_start:loc_start+tot_len-1), & + num_posts, ovf_id) + + end if ! print master + + if( m_neut_org .ne. 0 .and. m_neut_org .ne. m_neut ) then + ! product point has moved + if ( overflows_on .and. ovf_groups%amMaster(n)) then + write(stdout,*) 'ovf_loc_prd: nsteps_total=',nsteps_total, & + ' ovf=',ovf_id,' swap ovf UV old/new ', & + 'prd set old/new=',m_neut_org,m_neut + call shr_sys_flush(stdout) + endif + ! compute Uovf_n, Uovf_nm1 velocities for product sidewall + m = ovf(ovf_id)%prd_set ! product set for insertion + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for each set + kprd = ovf(ovf_id)%loc_prd(m,mp)%k + ufrc = c1/real(ovf(ovf_id)%num_prd(m)-1) + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 1 ) then + Uovf_nm1 = ovf(ovf_id)%Mp_nm1*ufrc/(dz(kprd)*DYU(i,j,iblock)) + Uovf_n = ovf(ovf_id)%Mp_n *ufrc/(dz(kprd)*DYU(i,j,iblock)) + endif + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 2 ) then + Uovf_nm1 = ovf(ovf_id)%Mp_nm1*ufrc/(dz(kprd)*DXU(i,j,iblock)) + Uovf_n = ovf(ovf_id)%Mp_n *ufrc/(dz(kprd)*DXU(i,j,iblock)) + endif + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 3 ) then + Uovf_nm1 = ovf(ovf_id)%Mp_nm1*ufrc/(dz(kprd)*DYU(i,j,iblock)) + Uovf_n = ovf(ovf_id)%Mp_n *ufrc/(dz(kprd)*DYU(i,j,iblock)) + endif + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 4 ) then + Uovf_nm1 = ovf(ovf_id)%Mp_nm1*ufrc/(dz(kprd)*DXU(i,j,iblock)) + Uovf_n = ovf(ovf_id)%Mp_n *ufrc/(dz(kprd)*DXU(i,j,iblock)) + endif + ovf(ovf_id)%loc_prd(m,mp)%Uovf_nm1 = Uovf_nm1 + ovf(ovf_id)%loc_prd(m,mp)%Uovf_n = Uovf_n + if(prnt) then + write(stdout,31) ovf(ovf_id)%loc_prd(m,mp)%i,ovf(ovf_id)%loc_prd(m,mp)%j, & + ovf(ovf_id)%loc_prd(m,mp)%k,ovf(ovf_id)%Mp_nm1,ufrc,dz(kprd),Uovf_nm1 +31 format(' loc_prd ijk=',3(i4,1x),'Mp_nm1 uf dz=',3(1pe10.3,1x), & + 'Uovf_nm1=',1pe10.3) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for each set + if( overflows_interactive ) then + ! zero out original product sidewall U + m = m_neut_org + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for each set + ! prd set original Uold sidewalls to zero + kprd = ovf(ovf_id)%loc_prd(m,mp)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + UVEL(i,j,kprd,newtime,iblock) = c0 + VVEL(i,j,kprd,newtime,iblock) = c0 + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for each set + endif ! interactive overflows + endif ! product point has moved + end do ! overflows + + if (prnt) then + call ovf_print_finalize(num_posts) + if (num_posts > 0) then + deallocate(mySendBuff) + end if + end if + + end if ! end of not master part + + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_loc_prd + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_W +! !INTERFACE: + + subroutine ovf_W + +! !DESCRIPTION: +! Evaluate ovf vertical velocity W on the t-grid +! +! !REVISION HISTORY: +! same as module +! +! ovf t-grid box ij from top +! sidewall transports and top TAREA +! used to compute Wovf at top +! signs of Wovf important! +! +! __________ +! | | +! Me ----> | ij | <---- Ms +! Mp <---- | TAREAij | +! |__________| +! + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + iblock,i,j,n,m,mp, & ! dummy loop indices + ib,ie,jb,je ! local domain index boundaries + type (block) :: & + this_block ! block information for current block + real (r8) :: & + ufrc ! fraction of ovf velocity for each box + logical (log_kind), parameter :: prnt = .false. + + integer (int_kind) :: ovf_id + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_W called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + !must have the groups initilaized + if (.not. ovf_groups%init) then + call ovf_init_groups() + end if + + do n=1, ovf_groups%numMyGroups ! each overflow + ovf_id = ovf_groups%groupIds(n) +! src + do m=1,ovf(ovf_id)%num_src ! source + ufrc = c1/real(ovf(ovf_id)%num_src-1) + if(m==1 .or. m==ovf(ovf_id)%num_src) ufrc = ufrc/c2 + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_src(m)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_src(m)%i .eq. this_block%i_glob(i) ) then + ovf(ovf_id)%loc_src(m)%Wovf = -abs(ovf(ovf_id)%Ms*ufrc & + /TAREA(i,j,iblock)) + if(prnt) then + write(stdout,10) n,ovf(ovf_id)%loc_src(m)%i, & + ovf(ovf_id)%loc_src(m)%j,ovf(ovf_id)%loc_src(m)%k, & + ovf(ovf_id)%Ms,ufrc,TAREA(i,j,iblock), & + ovf(ovf_id)%loc_src(m)%Wovf + 10 format(' ovf_W n=',i3,' src ijk=',3(i4,1x), & + 'Ms uf Ta Wovf=',4(1pe10.3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! source +! ent + do m=1,ovf(ovf_id)%num_ent ! entrainment + ufrc = c1/real(ovf(ovf_id)%num_ent-1) + if(m==1 .or. m==ovf(ovf_id)%num_ent) ufrc = ufrc/c2 + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_ent(m)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_ent(m)%i .eq. this_block%i_glob(i) ) then + ovf(ovf_id)%loc_ent(m)%Wovf = -abs(ovf(ovf_id)%Me*ufrc & + /TAREA(i,j,iblock)) + if(prnt) then + write(stdout,20) n,ovf(ovf_id)%loc_ent(m)%i, & + ovf(ovf_id)%loc_ent(m)%j,ovf(ovf_id)%loc_ent(m)%k, & + ovf(ovf_id)%Me,ufrc,TAREA(i,j,iblock), & + ovf(ovf_id)%loc_ent(m)%Wovf + 20 format(' ovf_W n=',i3,' ent ijk=',3(i4,1x), & + 'Me uf Ta Wovf=',4(1pe10.3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! entrainment +! prd +! set Wovf terms to zero at product points, incase product has moved + do m=1,ovf(ovf_id)%num_prd_sets + do mp=1,ovf(ovf_id)%num_prd(m) + ovf(ovf_id)%loc_prd(m,mp)%Wovf = c0 + end do + end do + m = ovf(ovf_id)%prd_set ! product set for insertion + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for each set + ufrc = c1/real(ovf(ovf_id)%num_prd(m)-1) + if(mp==1 .or. mp==ovf(ovf_id)%num_prd(m)) ufrc = ufrc/c2 + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i .eq. this_block%i_glob(i) ) then + ovf(ovf_id)%loc_prd(m,mp)%Wovf = abs(ovf(ovf_id)%Mp*ufrc & + /TAREA(i,j,iblock)) + if(prnt) then + write(stdout,30) n,ovf(ovf_id)%loc_prd(m,mp)%i, & + ovf(ovf_id)%loc_prd(m,mp)%j,ovf(ovf_id)%loc_prd(m,mp)%k, & + ovf(ovf_id)%Mp,ufrc,TAREA(i,j,iblock), & + ovf(ovf_id)%loc_prd(m,mp)%Wovf + 30 format(' ovf_W n=',i3,' prd ijk=',3(i4,1x), & + 'Mp uf Ta Wovf=',4(1pe10.3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for insertion set + end do ! each overflow +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_W + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_UV +! !INTERFACE: + + subroutine ovf_UV + +! !DESCRIPTION: +! Evaluate the ovf sidewall velocities UV on the u-grid +! !REVISION HISTORY: +! same as module +! +! ovf t-grid box ij with U on u-grid +! at corner set by orientation +! +! 2 +! U __________ U +! y ^ | | 1 +! | | | +! | | ij | +! +-----> | | +! x 3 |__________| +! U U +! 4 + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + iblock,i,j,n,m,mp, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + ksrc,kent,kprd ! overflow level indices + type (block) :: & + this_block ! block information for current block + real (r8) :: & + ufrc, & ! fraction of ovf velocity for each box + Uovf ! Uovf at one corner + logical (log_kind), parameter :: prnt = .false. + + integer (int_kind) :: ovf_id + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_UV called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + !must have the groups initilaized + if (.not. ovf_groups%init) then + call ovf_init_groups() + end if + + do n=1, ovf_groups%numMyGroups ! each overflow + ovf_id = ovf_groups%groupIds(n) +! src + do m=1,ovf(ovf_id)%num_src ! source + ksrc = ovf(ovf_id)%loc_src(m)%k + ufrc = c1/real(ovf(ovf_id)%num_src-1) + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + if( ovf(ovf_id)%loc_src(m)%orient .eq. 1 ) then + Uovf = ovf(ovf_id)%Ms*ufrc/(dz(ksrc)*DYU(i,j,iblock)) + if( overflows_interactive ) then + UVEL(i,j,ksrc,newtime,iblock) = -Uovf + endif + endif + if( ovf(ovf_id)%loc_src(m)%orient .eq. 2 ) then + Uovf = ovf(ovf_id)%Ms*ufrc/(dz(ksrc)*DXU(i,j,iblock)) + if( overflows_interactive ) then + VVEL(i,j,ksrc,newtime,iblock) = -Uovf + endif + endif + if( ovf(ovf_id)%loc_src(m)%orient .eq. 3 ) then + Uovf = ovf(ovf_id)%Ms*ufrc/(dz(ksrc)*DYU(i,j,iblock)) + if( overflows_interactive ) then + UVEL(i,j,ksrc,newtime,iblock) = +Uovf + endif + endif + if( ovf(ovf_id)%loc_src(m)%orient .eq. 4 ) then + Uovf = ovf(ovf_id)%Ms*ufrc/(dz(ksrc)*DXU(i,j,iblock)) + if( overflows_interactive ) then + VVEL(i,j,ksrc,newtime,iblock) = +Uovf + endif + endif + ovf(ovf_id)%loc_src(m)%Uovf = Uovf + if( prnt ) then + write(stdout,10) n,ovf(ovf_id)%loc_src(m)%i_u, & + ovf(ovf_id)%loc_src(m)%j_u,ovf(ovf_id)%loc_src(m)%k,Uovf + 10 format(' ovf_UV n=',i3,' src i_u j_u k Uovf=', & + 3(i3,1x),f9.5,2x) + endif ! print + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! source +! ent + do m=1,ovf(ovf_id)%num_ent ! entrainment + kent = ovf(ovf_id)%loc_ent(m)%k + ufrc = c1/real(ovf(ovf_id)%num_ent-1) + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + if( ovf(ovf_id)%loc_ent(m)%orient .eq. 1 ) then + Uovf = ovf(ovf_id)%Me*ufrc/(dz(kent)*DYU(i,j,iblock)) + if( overflows_interactive ) then + UVEL(i,j,kent,newtime,iblock) = -Uovf + endif + endif + if( ovf(ovf_id)%loc_ent(m)%orient .eq. 2 ) then + Uovf = ovf(ovf_id)%Me*ufrc/(dz(kent)*DXU(i,j,iblock)) + if( overflows_interactive ) then + VVEL(i,j,kent,newtime,iblock) = -Uovf + endif + endif + if( ovf(ovf_id)%loc_ent(m)%orient .eq. 3 ) then + Uovf = ovf(ovf_id)%Me*ufrc/(dz(kent)*DYU(i,j,iblock)) + if( overflows_interactive ) then + UVEL(i,j,kent,newtime,iblock) = +Uovf + endif + endif + if( ovf(ovf_id)%loc_ent(m)%orient .eq. 4 ) then + Uovf = ovf(ovf_id)%Me*ufrc/(dz(kent)*DXU(i,j,iblock)) + if( overflows_interactive ) then + VVEL(i,j,kent,newtime,iblock) = +Uovf + endif + endif + ovf(ovf_id)%loc_ent(m)%Uovf = Uovf + if( prnt ) then + write(stdout,20) n,ovf(ovf_id)%loc_ent(m)%i_u, & + ovf(ovf_id)%loc_ent(m)%j_u,ovf(ovf_id)%loc_ent(m)%k,Uovf + 20 format(' ovf_UV n=',i3,' ent i_u j_u k Uovf=', & + 3(i3,1x),f9.5,2x) + endif ! print + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! entrainment +! prd + m = ovf(ovf_id)%prd_set ! product set for insertion + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for each set + kprd = ovf(ovf_id)%loc_prd(m,mp)%k + ufrc = c1/real(ovf(ovf_id)%num_prd(m)-1) + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 1 ) then + Uovf = ovf(ovf_id)%Mp*ufrc/(dz(kprd)*DYU(i,j,iblock)) + if( overflows_interactive ) then + UVEL(i,j,kprd,newtime,iblock) = +Uovf + endif + endif + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 2 ) then + Uovf = ovf(ovf_id)%Mp*ufrc/(dz(kprd)*DXU(i,j,iblock)) + if( overflows_interactive ) then + VVEL(i,j,kprd,newtime,iblock) = +Uovf + endif + endif + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 3 ) then + Uovf = ovf(ovf_id)%Mp*ufrc/(dz(kprd)*DYU(i,j,iblock)) + if( overflows_interactive ) then + UVEL(i,j,kprd,newtime,iblock) = -Uovf + endif + endif + if( ovf(ovf_id)%loc_prd(m,mp)%orient .eq. 4 ) then + Uovf = ovf(ovf_id)%Mp*ufrc/(dz(kprd)*DXU(i,j,iblock)) + if( overflows_interactive ) then + VVEL(i,j,kprd,newtime,iblock) = -Uovf + endif + endif + ovf(ovf_id)%loc_prd(m,mp)%Uovf = Uovf + if( prnt ) then + write(stdout,30) n,ovf(ovf_id)%loc_prd(m,mp)%i_u, & + ovf(ovf_id)%loc_prd(m,mp)%j_u,ovf(ovf_id)%loc_prd(m,mp)%k,Uovf + 30 format(' ovf_UV n=',i3,' prd i_u j_u k Uovf=', & + 3(i3,1x),f9.5,2x) + endif ! print + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for insertion set + end do ! each overflow + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_UV + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_rhs_brtrpc_momentum +! !INTERFACE: + + subroutine ovf_rhs_brtrpc_momentum(ZX,ZY) + +! !DESCRIPTION: +! Renormalize overflow ZX and ZY vertical integrals of forcing +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + real (r8), dimension(nx_block,ny_block,max_blocks_clinic), & + intent(inout) :: & + ZX, ZY ! vertical integrals of forcing + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + i,j,k,n,m,mp, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + ksrc,kent,kprd, & ! level indices + iblock ! block index + type (block) :: & + this_block ! block information for current block + real (r8) :: & + dz_sidewall ! sidewall U-grid depth from top to ovf level + logical (log_kind), parameter :: prnt = .false. + + integer (int_kind) :: ovf_id + + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_rhs_brtrpc_momentum called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + !must have the groups initilaized + if (.not. ovf_groups%init) then + call ovf_init_groups() + end if + + do n=1, ovf_groups%numMyGroups ! each of my overflows + ovf_id = ovf_groups%groupIds(n) +! src + do m=1,ovf(ovf_id)%num_src ! source + ksrc = ovf(ovf_id)%loc_src(m)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,ksrc + dz_sidewall = dz_sidewall + dz(k) + enddo + ZX(i,j,iblock) = (ZX(i,j,iblock)* HU(i,j,iblock)) & + / (HU(i,j,iblock)+dz_sidewall) + ZY(i,j,iblock) = (ZY(i,j,iblock)* HU(i,j,iblock)) & + / (HU(i,j,iblock)+dz_sidewall) + if(prnt) then + write(stdout,10) n,ovf(ovf_id)%loc_src(m)%i_u,ovf(ovf_id)%loc_src(m)%j_u + 10 format(' ovf_rhs_brtrpc_momentum n=',i3, & + ' src ZX,ZY adj at i_u j_u=',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! source +! ent + do m=1,ovf(ovf_id)%num_ent ! entrainment + kent = ovf(ovf_id)%loc_ent(m)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,kent + dz_sidewall = dz_sidewall + dz(k) + enddo + ZX(i,j,iblock) = (ZX(i,j,iblock)* HU(i,j,iblock)) & + / (HU(i,j,iblock)+dz_sidewall) + ZY(i,j,iblock) = (ZY(i,j,iblock)* HU(i,j,iblock)) & + / (HU(i,j,iblock)+dz_sidewall) + if(prnt) then + write(stdout,20) n,ovf(ovf_id)%loc_ent(m)%i_u,ovf(ovf_id)%loc_ent(m)%j_u + 20 format(' ovf_rhs_brtrpc_momentum n=',i3, & + ' ent ZX,ZY adj at i_u j_u=',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! entrainment +! prd + do m=1,ovf(ovf_id)%num_prd_sets + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for each set + kprd = ovf(ovf_id)%loc_prd(m,mp)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,kprd + dz_sidewall = dz_sidewall + dz(k) + enddo + ZX(i,j,iblock) = (ZX(i,j,iblock)* HU(i,j,iblock)) & + / (HU(i,j,iblock)+dz_sidewall) + ZY(i,j,iblock) = (ZY(i,j,iblock)* HU(i,j,iblock)) & + / (HU(i,j,iblock)+dz_sidewall) + if(prnt) then + write(stdout,30) n,ovf(ovf_id)%loc_prd(m,mp)%i_u, & + ovf(ovf_id)%loc_prd(m,mp)%j_u + 30 format(' ovf_rhs_brtrpc_momentum n=',i3, & + ' prd ZX,ZY adj at i_u j_u=',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for each set + end do ! all product sets + end do ! each overflow + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_rhs_brtrpc_momentum + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_brtrpc_renorm +! !INTERFACE: + + subroutine ovf_brtrpc_renorm(WORK3,WORK4,iblock) + +! !DESCRIPTION: +! Renormalize overflow HU for WORK3 and WORK4 in barotropic solution +! Note- ij limits are 1,nx_block and 1,ny_block to compute ghost values +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + real (r8), dimension(nx_block,ny_block), & + intent(inout) :: & + WORK3,WORK4 ! grid x,y work arrays respectively + integer (int_kind), & + intent(in) :: & + iblock ! block index + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + i,j,k,n,m,mp, & ! dummy loop indices + ksrc,kent,kprd ! level indices + type (block) :: & + this_block ! block information for current block + real (r8) :: & + dz_sidewall ! sidewall U-grid depth from top to ovf level + + logical (log_kind), parameter :: prnt = .false. + + integer (int_kind) :: ovf_id + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_brtrpc_renorm called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + + + !must have the groups initilaized + if (.not. ovf_groups%init) then + call ovf_init_groups() + end if + + do n=1, ovf_groups%numMyGroups ! each overflow + ovf_id = ovf_groups%groupIds(n) +! src + do m=1,ovf(ovf_id)%num_src ! source + ksrc = ovf(ovf_id)%loc_src(m)%k + this_block = get_block(blocks_clinic(iblock),iblock) + do j=1,ny_block + if( ovf(ovf_id)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(ovf_id)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,ksrc + dz_sidewall = dz_sidewall + dz(k) + enddo + WORK3(i,j) = WORK3(i,j)*HUR(i,j,iblock) & + *(HU(i,j,iblock)+dz_sidewall) + WORK4(i,j) = WORK4(i,j)*HUR(i,j,iblock) & + *(HU(i,j,iblock)+dz_sidewall) + if(prnt) then + write(stdout,10) n,ovf(ovf_id)%loc_src(m)%i_u, & + ovf(ovf_id)%loc_src(m)%j_u + 10 format(' ovf_brtrpc_renorm n=',i3, & + ' src WORK3/WORK4 adj at i_u j_u=',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! source +! ent + do m=1,ovf(ovf_id)%num_ent ! entrainment + kent = ovf(ovf_id)%loc_ent(m)%k + this_block = get_block(blocks_clinic(iblock),iblock) + do j=1,ny_block + if( ovf(ovf_id)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(ovf_id)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,kent + dz_sidewall = dz_sidewall + dz(k) + enddo + WORK3(i,j) = WORK3(i,j)*HUR(i,j,iblock) & + *(HU(i,j,iblock)+dz_sidewall) + WORK4(i,j) = WORK4(i,j)*HUR(i,j,iblock) & + *(HU(i,j,iblock)+dz_sidewall) + if(prnt) then + write(stdout,20) n,ovf(ovf_id)%loc_ent(m)%i_u, & + ovf(ovf_id)%loc_ent(m)%j_u + 20 format(' ovf_brtrpc_renorm n=',i3, & + ' ent WORK3/WORK4 adj at i_u j_u=',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! entrainment +! prd + do m=1,ovf(ovf_id)%num_prd_sets + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for each set + kprd = ovf(ovf_id)%loc_prd(m,mp)%k + this_block = get_block(blocks_clinic(iblock),iblock) + do j=1,ny_block + if( ovf(ovf_id)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=1,nx_block + if( ovf(ovf_id)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,kprd + dz_sidewall = dz_sidewall + dz(k) + enddo + WORK3(i,j) = WORK3(i,j)*HUR(i,j,iblock) & + *(HU(i,j,iblock)+dz_sidewall) + WORK4(i,j) = WORK4(i,j)*HUR(i,j,iblock) & + *(HU(i,j,iblock)+dz_sidewall) + if(prnt) then + write(stdout,30) n,ovf(ovf_id)%loc_prd(m,mp)%i_u, & + ovf(ovf_id)%loc_prd(m,mp)%j_u + 30 format(' ovf_brtrpc_renorm n=',i3, & + ' prd WORK3/WORK4 adj at i_u j_u=',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! product points for each set + end do ! all product sets + end do ! each overflow + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_brtrpc_renorm + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_rhs_brtrpc_continuity +! !INTERFACE: + + subroutine ovf_rhs_brtrpc_continuity(RHS,iblock) + +! !DESCRIPTION: +! Add overflow vertical velocity to RHS barotropic continuity equation +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + real (r8), dimension(nx_block,ny_block,max_blocks_clinic), & + intent(inout) :: & + RHS ! RHS barotropic continuity equation + integer (int_kind), & + intent(in) :: & + iblock ! block index + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + i,j,n,m,mp, & ! dummy loop indices + ib,ie,jb,je ! local domain index boundaries + type (block) :: & + this_block ! block information for current block + logical (log_kind), parameter :: prnt = .false. + + integer (int_kind) :: ovf_id + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_rhs_brtrpc_continuity called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + !must have the groups initilaized + if (.not. ovf_groups%init) then + call ovf_init_groups() + end if +! for each of MY overflows + do n=1,ovf_groups%numMyGroups + ovf_id = ovf_groups%groupIds(n) +! src + do m=1,ovf(ovf_id)%num_src ! source + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_src(m)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_src(m)%i .eq. this_block%i_glob(i) ) then + RHS(i,j,iblock) = RHS(i,j,iblock) - (ovf(ovf_id)%loc_src(m)%Wovf & + * TAREA(i,j,iblock)/(beta*c2dtp)) + if(prnt) then + write(stdout,10) n,ovf(ovf_id)%loc_src(m)%i,ovf(ovf_id)%loc_src(m)%j, & + ovf(ovf_id)%loc_src(m)%Wovf,TAREA(i,j,iblock) + 10 format(' n=',i3,' src RHS adjusted at ij=',2(i3,1x), & + ' Wovf=',f9.6,' TAREA=',1pe11.4) + endif + endif + end do ! i + endif + end do ! j + end do ! source +! ent + do m=1,ovf(ovf_id)%num_ent ! entrainment + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_ent(m)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_ent(m)%i .eq. this_block%i_glob(i) ) then + RHS(i,j,iblock) = RHS(i,j,iblock) - (ovf(ovf_id)%loc_ent(m)%Wovf & + * TAREA(i,j,iblock)/(beta*c2dtp)) + if(prnt) then + write(stdout,20) n,ovf(ovf_id)%loc_ent(m)%i,ovf(ovf_id)%loc_ent(m)%j, & + ovf(ovf_id)%loc_ent(m)%Wovf,TAREA(i,j,iblock) + 20 format(' n=',i3,' ent RHS adjusted at ij=',2(i3,1x), & + ' Wovf=',f9.6,' TAREA=',1pe11.4) + endif + endif + end do ! i + endif + end do ! j + end do ! entrainment +! prd + m = ovf(ovf_id)%prd_set + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for each set + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i .eq. this_block%i_glob(i) ) then + RHS(i,j,iblock) = RHS(i,j,iblock) - (ovf(ovf_id)%loc_prd(m,mp)%Wovf & + * TAREA(i,j,iblock)/(beta*c2dtp)) + if(prnt) then + write(stdout,30) n,ovf(ovf_id)%loc_prd(m,mp)%i,ovf(ovf_id)%loc_prd(m,mp)%j, & + ovf(ovf_id)%loc_prd(m,mp)%Wovf,TAREA(i,j,iblock) + 30 format(' n=',i3,' prd RHS adjusted at ij=',2(i3,1x), & + ' Wovf=',f9.6,' TAREA=',1pe11.4) + endif + endif + end do ! i + endif + end do ! j + end do ! product points for each set + end do ! each overflow + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_rhs_brtrpc_continuity + +!*********************************************************************** +!BOP +! !IROUTINE: ovf_solvers_9pt +! !INTERFACE: + + subroutine ovf_solvers_9pt + +! !DESCRIPTION: +! This routine updates the coefficients of the 9-point stencils for +! the barotropic operator for the overflow points +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables: +! +! {X,Y}{NE,SE,NW,SW} = contribution to {ne,se,nw,sw} coefficients +! from {x,y} components of divergence +! HU = depth at U points +! +!----------------------------------------------------------------------- + integer (POP_i4) :: & + errorCode, &! error return code + numBlocksTropic, &!num local blocks in barotropic distribution + numBlocksClinic !num local blocks in baroclinic distribution + + real (POP_r8) :: & + xne,xse,xnw,xsw, &! contribution to coefficients from x,y + yne,yse,ynw,ysw, &! components of divergence + ase,anw,asw + + integer (int_kind) :: & + i,j,n, &! dummy counter + iblock, &! block counter + istat + + real (POP_r8), dimension(:,:,:), allocatable :: & + workNorth, &! + workEast, &! + workNE, &! + HUM ! HU if no overflows; modified if overflows + +!----------------------------------------------------------------------- +! +! compute nine point operator coefficients: compute on baroclinic +! decomposition first where grid info defined and redistribute +! to barotropic distribution +! leave A0,AC in baroclinic distribution to facilitate easy +! time-dependent changes in barotropic routine +! +!----------------------------------------------------------------------- + + call POP_DistributionGet(POP_distrbClinic, errorCode, & + numLocalBlocks = numBlocksClinic) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error retrieving clinic local block count') +! activate later, when errorCode is fully supported +! return + endif + + allocate(workNorth (POP_nxBlock,POP_nyBlock,numBlocksClinic), & + workEast (POP_nxBlock,POP_nyBlock,numBlocksClinic), & + workNE (POP_nxBlock,POP_nyBlock,numBlocksClinic), & + HUM (POP_nxBlock,POP_nyBlock,numBlocksClinic), & + stat=istat) + + if (istat > 0) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error allocating temporary arrays') + call exit_POP (sigAbort,'ERROR ovf_solvers_9pt: error allocating temporary arrays') +! activate later, when errorCode is fully supported +! return + endif + + HUM(:,:,:) = HU(:,:,:) + call ovf_HU(HU,HUM) + call POP_HaloUpdate(HUM, POP_haloClinic, POP_gridHorzLocNECorner,& + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + !$OMP PARALLEL DO PRIVATE(iblock,i,j,xne,xse,xnw,xsw,yne,yse,ynw,ysw,ase,anw,asw) + do iblock = 1,numBlocksClinic + + workNorth (:,:,iblock) = 0.0_POP_r8 + workEast (:,:,iblock) = 0.0_POP_r8 + workNE (:,:,iblock) = 0.0_POP_r8 + centerWgtClinicIndep (:,:,iblock) = 0.0_POP_r8 + + do j=2,POP_nyBlock + do i=2,POP_nxBlock + + xne = 0.25_POP_r8*HUM(i ,j ,iblock)*DXUR(i ,j ,iblock)* & + DYU (i ,j ,iblock) + xse = 0.25_POP_r8*HUM(i ,j-1,iblock)*DXUR(i ,j-1,iblock)* & + DYU (i ,j-1,iblock) + xnw = 0.25_POP_r8*HUM(i-1,j ,iblock)*DXUR(i-1,j ,iblock)* & + DYU (i-1,j ,iblock) + xsw = 0.25_POP_r8*HUM(i-1,j-1,iblock)*DXUR(i-1,j-1,iblock)* & + DYU (i-1,j-1,iblock) + + yne = 0.25_POP_r8*HUM(i ,j ,iblock)*DYUR(i ,j ,iblock)* & + DXU (i ,j ,iblock) + yse = 0.25_POP_r8*HUM(i ,j-1,iblock)*DYUR(i ,j-1,iblock)* & + DXU (i ,j-1,iblock) + ynw = 0.25_POP_r8*HUM(i-1,j ,iblock)*DYUR(i-1,j ,iblock)* & + DXU (i-1,j ,iblock) + ysw = 0.25_POP_r8*HUM(i-1,j-1,iblock)*DYUR(i-1,j-1,iblock)* & + DXU (i-1,j-1,iblock) + + workNE(i,j,iblock) = xne + yne + ase = xse + yse + anw = xnw + ynw + asw = xsw + ysw + + workEast (i,j,iblock) = xne + xse - yne - yse + workNorth(i,j,iblock) = yne + ynw - xne - xnw + + centerWgtClinicIndep(i,j,iblock) = & + -(workNE(i,j,iblock) + ase + anw + asw) + + end do + end do + end do + !$OMP END PARALLEL DO + + +!----------------------------------------------------------------------- +! +! redistribute operator weights and mask to barotropic distribution +! +!----------------------------------------------------------------------- + + call POP_DistributionGet(POP_distrbTropic, errorCode, & + numLocalBlocks = numBlocksTropic) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error retrieving tropic local block count') + call exit_POP (sigAbort,'ERROR ovf_solvers_9pt: error retrieving tropic local block count') +! activate later, when errorCode is fully supported +! return + endif + + + call POP_RedistributeBlocks(btropWgtNorth, POP_distrbTropic, & + workNorth, POP_distrbClinic, errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error redistributing north operator weight') + call exit_POP (sigAbort,'ERROR ovf_solvers_9pt: error redistributing north operator weight') +! activate later, when errorCode is fully supported +! return + endif + + + call POP_RedistributeBlocks(btropWgtEast, POP_distrbTropic, & + workEast, POP_distrbClinic, errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error redistributing east operator weight') + call exit_POP (sigAbort,'ERROR ovf_solvers_9pt: error redistributing east operator weight') +! activate later, when errorCode is fully supported +! return + endif + + call POP_RedistributeBlocks(btropWgtNE, POP_distrbTropic, & + workNE, POP_distrbClinic, errorCode) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error redistributing NE operator weight') + call exit_POP (sigAbort,'ERROR ovf_solvers_9pt: error redistributing NE operator weight') +! activate later, when errorCode is fully supported +! return + endif + +!----------------------------------------------------------------------- +! +! clean up temporary arrays +! +!----------------------------------------------------------------------- + + deallocate(workNorth, workEast, workNE, HUM, stat=istat) + + if (istat > 0) then + call POP_ErrorSet(errorCode, & + 'ovf_solvers_9pt: error deallocating temp mask') + call exit_POP (sigAbort,'ERROR ovf_solvers_9pt: error deallocating temp mask') +! activate later, when errorCode is fully supported +! return + endif + + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_solvers_9pt + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_HU +! !INTERFACE: + + subroutine ovf_HU(HU,HUM) + +! !DESCRIPTION: +! Modify HU for overflows sidewalls +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + real (r8), dimension(nx_block,ny_block,max_blocks_clinic), & + intent(in) :: HU ! HU + + real (r8), dimension(nx_block,ny_block,max_blocks_clinic), & + intent(inout) :: HUM ! HUM (modified HU) + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + i,j,k,n,m,mp, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + ksrc,kent,kprd, & ! level indices + iblock ! block index + real (r8) :: & + dz_sidewall ! sidewall U-grid depth from top to ovf level + type (block) :: & + this_block ! block information for current block + logical (log_kind), parameter :: prnt = .false. + + integer (int_kind) :: ovf_id + + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_HU called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + !must have the groups initilaized + if (.not. ovf_groups%init) then + call ovf_init_groups() + end if + + do n=1, ovf_groups%numMyGroups ! each overflow + ovf_id = ovf_groups%groupIds(n) +! src + do m=1,ovf(ovf_id)%num_src ! source + ksrc = ovf(ovf_id)%loc_src(m)%k + do iblock=1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,ksrc + dz_sidewall = dz_sidewall + dz(k) + enddo + HUM(i,j,iblock) = HU(i,j,iblock) + dz_sidewall + if(prnt) then + write(stdout,10) n, & + ovf(ovf_id)%loc_src(m)%i_u,ovf(ovf_id)%loc_src(m)%j_u + 10 format(' n=',i3,' src HU adjusted at i_u j_u =',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblocks + end do ! source +! ent + do m=1,ovf(ovf_id)%num_ent ! entrainment + kent = ovf(ovf_id)%loc_ent(m)%k + do iblock=1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,kent + dz_sidewall = dz_sidewall + dz(k) + enddo + HUM(i,j,iblock) = HU(i,j,iblock) + dz_sidewall + if(prnt) then + write(stdout,20) n, & + ovf(ovf_id)%loc_ent(m)%i_u,ovf(ovf_id)%loc_ent(m)%j_u + 20 format(' n=',i3,' ent HU adjusted at i_u j_u =',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblocks + end do ! entrainment +! prd + do m=1,ovf(ovf_id)%num_prd_sets + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for each set + kprd = ovf(ovf_id)%loc_prd(m,mp)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + dz_sidewall = c0 + do k=KMU(i,j,iblock)+1,kprd + dz_sidewall = dz_sidewall + dz(k) + enddo + HUM(i,j,iblock) = HU(i,j,iblock) + dz_sidewall + if(prnt) then + write(stdout,30) n,ovf(ovf_id)%loc_prd(m,mp)%i_u, & + ovf(ovf_id)%loc_prd(m,mp)%j_u + 30 format(' n=',i3,' prd HU adjusted at i_u j_u =',2(i3,1x)) + endif + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for each set + end do ! all product sets + end do ! each overflow + +!----------------------------------------------------------------------- +!EOC + + end subroutine ovf_HU + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_UV_solution +! !INTERFACE: + + subroutine ovf_UV_solution + +! !DESCRIPTION: +! Evaluate ovf column solution for baroclinic U and V. Should be called +! BEFORE the final addition of baroclinic and barotropic velocities. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + iblock,i,j,k,n,m,mp, & ! dummy loop indices + ib,ie,jb,je, & ! local domain index boundaries + ksrc,kent,kprd ! overflow level indices + + real (r8) :: & + Uovf, & ! overflow U + Uovf_nm1, & ! overflow U at n-1 + ubar, & ! barotropic velocity + utlda(km) ! unnormalized baroclinic velocity + + type (block) :: & + this_block ! block information for current block + logical (log_kind), parameter :: prnt = .false. + + integer (int_kind) :: ovf_id + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_UV_solution called ' + call shr_sys_flush(stdout) + endif + +!----------------------------------------------------------------------- +! overflow loop +!----------------------------------------------------------------------- + !must have the groups initilaized + if (.not. ovf_groups%init) then + call ovf_init_groups() + end if + + do n=1, ovf_groups%numMyGroups ! each overflow + ovf_id = ovf_groups%groupIds(n) +! src + do m=1,ovf(ovf_id)%num_src ! source + ksrc = ovf(ovf_id)%loc_src(m)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_src(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_src(m)%i_u .eq. this_block%i_glob(i) ) then + if(prnt) then + write(stdout,10) n,ovf(ovf_id)%loc_src(m)%i_u, & + ovf(ovf_id)%loc_src(m)%j_u + 10 format(' n=',i3,' src iu ju column evaluated=',2(i3,1x)) + endif +! U + do k=1,km + utlda(k) = ovf(ovf_id)%loc_src(m)%Utlda(k) + enddo + Uovf = UVEL(i,j,ksrc,newtime,iblock) + ubar = UBTROP(i,j,newtime,iblock) + + Uovf_nm1 = UVEL(i,j,ksrc,oldtime,iblock) + call ovf_U_column(i,j,ksrc,iblock, & + Uovf,ubar,utlda,Uovf_nm1) +! V + do k=1,km + utlda(k) = ovf(ovf_id)%loc_src(m)%Vtlda(k) + enddo + Uovf = VVEL(i,j,ksrc,newtime,iblock) + ubar = VBTROP(i,j,newtime,iblock) + Uovf_nm1 = VVEL(i,j,ksrc,oldtime,iblock) + call ovf_V_column(i,j,ksrc,iblock, & + Uovf,ubar,utlda,Uovf_nm1) + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! source +! ent + do m=1,ovf(ovf_id)%num_ent ! entrainment + kent = ovf(ovf_id)%loc_ent(m)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_ent(m)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_ent(m)%i_u .eq. this_block%i_glob(i) ) then + if(prnt) then + write(stdout,20) n,ovf(ovf_id)%loc_ent(m)%i_u, & + ovf(ovf_id)%loc_ent(m)%j_u + 20 format(' n=',i3,' ent iu ju column evaluated=',2(i3,1x)) + endif +! U + do k=1,km + utlda(k) = ovf(ovf_id)%loc_ent(m)%Utlda(k) + enddo + Uovf = UVEL(i,j,kent,newtime,iblock) + ubar = UBTROP(i,j,newtime,iblock) + Uovf_nm1 = UVEL(i,j,kent,oldtime,iblock) + call ovf_U_column(i,j,kent,iblock, & + Uovf,ubar,utlda,Uovf_nm1) +! V + do k=1,km + utlda(k) = ovf(ovf_id)%loc_ent(m)%Vtlda(k) + enddo + Uovf = VVEL(i,j,kent,newtime,iblock) + ubar = VBTROP(i,j,newtime,iblock) + Uovf_nm1 = VVEL(i,j,kent,oldtime,iblock) + call ovf_V_column(i,j,kent,iblock, & + Uovf,ubar,utlda,Uovf_nm1) + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! entrainment +! prd + do m=1,ovf(ovf_id)%num_prd_sets + do mp=1,ovf(ovf_id)%num_prd(m) ! product points for each set + kprd = ovf(ovf_id)%loc_prd(m,mp)%k + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + ib = this_block%ib + ie = this_block%ie + jb = this_block%jb + je = this_block%je + do j=jb,je + if( ovf(ovf_id)%loc_prd(m,mp)%j_u .eq. this_block%j_glob(j) ) then + do i=ib,ie + if( ovf(ovf_id)%loc_prd(m,mp)%i_u .eq. this_block%i_glob(i) ) then + if(prnt) then + write(stdout,30) n,ovf(ovf_id)%loc_prd(m,mp)%i_u, & + ovf(ovf_id)%loc_prd(m,mp)%j_u + 30 format(' n=',i3,' prd iu ju column evaluated=',2(i3,1x)) + endif +! U + do k=1,km + utlda(k) = ovf(ovf_id)%loc_prd(m,mp)%Utlda(k) + enddo + Uovf = UVEL(i,j,kprd,newtime,iblock) + ubar = UBTROP(i,j,newtime,iblock) + Uovf_nm1 = UVEL(i,j,kprd,oldtime,iblock) + call ovf_U_column(i,j,kprd,iblock, & + Uovf,ubar,utlda,Uovf_nm1) +! V + do k=1,km + utlda(k) = ovf(ovf_id)%loc_prd(m,mp)%Vtlda(k) + enddo + Uovf = VVEL(i,j,kprd,newtime,iblock) + ubar = VBTROP(i,j,newtime,iblock) + Uovf_nm1 = VVEL(i,j,kprd,oldtime,iblock) + call ovf_V_column(i,j,kprd,iblock, & + Uovf,ubar,utlda,Uovf_nm1) + endif + end do ! i + endif + end do ! j + end do ! iblock + end do ! product points for each set + end do ! all product sets + end do ! each overflow + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_UV_solution + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_U_column +! !INTERFACE: + + subroutine ovf_U_column(i,j,kovf,iblock,Uovf,ubar,utlda,Uovf_nm1) + +! !DESCRIPTION: +! Evaluate ovf column solution for U baroclinic +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + integer (int_kind), & + intent(in) :: & + i, & ! local block i index on u-grid + j, & ! local block j index on u-grid + kovf, & ! k index of overflow + iblock ! block index + + real (r8), intent(in) :: & + Uovf, & ! overflow U + ubar, & ! barotropic velocity + utlda(km), & ! unnormalized baroclinic velocity + Uovf_nm1 ! overflow U at n-1 + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + k ! vertical loop index + + real (r8) :: & + uprime, & ! overflow sidewall baroclinic velocity + hu, & ! HU after accumulation of column dz + vert_sum, & ! vertical sum accumulation of utlda*dz + utlda_bar ! vertical mean of utlda + + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_U_column called ' + call shr_sys_flush(stdout) + endif + +! evaluate baroclinic normalization for the overflow column by including +! the overflow contributions along the sidewall above the overflow + +! above the topography + hu = c0 + vert_sum = c0 + do k=1,KMU(i,j,iblock) + hu = hu + dz(k) + vert_sum = vert_sum + utlda(k)*dz(k) + enddo + +! below the topography but above the overflow + uprime = -ubar + do k=KMU(i,j,iblock)+1,kovf-1 + vert_sum = vert_sum + uprime*dz(k) + enddo + +! the overflow contribution + uprime = Uovf - ubar + vert_sum = vert_sum + uprime*dz(kovf) + +! adjusted utlda_bar + utlda_bar = vert_sum/hu + +! evaluate overflow modified baroclinic velocity for the column + do k=1,KMU(i,j,iblock) + UVEL(i,j,k,newtime,iblock) = utlda(k) - utlda_bar + enddo + +! check of zero vertical sum + hu = c0 + vert_sum = c0 + do k=1,KMU(i,j,iblock) + hu = hu + dz(k) + vert_sum = vert_sum + UVEL(i,j,k,newtime,iblock)*dz(k) + end do + uprime = -ubar + do k=KMU(i,j,iblock)+1,kovf-1 + vert_sum = vert_sum + uprime*dz(k) + enddo + uprime = Uovf - ubar + vert_sum = vert_sum + uprime*dz(kovf) + vert_sum = vert_sum / hu + + if( prnt ) then + write(stdout,*) 'ovf_U_column ' + write(stdout,5) KMU(i,j,iblock),kovf,Uovf,ubar,utlda_bar,Uovf_nm1, & + vert_sum + 5 format(' kmu,kovf,Uovf ubar utlda_bar Uovf_nm1 vert_sum='/ & + 1x,2(i3,1x),2x,4(f10.5,1x),1pe11.4) + do k=1,kovf + if( k <= KMU(i,j,iblock) ) then + write(stdout,10) k,dz(k),utlda(k)-utlda_bar + 10 format(' k dz U_baroclinic =',i3,1x, & + f8.2,1x,f9.5) + else if( k > KMU(i,j,iblock) .and. k < kovf ) then + write(stdout,15) k,dz(k),-ubar + 15 format(' k dz U_baroclinic =',i3,1x, & + f8.2,1x,f9.5) + else + write(stdout,20) k,dz(k),Uovf-ubar + 20 format(' k dz U_baroclinic =',i3,1x, & + f8.2,1x,f9.5) + endif + end do + endif + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_U_column + +!*********************************************************************** +!EOP +! !IROUTINE: ovf_V_column +! !INTERFACE: + + subroutine ovf_V_column(i,j,kovf,iblock,Uovf,ubar,utlda,Uovf_nm1) + +! !DESCRIPTION: +! Evaluate ovf column solution for V baroclinic +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! input variables +!----------------------------------------------------------------------- + + integer (int_kind), & + intent(in) :: & + i, & ! local block i index on u-grid + j, & ! local block j index on u-grid + kovf, & ! k index of overflow + iblock ! block index + + real (r8), intent(in) :: & + Uovf, & ! overflow U + ubar, & ! barotropic velocity + utlda(km), & ! unnormalized baroclinic velocity + Uovf_nm1 ! overflow U at n-1 + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + + integer (int_kind) :: & + k ! vertical loop index + + real (r8) :: & + uprime, & ! overflow sidewall baroclinic velocity + hu, & ! HU after accumulation of column dz + vert_sum, & ! vertical sum accumulation of utlda*dz + utlda_bar ! vertical mean of utlda + + logical (log_kind), parameter :: prnt = .false. + + if( prnt .and. my_task == master_task ) then + write(stdout,*) 'ovf_V_column called ' + call shr_sys_flush(stdout) + endif + +! evaluate baroclinic normalization for the overflow column by including +! the overflow contributions along the sidewall above the overflow + +! above the topography + hu = c0 + vert_sum = c0 + do k=1,KMU(i,j,iblock) + hu = hu + dz(k) + vert_sum = vert_sum + utlda(k)*dz(k) + enddo + +! below the topography but above the overflow + uprime = -ubar + do k=KMU(i,j,iblock)+1,kovf-1 + vert_sum = vert_sum + uprime*dz(k) + enddo + +! the overflow contribution + uprime = Uovf - ubar + vert_sum = vert_sum + uprime*dz(kovf) + +! adjusted utlda_bar + utlda_bar = vert_sum/hu + +! evaluate overflow modified baroclinic velocity for the column + do k=1,KMU(i,j,iblock) + VVEL(i,j,k,newtime,iblock) = utlda(k) - utlda_bar + enddo + +! check of zero vertical sum + hu = c0 + vert_sum = c0 + do k=1,KMU(i,j,iblock) + hu = hu + dz(k) + vert_sum = vert_sum + VVEL(i,j,k,newtime,iblock)*dz(k) + end do + uprime = -ubar + do k=KMU(i,j,iblock)+1,kovf-1 + vert_sum = vert_sum + uprime*dz(k) + enddo + uprime = Uovf - ubar + vert_sum = vert_sum + uprime*dz(kovf) + vert_sum = vert_sum / hu + + if( prnt ) then + write(stdout,*) 'ovf_V_column ' + write(stdout,5) KMU(i,j,iblock),kovf,Uovf,ubar,utlda_bar,Uovf_nm1, & + vert_sum + 5 format(' kmu,kovf,Uovf ubar utlda_bar Uovf_nm1 vert_sum='/ & + 1x,2(i3,1x),2x,4(f10.5,1x),1pe11.4) + do k=1,kovf + if( k <= KMU(i,j,iblock) ) then + write(stdout,10) k,dz(k),utlda(k)-utlda_bar + 10 format(' k dz U_baroclinic =',i3,1x, & + f8.2,1x,f9.5) + else if( k > KMU(i,j,iblock) .and. k < kovf ) then + write(stdout,15) k,dz(k),-ubar + 15 format(' k dz U_baroclinic =',i3,1x, & + f8.2,1x,f9.5) + else + write(stdout,20) k,dz(k),Uovf-ubar + 20 format(' k dz U_baroclinic =',i3,1x, & + f8.2,1x,f9.5) + endif + end do + endif + +!---------------------------------------------------------------------- +!EOC + + end subroutine ovf_V_column + +!*********************************************************************** + + end module overflows + +!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.pop2/restart.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.pop2/restart.F90 new file mode 100644 index 0000000000..aed2ff67b8 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.pop2/restart.F90 @@ -0,0 +1,2286 @@ + +! DART note: this file started life as: +! /glade/p/cesm/cseg/collections/cesm1_2_1/models/ocn/pop2/source/restart.F90 + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + + module restart + +!BOP +! !MODULE: restart +! !DESCRIPTION: +! This module contains routins for reading and writing data necessary +! for restarting a POP simulation. +! +! !REVISION HISTORY: +! SVN:$Id: restart.F90 20992 2010-02-12 23:01:33Z njn01 $ +! +! !USES: + + use POP_KindsMod + use POP_ErrorMod + use POP_IOUnitsMod + use POP_FieldMod + use POP_GridHorzMod + use POP_HaloMod + + use domain_size + use domain + use constants, only: char_blank, field_loc_NEcorner, field_type_vector, & + field_loc_center, field_type_scalar, blank_fmt, c0, grav + use blocks, only: nx_block, ny_block, block, get_block + use prognostic, only: UBTROP, VBTROP, PSURF, GRADPX, GRADPY, UVEL, VVEL, & + PGUESS, TRACER, nt, nx_global, ny_global, km, curtime, newtime, oldtime, & + tracer_d + use broadcast, only: broadcast_scalar + use communicate, only: my_task, master_task + use operators, only: div,grad !!POPDART added by AK on Sept 21,2012 + use grid, only: sfc_layer_type, sfc_layer_varthick, CALCU, CALCT, KMU, & + KMT, HU, TAREA_R + use io, only: data_set + use io_types, only: io_field_desc, datafile, io_dim, luse_pointer_files, & + pointer_filename, stdout, construct_io_field, construct_file, & + rec_type_dbl, construct_io_dim, nml_in, nml_filename, get_unit, & + release_unit, destroy_file, add_attrib_file, destroy_io_field, & + extract_attrib_file + use time_management + use ice, only: tlast_ice, liceform, AQICE, FW_FREEZE, QFLUX + use forcing_fields, only: FW_OLD + use forcing_ap, only: ap_interp_last + use forcing_ws, only: ws_interp_last + use forcing_shf, only: shf_interp_last + use forcing_sfwf, only: sfwf_interp_last, sum_precip, precip_fact, & + ssh_initial, sal_initial + use forcing_pt_interior, only: pt_interior_interp_last + use forcing_s_interior, only: s_interior_interp_last + use exit_mod, only: sigAbort, exit_pop, flushm + use registry + use passive_tracers, only: write_restart_passive_tracers + use overflows + use overflow_type + use global_reductions !!POPDART added by AK on Sept 21,2012 + + implicit none + private + save + +! !PUBLIC MEMBER FUNCTIONS: + + public :: init_restart, & + write_restart, & + read_restart + +! !PUBLIC DATA MEMBERS: + public :: restart_fmt, & + read_restart_filename, & + lrestart_write + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! module variables +! +!----------------------------------------------------------------------- + + character (POP_charLength) :: & + restart_outfile ! restart output filename root + + character (POP_charLength) :: & + restart_fmt ! format (bin or nc) of output restart + + character (POP_charLength) :: & + read_restart_filename = 'undefined' ! file name for restart file + + character (POP_charLength) :: & + exit_string = 'undefined' ! error-exit string + + logical (POP_logical) :: & + pressure_correction, &! fix pressure for exact restart + lrestart_on, &! flag to turn restarts on/off + leven_odd_on, &! flag to turn even_odd restarts on/off + lrestart_write ! flag to determine whether restart is written + + + integer (POP_i4) :: & + even_odd_freq, &! even/odd restart files every freq steps + last_even_odd, &! last even/odd dump + restart_flag, &! time flag id for restarts + evenodd_flag, &! time flag id for even-odd restarts + out_stop_now, &! time flag id for stop_now flag + restart_cpl_ts, &! time flag id for coupled_ts time flag + restart_freq_iopt, &! restart frequency option + restart_freq, &! restart frequency + restart_start_iopt, &! start after option + restart_start ! start regular restart writes after restart_start + + integer (POP_i4), parameter :: & + even = 0, &! integer for which even/odd dump + odd = 1 + + !*** field descriptors for all output fields + + type (io_field_desc) :: & + UBTROP_CUR, UBTROP_OLD, &! barotropic U at current, old times + VBTROP_CUR, VBTROP_OLD, &! barotropic U at current, old times + PSURF_CUR, PSURF_OLD, &! surface press at current, old times + GRADPX_CUR, GRADPX_OLD, &! sfc press gradient in x at both times + GRADPY_CUR, GRADPY_OLD, &! sfc press gradient in y at both times + PGUESSd, &! guess for next surface pressure + FW_OLDd, &! freshwater input at old time + FW_FREEZEd, &! water flux at T points due to frazil ice formation + AQICEd, &! accumulated ice melt/freeze + QFLUXd, &! internal ocn heat flux due to ice formation + UVEL_CUR, UVEL_OLD, &! U at current, old times + VVEL_CUR, VVEL_OLD ! V at current, old times + + type (io_field_desc), dimension(nt) :: & + TRACER_CUR, TRACER_OLD ! tracers at current, old times + +!----------------------------------------------------------------------- +! ccsm coupling variable +!----------------------------------------------------------------------- + integer (POP_i4) :: & + cpl_write_restart ! flag id for restart-file signal from cpl + + +!----------------------------------------------------------------------- +! +! scalar data to be written/read from restart file +! +! runid, +! iyear, imonth, iday, ihour, iminute, isecond +! iyear0, imonth0, iday0, ihour0, iminute0, isecond0 +! dtt, iday_of_year, iday_of_year_last +! elapsed_days, elapsed_months, elapsed_years +! elapsed_days_this_year +! seconds_this_day, seconds_this_day_next +! seconds_this_year, seconds_this_year_next +! nsteps_total +! eod, eod_last, eom, eom_last, eom_next, eoy, eoy_last +! midnight_last, adjust_year_next, newday, newhour +! leapyear, days_in_year, days_in_prior_year +! seconds_in_year, hours_in_year +! tlast_ice +! lcoupled_ts +! shf_interp_last, sfwf_interp_last, ws_interp_last +! ap_interp_last, pt_interior_interp_last +! s_interior_interp_last +! sal_initial, sum_precip, precip_fact, ssh_initial +! +!----------------------------------------------------------------------- + +!EOC +!*********************************************************************** + + contains + +!*********************************************************************** +!BOP +! !IROUTINE: read_restart +! !INTERFACE: + + subroutine read_restart(in_filename,lccsm_branch,lccsm_hybrid, & + in_restart_fmt, errorCode, ldata_assim ) !POPDART added by AK on Sept 21,2012 + +! !DESCRIPTION: +! This routine reads restart data from a file. +! +! Prognostic fields read are: +! UBTROP,VBTROP : barotropic velocities +! PSURF : surface pressure +! GRADPX,GRADPY : surface pressure gradient +! PGUESS : next guess for pressure +! UVEL,VVEL : 3d velocities +! TRACER : 3d tracers +! +! !REVISION HISTORY: +! same as module + +! !INPUT PARAMETERS: + + character (*), intent(in) :: & + in_filename, &! filename of restart file + in_restart_fmt ! format of restart file (bin,nc) + + logical (POP_logical), intent(in) :: & + lccsm_branch ,&! flag if ccsm branch initialization + lccsm_hybrid ! flag if ccsm hybrid initialization + + logical (POP_logical), intent(in), optional :: & + ldata_assim ! flag if continuation after DART data assimilation !POPDART added by AK on Sept 21,2012 + +! !OUTPUT PARAMETERS: + + integer (POP_i4), intent(out) :: & + errorCode ! returned error code + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (POP_i4) :: & + n, k, &! dummy counters + nu, &! i/o unit for pointer file reads + iblock, &! local block index + cindx,cindx2 ! indices into character strings + + real (POP_r8), dimension(nx_block,ny_block) :: & + WORK1,WORK2 ! work space for pressure correction + + character (POP_charLength) :: & + restart_pointer_file, &! file name for restart pointer file + short_name, long_name ! tracer name temporaries + + logical (POP_logical) :: & + lcoupled_ts ! flag to check whether coupled time step + + type (block) :: & + this_block ! block information for current block + + type (datafile) :: & + restart_file ! io file descriptor + + type (io_dim) :: & + i_dim, j_dim, &! dimension descriptors for horiz dims + k_dim ! dimension descriptor for vertical levels + +!----------------------------------------------------------------------- +! +! if pointer files are used, pointer file must be read to get +! actual filenames - skip this for branch initialization +! +!----------------------------------------------------------------------- + + errorCode = POP_Success + + read_restart_filename = char_blank + restart_pointer_file = char_blank + + if (luse_pointer_files) then + call get_unit(nu) + if (my_task == master_task) then + restart_pointer_file = pointer_filename + cindx = len_trim(pointer_filename) + 1 + cindx2= cindx + 7 + restart_pointer_file(cindx:cindx2) = '.restart' + write(stdout,*) 'Reading pointer file: ', & + trim(restart_pointer_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + open(nu, file=trim(restart_pointer_file), form='formatted', & + status='old') + read(nu,'(a)') read_restart_filename + close(nu) + endif + call release_unit(nu) + + call broadcast_scalar(read_restart_filename, master_task) + +!----------------------------------------------------------------------- +! +! otherwise use input filename +! +!----------------------------------------------------------------------- + + else + cindx2 = len_trim(in_filename) + read_restart_filename(1:cindx2) = trim(in_filename) + endif + +!----------------------------------------------------------------------- +! +! create input file and define scalars with default values +! +!----------------------------------------------------------------------- + + restart_file = construct_file(in_restart_fmt, & + full_name=trim(read_restart_filename), & + record_length=rec_type_dbl, & + recl_words=nx_global*ny_global) + + !*** set some defaults for namelist variables not initialized + !*** under some options + + tlast_ice = c0 + lcoupled_ts = .false. + + !*** add defaults as file attributes + + call add_attrib_file(restart_file, 'runid', runid ) + call add_attrib_file(restart_file, 'iyear', iyear ) + call add_attrib_file(restart_file, 'imonth', imonth ) + call add_attrib_file(restart_file, 'iday', iday ) + call add_attrib_file(restart_file, 'ihour', ihour ) + call add_attrib_file(restart_file, 'iminute', iminute ) + call add_attrib_file(restart_file, 'isecond', isecond ) + call add_attrib_file(restart_file, 'iyear0', iyear0 ) + call add_attrib_file(restart_file, 'imonth0', imonth0 ) + call add_attrib_file(restart_file, 'iday0', iday0 ) + call add_attrib_file(restart_file, 'ihour0', ihour0 ) + call add_attrib_file(restart_file, 'iminute0', iminute0) + call add_attrib_file(restart_file, 'isecond0', isecond0) + call add_attrib_file(restart_file, 'dtt', dtt ) + call add_attrib_file(restart_file, 'iday_of_year', iday_of_year) + call add_attrib_file(restart_file, 'iday_of_year_last', & + iday_of_year_last) + call add_attrib_file(restart_file, 'elapsed_days', elapsed_days) + call add_attrib_file(restart_file, 'elapsed_months', elapsed_months) + call add_attrib_file(restart_file, 'elapsed_years', elapsed_years) + call add_attrib_file(restart_file, 'elapsed_days_this_year', & + elapsed_days_this_year) + call add_attrib_file(restart_file, 'seconds_this_day', & + seconds_this_day) + call add_attrib_file(restart_file, 'seconds_this_day_next', & + seconds_this_day_next) + call add_attrib_file(restart_file, 'seconds_this_year', & + seconds_this_year) + call add_attrib_file(restart_file, 'seconds_this_year_next', & + seconds_this_year_next) + call add_attrib_file(restart_file, 'nsteps_total' , nsteps_total) + call add_attrib_file(restart_file, 'eod' , eod ) + call add_attrib_file(restart_file, 'eod_last', eod_last) + call add_attrib_file(restart_file, 'eom' , eom ) + call add_attrib_file(restart_file, 'eom_last', eom_last) + call add_attrib_file(restart_file, 'eom_next', eom_next) + call add_attrib_file(restart_file, 'eoy' , eoy ) + call add_attrib_file(restart_file, 'eoy_last', eoy_last) + call add_attrib_file(restart_file, 'midnight_last', midnight_last) + call add_attrib_file(restart_file, 'adjust_year_next', & + adjust_year_next) + call add_attrib_file(restart_file, 'newday' , newday ) + call add_attrib_file(restart_file, 'newhour', newhour ) + call add_attrib_file(restart_file, 'leapyear',leapyear) + call add_attrib_file(restart_file, 'days_in_year', days_in_year) + call add_attrib_file(restart_file, 'days_in_prior_year', & + days_in_prior_year) + call add_attrib_file(restart_file, 'seconds_in_year', & + seconds_in_year) + call add_attrib_file(restart_file, 'hours_in_year', hours_in_year) + call add_attrib_file(restart_file, 'tlast_ice', tlast_ice ) + call add_attrib_file(restart_file, 'lcoupled_ts', lcoupled_ts) + call add_attrib_file(restart_file, 'shf_interp_last', & + shf_interp_last) + call add_attrib_file(restart_file, 'sfwf_interp_last', & + sfwf_interp_last) + call add_attrib_file(restart_file, 'ws_interp_last', & + ws_interp_last) + call add_attrib_file(restart_file, 'ap_interp_last', & + ap_interp_last) + call add_attrib_file(restart_file, 'pt_interior_interp_last', & + pt_interior_interp_last) + call add_attrib_file(restart_file, 's_interior_interp_last', & + s_interior_interp_last) + call add_attrib_file(restart_file, 'sum_precip' , sum_precip ) + call add_attrib_file(restart_file, 'precip_fact', precip_fact) + call add_attrib_file(restart_file, 'ssh_initial', ssh_initial) + + short_name = char_blank + do k=1,km + write(short_name,'(a11,i3.3)') 'sal_initial',k + call add_attrib_file(restart_file,trim(short_name),sal_initial(k)) + end do + +!----------------------------------------------------------------------- +! +! open a file and extract scalars as file attributes +! do not extract if this is a ccsm branch initialization - values are set elsewhere +! +!----------------------------------------------------------------------- + + !*** open file and read attributes + + call data_set(restart_file, 'open_read') + + !*** extract scalars if not a ccsm branch initialization + + if (.not. lccsm_branch .and. .not. lccsm_hybrid) then + call extract_attrib_file(restart_file, 'runid', runid ) + endif + + + if (.not. lccsm_hybrid) then + call extract_attrib_file(restart_file, 'iyear', iyear ) + call extract_attrib_file(restart_file, 'imonth', imonth ) + call extract_attrib_file(restart_file, 'iday', iday ) + call extract_attrib_file(restart_file, 'ihour', ihour ) + call extract_attrib_file(restart_file, 'iminute', iminute ) + call extract_attrib_file(restart_file, 'isecond', isecond ) + call extract_attrib_file(restart_file, 'iyear0', iyear0 ) + call extract_attrib_file(restart_file, 'imonth0', imonth0 ) + call extract_attrib_file(restart_file, 'iday0', iday0 ) + call extract_attrib_file(restart_file, 'ihour0', ihour0 ) + call extract_attrib_file(restart_file, 'iminute0', iminute0) + call extract_attrib_file(restart_file, 'isecond0', isecond0) + call extract_attrib_file(restart_file, 'dtt', dtt ) + call extract_attrib_file(restart_file, 'iday_of_year', & + iday_of_year) + call extract_attrib_file(restart_file, 'iday_of_year_last',& + iday_of_year_last) + call extract_attrib_file(restart_file, 'elapsed_days', & + elapsed_days) + call extract_attrib_file(restart_file, 'elapsed_months', & + elapsed_months) + call extract_attrib_file(restart_file, 'elapsed_years', & + elapsed_years) + call extract_attrib_file(restart_file, 'elapsed_days_this_year', & + elapsed_days_this_year) + call extract_attrib_file(restart_file, 'seconds_this_day', & + seconds_this_day) + call extract_attrib_file(restart_file, 'seconds_this_day_next', & + seconds_this_day_next) + call extract_attrib_file(restart_file, 'seconds_this_year', & + seconds_this_year) + call extract_attrib_file(restart_file, 'seconds_this_year_next', & + seconds_this_year_next) + call extract_attrib_file(restart_file, 'nsteps_total', & + nsteps_total) + call extract_attrib_file(restart_file, 'eod' , eod ) + call extract_attrib_file(restart_file, 'eod_last', eod_last) + call extract_attrib_file(restart_file, 'eom' , eom ) + call extract_attrib_file(restart_file, 'eom_last', eom_last) + call extract_attrib_file(restart_file, 'eom_next', eom_next) + call extract_attrib_file(restart_file, 'eoy' , eoy ) + call extract_attrib_file(restart_file, 'eoy_last', eoy_last) + call extract_attrib_file(restart_file, 'midnight_last', & + midnight_last) + call extract_attrib_file(restart_file, 'adjust_year_next', & + adjust_year_next) + call extract_attrib_file(restart_file, 'newday' , newday ) + call extract_attrib_file(restart_file, 'newhour', newhour ) + call extract_attrib_file(restart_file, 'leapyear',leapyear) + call extract_attrib_file(restart_file, 'days_in_year', & + days_in_year) + call extract_attrib_file(restart_file, 'days_in_prior_year',& + days_in_prior_year) + call extract_attrib_file(restart_file, 'seconds_in_year', & + seconds_in_year) + call extract_attrib_file(restart_file, 'hours_in_year', & + hours_in_year) + call extract_attrib_file(restart_file, 'tlast_ice', tlast_ice ) + endif ! .not. lccsm_hybrid + + + call extract_attrib_file(restart_file, 'lcoupled_ts', & + lcoupled_ts) + + if (.not. lccsm_hybrid) then + call extract_attrib_file(restart_file, 'shf_interp_last', & + shf_interp_last) + call extract_attrib_file(restart_file, 'sfwf_interp_last', & + sfwf_interp_last) + call extract_attrib_file(restart_file, 'ws_interp_last', & + ws_interp_last) + call extract_attrib_file(restart_file, 'ap_interp_last', & + ap_interp_last) + call extract_attrib_file(restart_file, 'pt_interior_interp_last',& + pt_interior_interp_last) + call extract_attrib_file(restart_file, 's_interior_interp_last', & + s_interior_interp_last) + call extract_attrib_file(restart_file, 'sum_precip' , sum_precip ) + call extract_attrib_file(restart_file, 'precip_fact', precip_fact) + call extract_attrib_file(restart_file, 'ssh_initial', ssh_initial) + + + short_name = char_blank + do k=1,km + write(short_name,'(a11,i3.3)') 'sal_initial',k + call extract_attrib_file(restart_file, trim(short_name), & + sal_initial(k)) + end do + + call int_to_char(4, iyear,cyear) + call int_to_char(2, imonth,cmonth) + call int_to_char(2, iday,cday) + cmonth3 = month3_all(imonth) + + !*** set old value for the time flag 'coupled_ts' + + if (lcoupled_ts) then + call register_string('coupled_ts_last_true') + ! coupled_ts will be initialized accordingly in pop_init_coupled + endif + + endif ! .not. lccsm_hybrid + +!----------------------------------------------------------------------- +! +! define all fields to be read +! +!----------------------------------------------------------------------- + + !*** define dimensions + + i_dim = construct_io_dim('i', nx_global) + j_dim = construct_io_dim('j', ny_global) + k_dim = construct_io_dim('k', km) + + UBTROP_CUR = construct_io_field('UBTROP_CUR', dim1=i_dim, dim2=j_dim, & + long_name='U barotropic velocity at current time', & + units ='cm/s', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =UBTROP(:,:,curtime,:)) + call data_set (restart_file, 'define', UBTROP_CUR) + + UBTROP_OLD = construct_io_field('UBTROP_OLD', dim1=i_dim, dim2=j_dim, & + long_name='U barotropic velocity at old time', & + units ='cm/s', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =UBTROP(:,:,oldtime,:)) + call data_set (restart_file, 'define', UBTROP_OLD) + + VBTROP_CUR = construct_io_field('VBTROP_CUR', dim1=i_dim, dim2=j_dim, & + long_name='V barotropic velocity at current time', & + units ='cm/s', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =VBTROP(:,:,curtime,:)) + call data_set (restart_file, 'define', VBTROP_CUR) + + VBTROP_OLD = construct_io_field('VBTROP_OLD', dim1=i_dim, dim2=j_dim, & + long_name='V barotropic velocity at old time', & + units ='cm/s', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =VBTROP(:,:,oldtime,:)) + call data_set (restart_file, 'define', VBTROP_OLD) + + PSURF_CUR = construct_io_field('PSURF_CUR', dim1=i_dim, dim2=j_dim, & + long_name='surface pressure at current time', & + units ='dyne/cm2', grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array =PSURF(:,:,curtime,:)) + call data_set (restart_file, 'define', PSURF_CUR) + + PSURF_OLD = construct_io_field('PSURF_OLD', dim1=i_dim, dim2=j_dim, & + long_name='surface pressure at old time', & + units ='dyne/cm2', grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array =PSURF(:,:,oldtime,:)) + call data_set (restart_file, 'define', PSURF_OLD) + + GRADPX_CUR = construct_io_field('GRADPX_CUR', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in x at current time',& + units ='dyne/cm3', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =GRADPX(:,:,curtime,:)) + call data_set (restart_file, 'define', GRADPX_CUR) + + GRADPX_OLD = construct_io_field('GRADPX_OLD', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in x at old time', & + units ='dyne/cm3', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =GRADPX(:,:,oldtime,:)) + call data_set (restart_file, 'define', GRADPX_OLD) + + GRADPY_CUR = construct_io_field('GRADPY_CUR', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in y at current time',& + units ='dyne/cm3', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =GRADPY(:,:,curtime,:)) + call data_set (restart_file, 'define', GRADPY_CUR) + + GRADPY_OLD = construct_io_field('GRADPY_OLD', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in y at old time', & + units ='dyne/cm3', grid_loc ='2220', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d2d_array =GRADPY(:,:,oldtime,:)) + call data_set (restart_file, 'define', GRADPY_OLD) + + PGUESSd = construct_io_field('PGUESS', dim1=i_dim, dim2=j_dim, & + long_name='guess for sfc pressure at new time', & + units ='dyne/cm2', grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array =PGUESS) + call data_set (restart_file, 'define', PGUESSd) + + if (sfc_layer_type == sfc_layer_varthick) then + FW_OLDd = construct_io_field('FW_OLD', dim1=i_dim, dim2=j_dim, & + long_name='fresh water input at old time', & + grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array = FW_OLD) + call data_set (restart_file, 'define', FW_OLDd) + FW_FREEZEd = construct_io_field('FW_FREEZE', dim1=i_dim, dim2=j_dim, & + long_name='water flux due to frazil ice formation',& + grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array = FW_FREEZE) + call data_set (restart_file, 'define', FW_FREEZEd) + endif + + if (liceform) then + if (lcoupled_ts) then + QFLUXd = construct_io_field('QFLUX', dim1=i_dim, dim2=j_dim, & + long_name='Internal Ocean Heat Flux Due to Ice Formation',& + grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array = QFLUX) + call data_set (restart_file, 'define', QFLUXd) + else + AQICEd = construct_io_field('AQICE', dim1=i_dim, dim2=j_dim, & + long_name='accumulated ice melt/heat', & + grid_loc ='2110', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d2d_array = AQICE) + call data_set (restart_file, 'define', AQICEd) + endif + endif + + UVEL_CUR = construct_io_field('UVEL_CUR', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='U velocity at current time', & + units ='cm/s', & + grid_loc ='3221', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d3d_array = UVEL(:,:,:,curtime,:)) + call data_set (restart_file, 'define', UVEL_CUR) + + + UVEL_OLD = construct_io_field('UVEL_OLD', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='U velocity at old time', & + units ='cm/s', & + grid_loc ='3221', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d3d_array = UVEL(:,:,:,oldtime,:)) + call data_set (restart_file, 'define', UVEL_OLD) + + VVEL_CUR = construct_io_field('VVEL_CUR', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='V velocity at current time', & + units ='cm/s', & + grid_loc ='3221', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d3d_array = VVEL(:,:,:,curtime,:)) + call data_set (restart_file, 'define', VVEL_CUR) + + VVEL_OLD = construct_io_field('VVEL_OLD', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='V velocity at old time', & + units ='cm/s', & + grid_loc ='3221', & + field_loc = field_loc_NEcorner, & + field_type = field_type_vector, & + d3d_array = VVEL(:,:,:,oldtime,:)) + call data_set (restart_file, 'define', VVEL_OLD) + + do n=1,2 + short_name = char_blank + short_name = trim(tracer_d(n)%short_name)/& + &/'_CUR' + long_name = char_blank + long_name = trim(tracer_d(n)%long_name)/& + &/' at current time' + TRACER_CUR(n) = construct_io_field(trim(short_name), & + dim1=i_dim, dim2=j_dim, dim3=k_dim, & + long_name=trim(long_name), & + units =trim(tracer_d(n)%units), & + grid_loc ='3111', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d3d_array = TRACER(:,:,:,n,curtime,:)) + call data_set (restart_file, 'define', TRACER_CUR(n)) + end do + + + do n=1,2 + + short_name = char_blank + short_name = trim(tracer_d(n)%short_name)/& + &/'_OLD' + long_name = char_blank + long_name = trim(tracer_d(n)%long_name)/& + &/' at old time' + + TRACER_OLD(n) = construct_io_field(trim(short_name), & + dim1=i_dim, dim2=j_dim, dim3=k_dim, & + long_name=trim(long_name), & + units =trim(tracer_d(n)%units), & + grid_loc ='3111', & + field_loc = field_loc_center, & + field_type = field_type_scalar, & + d3d_array = TRACER(:,:,:,n,oldtime,:)) + + call data_set (restart_file, 'define', TRACER_OLD(n)) + end do + +!----------------------------------------------------------------------- +! +! now we actually read each field +! after reading, get rid of io field descriptors and close file +! +!----------------------------------------------------------------------- + + call data_set (restart_file, 'read', UBTROP_CUR) + call data_set (restart_file, 'read', UBTROP_OLD) + call data_set (restart_file, 'read', VBTROP_CUR) + call data_set (restart_file, 'read', VBTROP_OLD) + call data_set (restart_file, 'read', PSURF_CUR) + call data_set (restart_file, 'read', PSURF_OLD) + call data_set (restart_file, 'read', GRADPX_CUR) + call data_set (restart_file, 'read', GRADPX_OLD) + call data_set (restart_file, 'read', GRADPY_CUR) + call data_set (restart_file, 'read', GRADPY_OLD) + call data_set (restart_file, 'read', PGUESSd) + + if (sfc_layer_type == sfc_layer_varthick) then + call data_set (restart_file, 'read', FW_OLDd) + call data_set (restart_file, 'read', FW_FREEZEd) + endif + if (liceform) then + if (lcoupled_ts) then + call data_set (restart_file, 'read', QFLUXd) + else + call data_set (restart_file, 'read', AQICEd) + endif + endif + + call data_set (restart_file, 'read', UVEL_CUR) + call data_set (restart_file, 'read', UVEL_OLD) + call data_set (restart_file, 'read', VVEL_CUR) + call data_set (restart_file, 'read', VVEL_OLD) + + do n=1,2 + call data_set (restart_file, 'read', TRACER_CUR(n)) + call data_set (restart_file, 'read', TRACER_OLD(n)) + end do + + call destroy_io_field (UBTROP_CUR) + call destroy_io_field (UBTROP_OLD) + call destroy_io_field (VBTROP_CUR) + call destroy_io_field (VBTROP_OLD) + call destroy_io_field (PSURF_CUR) + call destroy_io_field (PSURF_OLD) + call destroy_io_field (GRADPX_CUR) + call destroy_io_field (GRADPX_OLD) + call destroy_io_field (GRADPY_CUR) + call destroy_io_field (GRADPY_OLD) + call destroy_io_field (PGUESSd) + + if (sfc_layer_type == sfc_layer_varthick) then + call destroy_io_field (FW_OLDd) + call destroy_io_field (FW_FREEZEd) + endif + if (liceform) then + if (lcoupled_ts) then + call destroy_io_field (QFLUXd) + else + call destroy_io_field (AQICEd) + endif + endif + + call destroy_io_field (UVEL_CUR) + call destroy_io_field (UVEL_OLD) + call destroy_io_field (VVEL_CUR) + call destroy_io_field (VVEL_OLD) + do n=1,2 + call destroy_io_field (TRACER_CUR(n)) + call destroy_io_field (TRACER_OLD(n)) + end do + + call data_set (restart_file, 'close') + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,*) ' file read: ', trim(read_restart_filename) + endif + + call destroy_file(restart_file) + +!----------------------------------------------------------------------- +! +! zero prognostic variables at land points +! +!----------------------------------------------------------------------- + + do iblock = 1,nblocks_clinic + + this_block = get_block(blocks_clinic(iblock),iblock) + + where (.not. CALCU(:,:,iblock)) + UBTROP(:,:,curtime,iblock) = c0 + VBTROP(:,:,curtime,iblock) = c0 + GRADPX(:,:,curtime,iblock) = c0 + GRADPY(:,:,curtime,iblock) = c0 + UBTROP(:,:,oldtime,iblock) = c0 + VBTROP(:,:,oldtime,iblock) = c0 + GRADPX(:,:,oldtime,iblock) = c0 + GRADPY(:,:,oldtime,iblock) = c0 + endwhere + + where (.not. CALCT(:,:,iblock)) + PSURF(:,:,curtime,iblock) = c0 + PSURF(:,:,oldtime,iblock) = c0 + PGUESS(:,:,iblock) = c0 + endwhere + + if (liceform) then + if (lcoupled_ts) then + where (.not. CALCT(:,:,iblock)) + QFLUX(:,:,iblock) = c0 + endwhere + else + where (.not. CALCT(:,:,iblock)) + AQICE(:,:,iblock) = c0 + endwhere + endif + endif + + if (sfc_layer_type == sfc_layer_varthick) then + where (.not. CALCT(:,:,iblock)) + FW_OLD (:,:,iblock) = c0 + FW_FREEZE(:,:,iblock) = c0 + endwhere + endif + + if( overflows_on .and. overflows_interactive & + .and. overflows_restart_type /= 'ccsm_startup' ) then + ! Do not set sidewall velocities to zero when overflows + ! on and interactive; otherwise, valid overflow velocities + ! will be lost + else + do k = 1,km + where (k > KMU(:,:,iblock)) + UVEL(:,:,k,curtime,iblock) = c0 + VVEL(:,:,k,curtime,iblock) = c0 + endwhere + enddo + endif + + do n = 1,2 + do k = 1,km + where (k > KMT(:,:,iblock)) + TRACER(:,:,k,n,curtime,iblock) = c0 + TRACER(:,:,k,n,oldtime,iblock) = c0 + endwhere + enddo + enddo + +!----------------------------------------------------------------------- +! +! reset PSURF(oldtime) to eliminate error in barotropic continuity +! eqn due to (possible) use of different timestep after restart +! +! NOTE: use pressure_correction = .false. for exact restart +! +!----------------------------------------------------------------------- + + if (pressure_correction) then + + WORK1 = HU(:,:,iblock)*UBTROP(:,:,curtime,iblock) + WORK2 = HU(:,:,iblock)*VBTROP(:,:,curtime,iblock) + + !*** use PSURF(oldtime) as temp + call div(1, PSURF(:,:,oldtime,iblock),WORK1,WORK2,this_block) + + PSURF(:,:,oldtime,iblock) = PSURF(:,:,curtime,iblock) + & + grav*dtp*PSURF(:,:,oldtime,iblock)* & + TAREA_R(:,:,iblock) + + endif + end do !block loop + + if (pressure_correction) then + call POP_HaloUpdate(PSURF(:,:,oldtime,:), POP_haloClinic, & + POP_gridHorzLocCenter, POP_fieldKindScalar, & + errorCode, fillValue = 0.0_POP_r8) + + if (errorCode /= POP_Success) then + call POP_ErrorSet(errorCode, & + 'read_restart: error updating sfc pressure halo') + return + endif + endif + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + + call POP_HaloUpdate(UBTROP, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(VBTROP, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(UVEL, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(VVEL, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(TRACER(:,:,:,:,curtime,:), & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(TRACER(:,:,:,:,newtime,:), & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(GRADPX, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(GRADPY, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(PSURF, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(PGUESS, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + if (sfc_layer_type == sfc_layer_varthick) then + call POP_HaloUpdate(FW_OLD, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(FW_FREEZE, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + if (liceform) then + if (lcoupled_ts) then + call POP_HaloUpdate(QFLUX, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + else + call POP_HaloUpdate(AQICE, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + endif + endif + endif + +!****POPDART added by AK on Sept 21,2012 + +if (present(ldata_assim)) then + if (ldata_assim) then + if (my_task == master_task) then + write(stdout,*) 'read_restart: calling DART_modify_restart because ldata_assim = ',ldata_assim + call POP_IOUnitsFlush(POP_stdout) + call POP_IOUnitsFlush(stdout) + endif + call DART_modify_restart + endif +else + if (my_task == master_task) then + write(stdout,*) 'read_restart: ldata_assim not present.' + endif +endif + +!************************** + +!----------------------------------------------------------------------- +!EOC + + end subroutine read_restart + +!!***POPDART added by AK on Sept 21,2012 +!*********************************************************************** +!BOP +! !IROUTINE: DART_modify_restart +! !INTERFACE: + + subroutine DART_modify_restart + +! !DESCRIPTION: +! This routine modifies POP restart variables as needed +! when initializing POP from restart files which are altered by +! the DART data assimilation code (init_ts_suboption == 'data_assim'). +! +! !REVISION HISTORY: +! same as module +! +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + integer (POP_i4) :: & + i,j, &! dummy indices for horizontal directions + n,k, &! dummy indices for vertical level, tracer + iblock ! counter for block loops + + real (POP_r8), dimension(nx_block,ny_block) :: & + WORK1,WORK2 ! local work space, single-block + + real (POP_r8), dimension(nx_block,ny_block,max_blocks_clinic) :: & + WORK3, WORK4 ! local work space, multi-block + + real (POP_r8) :: & + psurf_hor_ave, &! area-weighted mean of PSURF + psurf_hor_area, &! total area of PSURF + psurf_mean ! mean of PSURF + + type (block) :: & + this_block ! block information for current block + + integer (POP_i4) :: & + errorCode ! returned error code + + errorCode = POP_Success +!----------------------------------------------------------------------- +! +! recalculate UBTROP_CUR and VBTROP_CUR as vertical integrals +! of UVEL_CUR and VVEL_CUR +! +! !!!NEEDS MODS FOR OVERFLOWS!!! +! +!----------------------------------------------------------------------- + WORK3 = c0 ! initialize sums + WORK4 = c0 + + if (partial_bottom_cells) then + do k = 1,km + WORK3 = WORK3 + UVEL(:,:,k,curtime,:)*DZU(:,:,k,:) + WORK4 = WORK4 + VVEL(:,:,k,curtime,:)*DZU(:,:,k,:) + enddo + else + do k = 1,km + WORK3 = WORK3 + UVEL(:,:,k,curtime,:)*dz(k) + WORK4 = WORK4 + VVEL(:,:,k,curtime,:)*dz(k) + enddo + endif + + UBTROP(:,:,curtime,:) = WORK3*HUR ! normalize by dividing by depth + VBTROP(:,:,curtime,:) = WORK4*HUR ! normalize by dividing by depth + +!----------------------------------------------------------------------- +! +! ensure zero horizontal mean PSURF_CUR, seperately in marginal seas +! and open ocean. +! +!----------------------------------------------------------------------- + do n = 0,num_regions + WORK3 = c0 + WORK4 = c0 + if (n.eq.0) then + WORK3 = merge(TAREA*PSURF(:,:,curtime,:),c0, REGION_MASK > 0) + WORK4 = merge(TAREA,c0, REGION_MASK > 0) + else + if (region_info(n)%marginal_sea) then + WORK3 = merge(TAREA*PSURF(:,:,curtime,:), c0, & + REGION_MASK == region_info(n)%number) + WORK4 = merge(TAREA, c0, & + REGION_MASK == region_info(n)%number) + endif + endif + + psurf_hor_ave = global_sum(WORK3, distrb_clinic, field_loc_center) + psurf_hor_area = global_sum(WORK4, distrb_clinic, field_loc_center) + if (psurf_hor_area > c0) then + psurf_mean = psurf_hor_ave/psurf_hor_area + else + psurf_mean = c0 + endif + + if (n.eq.0) then + if (my_task == master_task) then + write(stdout,*)'(DART_modify_restart): region_id = ',0, & + ' psurf_mean = ', psurf_mean + end if + else + if (my_task == master_task) then + write(stdout,*)'(DART_modify_restart): region_id = ', & + region_info(n)%number, ' psurf_mean = ', psurf_mean + endif + endif + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + + where (WORK4 > c0) + PSURF(:,:,curtime,:) = PSURF(:,:,curtime,:) - psurf_mean + endwhere + + enddo ! n loop + +!----------------------------------------------------------------------- +! +! recompute GRADPX_CUR and GRADPY_CUR using new PSURF_CUR +! +!----------------------------------------------------------------------- + do iblock = 1,nblocks_clinic + this_block = get_block(blocks_clinic(iblock),iblock) + + call grad(1,GRADPX(:,:,curtime,iblock), & + GRADPY(:,:,curtime,iblock), & + PSURF(:,:,curtime,iblock),this_block) + enddo ! block loop + +!----------------------------------------------------------------------- +! +! reset PGUESS +! +!----------------------------------------------------------------------- + do iblock = 1,nblocks_clinic + + PGUESS(:,:,iblock) = PSURF(:,:,curtime,iblock) + + enddo ! block loop + +!----------------------------------------------------------------------- +! +! redo Halo Updates +! +!----------------------------------------------------------------------- + + call POP_HaloUpdate(PGUESS, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(UBTROP, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(VBTROP, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(GRADPX, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(GRADPY, & + POP_haloClinic, & + POP_gridHorzLocNECorner, & + POP_fieldKindVector, errorCode, & + fillValue = 0.0_POP_r8) + + call POP_HaloUpdate(PSURF, & + POP_haloClinic, & + POP_gridHorzLocCenter, & + POP_fieldKindScalar, errorCode, & + fillValue = 0.0_POP_r8) + +!----------------------------------------------------------------------- +! +! reset OLD to CUR +! +!----------------------------------------------------------------------- + do iblock = 1,nblocks_clinic + + UBTROP(:,:,oldtime,iblock) = UBTROP(:,:,curtime,iblock) + VBTROP(:,:,oldtime,iblock) = VBTROP(:,:,curtime,iblock) + PSURF(:,:,oldtime,iblock) = PSURF(:,:,curtime,iblock) + GRADPX(:,:,oldtime,iblock) = GRADPX(:,:,curtime,iblock) + GRADPY(:,:,oldtime,iblock) = GRADPY(:,:,curtime,iblock) + do k = 1,km + UVEL(:,:,k,oldtime,iblock) = UVEL(:,:,k,curtime,iblock) + VVEL(:,:,k,oldtime,iblock) = VVEL(:,:,k,curtime,iblock) + do n = 1,2 + TRACER(:,:,k,n,oldtime,iblock) = TRACER(:,:,k,n,curtime,iblock) + enddo + enddo + + enddo ! block loop + +!----------------------------------------------------------------------- +!EOC + + end subroutine DART_modify_restart + + + + +!*********************************************************************** +!BOP +! !IROUTINE: write_restart +! !INTERFACE: + + subroutine write_restart(restart_type) + +! !DESCRIPTION: +! This routine writes all the data necessary for restarting a POP +! simulation if it is determined that the time has come to write +! the data. It also returns the type of restart that was written +! so that the tavg module can determine whether it need to write +! a restart file for tavg fields. +! +! !REVISION HISTORY: +! same as module +! +! !OUTPUT PARAMETERS: + + character(POP_charLength), intent(out) :: & + restart_type ! type of restart file written if any + ! possible values are: none,restart,even,odd,end + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables +! +!----------------------------------------------------------------------- + + character (POP_charLength) :: & + file_suffix ! suffix to append to root filename + + integer (POP_i4) :: & + k, n, &! dummy counters + nu ! i/o unit for pointer file writes + + character (POP_charLength) :: & + write_restart_filename, &! modified file name for restart file + restart_pointer_file, &! file name for restart pointer file + short_name, &! temporary for short name for io fields + long_name ! temporary for long name for io fields + + logical (POP_logical) :: & + lcoupled_ts ! flag to check whether coupled time step + + type (datafile) :: & + restart_file ! io file descriptor + + type (io_dim) :: & + i_dim, j_dim, &! dimension descriptors for horiz dims + k_dim ! dimension descriptor for vertical levels + +!----------------------------------------------------------------------- +! +! always set restart_type, because it is used in write_tavg +! +!----------------------------------------------------------------------- + + restart_type = char_blank + restart_type = 'none' + +!----------------------------------------------------------------------- +! +! check to see if it is time to begin regularly writing restart files +! +!----------------------------------------------------------------------- + + + if (check_time_flag(out_stop_now) ) then + ! procede regardless of time_to_start option + else + if ( .not. time_to_start(restart_start_iopt,restart_start)) return + endif + +!----------------------------------------------------------------------- +! +! check to see whether it is time to write files +! +!----------------------------------------------------------------------- + + lrestart_write = .false. + + !*** write restart files if code is stopping for any reason + + if (check_time_flag(out_stop_now) .and. & + (lrestart_on .or. leven_odd_on)) then + + lrestart_write = .true. + restart_type = char_blank + restart_type = 'end' + endif + + !*** check if it is time for even/odd output + !*** (but not if an end file is written) + + if (.not. lrestart_write .and. check_time_flag(evenodd_flag) & + .and. .not. check_time_flag(out_stop_now)) then + + lrestart_write = .true. + restart_type = char_blank + + if (last_even_odd == even) then + restart_type = 'odd' + last_even_odd = odd + else + restart_type = 'even' + last_even_odd = even + endif + + endif + + !*** check if it is time for regularly-scheduled restart output + !*** note that this option over-rides others + + if (check_time_flag(restart_flag) .or. & + (check_time_flag(cpl_write_restart) .and. & + (nsteps_this_interval == nsteps_per_interval)) ) then + + lrestart_write = .true. + restart_type = char_blank + restart_type = 'restart' + + endif + + !*** turn off cpl_write_restart if necessary + + if (check_time_flag(cpl_write_restart) .and. eod) & + call override_time_flag(cpl_write_restart, value=.false.) + + +!----------------------------------------------------------------------- +! +! the rest of this routine is only executed if it is time to write a +! restart file +! +!----------------------------------------------------------------------- + + if (lrestart_write) then + + +!----------------------------------------------------------------------- +! +! create filename for user-supplied root and append date +! +!----------------------------------------------------------------------- + + write_restart_filename = char_blank + file_suffix = char_blank + + if (registry_match('lccsm')) then + call create_restart_suffix_ccsm(file_suffix, restart_type,freq_opt_nsecond) + else + call create_restart_suffix(file_suffix, restart_type) + endif + + !*** must split concatenation operator to avoid preprocessor mangling + + write_restart_filename = trim(restart_outfile)/& + &/'.'/& + &/trim(file_suffix) + +!----------------------------------------------------------------------- +! +! create output file +! +!----------------------------------------------------------------------- + + restart_file = construct_file(restart_fmt, & + full_name=trim(write_restart_filename), & + record_length=rec_type_dbl, & + recl_words=nx_global*ny_global) + +!----------------------------------------------------------------------- +! +! scalar variables in restart file are output as file attributes +! so define them here +! +!----------------------------------------------------------------------- + + !*** query time_flag routine for present value of lcoupled_ts + + lcoupled_ts = check_time_flag (restart_cpl_ts) + + !*** add defaults as file attributes + + call add_attrib_file(restart_file, 'runid', runid ) + call add_attrib_file(restart_file, 'iyear', iyear ) + call add_attrib_file(restart_file, 'imonth', imonth ) + call add_attrib_file(restart_file, 'iday', iday ) + call add_attrib_file(restart_file, 'ihour', ihour ) + call add_attrib_file(restart_file, 'iminute', iminute ) + call add_attrib_file(restart_file, 'isecond', isecond ) + call add_attrib_file(restart_file, 'iyear0', iyear0 ) + call add_attrib_file(restart_file, 'imonth0', imonth0 ) + call add_attrib_file(restart_file, 'iday0', iday0 ) + call add_attrib_file(restart_file, 'ihour0', ihour0 ) + call add_attrib_file(restart_file, 'iminute0', iminute0) + call add_attrib_file(restart_file, 'isecond0', isecond0) + call add_attrib_file(restart_file, 'dtt', dtt ) + call add_attrib_file(restart_file, 'iday_of_year', iday_of_year) + call add_attrib_file(restart_file, 'iday_of_year_last', & + iday_of_year_last) + call add_attrib_file(restart_file, 'elapsed_days', elapsed_days) + call add_attrib_file(restart_file, 'elapsed_months', elapsed_months) + call add_attrib_file(restart_file, 'elapsed_years', elapsed_years) + call add_attrib_file(restart_file, 'elapsed_days_this_year', & + elapsed_days_this_year) + call add_attrib_file(restart_file, 'seconds_this_day', & + seconds_this_day) + call add_attrib_file(restart_file, 'seconds_this_day_next', & + seconds_this_day_next) + call add_attrib_file(restart_file, 'seconds_this_year', & + seconds_this_year) + call add_attrib_file(restart_file, 'seconds_this_year_next', & + seconds_this_year_next) + call add_attrib_file(restart_file, 'nsteps_total', & + nsteps_total) + call add_attrib_file(restart_file, 'eod' , eod ) + call add_attrib_file(restart_file, 'eod_last', eod_last) + call add_attrib_file(restart_file, 'eom' , eom ) + call add_attrib_file(restart_file, 'eom_last', eom_last) + call add_attrib_file(restart_file, 'eom_next', eom_next) + call add_attrib_file(restart_file, 'eoy' , eoy ) + call add_attrib_file(restart_file, 'eoy_last', eoy_last) + call add_attrib_file(restart_file, 'midnight_last', midnight_last) + call add_attrib_file(restart_file, 'adjust_year_next', & + adjust_year_next) + call add_attrib_file(restart_file, 'newday' , newday ) + call add_attrib_file(restart_file, 'newhour', newhour ) + call add_attrib_file(restart_file, 'leapyear',leapyear) + call add_attrib_file(restart_file, 'days_in_year', days_in_year) + call add_attrib_file(restart_file, 'days_in_prior_year', & + days_in_prior_year) + call add_attrib_file(restart_file, 'seconds_in_year', & + seconds_in_year) + call add_attrib_file(restart_file, 'hours_in_year', hours_in_year) + call add_attrib_file(restart_file, 'tlast_ice', tlast_ice ) + call add_attrib_file(restart_file, 'lcoupled_ts', lcoupled_ts) + call add_attrib_file(restart_file, 'shf_interp_last', & + shf_interp_last) + call add_attrib_file(restart_file, 'sfwf_interp_last', & + sfwf_interp_last) + call add_attrib_file(restart_file, 'ws_interp_last', & + ws_interp_last) + call add_attrib_file(restart_file, 'ap_interp_last', & + ap_interp_last) + call add_attrib_file(restart_file, 'pt_interior_interp_last', & + pt_interior_interp_last) + call add_attrib_file(restart_file, 's_interior_interp_last', & + s_interior_interp_last) + call add_attrib_file(restart_file, 'sum_precip' , sum_precip ) + call add_attrib_file(restart_file, 'precip_fact', precip_fact) + call add_attrib_file(restart_file, 'ssh_initial', ssh_initial) + + short_name = char_blank + do k=1,km + write(short_name,'(a11,i3.3)') 'sal_initial',k + call add_attrib_file(restart_file,trim(short_name),sal_initial(k)) + end do + + if (nt > 2) call write_restart_passive_tracers(restart_file,'add_attrib_file') + +!----------------------------------------------------------------------- +! +! open a file (also writes scalars as attributes to file) +! +!----------------------------------------------------------------------- + + call data_set(restart_file, 'open') + +!----------------------------------------------------------------------- +! +! construct all fields to be written +! +!----------------------------------------------------------------------- + + !*** define dimensions + + i_dim = construct_io_dim('i', nx_global) + j_dim = construct_io_dim('j', ny_global) + k_dim = construct_io_dim('k', km) + + UBTROP_CUR = construct_io_field('UBTROP_CUR', dim1=i_dim, dim2=j_dim, & + long_name='U barotropic velocity at current time', & + units ='cm/s', & + grid_loc ='2220', & + d2d_array =UBTROP(:,:,curtime,:)) + + UBTROP_OLD = construct_io_field('UBTROP_OLD', dim1=i_dim, dim2=j_dim, & + long_name='U barotropic velocity at old time', & + units ='cm/s', & + grid_loc ='2220', & + d2d_array =UBTROP(:,:,oldtime,:)) + + VBTROP_CUR = construct_io_field('VBTROP_CUR', dim1=i_dim, dim2=j_dim, & + long_name='V barotropic velocity at current time', & + units ='cm/s', & + grid_loc ='2220', & + d2d_array =VBTROP(:,:,curtime,:)) + + VBTROP_OLD = construct_io_field('VBTROP_OLD', dim1=i_dim, dim2=j_dim, & + long_name='V barotropic velocity at old time', & + units ='cm/s', & + grid_loc ='2220', & + d2d_array =VBTROP(:,:,oldtime,:)) + + PSURF_CUR = construct_io_field('PSURF_CUR', dim1=i_dim, dim2=j_dim, & + long_name='surface pressure at current time', & + units ='dyne/cm2', & + grid_loc ='2110', & + d2d_array =PSURF(:,:,curtime,:)) + + PSURF_OLD = construct_io_field('PSURF_OLD', dim1=i_dim, dim2=j_dim, & + long_name='surface pressure at old time', & + units ='dyne/cm2', & + grid_loc ='2110', & + d2d_array =PSURF(:,:,oldtime,:)) + + GRADPX_CUR = construct_io_field('GRADPX_CUR', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in x at current time',& + units ='dyne/cm3', & + grid_loc ='2220', & + d2d_array =GRADPX(:,:,curtime,:)) + + GRADPX_OLD = construct_io_field('GRADPX_OLD', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in x at old time', & + units ='dyne/cm3', & + grid_loc ='2220', & + d2d_array =GRADPX(:,:,oldtime,:)) + + GRADPY_CUR = construct_io_field('GRADPY_CUR', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in y at current time',& + units ='dyne/cm3', & + grid_loc ='2220', & + d2d_array =GRADPY(:,:,curtime,:)) + + GRADPY_OLD = construct_io_field('GRADPY_OLD', dim1=i_dim, dim2=j_dim, & + long_name='sfc press gradient in y at old time', & + units ='dyne/cm3', & + grid_loc ='2220', & + d2d_array =GRADPY(:,:,oldtime,:)) + + PGUESSd = construct_io_field('PGUESS', dim1=i_dim, dim2=j_dim, & + long_name='guess for sfc pressure at new time', & + units ='dyne/cm2', & + grid_loc ='2110', & + d2d_array =PGUESS) + + if (sfc_layer_type == sfc_layer_varthick) then + FW_OLDd = construct_io_field('FW_OLD', dim1=i_dim, dim2=j_dim, & + long_name='fresh water input at old time', & + grid_loc ='2110', & + d2d_array = FW_OLD) + FW_FREEZEd = construct_io_field('FW_FREEZE', dim1=i_dim, dim2=j_dim, & + long_name='water flux due to frazil ice formation',& + grid_loc ='2110', & + d2d_array = FW_FREEZE) + endif + + if (liceform) then + if (lcoupled_ts) then + QFLUXd = construct_io_field('QFLUX', dim1=i_dim, dim2=j_dim, & + long_name='Internal Ocean Heat Flux Due to Ice Formation',& + grid_loc ='2110', & + d2d_array = QFLUX) + else + AQICEd = construct_io_field('AQICE', dim1=i_dim, dim2=j_dim, & + long_name='accumulated ice melt/heat', & + grid_loc ='2110', & + d2d_array = AQICE) + endif + endif + + UVEL_CUR = construct_io_field('UVEL_CUR', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='U velocity at current time', & + units ='cm/s', & + grid_loc ='3221', & + d3d_array = UVEL(:,:,:,curtime,:)) + + UVEL_OLD = construct_io_field('UVEL_OLD', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='U velocity at old time', & + units ='cm/s', & + grid_loc ='3221', & + d3d_array = UVEL(:,:,:,oldtime,:)) + + VVEL_CUR = construct_io_field('VVEL_CUR', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='V velocity at current time', & + units ='cm/s', & + grid_loc ='3221', & + d3d_array = VVEL(:,:,:,curtime,:)) + + VVEL_OLD = construct_io_field('VVEL_OLD', dim1=i_dim, dim2=j_dim, dim3=k_dim,& + long_name='V velocity at old time', & + units ='cm/s', & + grid_loc ='3221', & + d3d_array = VVEL(:,:,:,oldtime,:)) + + do n=1,nt + short_name = char_blank + short_name = trim(tracer_d(n)%short_name)/& + &/'_CUR' + long_name = char_blank + long_name = trim(tracer_d(n)%long_name)/& + &/' at current time' + + TRACER_CUR(n) = construct_io_field(trim(short_name), & + dim1=i_dim, dim2=j_dim, dim3=k_dim, & + long_name=trim(long_name), & + units =trim(tracer_d(n)%units), & + grid_loc ='3111', & + d3d_array = TRACER(:,:,:,n,curtime,:)) + end do + + do n=1,nt + short_name = char_blank + short_name = trim(tracer_d(n)%short_name)/& + &/'_OLD' + long_name = char_blank + long_name = trim(tracer_d(n)%long_name)/& + &/' at old time' + + TRACER_OLD(n) = construct_io_field(trim(short_name), & + dim1=i_dim, dim2=j_dim, dim3=k_dim, & + long_name=trim(long_name), & + units =trim(tracer_d(n)%units), & + grid_loc ='3111', & + d3d_array = TRACER(:,:,:,n,oldtime,:)) + end do + +!----------------------------------------------------------------------- +! +! define all fields to be read +! +!----------------------------------------------------------------------- + + !*** must call in this order for back compatibility + + call data_set (restart_file, 'define', UBTROP_CUR) + call data_set (restart_file, 'define', UBTROP_OLD) + call data_set (restart_file, 'define', VBTROP_CUR) + call data_set (restart_file, 'define', VBTROP_OLD) + call data_set (restart_file, 'define', PSURF_CUR) + call data_set (restart_file, 'define', PSURF_OLD) + call data_set (restart_file, 'define', GRADPX_CUR) + call data_set (restart_file, 'define', GRADPX_OLD) + call data_set (restart_file, 'define', GRADPY_CUR) + call data_set (restart_file, 'define', GRADPY_OLD) + call data_set (restart_file, 'define', PGUESSd) + + if (sfc_layer_type == sfc_layer_varthick) then + call data_set (restart_file, 'define', FW_OLDd) + call data_set (restart_file, 'define', FW_FREEZEd) + endif + if (liceform) then + if (lcoupled_ts) then + call data_set (restart_file, 'define', QFLUXd) + else + call data_set (restart_file, 'define', AQICEd) + endif + endif + + call data_set (restart_file, 'define', UVEL_CUR) + call data_set (restart_file, 'define', UVEL_OLD) + call data_set (restart_file, 'define', VVEL_CUR) + call data_set (restart_file, 'define', VVEL_OLD) + + do n=1,nt + call data_set (restart_file, 'define', TRACER_CUR(n)) + call data_set (restart_file, 'define', TRACER_OLD(n)) + end do + + if (nt > 2) call write_restart_passive_tracers(restart_file,'define') + +!----------------------------------------------------------------------- +! +! now we actually write each field +! +!----------------------------------------------------------------------- + + call data_set (restart_file, 'write', UBTROP_CUR) + call data_set (restart_file, 'write', UBTROP_OLD) + call data_set (restart_file, 'write', VBTROP_CUR) + call data_set (restart_file, 'write', VBTROP_OLD) + call data_set (restart_file, 'write', PSURF_CUR) + call data_set (restart_file, 'write', PSURF_OLD) + call data_set (restart_file, 'write', GRADPX_CUR) + call data_set (restart_file, 'write', GRADPX_OLD) + call data_set (restart_file, 'write', GRADPY_CUR) + call data_set (restart_file, 'write', GRADPY_OLD) + call data_set (restart_file, 'write', PGUESSd) + + if (sfc_layer_type == sfc_layer_varthick) then + call data_set (restart_file, 'write', FW_OLDd) + call data_set (restart_file, 'write', FW_FREEZEd) + endif + if (liceform) then + if (lcoupled_ts) then + call data_set (restart_file, 'write', QFLUXd) + else + call data_set (restart_file, 'write', AQICEd) + endif + endif + + call data_set (restart_file, 'write', UVEL_CUR) + call data_set (restart_file, 'write', UVEL_OLD) + call data_set (restart_file, 'write', VVEL_CUR) + call data_set (restart_file, 'write', VVEL_OLD) + do n=1,nt + call data_set (restart_file, 'write', TRACER_CUR(n)) + call data_set (restart_file, 'write', TRACER_OLD(n)) + end do + + if (nt > 2) call write_restart_passive_tracers(restart_file,'write') + +!----------------------------------------------------------------------- +! +! close and destroy file +! +!----------------------------------------------------------------------- + + call data_set (restart_file, 'close') + + if (my_task == master_task) then + write(stdout,blank_fmt) + write(stdout,*) ' restart file written: ', trim(write_restart_filename) + endif + + call destroy_file(restart_file) + +!----------------------------------------------------------------------- +! +! if pointer files are used, write filename to pointer file +! +!----------------------------------------------------------------------- + + if (luse_pointer_files) then + call get_unit(nu) + if (my_task == master_task) then + restart_pointer_file = trim(pointer_filename)/& + &/'.restart' + + open(nu, file=restart_pointer_file, form='formatted', & + status='unknown') + write(nu,'(a)') trim(write_restart_filename) + write(nu,'(a,a)') 'RESTART_FMT=',trim(restart_fmt) + close(nu) + write(stdout,blank_fmt) + write(stdout,*) ' restart pointer file written: ',trim(restart_pointer_file) + call POP_IOUnitsFlush(POP_stdout) ; call POP_IOUnitsFlush(stdout) + endif + call release_unit(nu) + endif + + +!----------------------------------------------------------------------- +! +! finished writing file +! +!----------------------------------------------------------------------- + + endif ! lrestart_write + +!----------------------------------------------------------------------- +!EOC + + end subroutine write_restart + + +!*********************************************************************** +!BOP +! !IROUTINE: init_restart +! !INTERFACE: + + subroutine init_restart + +! !DESCRIPTION: +! Initializes quantities associated with writing all the data +! necessary for restarting a simulation. +! +! !REVISION HISTORY: +! same as module + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variables and input namelist +! +!----------------------------------------------------------------------- + + integer (POP_i4) :: & + n, &! tracer loop index + nml_error ! namelist i/o error flag + + character (POP_charLength) :: & + restart_freq_opt, &! input option for freq of restart dumps + restart_start_opt ! choice for starting regular restart writes + + character (POP_charLength), parameter :: & + start_fmt = "('regular restart writes will start at ',a,i8)" + + namelist /restart_nml/ restart_freq_opt, restart_freq, & + restart_outfile, restart_fmt, & + leven_odd_on, even_odd_freq, & + pressure_correction, & + restart_start_opt, restart_start + +!----------------------------------------------------------------------- +! +! register init_restart +! +!----------------------------------------------------------------------- + call register_string('init_restart') + +!----------------------------------------------------------------------- +! +! read namelist input and broadcast variables +! +!----------------------------------------------------------------------- + + restart_outfile = 'd' + restart_fmt = 'bin' + restart_freq_iopt = freq_opt_never + restart_start_iopt= start_opt_nstep + restart_start = 0 + restart_freq = 100000 + leven_odd_on = .false. + even_odd_freq = 100000 + pressure_correction = .false. + + if (my_task == master_task) then + open (nml_in, file=nml_filename, status='old',iostat=nml_error) + if (nml_error /= 0) then + nml_error = -1 + else + nml_error = 1 + endif + do while (nml_error > 0) + read(nml_in, nml=restart_nml,iostat=nml_error) + end do + if (nml_error == 0) close(nml_in) + endif + + call broadcast_scalar(nml_error, master_task) + if (nml_error /= 0) then + exit_string = 'FATAL ERROR: reading restart_nml' + call document ('init_restart', exit_string) + call exit_POP (sigAbort, exit_string, out_unit=stdout) + endif + + if (my_task == master_task) then + select case (restart_freq_opt) + case ('never') + restart_freq_iopt = freq_opt_never + case ('nyear') + restart_freq_iopt = freq_opt_nyear + case ('nmonth') + restart_freq_iopt = freq_opt_nmonth + case ('nday') + restart_freq_iopt = freq_opt_nday + case ('nhour') + restart_freq_iopt = freq_opt_nhour + case ('nsecond') + restart_freq_iopt = freq_opt_nsecond + case ('nstep') + restart_freq_iopt = freq_opt_nstep + case default + restart_freq_iopt = -1000 + end select + + if (restart_freq_iopt /= freq_opt_never) then + select case (restart_start_opt) + case ('nstep') + restart_start_iopt = start_opt_nstep + write(stdout,start_fmt) 'step ', restart_start + case ('nday') + restart_start_iopt = start_opt_nday + write(stdout,start_fmt) 'day ', restart_start + case ('nyear') + restart_start_iopt = start_opt_nyear + write(stdout,start_fmt) 'year ', restart_start + case ('date') + restart_start_iopt = start_opt_date + write(stdout,start_fmt) ' ', restart_start + case default + restart_start_iopt = -1000 + end select + endif + + endif + + call broadcast_scalar (restart_outfile, master_task) + call broadcast_scalar (restart_freq_iopt, master_task) + call broadcast_scalar (restart_freq, master_task) + call broadcast_scalar (restart_start_iopt, master_task) + call broadcast_scalar (restart_start, master_task) + call broadcast_scalar (restart_fmt, master_task) + call broadcast_scalar (leven_odd_on, master_task) + call broadcast_scalar (even_odd_freq, master_task) + call broadcast_scalar (pressure_correction, master_task) + + if (restart_freq_iopt == -1000) then + exit_string = 'FATAL ERROR: unknown restart frequency option' + call document ('init_restart', exit_string) + call exit_POP (sigAbort, exit_string, out_unit=stdout) + else if (restart_start_iopt == -1000) then + exit_string = 'FATAL ERROR: unknown restart start option' + call document ('init_restart', exit_string) + call exit_POP (sigAbort, exit_string, out_unit=stdout) + else if (restart_freq_iopt == freq_opt_never) then + lrestart_on = .false. + else + lrestart_on = .true. + endif + +!----------------------------------------------------------------------- +! +! create some time flags +! +!----------------------------------------------------------------------- + + call init_time_flag('restart',restart_flag, default=.false., & + owner = 'init_restart', & + freq_opt = restart_freq_iopt, & + freq = restart_freq) + + if (leven_odd_on) then + last_even_odd = even + call init_time_flag('evenodd', evenodd_flag, default=.false., & + owner = 'init_restart', & + freq_opt = freq_opt_nstep, & + freq = even_odd_freq) + else + call init_time_flag('evenodd',evenodd_flag, default=.false., & + owner = 'init_restart', & + freq_opt = freq_opt_never, & + freq = even_odd_freq) + endif + +!----------------------------------------------------------------------- +! +! get handle for time flags defined in other modules +! +!----------------------------------------------------------------------- + + call access_time_flag('cpl_write_restart',cpl_write_restart) + call access_time_flag('coupled_ts',restart_cpl_ts) + call access_time_flag('stop_now',out_stop_now) + +!----------------------------------------------------------------------- +!EOC + + end subroutine init_restart + +!*********************************************************************** +!BOP +! !IROUTINE: create_restart_suffix +! !INTERFACE: + + subroutine create_restart_suffix(file_suffix, restart_type) + +! !DESCRIPTION: +! Determines suffix to append to restart files based on restart type. +! +! !REVISION HISTORY: +! same as module + +! !INPUT PARAMETERS: + + character (*), intent(in) :: & + restart_type ! type of restart file to be written + ! (restart,even,odd,end) + +! !OUTPUT PARAMETERS: + + character (POP_charLength), intent(out) :: & + file_suffix ! suffix to append to root filename + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variable +! +!----------------------------------------------------------------------- + + integer (POP_i4) :: & + cindx, cindx2, &! indices into character strings + len_date ! length of date string + + character (POP_charLength) :: & + char_temp ! temp character space + + character (10) :: & + cdate ! date string + +!----------------------------------------------------------------------- +! +! clear character strings +! +!----------------------------------------------------------------------- + + file_suffix = char_blank + char_temp = char_blank + +!----------------------------------------------------------------------- +! +! for even, odd, or end, simply add the appropriate string +! +!----------------------------------------------------------------------- + + select case (trim(restart_type)) + case('end') + file_suffix = trim(runid)/& + &/'.end' + case('even') + file_suffix = trim(runid)/& + &/'.even' + case('odd') + file_suffix = trim(runid)/& + &/'.odd' + +!----------------------------------------------------------------------- +! +! for a regular restart file, append a date/time string +! +!----------------------------------------------------------------------- + + case('restart') + + if (date_separator == ' ') then + len_date = 8 + cdate(1:4) = cyear + cdate(5:6) = cmonth + cdate(7:8) = cday + cdate(9:10)= ' ' + else + len_date = 10 + cdate(1:4) = cyear + cdate(5:5) = date_separator + cdate(6:7) = cmonth + cdate(8:8) = date_separator + cdate(9:10) = cday + endif + + select case (restart_freq_iopt) + case (freq_opt_nyear, freq_opt_nmonth, freq_opt_nday) + + !*** append the date after the runid + + file_suffix = trim(runid)/& + &/'.'/& + &/trim(cdate) + + case (freq_opt_nhour) + + !*** append the date to runid and add hour + + write(file_suffix,'(i2)') ihour + char_temp = adjustl(file_suffix) + + file_suffix = trim(runid)/& + &/'.'/& + &/trim(cdate)/& + &/'.h'/& + &/trim(char_temp) + + case (freq_opt_nsecond) + + !*** append the date to runid and the elapsed seconds in day + + write (file_suffix,'(i6)') isecond + char_temp = adjustl(file_suffix) + + file_suffix = trim(runid)/& + &/'.'/& + &/trim(cdate)/& + &/'.s'/& + &/trim(char_temp) + + case (freq_opt_nstep) + + !*** append the step number + + write (file_suffix,'(i10)') nsteps_total + char_temp = adjustl(file_suffix) + + file_suffix = trim(runid)/& + &/'.'/& + &/trim(char_temp) + + case default + file_suffix = trim(runid) + end select + + end select + +!----------------------------------------------------------------------- +!EOC + + end subroutine create_restart_suffix +!*********************************************************************** + +!BOP +! !IROUTINE: create_restart_suffix_ccsm +! !INTERFACE: + + subroutine create_restart_suffix_ccsm(file_suffix, restart_type,in_freq_opt) + +! !DESCRIPTION: +! Determines suffix to append to CCSM restart files based on restart type. +! +! !REVISION HISTORY: +! same as module + +! !INPUT PARAMETERS: + + character (*), intent(in) :: & + restart_type ! type of restart file to be written + ! (restart,even,odd,end) + integer (POP_i4), intent(in) :: & + in_freq_opt ! type of ccsm date string + ! (annual, monthly, daily, or instantaneous) + +! !OUTPUT PARAMETERS: + + character (POP_charLength), intent(out) :: & + file_suffix ! suffix to append to root filename + +!EOP +!BOC +!----------------------------------------------------------------------- +! +! local variable +! +!----------------------------------------------------------------------- + + integer (POP_i4) :: & + cindx, cindx2, &! indices into character strings + len_date ! length of date string + + character (POP_charLength) :: & + char_temp, &! temp character space + ccsm_date_string + + character (10) :: & + cdate ! date string + +!----------------------------------------------------------------------- +! +! clear character strings +! +!----------------------------------------------------------------------- + + file_suffix = char_blank + char_temp = char_blank + +!----------------------------------------------------------------------- +! +! for even, odd, or end, simply add the appropriate string +! +!----------------------------------------------------------------------- + + select case (trim(restart_type)) + case('end') + file_suffix = trim(runid)/& + &/'.end' + case('even') + file_suffix = trim(runid)/& + &/'.even' + case('odd') + file_suffix = trim(runid)/& + &/'.odd' + +!----------------------------------------------------------------------- +! +! for a regular restart file, append a date/time string +! +!----------------------------------------------------------------------- + + case('restart') + + char_temp = char_blank + file_suffix = char_blank + + select case (in_freq_opt) + case (freq_opt_nyear) + char_temp = 'y' + + case (freq_opt_nmonth) + char_temp = 'ym' + + case (freq_opt_nday) + char_temp = 'ymd' + + case (freq_opt_nhour) + char_temp = 'ymds' + + case (freq_opt_nsecond) + char_temp = 'ymds' + + case (freq_opt_nstep) + char_temp = 'ymds' + + case default + char_temp = 'ymds' + end select + + + call ccsm_date_stamp (ccsm_date_string, char_temp) + + file_suffix = trim(ccsm_date_string) + + end select + + +!----------------------------------------------------------------------- +! +! for a restart file in netCDF format, append the suffix '.nc' +! +!----------------------------------------------------------------------- + + select case (trim(restart_fmt)) + case('nc') + file_suffix = trim(file_suffix)/& + &/'.'/& + &/'nc' + end select + +!----------------------------------------------------------------------- +!EOC + + end subroutine create_restart_suffix_ccsm + + + +!*********************************************************************** + + end module restart + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.share/shr_dmodel_mod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.share/shr_dmodel_mod.F90 new file mode 100644 index 0000000000..504f3291a1 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.share/shr_dmodel_mod.F90 @@ -0,0 +1,1574 @@ + + +! DART bugzilla 1927 fix for 'longwave radiation error' +! DART note: this file started life as: +! /glade/p/cesm/releases/cesm1_2_1/models/csm_share/shr/shr_dmodel_mod.F90 + +module shr_dmodel_mod + +! !USES: + + use shr_sys_mod + use shr_kind_mod, only: IN=>SHR_KIND_IN, R8=>SHR_KIND_R8, & + CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, & + CX=>SHR_KIND_CX, CXX=>SHR_KIND_CXX + use shr_log_mod, only: loglev => shr_log_Level + use shr_log_mod, only: logunit => shr_log_Unit + use shr_mpi_mod, only: shr_mpi_bcast + use mct_mod +! use esmf + use perf_mod + use pio + +! !PUBLIC TYPES: + implicit none + private ! except + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: shr_dmodel_gsmapCreate + public :: shr_dmodel_readLBUB + public :: shr_dmodel_readgrid + public :: shr_dmodel_gGridCompare + public :: shr_dmodel_mapSet + public :: shr_dmodel_translateAV + public :: shr_dmodel_translateAV_list + public :: shr_dmodel_translate_list + public :: shr_dmodel_rearrGGrid + + interface shr_dmodel_mapSet; module procedure & + shr_dmodel_mapSet_global +! shr_dmodel_mapSet_dest + end interface + + integer(IN),parameter,public :: shr_dmodel_gGridCompareXYabs = 1 ! X,Y relative error + integer(IN),parameter,public :: shr_dmodel_gGridCompareXYrel = 2 ! X,Y absolute error + integer(IN),parameter,public :: shr_dmodel_gGridCompareAreaAbs = 3 ! area relative error + integer(IN),parameter,public :: shr_dmodel_gGridCompareAreaRel = 4 ! area absolute error + integer(IN),parameter,public :: shr_dmodel_gGridCompareMaskIdent = 5 ! masks are identical + integer(IN),parameter,public :: shr_dmodel_gGridCompareMaskZeros = 6 ! masks have same zeros + integer(IN),parameter,public :: shr_dmodel_gGridCompareMaskSubset = 7 ! mask is subset of other + + ! masked methods + + integer(IN),parameter,public :: shr_dmodel_gGridCompareXYabsMask = 101 ! X,Y relative error + integer(IN),parameter,public :: shr_dmodel_gGridCompareXYrelMask = 102 ! X,Y absolute error + integer(IN),parameter,public :: shr_dmodel_gGridCompareAreaAbsMask = 103 ! area relative error + integer(IN),parameter,public :: shr_dmodel_gGridCompareAreaRelMask = 104 ! area absolute error + integer(IN),parameter,public :: shr_dmodel_gGridCompareMaskIdentMask = 105 ! masks are identical + integer(IN),parameter,public :: shr_dmodel_gGridCompareMaskZerosMask = 106 ! masks have same zeros + integer(IN),parameter,public :: shr_dmodel_gGridCompareMaskSubsetMask = 107 ! mask is subset of other + + integer(IN),parameter,public :: iotype_std_netcdf = -99 ! non pio option + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CONTAINS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!=============================================================================== +subroutine shr_dmodel_gsmapCreate(gsmap,gsize,compid,mpicom,decomp) + + implicit none + + type(mct_gsMap), intent(inout) :: gsmap + integer(IN) , intent(in) :: gsize + integer(IN) , intent(in) :: compid + integer(IN) , intent(in) :: mpicom + character(len=*),intent(in) :: decomp + + ! local + + integer(IN) :: n,npes,ierr + integer(IN), pointer :: start(:) ! for gsmap initialization + integer(IN), pointer :: length(:) ! for gsmap initialization + integer(IN), pointer :: pe_loc(:) ! for gsmap initialization + character(*), parameter :: subname = '(shr_dmodel_gsmapCreate) ' + character(*), parameter :: F00 = "('(shr_dmodel_gsmapCreate) ',8a)" + character(*), parameter :: F01 = "('(shr_dmodel_gsmapCreate) ',a,5i8)" + + ! --------------------------------------------- + + if (gsize > 0) then + call mpi_comm_size(mpicom,npes,ierr) + allocate(start(npes),length(npes),pe_loc(npes)) + + start = 0 + length = 0 + do n = 1,npes + if (trim(decomp) == '1d') then + length(n) = gsize/npes + if (n <= mod(gsize,npes)) length(n) = length(n) + 1 + elseif (trim(decomp) == 'root') then + length = 0 + length(1) = gsize + else + write(logunit,F00) ' ERROR: decomp not allowed, ',trim(decomp) + call shr_sys_abort(subname//' ERROR decomp') + endif + if (n == 1) then + start(n) = 1 + else + start(n) = start(n-1) + length(n-1) + endif + pe_loc(n) = n-1 + enddo + call mct_gsMap_init( gsMap, COMPID, npes, gsize, start, length, pe_loc) + deallocate(start,length,pe_loc) + endif + +end subroutine shr_dmodel_gsmapCreate +!=============================================================================== + +subroutine shr_dmodel_readgrid( gGrid, gsMap, nxgo, nygo, filename, compid, mpicom, & + decomp, lonname, latname, maskname, areaname, fracname, readfrac, & + scmmode, scmlon, scmlat) + + use seq_flds_mod, only : seq_flds_dom_coord, seq_flds_dom_other + use shr_file_mod, only : shr_file_noprefix, shr_file_queryprefix, shr_file_get + use shr_string_mod, only : shr_string_lastindex + use shr_ncread_mod, only : shr_ncread_domain, shr_ncread_vardimsizes, & + shr_ncread_varexists, shr_ncread_vardimnum + implicit none + + !----- arguments ----- + type(mct_gGrid), intent(inout) :: gGrid + type(mct_gsMap), intent(inout) :: gsMap + integer(IN) , intent(out) :: nxgo + integer(IN) , intent(out) :: nygo + character(len=*),intent(in) :: filename + integer(IN) , intent(in) :: compid + integer(IN) , intent(in) :: mpicom + character(len=*),optional,intent(in) :: decomp ! decomp strategy for gsmap + character(len=*),optional,intent(in) :: lonname ! name of lon variable in file + character(len=*),optional,intent(in) :: latname ! name of lat variable in file + character(len=*),optional,intent(in) :: maskname ! name of mask variable in file + character(len=*),optional,intent(in) :: areaname ! name of area variable in file + character(len=*),optional,intent(in) :: fracname ! name of frac variable in file + logical ,optional,intent(in) :: readfrac ! T <=> also read frac in file + logical ,optional,intent(in) :: scmmode ! single column mode + real(R8) ,optional,intent(in) :: scmlon ! single column lon + real(R8) ,optional,intent(in) :: scmlat ! single column lat + + !----- local ----- + integer(IN) :: n,k,j,i ! indices + integer(IN) :: lsize ! lsize + integer(IN) :: gsize ! gsize + integer(IN) :: my_task, master_task + integer(IN) :: ierr ! error code + logical :: fileexists ! + integer(IN) :: rCode ! return code + character(CL) :: remoteFn ! input file name (possibly at an archival location) + character(CL) :: localFn ! file name to be opened (possibly a local copy) + character(CS) :: prefix ! file prefix + character(CS) :: ldecomp ! decomp strategy + character(CS) :: llatname ! name of lat variable + character(CS) :: llonname ! name of lon variable + character(CS) :: lmaskname ! name of mask variable + character(CS) :: lareaname ! name of area variable + character(CS) :: lfracname ! name of area variable + logical :: lreadfrac ! read fraction + logical :: maskexists ! is mask on dataset + integer(IN) :: nxg,nyg ! size of input fields + integer(IN) :: ndims ! number of dims + integer(IN) :: nlon,nlat,narea,nmask,nfrac + logical :: lscmmode ! local scm mode + real(R8) :: dist,mind ! scmmode point search + integer(IN) :: ni,nj ! scmmode point search + real(R8) :: lscmlon ! local copy of scmlon + + real (R8),allocatable :: lon(:,:) ! temp array for domain lon info + real (R8),allocatable :: lat(:,:) ! temp array for domain lat info + integer(IN),allocatable :: mask(:,:) ! temp array for domain mask info + real (R8),allocatable :: area(:,:) ! temp array for domain area info + real (R8),allocatable :: frac(:,:) ! temp array for domain frac info + + integer(IN), pointer :: idata(:) ! temporary + type(mct_ggrid) :: gGridRoot ! global mct ggrid + + character(*), parameter :: subname = '(shr_dmodel_readgrid) ' + character(*), parameter :: F00 = "('(shr_dmodel_readgrid) ',8a)" + character(*), parameter :: F01 = "('(shr_dmodel_readgrid) ',a,5i8)" + +!------------------------------------------------------------------------------- +! PURPOSE: Read MCT ggrid and set gsmap +!---------------------------------------------------------------------------- +! Notes: +! o as per shr_file_get(), the file name format is expected to be +! remoteFn = [location:][directory path]localFn +! eg. "foobar.nc" "/home/user/foobar.nc" "mss:/USER/fobar.nc" +! o assumes a very specific netCDF domain file format wrt var names, etc. +! +! TO DO: have the calling routine select/input the domain's file name +!---------------------------------------------------------------------------- + + call MPI_COMM_RANK(mpicom,my_task,ierr) + master_task = 0 + + lscmmode = .false. + if (present(scmmode)) then + lscmmode = scmmode + if (lscmmode) then + if (.not.present(scmlon) .or. .not.present(scmlat)) then + write(logunit,*) subname,' ERROR: scmmode must supply scmlon and scmlat' + call shr_sys_abort(subname//' ERROR: scmmode1 lon lat') + endif + if (my_task > 0) then + write(logunit,*) subname,' ERROR: scmmode must be run on one pe' + call shr_sys_abort(subname//' ERROR: scmmode2 tasks') + endif + endif + endif + + if (my_task == master_task) then + if ( shr_file_queryPrefix(fileName,prefix=prefix) /= shr_file_noPrefix ) then + n = max(len_trim(prefix),shr_string_lastIndex(fileName,"/")) + remoteFn = fileName + localFn = fileName(n+1: len_trim(fileName) ) + call shr_file_get(rCode,localFn,remoteFn) + else + remoteFn = "undefined" ! this isn't needed + localFn = fileName ! file to open + end if + inquire(file=trim(localFn),exist=fileExists) + if (.not. fileExists) then + write(logunit,F00) "ERROR: file does not exist: ", trim(localFn) + call shr_sys_abort(subName//"ERROR: file does not exist: "//trim(localFn)) + end if + endif + + lreadfrac = .false. + ldecomp = "1d" + llonname = "xc" ! default values / standard data model domain file format + llatname = "yc" + lmaskname = "mask" + lareaname = "area" + lfracname = "frac" + if (present( decomp)) ldecomp = decomp + if (present(readfrac)) lreadfrac = readfrac + if (present( lonname)) llonname = lonname + if (present( latname)) llatname = latname + if (present(maskname)) lmaskname = maskname + if (present(areaname)) lareaname = areaname + if (present(fracname)) lfracname = fracname + + ! Initialize mct domain type + ! lat/lon in degrees, area in radians^2, mask is 1 (ocean), 0 (non-ocean) + + if (my_task == master_task) then + if (shr_ncread_varexists(localFn,lmaskname)) then + maskexists = .true. + call shr_ncread_varDimSizes(localFn,lmaskname,nxg,nyg) + else + maskexists = .false. + call shr_ncread_varDimNum(localFn,llonName,ndims) + if (ndims == 1) then + call shr_ncread_varDimSizes(localFn,llonName,nxg) + call shr_ncread_varDimSizes(localFn,llatName,nyg) + else + call shr_ncread_varDimSizes(localFn,llonName,nxg,nyg) + endif + endif + endif + call shr_mpi_bcast(nxg,mpicom) + call shr_mpi_bcast(nyg,mpicom) + if (lscmmode) then + nxgo = 1 + nygo = 1 + gsize = 1 + else + nxgo = nxg + nygo = nyg + gsize = nxg*nyg + if (gsize < 1) return + endif + + call shr_dmodel_gsmapCreate(gsMap,gsize,compid,mpicom,trim(ldecomp)) + lsize = mct_gsMap_lsize(gsMap, mpicom) + call mct_gGrid_init( GGrid=gGrid, CoordChars=trim(seq_flds_dom_coord), & + OtherChars=trim(seq_flds_dom_other), lsize=lsize ) + + ! Determine global gridpoint number attribute, GlobGridNum, automatically in ggrid + + call mct_gsMap_orderedPoints(gsMap, my_task, idata) + call mct_gGrid_importIAttr(gGrid,'GlobGridNum',idata,lsize) + deallocate(idata) + + ! Initialize attribute vector with special value + + gGrid%data%rAttr = -9999.0_R8 + + ! Load file data into domG then scatter to ggrid + + if (my_task == master_task) then + + allocate(lon(nxg,nyg)) + allocate(lat(nxg,nyg)) + allocate(area(nxg,nyg)) + allocate(mask(nxg,nyg)) + allocate(frac(nxg,nyg)) + + if (.not.maskexists) then + call shr_ncread_domain(localFn,llonName,lon,llatName,lat) + mask = 1 + frac = 1.0_R8 + area = 1.0e36_R8 + else + if (lreadfrac) then + call shr_ncread_domain(localFn,llonName,lon,llatName,lat, & + lmaskName,mask,lareaName,area,lfracName,frac) + else ! assume frac = 1.0 + call shr_ncread_domain(localFn,llonName,lon,llatName,lat, & + lmaskName,mask,lareaName,area) + where (mask == 0) + frac = 0.0_R8 + elsewhere + frac = 1.0_R8 + end where + endif + endif + + call mct_gGrid_init(gGridRoot,gGrid,gsize) + +! initialize gGridRoot to avoid errors when using strict compiler checks + gGridRoot%data%rAttr = -9999.0_R8 + + nlon = mct_aVect_indexRA(gGridRoot%data,'lon') + nlat = mct_aVect_indexRA(gGridRoot%data,'lat') + narea = mct_aVect_indexRA(gGridRoot%data,'area') + nmask = mct_aVect_indexRA(gGridRoot%data,'mask') + nfrac = mct_aVect_indexRA(gGridRoot%data,'frac') + + if (lscmmode) then + !--- assumes regular 2d grid for compatability with shr_scam_getCloseLatLon --- + !--- want lon values between 0 and 360, assume 1440 is enough --- + lscmlon = mod(scmlon+1440.0_r8,360.0_r8) + lon = mod(lon +1440.0_r8,360.0_r8) + + !--- start with wraparound --- + ni = 1 + mind = abs(lscmlon - (lon(1,1)+360.0_r8)) + do i=1,nxg + dist = abs(lscmlon - lon(i,1)) + if (dist < mind) then + mind = dist + ni = i + endif + enddo + + nj = -1 + mind = 1.0e20 + do j=1,nyg + dist = abs(scmlat - lat(1,j)) + if (dist < mind) then + mind = dist + nj = j + endif + enddo + + n = 1 + i = ni + j = nj + gGridRoot%data%rAttr(nlat ,n) = lat(i,j) + gGridRoot%data%rAttr(nlon ,n) = lon(i,j) + gGridRoot%data%rAttr(narea,n) = area(i,j) + gGridRoot%data%rAttr(nmask,n) = real(mask(i,j),R8) + gGridRoot%data%rAttr(nfrac,n) = frac(i,j) + else + n=0 + do j=1,nyg + do i=1,nxg + n=n+1 + gGridRoot%data%rAttr(nlat ,n) = lat(i,j) + gGridRoot%data%rAttr(nlon ,n) = lon(i,j) + gGridRoot%data%rAttr(narea,n) = area(i,j) + gGridRoot%data%rAttr(nmask,n) = real(mask(i,j),R8) + gGridRoot%data%rAttr(nfrac,n) = frac(i,j) + enddo + enddo + endif + deallocate(lon) + deallocate(lat) + deallocate(area) + deallocate(mask) + deallocate(frac) + endif + + call mct_gGrid_scatter(gGridRoot, gGrid, gsMap, master_task, mpicom) + if (my_task == master_task) call mct_gGrid_clean(gGridRoot) + +end subroutine shr_dmodel_readgrid + +!=============================================================================== + +subroutine shr_dmodel_readLBUB(stream,pio_subsystem,pio_iotype,pio_iodesc,mDate,mSec,mpicom,gsMap, & + avLB,mDateLB,mSecLB,avUB,mDateUB,mSecUB,newData,rmOldFile,istr) + + use shr_file_mod, only : shr_file_noprefix, shr_file_queryprefix, shr_file_get + use shr_const_mod, only : shr_const_cDay + use shr_stream_mod + implicit none + + !----- arguments ----- + type(shr_stream_streamType),intent(inout) :: stream + type(iosystem_desc_t) ,intent(inout), target :: pio_subsystem + integer(IN) ,intent(in) :: pio_iotype + type(io_desc_t) ,intent(inout) :: pio_iodesc + integer(IN) ,intent(in) :: mDate ,mSec + integer(IN) ,intent(in) :: mpicom + type(mct_gsMap) ,intent(in) :: gsMap + type(mct_aVect) ,intent(inout) :: avLB + integer(IN) ,intent(inout) :: mDateLB,mSecLB + type(mct_aVect) ,intent(inout) :: avUB + integer(IN) ,intent(inout) :: mDateUB,mSecUB + logical ,intent(out) :: newData + logical,optional ,intent(in) :: rmOldFile + character(len=*),optional ,intent(in) :: istr + + !----- local ----- + integer(IN) :: n,k,j,i ! indices + integer(IN) :: lsize ! lsize + integer(IN) :: gsize ! gsize + integer(IN) :: my_task, master_task + integer(IN) :: ierr ! error code + integer(IN) :: rCode ! return code + logical :: localCopy,fileexists + integer(IN) :: ivals(6) ! bcast buffer + + integer(IN) :: oDateLB,oSecLB,dDateLB,oDateUB,oSecUB,dDateUB + real(R8) :: rDateM,rDateLB,rDateUB ! model,LB,UB dates with fractional days + integer(IN) :: n_lb, n_ub + character(CL) :: fn_lb,fn_ub,fn_next,fn_prev + character(CL) :: path + character(len=32) :: lstr + + real(R8) :: spd + + character(*), parameter :: subname = '(shr_dmodel_readLBUB) ' + character(*), parameter :: F00 = "('(shr_dmodel_readLBUB) ',8a)" + character(*), parameter :: F01 = "('(shr_dmodel_readLBUB) ',a,5i8)" + character(*), parameter :: F02 = "('(shr_dmodel_readLBUB) ',3a,i8)" + +!------------------------------------------------------------------------------- +! PURPOSE: Read LB and UB stream data +!---------------------------------------------------------------------------- + + lstr = 'shr_dmodel_readLBUB' + if (present(istr)) then + lstr = trim(istr) + endif + + call t_startf(trim(lstr)//'_setup') + call MPI_COMM_RANK(mpicom,my_task,ierr) + master_task = 0 + spd = shr_const_cday + + newData = .false. + n_lb = -1 + n_ub = -1 + fn_lb = 'undefinedlb' + fn_ub = 'undefinedub' + + oDateLB = mDateLB + oSecLB = mSecLB + oDateUB = mDateUB + oSecUB = mSecUB + + rDateM = real(mDate ,R8) + real(mSec ,R8)/spd + rDateLB = real(mDateLB,R8) + real(mSecLB,R8)/spd + rDateUB = real(mDateUB,R8) + real(mSecUB,R8)/spd + call t_stopf(trim(lstr)//'_setup') + + if (rDateM < rDateLB .or. rDateM > rDateUB) then + call t_startf(trim(lstr)//'_fbound') + if (my_task == master_task) then +! call shr_stream_findBounds(stream,mDate,mSec, & +! mDateLB,dDateLB,mSecLB,n_lb,fn_lb, & +! mDateUB,dDateUB,mSecUB,n_ub,fn_ub ) + call shr_stream_findBounds(stream,mDate,mSec, & + ivals(1),dDateLB,ivals(2),ivals(5),fn_lb, & + ivals(3),dDateUB,ivals(4),ivals(6),fn_ub ) + call shr_stream_getFilePath(stream,path) + localCopy = (shr_file_queryPrefix(path) /= shr_file_noPrefix ) + endif + call t_stopf(trim(lstr)//'_fbound') + call t_startf(trim(lstr)//'_bcast') + +! --- change 4 bcasts to a single bcast and copy for performance --- +! call shr_mpi_bcast(mDateLB,mpicom) +! call shr_mpi_bcast(mSecLB,mpicom) +! call shr_mpi_bcast(mDateUB,mpicom) +! call shr_mpi_bcast(mSecUB,mpicom) + call shr_mpi_bcast(stream%calendar,mpicom) + call shr_mpi_bcast(ivals,mpicom) + mDateLB = ivals(1) + mSecLB = ivals(2) + mDateUB = ivals(3) + mSecUB = ivals(4) + n_lb = ivals(5) + n_ub = ivals(6) + call t_stopf(trim(lstr)//'_bcast') + endif + + if (mDateLB /= oDateLB .or. mSecLB /= oSecLB) then + newdata = .true. + if (mDateLB == oDateUB .and. mSecLB == oSecUB) then + call t_startf(trim(lstr)//'_LB_copy') + avLB%rAttr(:,:) = avUB%rAttr(:,:) + call t_stopf(trim(lstr)//'_LB_copy') + else + if (my_task == master_task) then + write(logunit,F02) 'reading file: ',trim(path),trim(fn_lb),n_lb + call shr_sys_flush(logunit) + endif + call shr_dmodel_readstrm(stream, pio_subsystem, pio_iotype, pio_iodesc, gsMap, avLB, mpicom, & + path, fn_lb, n_lb,istr=trim(lstr)//'_LB') + endif + endif + + if (mDateUB /= oDateUB .or. mSecUB /= oSecUB) then + newdata = .true. + if (my_task == master_task) then + write(logunit,F02) 'reading file: ',trim(path),trim(fn_ub),n_ub + call shr_sys_flush(logunit) + endif + call shr_dmodel_readstrm(stream, pio_subsystem, pio_iotype, pio_iodesc, gsMap, avUB, mpicom, & + path, fn_ub, n_ub,istr=trim(lstr)//'_UB') + endif + + call t_startf(trim(lstr)//'_filemgt') + !--- determine previous & next data files in list of files --- + if (my_task == master_task .and. newdata) then + call shr_stream_getFilePath(stream,path) + localCopy = (shr_file_queryPrefix(path) /= shr_file_noPrefix ) + if (localCopy) then + call shr_stream_getPrevFileName(stream,fn_lb,fn_prev,path) + call shr_stream_getNextFileName(stream,fn_ub,fn_next,path) + inquire(file=trim(fn_next),exist=fileExists) + if ( trim(fn_next) == "unknown" .or. fileExists) then + ! do nothing + else + call shr_file_get(rCode,fn_next,trim(path)//fn_next,async=.true.) + write(logunit,F00) "get next file: ",trim(fn_next) + call shr_sys_flush(logunit) + end if + + !--- remove the old file? (only if acquiring local copies) --- + if ( rmOldFile .and. & + fn_prev/=fn_lb .and. fn_prev/=fn_ub .and. fn_prev/=fn_next ) then + !--- previous file is not in use and is not next in list --- + inquire(file=trim(fn_prev),exist=fileExists) + if ( fileExists ) then + call shr_sys_system(" rm "//trim(fn_prev),rCode) + write(logunit,F00) "rm prev file: ",trim(fn_prev) + call shr_sys_flush(logunit) + end if + end if + endif + endif + call t_stopf(trim(lstr)//'_filemgt') + +end subroutine shr_dmodel_readLBUB + +!=============================================================================== +subroutine shr_dmodel_readstrm(stream, pio_subsystem, pio_iotype, pio_iodesc, gsMap, av, mpicom, & + path, fn, nt, istr) + + use shr_file_mod, only : shr_file_noprefix, shr_file_queryprefix, shr_file_get + use shr_stream_mod + use shr_ncread_mod + implicit none + + !----- arguments ----- + type(shr_stream_streamType),intent(inout) :: stream + type(iosystem_desc_t),intent(inout), target :: pio_subsystem + integer(IN) ,intent(in) :: pio_iotype + type(io_desc_t) ,intent(inout) :: pio_iodesc + type(mct_gsMap) ,intent(in) :: gsMap + type(mct_aVect) ,intent(inout) :: av + integer(IN) ,intent(in) :: mpicom + character(len=*),intent(in) :: path + character(len=*),intent(in) :: fn + integer(IN) ,intent(in) :: nt + character(len=*),optional ,intent(in) :: istr + + !----- local ----- + integer(IN) :: my_task + integer(IN) :: master_task + integer(IN) :: ierr + logical :: localCopy,fileexists + type(mct_avect) :: avG + integer(IN) :: gsize,nx,ny + integer(IN) :: k + integer(IN) :: fid + integer(IN) :: rCode ! return code + real(R8),allocatable :: data(:,:) + character(CL) :: fileName + character(CL) :: sfldName + type(mct_avect) :: avtmp + character(len=32) :: lstr + + integer(in) :: ndims + integer(in),pointer :: dimid(:) + type(file_desc_t) :: pioid + type(var_desc_t) :: varid + integer(kind=pio_offset) :: frame + + character(*), parameter :: subname = '(shr_dmodel_readstrm) ' + character(*), parameter :: F00 = "('(shr_dmodel_readstrm) ',8a)" + character(*), parameter :: F01 = "('(shr_dmodel_readstrm) ',a,5i8)" + +!------------------------------------------------------------------------------- + + lstr = 'shr_dmodel_readstrm' + if (present(istr)) then + lstr = trim(istr) + endif + + call t_barrierf(trim(lstr)//'_BARRIER',mpicom) + call t_startf(trim(lstr)//'_setup') + call MPI_COMM_RANK(mpicom,my_task,ierr) + master_task = 0 + + gsize = mct_gsmap_gsize(gsMap) + + if (my_task == master_task) then + localCopy = (shr_file_queryPrefix(path) /= shr_file_noPrefix ) + if (localCopy) then + call shr_file_get(rCode,fn,trim(path)//fn) + fileName = fn + else ! DON'T acquire a local copy of the data file + fileName = trim(path)//fn + end if + inquire(file=trim(fileName),exist=fileExists) + if (.not. fileExists) then + write(logunit,F00) "ERROR: file does not exist: ", trim(fileName) + call shr_sys_abort(subName//"ERROR: file does not exist: "//trim(fileName)) + end if + endif + + if (my_task == master_task) then + call shr_stream_getFileFieldName(stream,1,sfldName) + endif + + call t_stopf(trim(lstr)//'_setup') + + if (pio_iotype == iotype_std_netcdf) then + + call t_startf(trim(lstr)//'_readcdf') + if (my_task == master_task) then + call shr_ncread_varDimSizes(trim(fileName),trim(sfldName),nx,ny) + if (gsize /= nx*ny) then + write(logunit,F01) "ERROR in data sizes ",nx,ny,gsize + call shr_sys_abort(subname//"ERROR in data sizes") + endif + call mct_aVect_init(avG,av,gsize) + allocate(data(nx,ny)) + call shr_ncread_open(trim(fileName),fid,rCode) + do k = 1,mct_aVect_nRAttr(av) + call shr_stream_getFileFieldName(stream,k,sfldName) + call shr_ncread_tField(fileName,nt,sfldName,data,fidi=fid,rc=rCode) + avG%rAttr(k,:) = reshape(data, (/gsize/)) + enddo + call shr_ncread_close(fid,rCode) + deallocate(data) + endif + call t_stopf(trim(lstr)//'_readcdf') + call t_barrierf(trim(lstr)//'_scatter'//'_BARRIER',mpicom) + call t_startf(trim(lstr)//'_scatter') + call mct_aVect_scatter(avG,avtmp,gsMap,master_task,mpicom) + call mct_aVect_copy(avtmp,av) + if (my_task == master_task) call mct_aVect_clean(avG) + call mct_aVect_clean(avtmp) + call t_stopf(trim(lstr)//'_scatter') + + else + + call t_startf(trim(lstr)//'_readpio') + call shr_mpi_bcast(sfldName,mpicom,'sfldName') + call shr_mpi_bcast(filename,mpicom,'filename') + rcode = pio_openfile(pio_subsystem, pioid, pio_iotype, trim(filename), pio_nowrite) + call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR) + + rcode = pio_inq_varid(pioid,trim(sfldName),varid) + rcode = pio_inq_varndims(pioid, varid, ndims) + allocate(dimid(ndims)) + rcode = pio_inq_vardimid(pioid, varid, dimid(1:ndims)) + rcode = pio_inq_dimlen(pioid, dimid(1), nx) + rcode = pio_inq_dimlen(pioid, dimid(2), ny) + deallocate(dimid) + if (gsize /= nx*ny) then + write(logunit,F01) "ERROR in data sizes ",nx,ny,gsize + call shr_sys_abort(subname//"ERROR in data sizes") + endif + + do k = 1,mct_aVect_nRAttr(av) + if (my_task == master_task) then + call shr_stream_getFileFieldName(stream,k,sfldName) + endif + call shr_mpi_bcast(sfldName,mpicom,'sfldName') + rcode = pio_inq_varid(pioid,trim(sfldName),varid) + frame = nt + call pio_setframe(varid,frame) + call pio_read_darray(pioid,varid,pio_iodesc,av%rattr(k,:),rcode) +!KO + if (sfldName == "a2x6h_Faxa_swndr" .or. sfldName == "a2x6h_Faxa_swvdr" .or. & + sfldName == "a2x6h_Faxa_swndf" .or. sfldName == "a2x6h_Faxa_swvdf") then + av%rattr(k,:) = max(av%rattr(k,:),0._r8) + end if +!KO + enddo + + call pio_closefile(pioid) + call t_stopf(trim(lstr)//'_readpio') + + endif + +end subroutine shr_dmodel_readstrm +!=============================================================================== +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_dmodel_gGridCompare -- returns TRUE if two domains are the same. +! +! !DESCRIPTION: +! Returns TRUE if two domains are the the same (within tolerance). +! +! !REVISION HISTORY: +! 2005-May-03 - B. Kauffman - added mulitiple methods +! 2005-May-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function shr_dmodel_gGridCompare(ggrid1,gsmap1,ggrid2,gsmap2,method,mpicom,eps) + +! !USES: + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_gGrid) ,intent(in) :: ggrid1 ! 1st ggrid + type(mct_gsmap) ,intent(in) :: gsmap1 ! 1st gsmap + type(mct_gGrid) ,intent(in) :: ggrid2 ! 2nd ggrid + type(mct_gsmap) ,intent(in) :: gsmap2 ! 2nd gsmap + integer(IN) ,intent(in) :: method ! selects what to compare + integer(IN) ,intent(in) :: mpicom ! mpicom + real(R8) ,optional,intent(in) :: eps ! epsilon compare value + +!EOP + + !--- local --- + real(R8) :: leps ! local epsilon + integer(IN) :: n ! counters + integer(IN) :: my_task,master_task + integer(IN) :: gsize + integer(IN) :: ierr + integer(IN) :: nlon1, nlon2, nlat1, nlat2, nmask1, nmask2 ! av field indices + logical :: compare ! local compare logical + real(R8) :: lon1,lon2 ! longitudes to compare + real(R8) :: lat1,lat2 ! latitudes to compare + real(R8) :: msk1,msk2 ! masks to compare + integer(IN) :: nx,ni1,ni2 ! i grid size, i offset for 1 vs 2 and 2 vs 1 + integer(IN) :: n1,n2,i,j ! local indices + type(mct_aVect) :: avG1 ! global av + type(mct_aVect) :: avG2 ! global av + integer(IN) :: lmethod ! local method + logical :: maskmethod, maskpoint ! masking on method + + !--- formats --- + character(*),parameter :: subName = '(shr_dmodel_gGridCompare) ' + character(*),parameter :: F01 = "('(shr_dmodel_gGridCompare) ',4a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call MPI_COMM_RANK(mpicom,my_task,ierr) + master_task = 0 + + leps = 1.0e-6_R8 + if (present(eps)) leps = eps + + lmethod = mod(method,100) + if (method > 100) then + maskmethod=.true. + else + maskmethod=.false. + endif + + call mct_aVect_gather(gGrid1%data,avG1,gsmap1,master_task,mpicom) + call mct_aVect_gather(gGrid2%data,avG2,gsmap2,master_task,mpicom) + + if (my_task == master_task) then + + compare = .true. + gsize = mct_aVect_lsize(avG1) + if (gsize /= mct_aVect_lsize(avG2)) then + compare = .false. + endif + + if (.not. compare ) then + !--- already failed the comparison test, check no futher --- + else + nlon1 = mct_aVect_indexRA(avG1,'lon') + nlat1 = mct_aVect_indexRA(avG1,'lat') + nlon2 = mct_aVect_indexRA(avG2,'lon') + nlat2 = mct_aVect_indexRA(avG2,'lat') + nmask1 = mct_aVect_indexRA(avG1,'mask') + nmask2 = mct_aVect_indexRA(avG2,'mask') + + ! To compare, want to be able to treat longitude wraparound generally. + ! So we need to compute i index offset and we need to compute the size of the nx dimension + ! First adjust the lon so it's in the range [0,360), add 1440 to lon to take into + ! accounts lons less than 1440. if any lon is less than -1440, abort. 1440 is arbitrary + ! Next, comute ni1 and ni2. These are the offsets of grid1 relative to grid2 and + ! grid2 relative to grid1. The sum of those offsets is nx. Use ni1 to offset grid2 + ! in comparison and compute new grid2 index from ni1 and nx. If ni1 is zero, then + ! there is no offset, don't need to compute ni2, and nx can be anything > 0. + + !--- compute offset of grid2 compared to pt 1 of grid 1 + lon1 = minval(avG1%rAttr(nlon1,:)) + lon2 = minval(avG2%rAttr(nlon2,:)) + if ((lon1 < -1440.0_R8) .or. (lon2 < -1440.0_R8)) then + write(logunit,*) subname,' ERROR: lon1 lon2 lt -1440 ',lon1,lon2 + call shr_sys_abort(subname//' ERROR: lon1 lon2 lt -1440') + endif + + lon1 = mod(avG1%rAttr(nlon1,1)+1440.0_R8,360.0_R8) + lat1 = avG1%rAttr(nlat1,1) + ni1 = -1 + do n = 1,gsize + lon2 = mod(avG2%rAttr(nlon2,n)+1440.0_R8,360.0_R8) + lat2 = avG2%rAttr(nlat2,n) + if ((ni1 < 0) .and. abs(lon1-lon2) <= leps .and. abs(lat1-lat2) <= leps) then + ni1 = n - 1 ! offset, compare to first gridcell in grid 1 + endif + enddo + + if (ni1 < 0) then ! no match for grid point 1, so fails without going further + compare = .false. + elseif (ni1 == 0) then ! no offset, set nx to anything > 0 + nx = 1 + else ! now compute ni2 + ! compute offset of grid1 compared to pt 1 of grid 2 + lon2 = mod(avG2%rAttr(nlon2,1)+1440.0_R8,360.0_R8) + lat2 = avG2%rAttr(nlat2,1) + ni2 = -1 + do n = 1,gsize + lon1 = mod(avG1%rAttr(nlon1,n)+1440.0_R8,360.0_R8) + lat1 = avG1%rAttr(nlat1,n) + if ((ni2 < 0) .and. abs(lon1-lon2) <= leps .and. abs(lat1-lat2) <= leps) then + ni2 = n - 1 ! offset, compare to first gridcell in grid 1 + endif + enddo + if (ni2 < 0) then + write(logunit,*) subname,' ERROR in ni2 ',ni1,ni2 + call shr_sys_abort(subname//' ERROR in ni2') + endif + nx = ni1 + ni2 + endif + + if (compare) then + do n = 1,gsize + j = ((n-1)/nx) + 1 + i = mod(n-1,nx) + 1 + n1 = (j-1)*nx + mod(n-1,nx) + 1 + n2 = (j-1)*nx + mod(n-1+ni1,nx) + 1 + if (n1 /= n) then ! sanity check, could be commented out + write(logunit,*) subname,' ERROR in n1 n2 ',n,i,j,n1,n2 + call shr_sys_abort(subname//' ERROR in n1 n2') + endif + lon1 = mod(avG1%rAttr(nlon1,n1)+1440.0_R8,360.0_R8) + lat1 = avG1%rAttr(nlat1,n1) + lon2 = mod(avG2%rAttr(nlon2,n2)+1440.0_R8,360.0_R8) + lat2 = avG2%rAttr(nlat2,n2) + msk1 = avG1%rAttr(nmask1,n1) + msk2 = avG2%rAttr(nmask2,n2) + + maskpoint = .true. + if (maskmethod .and. (msk1 == 0 .or. msk2 == 0)) then + maskpoint = .false. + endif + + if (maskpoint) then + if (lmethod == shr_dmodel_gGridCompareXYabs ) then + if (abs(lon1 - lon2) > leps) compare = .false. + if (abs(lat1 - lat2) > leps) compare = .false. + else if (lmethod == shr_dmodel_gGridCompareXYrel ) then + if (rdiff(lon1,lon2) > leps) compare = .false. + if (rdiff(lat1,lat2) > leps) compare = .false. + else if (lmethod == shr_dmodel_gGridCompareMaskIdent ) then + if (msk1 /= msk2)compare = .false. + else if (lmethod == shr_dmodel_gGridCompareMaskZeros ) then + if (msk1 == 0 .and. msk2 /= 0) compare = .false. + if (msk1 /= 0 .and. msk2 == 0) compare = .false. + else if (lmethod == shr_dmodel_gGridCompareMaskSubset ) then + if (msk1 /= 0 .and. msk2 == 0) compare = .false. + else + write(logunit,F01) "ERROR: compare method not recognized, method = ",method + call shr_sys_abort(subName//"ERROR: compare method not recognized") + endif ! lmethod + endif ! maskpoint + enddo ! gsize + endif ! compare + endif ! compare + endif ! master_task + + if (my_task == master_task) call mct_avect_clean(avG1) + if (my_task == master_task) call mct_avect_clean(avG2) + + call shr_mpi_bcast(compare,mpicom) + shr_dmodel_gGridCompare = compare + + return + +!------------------------------------------------------------------------------- +contains ! internal subprogram +!------------------------------------------------------------------------------- + + real(R8) function rdiff(v1,v2) ! internal function + !------------------------------------------ + real(R8),intent(in) :: v1,v2 ! two values to compare + real(R8),parameter :: c0 = 0.0_R8 ! zero + real(R8),parameter :: large_number = 1.0e20_R8 ! infinity + !------------------------------------------ + if (v1 == v2) then + rdiff = c0 + elseif (v1 == c0 .and. v2 /= c0) then + rdiff = large_number + elseif (v2 == c0 .and. v1 /= c0) then + rdiff = large_number + else +! rdiff = abs((v2-v1)/v1) ! old version, but rdiff(v1,v2) /= vdiff(v2,v1) + rdiff = abs(2.0_R8*(v2-v1)/(v1+v2)) + endif + !------------------------------------------ + end function rdiff + +end function shr_dmodel_gGridCompare + +!=============================================================================== + +subroutine shr_dmodel_mapSet_global(smatp,ggridS,gsmapS,nxgS,nygS,ggridD,gsmapD,nxgD,nygD, & + name,type,algo,mask,vect,compid,mpicom,strategy) + + use shr_map_mod + implicit none + + !----- arguments ----- + type(mct_sMatP), intent(inout) :: smatp + type(mct_gGrid), intent(in) :: ggridS + type(mct_gsmap), intent(in) :: gsmapS + integer(IN) , intent(in) :: nxgS + integer(IN) , intent(in) :: nygS + type(mct_gGrid), intent(in) :: ggridD + type(mct_gsmap), intent(in) :: gsmapD + integer(IN) , intent(in) :: nxgD + integer(IN) , intent(in) :: nygD + character(len=*),intent(in) :: name + character(len=*),intent(in) :: type + character(len=*),intent(in) :: algo + character(len=*),intent(in) :: mask + character(len=*),intent(in) :: vect + integer(IN) , intent(in) :: compid + integer(IN) , intent(in) :: mpicom + character(len=*),intent(in),optional :: strategy + + !----- local ----- + + integer(IN) :: n,i,j + integer(IN) :: lsizeS,gsizeS,lsizeD,gsizeD + integer(IN) :: nlon,nlat,nmsk + integer(IN) :: my_task,master_task,ierr + + real(R8) , pointer :: Xsrc(:,:) + real(R8) , pointer :: Ysrc(:,:) + integer(IN), pointer :: Msrc(:,:) + real(R8) , pointer :: Xdst(:,:) + real(R8) , pointer :: Ydst(:,:) + integer(IN), pointer :: Mdst(:,:) + type(shr_map_mapType) :: shrmap + type(mct_aVect) :: AVl + type(mct_aVect) :: AVg + + character(len=32) :: lstrategy + integer(IN) :: nsrc,ndst,nwts + integer(IN), pointer :: isrc(:) + integer(IN), pointer :: idst(:) + real(R8) , pointer :: wgts(:) + type(mct_sMat) :: sMat0 + + character(*), parameter :: subname = '(shr_dmodel_mapSet_global) ' + character(*), parameter :: F00 = "('(shr_dmodel_mapSet_global) ',8a)" + character(*), parameter :: F01 = "('(shr_dmodel_mapSet_global) ',a,5i8)" + +!------------------------------------------------------------------------------- +! PURPOSE: Initialize sMatP from mct gGrid +!------------------------------------------------------------------------------- + + call MPI_COMM_RANK(mpicom,my_task,ierr) + master_task = 0 + + !--- get sizes and allocate for SRC --- + + lsizeS = mct_aVect_lsize(ggridS%data) + call mct_avect_init(AVl,rList='lon:lat:mask',lsize=lsizeS) + call mct_avect_copy(ggridS%data,AVl,rList='lon:lat:mask') + call mct_avect_gather(AVl,AVg,gsmapS,master_task,mpicom) + + if (my_task == master_task) then + gsizeS = mct_aVect_lsize(AVg) + if (gsizeS /= nxgS*nygS) then + write(logunit,F01) ' ERROR: gsizeS ',gsizeS,nxgS,nygS + call shr_sys_abort(subname//' ERROR gsizeS') + endif + allocate(Xsrc(nxgS,nygS),Ysrc(nxgS,nygS),Msrc(nxgS,nygS)) + + nlon = mct_avect_indexRA(AVg,'lon') + nlat = mct_avect_indexRA(AVg,'lat') + nmsk = mct_avect_indexRA(AVg,'mask') + + n = 0 + Msrc = 1 + do j = 1,nygS + do i = 1,nxgS + n = n + 1 + Xsrc(i,j) = AVg%rAttr(nlon,n) + Ysrc(i,j) = AVg%rAttr(nlat,n) + if (abs(AVg%rAttr(nmsk,n)) < 0.5_R8) Msrc(i,j) = 0 + enddo + enddo + endif + + if (my_task == master_task) call mct_aVect_clean(AVg) + call mct_aVect_clean(AVl) + + !--- get sizes and allocate for DST --- + + lsizeD = mct_aVect_lsize(ggridD%data) + call mct_avect_init(AVl,rList='lon:lat:mask',lsize=lsizeD) + call mct_avect_copy(ggridD%data,AVl,rList='lon:lat:mask') + call mct_avect_gather(AVl,AVg,gsmapD,master_task,mpicom) + + if (my_task == master_task) then + gsizeD = mct_aVect_lsize(AVg) + if (gsizeD /= nxgD*nygD) then + write(logunit,F01) ' ERROR: gsizeD ',gsizeD,nxgD,nygD + call shr_sys_abort(subname//' ERROR gsizeD') + endif + allocate(Xdst(nxgD,nygD),Ydst(nxgD,nygD),Mdst(nxgD,nygD)) + + nlon = mct_avect_indexRA(AVg,'lon') + nlat = mct_avect_indexRA(AVg,'lat') + nmsk = mct_avect_indexRA(AVg,'mask') + + n = 0 + Mdst = 1 + do j = 1,nygD + do i = 1,nxgD + n = n + 1 + Xdst(i,j) = AVg%rAttr(nlon,n) + Ydst(i,j) = AVg%rAttr(nlat,n) + if (abs(AVg%rAttr(nmsk,n)) < 0.5_R8) Mdst(i,j) = 0 + enddo + enddo + endif + + if (my_task == master_task) call mct_aVect_clean(AVg) + call mct_aVect_clean(AVl) + + !--- set map --- + + if (my_task == master_task) then + call shr_map_mapSet(shrmap,Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst, & + trim(name),trim(type),trim(algo),trim(mask),trim(vect)) + deallocate(Xsrc,Ysrc,Msrc) + deallocate(Xdst,Ydst,Mdst) + endif + + !--- convert map to sMatP --- + + lstrategy = 'Xonly' + if (present(strategy)) then + lstrategy = trim(strategy) + endif + + if (my_task == master_task) then + call shr_map_get(shrmap,shr_map_fs_nsrc,nsrc) + call shr_map_get(shrmap,shr_map_fs_ndst,ndst) + call shr_map_get(shrmap,shr_map_fs_nwts,nwts) + allocate(isrc(nwts),idst(nwts),wgts(nwts)) + call shr_map_get(shrmap,isrc,idst,wgts) + call shr_map_clean(shrmap) + + call mct_sMat_init(sMat0,ndst,nsrc,nwts) + + call mct_sMat_ImpGColI (sMat0,isrc,nwts) + call mct_sMat_ImpGRowI (sMat0,idst,nwts) + call mct_sMat_ImpMatrix(sMat0,wgts,nwts) + deallocate(isrc,idst,wgts) + endif + + call mct_sMatP_Init(sMatP,sMat0,gsmapS,gsmapD,lstrategy,master_task,mpicom,compid) + + if (my_task == master_task) then + call mct_sMat_clean(sMat0) + endif + +end subroutine shr_dmodel_mapSet_global + +!=============================================================================== + +subroutine shr_dmodel_mapSet_dest(smatp,ggridS,gsmapS,nxgS,nygS,ggridD,gsmapD,nxgD,nygD, & + name,type,algo,mask,vect,compid,mpicom,strategy) + + use shr_map_mod + implicit none + + !----- arguments ----- + type(mct_sMatP), intent(inout) :: smatp + type(mct_gGrid), intent(in) :: ggridS + type(mct_gsmap), intent(in) :: gsmapS + integer(IN) , intent(in) :: nxgS + integer(IN) , intent(in) :: nygS + type(mct_gGrid), intent(in) :: ggridD + type(mct_gsmap), intent(in) :: gsmapD + integer(IN) , intent(in) :: nxgD + integer(IN) , intent(in) :: nygD + character(len=*),intent(in) :: name + character(len=*),intent(in) :: type + character(len=*),intent(in) :: algo + character(len=*),intent(in) :: mask + character(len=*),intent(in) :: vect + integer(IN) , intent(in) :: compid + integer(IN) , intent(in) :: mpicom + character(len=*),intent(in),optional :: strategy + + !----- local ----- + + integer(IN) :: n,i,j + integer(IN) :: lsizeS,gsizeS,lsizeD,gsizeD + integer(IN) :: nlon,nlat,nmsk + integer(IN) :: my_task,master_task,ierr + + real(R8) , pointer :: Xsrc(:,:) + real(R8) , pointer :: Ysrc(:,:) + integer(IN), pointer :: Msrc(:,:) + real(R8) , pointer :: Xdst(:) + real(R8) , pointer :: Ydst(:) + integer(IN), pointer :: Mdst(:) + type(shr_map_mapType) :: shrmap + type(mct_aVect) :: AVl + type(mct_aVect) :: AVg + + character(len=32) :: lstrategy + integer(IN) :: nsrc,ndst,nwts + integer(IN), pointer :: points(:) + integer(IN), pointer :: isrc(:) + integer(IN), pointer :: idst(:) + real(R8) , pointer :: wgts(:) + type(mct_sMat) :: sMat0 + + character(*), parameter :: subname = '(shr_dmodel_mapSet_dest) ' + character(*), parameter :: F00 = "('(shr_dmodel_mapSet_dest) ',8a)" + character(*), parameter :: F01 = "('(shr_dmodel_mapSet_dest) ',a,5i8)" + +!------------------------------------------------------------------------------- +! PURPOSE: Initialize sMatP from mct gGrid +!------------------------------------------------------------------------------- + + call MPI_COMM_RANK(mpicom,my_task,ierr) + master_task = 0 + + !--- get sizes and allocate for SRC --- + + lsizeS = mct_aVect_lsize(ggridS%data) + call mct_avect_init(AVl,rList='lon:lat:mask',lsize=lsizeS) + call mct_avect_copy(ggridS%data,AVl,rList='lon:lat:mask') + + call mct_avect_gather(AVl,AVg,gsmapS,master_task,mpicom) + + allocate(Xsrc(nxgS,nygS),Ysrc(nxgS,nygS),Msrc(nxgS,nygS)) + if (my_task == master_task) then + gsizeS = mct_aVect_lsize(AVg) + if (gsizeS /= nxgS*nygS) then + write(logunit,F01) ' ERROR: gsizeS ',gsizeS,nxgS,nygS + call shr_sys_abort(subname//' ERROR gsizeS') + endif + + nlon = mct_avect_indexRA(AVg,'lon') + nlat = mct_avect_indexRA(AVg,'lat') + nmsk = mct_avect_indexRA(AVg,'mask') + + n = 0 + Msrc = 1 + do j = 1,nygS + do i = 1,nxgS + n = n + 1 + Xsrc(i,j) = AVg%rAttr(nlon,n) + Ysrc(i,j) = AVg%rAttr(nlat,n) + if (abs(AVg%rAttr(nmsk,n)) < 0.5_R8) Msrc(i,j) = 0 + enddo + enddo + endif + call shr_mpi_bcast(Xsrc,mpicom) + call shr_mpi_bcast(Ysrc,mpicom) + call shr_mpi_bcast(Msrc,mpicom) + + if (my_task == master_task) call mct_aVect_clean(AVg) + call mct_aVect_clean(AVl) + + !--- get sizes and allocate for DST --- + + lsizeD = mct_aVect_lsize(ggridD%data) + call mct_avect_init(AVl,rList='lon:lat:mask',lsize=lsizeD) + call mct_avect_copy(ggridD%data,AVl,rList='lon:lat:mask') + +#if (1 == 0) + call mct_avect_gather(AVl,AVg,gsmapD,master_task,mpicom) + + if (my_task == master_task) then + gsizeD = mct_aVect_lsize(AVg) + if (gsizeD /= nxgD*nygD) then + write(logunit,F01) ' ERROR: gsizeD ',gsizeD,nxgD,nygD + call shr_sys_abort(subname//' ERROR gsizeD') + endif + allocate(Xdst(nxgD,nygD),Ydst(nxgD,nygD),Mdst(nxgD,nygD)) + + nlon = mct_avect_indexRA(AVg,'lon') + nlat = mct_avect_indexRA(AVg,'lat') + nmsk = mct_avect_indexRA(AVg,'mask') + + n = 0 + Mdst = 1 + do j = 1,nygD + do i = 1,nxgD + n = n + 1 + Xdst(i,j) = AVg%rAttr(nlon,n) + Ydst(i,j) = AVg%rAttr(nlat,n) + if (abs(AVg%rAttr(nmsk,n)) < 0.5_R8) Mdst(i,j) = 0 + enddo + enddo + endif + + if (my_task == master_task) call mct_aVect_clean(AVg) +#endif + + allocate(Xdst(lsizeD),Ydst(lsizeD),Mdst(lsizeD)) + + nlon = mct_avect_indexRA(AVl,'lon') + nlat = mct_avect_indexRA(AVl,'lat') + nmsk = mct_avect_indexRA(AVl,'mask') + + Mdst = 1 + do n = 1,lsizeD + Xdst(n) = AVl%rAttr(nlon,n) + Ydst(n) = AVl%rAttr(nlat,n) + if (abs(AVl%rAttr(nmsk,n)) < 0.5_R8) Mdst(n) = 0 + enddo + + call mct_aVect_clean(AVl) + + !--- set map --- + + nsrc = nxgS*nygS + ndst = nxgD*nygD + call mct_gsmap_orderedPoints(gsmapD,my_task,points) + if (size(points) /= size(Xdst)) then + write(logunit,F01) ' ERROR: gsizeD ',size(points),size(Xdst) + call shr_sys_abort(subname//' ERROR points size') + endif + call shr_map_mapSet(shrmap,Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,ndst,points, & + trim(name),trim(type),trim(algo),trim(mask),trim(vect)) + deallocate(points) + deallocate(Xsrc,Ysrc,Msrc) + deallocate(Xdst,Ydst,Mdst) + + !--- convert map to sMatP --- + + lstrategy = 'Xonly' + if (present(strategy)) then + lstrategy = trim(strategy) + endif + + call shr_map_get(shrmap,shr_map_fs_nwts,nwts) + allocate(isrc(nwts),idst(nwts),wgts(nwts)) + call shr_map_get(shrmap,isrc,idst,wgts) + call shr_map_clean(shrmap) + + call mct_sMat_init(sMat0,ndst,nsrc,nwts) + + call mct_sMat_ImpLColI (sMat0,isrc,nwts) + call mct_sMat_ImpLRowI (sMat0,idst,nwts) + call mct_sMat_ImpMatrix(sMat0,wgts,nwts) + deallocate(isrc,idst,wgts) + + call mct_sMatP_Init(sMatP,sMat0,gsmapS,gsmapD,master_task,mpicom,compid) + + call mct_sMat_clean(sMat0) + +end subroutine shr_dmodel_mapSet_dest + +!=============================================================================== + +subroutine shr_dmodel_rearrGGrid( ggridi, ggrido, gsmap, rearr, mpicom ) + + implicit none + + !----- arguments ----- + type(mct_ggrid), intent(in) :: ggridi + type(mct_ggrid), intent(inout) :: ggrido + type(mct_gsmap), intent(in) :: gsmap + type(mct_rearr), intent(in) :: rearr + integer(IN) , intent(in) :: mpicom + + !----- local ----- + integer(IN) :: lsize ! lsize + real(R8) , pointer :: data(:) ! temporary + integer(IN), pointer :: idata(:) ! temporary + integer(IN) :: my_task ! local pe number + integer(IN) :: ier ! error code + character(*), parameter :: subname = '(shr_dmodel_rearrGGrid) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Determine MCT ggrid +!------------------------------------------------------------------------------- + + ! Initialize mct ggrid type + ! lat/lon in degrees, area in radians^2, mask is 1 (ocean), 0 (non-ocean) + + call mpi_comm_rank(mpicom,my_task,ier) + + lsize = mct_gsMap_lsize(gsMap, mpicom) + call mct_gGrid_init( ggrido, ggridi, lsize=lsize ) + + ! Determine global gridpoint number attribute, GlobGridNum, automatically in ggrid + + call mct_gsMap_orderedPoints(gsMap, my_task, idata) + call mct_gGrid_importIAttr(ggrido,'GlobGridNum',idata,lsize) + deallocate(idata) + + ! Initialize attribute vector with special value + + allocate(data(lsize)) + + data(:) = -9999.0_R8 + call mct_gGrid_importRAttr(ggrido,"lat" ,data,lsize) + call mct_gGrid_importRAttr(ggrido,"lon" ,data,lsize) + call mct_gGrid_importRAttr(ggrido,"area" ,data,lsize) + call mct_gGrid_importRAttr(ggrido,"aream",data,lsize) + data(:) = 0.0_R8 + call mct_gGrid_importRAttr(ggrido,"mask",data,lsize) + call mct_gGrid_importRAttr(ggrido,"frac",data,lsize) + + deallocate(data) + + call mct_rearr_rearrange(ggridi%data, ggrido%data, rearr) + +end subroutine shr_dmodel_rearrGGrid + +!=============================================================================== + +subroutine shr_dmodel_translateAV( avi, avo, avifld, avofld, rearr ) + + implicit none + + !----- arguments ----- + type(mct_aVect), intent(in) :: avi ! input av + type(mct_aVect), intent(inout) :: avo ! output av + character(len=*),intent(in) :: avifld(:) ! input field names for translation + character(len=*),intent(in) :: avofld(:) ! output field names for translation + type(mct_rearr), intent(in),optional :: rearr ! rearranger for diff decomp + + !----- local ----- + integer(IN) :: n,k,ka,kb,kc,cnt ! indices + integer(IN) :: lsize ! lsize + integer(IN) :: gsize ! gsize + integer(IN) :: nflds ! number of fields in avi + + type(mct_aVect) :: avtri,avtro ! translated av on input/output grid + character(CXX) :: ilist ! input list for translation + character(CXX) :: olist ! output list for translation + character(CX) :: cfld ! character field name + type(mct_string) :: sfld ! string field + integer(IN) :: ktrans + character(*), parameter :: subname = '(shr_dmodel_translateAV) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Fill avo from avi +!------------------------------------------------------------------------------- + + if (size(avifld) /= size(avofld)) then + write(logunit,*) subname,' ERROR": avi and avo fld list ',size(avifld),size(avofld) + call shr_sys_flush(logunit) + endif + ktrans = size(avifld) + + ! generate fld lists + nflds = mct_aVect_nRattr(avi) + cnt = 0 + do ka = 1,nflds + call mct_aVect_getRList(sfld,ka,avi) + cfld = mct_string_toChar(sfld) + call mct_string_clean(sfld) + + k = 0 + kb = 0 + kc = 0 + do while (kb == 0 .and. k < ktrans) + k = k + 1 + if (trim(avifld(k)) == trim(cfld)) then + kb = k + kc = mct_aVect_indexRA(avo,trim(avofld(kb)),perrWith='quiet') + if (ka > 0 .and. kc > 0) then + cnt = cnt + 1 + if (cnt == 1) then + ilist = trim(avifld(kb)) + olist = trim(avofld(kb)) + else + ilist = trim(ilist)//':'//trim(avifld(kb)) + olist = trim(olist)//':'//trim(avofld(kb)) + endif + endif + endif + enddo + enddo + + if (cnt > 0) then + lsize = mct_avect_lsize(avi) + call mct_avect_init(avtri,rlist=olist,lsize=lsize) + call mct_avect_Copy(avi,avtri,rList=ilist,TrList=olist) + + if (present(rearr)) then + lsize = mct_avect_lsize(avo) + call mct_avect_init(avtro,rlist=olist,lsize=lsize) + call mct_avect_zero(avtro) + call mct_rearr_rearrange(avtri, avtro, rearr) + call mct_avect_Copy(avtro,avo) + call mct_aVect_clean(avtro) + else + call mct_avect_Copy(avtri,avo) + endif + + call mct_aVect_clean(avtri) + endif + +end subroutine shr_dmodel_translateAV + +!=============================================================================== + +subroutine shr_dmodel_translate_list( avi, avo, avifld, avofld, ilist, olist, cnt) + + implicit none + + !----- arguments ----- + type(mct_aVect), intent(in) :: avi ! input av + type(mct_aVect), intent(inout) :: avo ! output av + character(len=*),intent(in) :: avifld(:) ! input field names for translation + character(len=*),intent(in) :: avofld(:) ! output field names for translation + character(CL) ,intent(out) :: ilist ! input list for translation + character(CL) ,intent(out) :: olist ! output list for translation + integer(IN) ,intent(out) :: cnt ! indices + + + !----- local ----- + integer(IN) :: n,k,ka,kb,kc ! indices + integer(IN) :: lsize ! lsize + integer(IN) :: nflds ! number of fields in avi + character(CL) :: cfld ! character field name + type(mct_string) :: sfld ! string field + integer(IN) :: ktrans + character(*), parameter :: subname = '(shr_dmodel_translateAV) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Fill avo from avi +!------------------------------------------------------------------------------- + + if (size(avifld) /= size(avofld)) then + write(logunit,*) subname,' ERROR": avi and avo fld list ',size(avifld),size(avofld) + call shr_sys_flush(logunit) + endif + ktrans = size(avifld) + + ! generate fld lists + nflds = mct_aVect_nRattr(avi) + cnt = 0 + do ka = 1,nflds + call mct_aVect_getRList(sfld,ka,avi) + cfld = mct_string_toChar(sfld) + call mct_string_clean(sfld) + + k = 0 + kb = 0 + kc = 0 + do while (kb == 0 .and. k < ktrans) + k = k + 1 + if (trim(avifld(k)) == trim(cfld)) then + kb = k + kc = mct_aVect_indexRA(avo,trim(avofld(kb)),perrWith='quiet') + if (ka > 0 .and. kc > 0) then + cnt = cnt + 1 + if (cnt == 1) then + ilist = trim(avifld(kb)) + olist = trim(avofld(kb)) + else + ilist = trim(ilist)//':'//trim(avifld(kb)) + olist = trim(olist)//':'//trim(avofld(kb)) + endif + endif + endif + enddo + enddo + +end subroutine shr_dmodel_translate_list + +!=============================================================================== + +subroutine shr_dmodel_translateAV_list( avi, avo, ilist, olist, rearr ) + + implicit none + + !----- arguments ----- + type(mct_aVect), intent(in) :: avi ! input av + type(mct_aVect), intent(inout) :: avo ! output av + character(CL) ,intent(in) :: ilist ! input list for translation + character(CL) ,intent(in) :: olist ! output list for translation + type(mct_rearr), intent(in),optional :: rearr ! rearranger for diff decomp + + !----- local ----- + integer(IN) :: lsize ! lsize + type(mct_aVect) :: avtri,avtro ! translated av on input/output grid + character(*), parameter :: subname = '(shr_dmodel_translateAV) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Fill avo from avi +!------------------------------------------------------------------------------- + + lsize = mct_avect_lsize(avi) + call mct_avect_init(avtri,rlist=olist,lsize=lsize) + call mct_avect_Copy(avi,avtri,rList=ilist,TrList=olist) + + if (present(rearr)) then + lsize = mct_avect_lsize(avo) + call mct_avect_init(avtro,rlist=olist,lsize=lsize) + call mct_avect_zero(avtro) + call mct_rearr_rearrange(avtri, avtro, rearr) + call mct_avect_Copy(avtro,avo) + call mct_aVect_clean(avtro) + else + call mct_avect_Copy(avtri,avo) + endif + + call mct_aVect_clean(avtri) + +end subroutine shr_dmodel_translateAV_list + +!=============================================================================== + +end module shr_dmodel_mod diff --git a/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.share/shr_strdata_mod.F90 b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.share/shr_strdata_mod.F90 new file mode 100644 index 0000000000..d54110dbed --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/SourceMods/src.share/shr_strdata_mod.F90 @@ -0,0 +1,1528 @@ + +! DART bugzilla 1927 fix for 'longwave radiation error' +! DART note: this file started life as: +! /glade/p/cesmdata/cseg/collections/cesm1_2_1/models/csm_share/shr/shr_strdata_mod.F90 + +!=============================================================================== +! SVN: $Id: shr_strdata.F90 11584 2008-09-08 03:16:24Z mvertens $ +! SVN: $HeadURL: https://svn-ccsm-models.cgd.ucar.edu/dlnd7/trunk_tags/dlnd7_090320/shr_strdata.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: shr_strdata_mod -- holds data and methods to advance data models +! +! !DESCRIPTION: +! holds data and methods to advance data models +! +! !REVISION HISTORY: +! 2009-Apr-15 - T. Craig initial version +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_strdata_mod + + use shr_const_mod, only: SHR_CONST_PI + use shr_kind_mod, only: IN=>SHR_KIND_IN, R8=>SHR_KIND_R8, & + CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, & + CXX=>SHR_KIND_CXX + use shr_sys_mod, only : shr_sys_abort, shr_sys_flush + use shr_mpi_mod, only : shr_mpi_bcast + use shr_file_mod, only : shr_file_getunit, shr_file_freeunit + use shr_log_mod, only: loglev => shr_log_Level + use shr_log_mod, only: logunit => shr_log_Unit + use shr_stream_mod ! stream data type and methods + use shr_string_mod + use shr_map_mod + use shr_cal_mod, only: shr_cal_calendarname, shr_cal_timeSet, & + shr_cal_noleap, shr_cal_gregorian, & + shr_cal_date2ymd, shr_cal_ymd2date + use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz, shr_orb_undef_real + use shr_tinterp_mod + + use shr_dmodel_mod ! shr data model stuff + + use shr_mct_mod + use mct_mod ! mct + use perf_mod ! timing + use pio ! pio + use esmf + + implicit none + + private + +! !PUBLIC TYPES: + + public shr_strdata_type + +! !PUBLIC MEMBER FUNCTIONS: + + public shr_strdata_readnml + public shr_strdata_bcastnml + public shr_strdata_restRead + public shr_strdata_restWrite + public shr_strdata_setOrbs + public shr_strdata_print + public shr_strdata_init + public shr_strdata_create + public shr_strdata_advance + public shr_strdata_clean + public shr_strdata_setlogunit + public shr_strdata_pioinit + +! !PUBLIC DATA MEMBERS: + + +! !PRIVATE: + + integer(IN),parameter :: nStrMax = 30 + integer(IN),parameter :: nVecMax = 30 + character(len=*),public,parameter :: shr_strdata_nullstr = 'null' + character(len=*),parameter :: shr_strdata_unset = 'NOT_SET' + real(R8),parameter,private :: dtlimit_default = 1.5_R8 + + type shr_strdata_type + ! --- set by input --- + character(CL) :: dataMode ! flags physics options wrt input data + character(CL) :: domainFile ! file containing domain info + character(CL) :: streams (nStrMax) ! stream description file names + character(CL) :: taxMode (nStrMax) ! time axis cycling mode + real(R8) :: dtlimit (nStrMax) ! dt max/min limit + character(CL) :: vectors (nVecMax) ! define vectors to vector map + character(CL) :: fillalgo(nStrMax) ! fill algorithm + character(CL) :: fillmask(nStrMax) ! fill mask + character(CL) :: fillread(nStrMax) ! fill mapping file to read + character(CL) :: fillwrit(nStrMax) ! fill mapping file to write + character(CL) :: mapalgo (nStrMax) ! scalar map algorithm + character(CL) :: mapmask (nStrMax) ! scalar map mask + character(CL) :: mapread(nStrMax) ! regrid mapping file to read + character(CL) :: mapwrit(nStrMax) ! regrid mapping file to write + character(CL) :: tintalgo(nStrMax) ! time interpolation algorithm + integer(IN) :: io_type + !--- data required by cosz t-interp method, set by user --- + real(R8) :: eccen + real(R8) :: mvelpp + real(R8) :: lambm0 + real(R8) :: obliqr + integer(IN) :: modeldt ! model dt in seconds + ! --- internal, public --- + integer(IN) :: nxg + integer(IN) :: nyg + integer(IN) :: lsize + type(mct_gsmap) :: gsmap + type(mct_ggrid) :: grid + type(mct_avect) :: avs(nStrMax) + ! --- internal --- + type(shr_stream_streamType) :: stream(nStrMax) + type(iosystem_desc_t), pointer :: pio_subsystem => null() + type(io_desc_t) :: pio_iodesc(nStrMax) + integer(IN) :: nstreams ! number of streams + integer(IN) :: strnxg(nStrMax) + integer(IN) :: strnyg(nStrMax) + logical :: dofill(nStrMax) + logical :: domaps(nStrMax) + integer(IN) :: lsizeR(nStrMax) + type(mct_gsmap) :: gsmapR(nStrMax) + type(mct_rearr) :: rearrR(nStrMax) + type(mct_ggrid) :: gridR(nStrMax) + type(mct_avect) :: avRLB(nStrMax) + type(mct_avect) :: avRUB(nStrMax) + type(mct_avect) :: avFUB(nStrMax) + type(mct_avect) :: avFLB(nStrMax) + type(mct_avect) :: avCoszen(nStrMax) ! data assocaited with coszen time interp + type(mct_sMatP) :: sMatPf(nStrMax) + type(mct_sMatP) :: sMatPs(nStrMax) + integer(IN) :: ymdLB(nStrMax),todLB(nStrMax) + integer(IN) :: ymdUB(nStrMax),todUB(nStrMax) + real(R8) :: dtmin(nStrMax) + real(R8) :: dtmax(nStrMax) + integer(IN) :: ymd ,tod + character(CL) :: calendar ! model calendar for ymd,tod + integer(IN) :: nvectors ! number of vectors + integer(IN) :: ustrm (nVecMax) + integer(IN) :: vstrm (nVecMax) + character(CL) :: allocstring + end type shr_strdata_type + + real(R8),parameter,private :: deg2rad = SHR_CONST_PI/180.0_R8 + character(len=*),parameter :: allocstring_value = 'strdata_allocated' + +!=============================================================================== + contains +!=============================================================================== + + subroutine shr_strdata_init(SDAT,mpicom,compid,name,scmmode,scmlon,scmlat, & + gsmap,ggrid,nxg,nyg,calendar) + + implicit none + + type(shr_strdata_type),intent(inout) :: SDAT + integer(IN) ,intent(in) :: mpicom + integer(IN) ,intent(in) :: compid + character(len=*) ,intent(in),optional :: name + logical ,intent(in),optional :: scmmode + real(R8) ,intent(in),optional :: scmlon + real(R8) ,intent(in),optional :: scmlat + type(mct_gsmap) ,intent(in),optional :: gsmap + type(mct_ggrid) ,intent(in),optional :: ggrid + integer(IN) ,intent(in),optional :: nxg + integer(IN) ,intent(in),optional :: nyg + character(len=*) ,intent(in),optional :: calendar + + integer(IN) :: n,m,k ! generic index + integer(IN) :: nu,nv ! u,v index + integer(IN) :: my_task,npes ! my task, total pes + integer(IN),parameter :: master_task = 0 + character(CS) :: lname ! local name + character(CL) :: filePath ! generic file path + character(CL) :: fileName ! generic file name + character(CS) :: timeName ! domain file: time variable name + character(CS) :: lonName ! domain file: lon variable name + character(CS) :: latName ! domain file: lat variable name + character(CS) :: maskName ! domain file: mask variable name + character(CS) :: areaName ! domain file: area variable name + character(CS) :: uname ! u vector field name + character(CS) :: vname ! v vector field name + character(CXX):: fldList ! list of fields + integer(IN) :: lsize + integer(IN) :: nfiles + integer(IN) :: ierr + integer(IN) :: method + integer(IN), pointer :: dof(:) + type(mct_sMat):: sMati + logical :: lscmmode + + character(len=*),parameter :: subname = "(shr_strdata_init) " + character(*),parameter :: F00 = "('(shr_strdata_init) ',8a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call MPI_COMM_SIZE(mpicom,npes,ierr) + call MPI_COMM_RANK(mpicom,my_task,ierr) + !--- Count streams again in case user made changes --- + if (my_task == master_task) then + do n=1,nStrMax + !--- check if a streams string is defined in strdata + if (trim(SDAT%streams(n)) /= trim(shr_strdata_nullstr)) SDAT%nstreams = max(SDAT%nstreams,n) + !--- check if a filename is defined in the stream + call shr_stream_getNFiles(SDAT%stream(n),nfiles) + if (nfiles > 0) SDAT%nstreams = max(SDAT%nstreams,n) + + if (trim(SDAT%taxMode(n)) == trim(shr_stream_taxis_extend)) SDAT%dtlimit(n) = 1.0e30 + end do + SDAT%nvectors = 0 + do n=1,nVecMax + if (trim(SDAT%vectors(n)) /= trim(shr_strdata_nullstr)) SDAT%nvectors = n + end do + endif + + call shr_mpi_bcast(SDAT%nstreams ,mpicom,'nstreams') + call shr_mpi_bcast(SDAT%nvectors ,mpicom,'nvectors') + call shr_mpi_bcast(SDAT%dtlimit ,mpicom,'dtlimit') + + n = 0 + if (present(gsmap)) then + n = n + 1 + endif + if (present(ggrid)) then + n = n + 1 + endif + if (present(nxg)) then + n = n + 1 + endif + if (present(nyg)) then + n = n + 1 + endif + + if ( n == 0 .or. n == 4) then + ! either all set or none set, this is OK + else + write(logunit,*) subname,' ERROR: gsmap, ggrid, nxg, and nyg must be specified together' + call shr_sys_abort(subname//' ERROR: gsmap, ggrid, nxg, nyg set together') + endif + + lscmmode = .false. + if (present(scmmode)) then + lscmmode = scmmode + if (lscmmode) then + if (.not.present(scmlon) .or. .not.present(scmlat)) then + write(logunit,*) subname,' ERROR: scmmode requires scmlon and scmlat' + call shr_sys_abort(subname//' ERROR: scmmode1 lon lat') + endif + endif + endif + + lname = "" + if (present(name)) then + lname = "_"//trim(name) + endif + + if (present(calendar)) then + SDAT%calendar = trim(shr_cal_calendarName(trim(calendar))) + endif + + ! --- initialize streams and stream domains --- + + + do n = 1,SDAT%nstreams + if (my_task == master_task) then + call shr_stream_getDomainInfo(SDAT%stream(n),filePath,fileName,timeName,lonName, & + latName,maskName,areaName) + call shr_stream_getFile(filePath,fileName) + endif + call shr_mpi_bcast(fileName,mpicom) + call shr_mpi_bcast(lonName,mpicom) + call shr_mpi_bcast(latName,mpicom) + call shr_mpi_bcast(maskName,mpicom) + call shr_mpi_bcast(areaName,mpicom) + call shr_dmodel_readgrid(SDAT%gridR(n),SDAT%gsmapR(n),SDAT%strnxg(n),SDAT%strnyg(n), & + fileName, compid, mpicom, '1d', lonName, latName, maskName, areaName) + SDAT%lsizeR(n) = mct_gsmap_lsize(SDAT%gsmapR(n),mpicom) + call mct_gsmap_OrderedPoints(SDAT%gsmapR(n), my_task, dof) + call pio_initdecomp(SDAT%pio_subsystem, pio_double, & + (/SDAT%strnxg(n),SDAT%strnyg(n)/), dof, SDAT%pio_iodesc(n)) + deallocate(dof) + + call shr_mpi_bcast(SDAT%stream(n)%calendar,mpicom) + enddo + + ! --- initialize model domain --- + + if (present(gsmap)) then + SDAT%nxg = nxg + SDAT%nyg = nyg + lsize = mct_gsmap_lsize(gsmap,mpicom) + call mct_gsmap_Copy(gsmap,SDAT%gsmap) + call mct_ggrid_init(SDAT%grid, ggrid, lsize) + call mct_aVect_copy(ggrid%data, SDAT%grid%data) + else + if (trim(SDAT%domainfile) == trim(shr_strdata_nullstr)) then + if (SDAT%nstreams > 0) then + if (my_task == master_task) then + call shr_stream_getDomainInfo(SDAT%stream(1),filePath,fileName,timeName,lonName, & + latName,maskName,areaName) + call shr_stream_getFile(filePath,fileName) + endif + call shr_mpi_bcast(fileName,mpicom) + call shr_mpi_bcast(lonName,mpicom) + call shr_mpi_bcast(latName,mpicom) + call shr_mpi_bcast(maskName,mpicom) + call shr_mpi_bcast(areaName,mpicom) + if (lscmmode) then + call shr_dmodel_readgrid(SDAT%grid,SDAT%gsmap,SDAT%nxg,SDAT%nyg, & + fileName, compid, mpicom, '1d', lonName, latName, maskName, areaName, & + scmmode=lscmmode,scmlon=scmlon,scmlat=scmlat) + else + call shr_dmodel_readgrid(SDAT%grid,SDAT%gsmap,SDAT%nxg,SDAT%nyg, & + fileName, compid, mpicom, '1d', lonName, latName, maskName, areaName) + endif + endif + else + if (lscmmode) then + call shr_dmodel_readgrid(SDAT%grid,SDAT%gsmap,SDAT%nxg,SDAT%nyg, & + SDAT%domainfile, compid, mpicom, '1d', readfrac=.true., & + scmmode=lscmmode,scmlon=scmlon,scmlat=scmlat) + else + call shr_dmodel_readgrid(SDAT%grid,SDAT%gsmap,SDAT%nxg,SDAT%nyg, & + SDAT%domainfile, compid, mpicom, '1d', readfrac=.true.) + endif + endif + endif + SDAT%lsize = mct_gsmap_lsize(SDAT%gsmap,mpicom) + + ! --- setup mapping --- + + do n = 1,SDAT%nstreams + if (shr_dmodel_gGridCompare(SDAT%gridR(n),SDAT%gsmapR(n),SDAT%grid,SDAT%gsmap, & + shr_dmodel_gGridCompareMaskSubset,mpicom) .or. trim(SDAT%fillalgo(n))=='none') then + SDAT%dofill(n) = .false. + else + SDAT%dofill(n) = .true. + endif + if (trim(SDAT%mapmask(n)) == 'dstmask') then + method = shr_dmodel_gGridCompareXYabsMask + else + method = shr_dmodel_gGridCompareXYabs + endif + if (shr_dmodel_gGridCompare(SDAT%gridR(n),SDAT%gsmapR(n),SDAT%grid,SDAT%gsmap, & + method,mpicom,0.01_r8) .or. trim(SDAT%mapalgo(n))=='none') then + SDAT%domaps(n) = .false. + else + SDAT%domaps(n) = .true. + endif + + if (SDAT%dofill(n)) then + if (trim(SDAT%fillread(n)) == trim(shr_strdata_unset)) then + if (my_task == master_task) then + write(logunit,F00) ' calling shr_dmodel_mapSet for fill' + call shr_sys_flush(logunit) + endif + call shr_dmodel_mapSet(SDAT%sMatPf(n), & + SDAT%gridR(n),SDAT%gsmapR(n),SDAT%strnxg(n),SDAT%strnyg(n), & + SDAT%gridR(n),SDAT%gsmapR(n),SDAT%strnxg(n),SDAT%strnyg(n), & + name='mapFill', type='cfill', & + algo=trim(SDAT%fillalgo(n)),mask=trim(SDAT%fillmask(n)),vect='scalar', & + compid=compid,mpicom=mpicom) + if (trim(SDAT%fillwrit(n)) /= trim(shr_strdata_unset)) then + if (my_task == master_task) then + write(logunit,F00) ' writing ',trim(SDAT%fillwrit(n)) + call shr_sys_flush(logunit) + endif + call shr_mct_sMatWritednc(SDAT%sMatPf(n)%Matrix,SDAT%pio_subsystem,sdat%io_type, SDAT%fillwrit(n),compid,mpicom) + endif + else + if (my_task == master_task) then + write(logunit,F00) ' reading ',trim(SDAT%fillread(n)) + call shr_sys_flush(logunit) + endif + call shr_mct_sMatReaddnc(sMati,SDAT%gsmapR(n),SDAT%gsmapR(n),'src', & + filename=trim(SDAT%fillread(n)),mytask=my_task,mpicom=mpicom) + call mct_sMatP_Init(SDAT%sMatPf(n),sMati,SDAT%gsMapR(n),SDAT%gsmapR(n),0, mpicom, compid) + call mct_sMat_Clean(sMati) + endif + endif + if (SDAT%domaps(n)) then + if (trim(SDAT%mapread(n)) == trim(shr_strdata_unset)) then + if (my_task == master_task) then + write(logunit,F00) ' calling shr_dmodel_mapSet for remap' + call shr_sys_flush(logunit) + endif + call shr_dmodel_mapSet(SDAT%sMatPs(n), & + SDAT%gridR(n),SDAT%gsmapR(n),SDAT%strnxg(n),SDAT%strnyg(n), & + SDAT%grid ,SDAT%gsmap ,SDAT%nxg ,SDAT%nyg, & + name='mapScalar', type='remap', & + algo=trim(SDAT%mapalgo(n)),mask=trim(SDAT%mapmask(n)), vect='scalar', & + compid=compid,mpicom=mpicom) + if (trim(SDAT%mapwrit(n)) /= trim(shr_strdata_unset)) then + if (my_task == master_task) then + write(logunit,F00) ' writing ',trim(SDAT%mapwrit(n)) + call shr_sys_flush(logunit) + endif + call shr_mct_sMatWritednc(SDAT%sMatPs(n)%Matrix,sdat%pio_subsystem,sdat%io_type,SDAT%mapwrit(n),compid,mpicom) + endif + else + if (my_task == master_task) then + write(logunit,F00) ' reading ',trim(SDAT%mapread(n)) + call shr_sys_flush(logunit) + endif + call shr_mct_sMatReaddnc(sMati,SDAT%gsmapR(n),SDAT%gsmap,'src', & + filename=trim(SDAT%mapread(n)),mytask=my_task,mpicom=mpicom) + call mct_sMatP_Init(SDAT%sMatPs(n),sMati,SDAT%gsMapR(n),SDAT%gsmap,0, mpicom, compid) + call mct_sMat_Clean(sMati) + endif + else + call mct_rearr_init(SDAT%gsmapR(n), SDAT%gsmap, mpicom, SDAT%rearrR(n)) + endif + enddo + + ! --- setup datatypes --- + + do n = 1,SDAT%nstreams + if (my_task == master_task) then + call shr_stream_getModelFieldList(SDAT%stream(n),fldList) + endif + call shr_mpi_bcast(fldList,mpicom) + call mct_aVect_init(SDAT%avs(n) ,rlist=fldList,lsize=SDAT%lsize) + call mct_aVect_init(SDAT%avFLB(n),rlist=fldList,lsize=SDAT%lsize) + call mct_aVect_init(SDAT%avFUB(n),rlist=fldList,lsize=SDAT%lsize) + call mct_aVect_init(SDAT%avRLB(n),rlist=fldList,lsize=SDAT%lsizeR(n)) + call mct_aVect_init(SDAT%avRUB(n),rlist=fldList,lsize=SDAT%lsizeR(n)) + if (trim(SDAT%tintalgo(n)) == 'coszen') then + call mct_aVect_init(SDAT%avCoszen(n),rlist="tavCosz",lsize=SDAT%lsize) + endif + enddo + + ! --- check vectors and compute ustrm,vstrm --- + + do m = 1,SDAT%nvectors + if (.not. shr_string_listIsValid(SDAT%vectors(m))) then + write(logunit,*) trim(subname),' vec fldlist invalid m=',m,trim(SDAT%vectors(m)) + call shr_sys_abort(subname//': vec fldlist invalid:'//trim(SDAT%vectors(m))) + endif + if (shr_string_listGetNum(SDAT%vectors(m)) /= 2) then + write(logunit,*) trim(subname),' vec fldlist ne 2 m=',m,trim(SDAT%vectors(m)) + call shr_sys_abort(subname//': vec fldlist ne 2:'//trim(SDAT%vectors(m))) + endif + call shr_string_listGetName(SDAT%vectors(m),1,uname) + call shr_string_listGetName(SDAT%vectors(m),2,vname) + nu = 0 + nv = 0 + do n = 1,SDAT%nstreams + k = mct_aVect_indexRA(SDAT%avRLB(n),trim(uname),perrWith='quiet') + if (k > 0) nu = n + k = mct_aVect_indexRA(SDAT%avRLB(n),trim(vname),perrWith='quiet') + if (k > 0) nv = n + enddo + if (nu == 0 .or. nv == 0) then + write(logunit,*) trim(subname),' vec flds not found m=',m,trim(SDAT%vectors(m)) + call shr_sys_abort(subname//': vec flds not found:'//trim(SDAT%vectors(m))) + endif + if (nu /= nv) then + if ((.not. shr_dmodel_gGridCompare(SDAT%gridR(nu),SDAT%gsmapR(nu), & + SDAT%gridR(nv),SDAT%gsmapR(nv), & + shr_dmodel_gGridCompareXYabs,mpicom,0.01_r8)) .or. & + (.not. shr_dmodel_gGridCompare(SDAT%gridR(nu),SDAT%gsmapR(nu), & + SDAT%gridR(nv),SDAT%gsmapR(nv), & + shr_dmodel_gGridCompareMaskZeros,mpicom))) then + write(logunit,*) trim(subname),' vec fld doms not same m=',m,trim(SDAT%vectors(m)) + call shr_sys_abort(subname//': vec fld doms not same:'//trim(SDAT%vectors(m))) + endif + endif + SDAT%ustrm(m) = nu + SDAT%vstrm(m) = nv + enddo + + end subroutine shr_strdata_init + +!=============================================================================== + + subroutine shr_strdata_advance(SDAT,ymd,tod,mpicom,istr,timers) + + implicit none + + type(shr_strdata_type),intent(inout) :: SDAT + integer(IN),intent(in) :: ymd ! current model date + integer(IN),intent(in) :: tod ! current model date + integer(IN),intent(in) :: mpicom + character(len=*),intent(in),optional :: istr + logical ,intent(in),optional :: timers + + integer(IN) :: n,m,i,k,l,kf ! generic index + integer(IN) :: my_task,npes + integer(IN),parameter :: master_task = 0 + logical :: mssrmlf + logical,allocatable :: newData(:) + integer(IN) :: ierr + integer(IN) :: nu,nv + integer(IN) :: lsize,lsizeR,lsizeF + integer(IN),allocatable :: ymdmod(:) ! modified model dates to handle Feb 29 + integer(IN) :: todmod ! modified model dates to handle Feb 29 + type(mct_avect) :: avRtmp + type(mct_avect) :: avRV,avFV + character(len=32) :: lstr + logical :: ltimers + real(R8) :: flb,fub ! factor for lb and ub + + !--- for cosz method --- + real(R8) :: calday ! julian day of year + real(R8) :: declin ! solar declination (radians) + real(R8) :: eccf ! earth sun distance factor + real(R8),pointer :: lonr(:) ! lon radians + real(R8),pointer :: latr(:) ! lat radians + real(R8),pointer :: cosz(:) ! cosz + real(R8),pointer :: tavCosz(:) ! cosz, time avg over [LB,UB] + real(R8),pointer :: xlon(:),ylon(:) + real(R8),parameter :: solZenMin = 0.001_R8 ! minimum solar zenith angle + + type(ESMF_Time) :: timeLB, timeUB ! lb and ub times + type(ESMF_TimeInterval) :: timeint ! delta time + integer(IN) :: dday ! delta days + real(R8) :: dtime ! delta time + integer(IN) :: uvar,vvar + logical :: someNewData ! newData test + character(CS) :: uname ! u vector field name + character(CS) :: vname ! v vector field name + integer(IN) :: year,month,day ! date year month day + character(len=*),parameter :: timname = "_strd_adv" + integer(IN),parameter :: tadj = 2 + + !----- formats ----- + character(*),parameter :: subname = "(shr_strdata_advance) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (SDAT%nstreams < 1) return + + lstr = '' + if (present(istr)) then + lstr = trim(istr) + endif + + ltimers = .true. + if (present(timers)) then + ltimers = timers + endif + + if (.not.ltimers) call t_adj_detailf(tadj) + + call MPI_COMM_SIZE(mpicom,npes,ierr) + call MPI_COMM_RANK(mpicom,my_task,ierr) + + mssrmlf = .false. + + SDAT%ymd = ymd + SDAT%tod = tod + + if (SDAT%nstreams > 0) then + allocate(newData(SDAT%nstreams)) + allocate(ymdmod(SDAT%nstreams)) + + do n = 1,SDAT%nstreams + ! ------------------------------------------------------- ! + ! tcraig, Oct 11 2010. Mismatching calendars: 4 cases ! + ! ------------------------------------------------------- ! + ! ymdmod and todmod are the ymd and tod to time ! + ! interpolate to. Generally, these are just the model ! + ! date and time. Also, always use the stream calendar ! + ! for time interpolation for reasons described below. ! + ! When there is a calendar mismatch, support Feb 29 in a ! + ! special way as needed to get reasonable values. ! + ! Note that when Feb 29 needs to be treated specially, ! + ! a discontinuity will be introduced. The size of that ! + ! discontinuity will depend on the time series input data.! + ! ------------------------------------------------------- ! + ! (0) The stream calendar and model calendar are ! + ! identical. Proceed in the standard way. ! + ! ------------------------------------------------------- ! + ! (1) If the stream is a no leap calendar and the model ! + ! is gregorian, then time interpolate on the noleap ! + ! calendar. Then if the model date is Feb 29, compute ! + ! stream data for Feb 28 by setting ymdmod and todmod to ! + ! Feb 28. This results in duplicate stream data on ! + ! Feb 28 and Feb 29 and a discontinuity at the start of ! + ! Feb 29. ! + ! This could be potentially updated by using the gregorian! + ! calendar for time interpolation when the input data is ! + ! relatively infrequent (say greater than daily) with the ! + ! following concerns. + ! - The forcing will not be reproduced identically on ! + ! the same day with climatological inputs data ! + ! - Input data with variable input frequency might ! + ! behave funny + ! - An arbitrary discontinuity will be introduced in ! + ! the time interpolation method based upon the ! + ! logic chosen to transition from reproducing Feb 28 ! + ! on Feb 29 and interpolating to Feb 29. ! + ! - The time gradient of data will change by adding a ! + ! day arbitrarily. + ! ------------------------------------------------------- ! + ! (2) If the stream is a gregorian calendar and the model ! + ! is a noleap calendar, then just time interpolate on the ! + ! gregorian calendar. The causes Feb 29 stream data ! + ! to be skipped and will lead to a discontinuity at the ! + ! start of March 1. ! + ! ------------------------------------------------------- ! + ! (3) If the calendars mismatch and neither of the three ! + ! cases above are recognized, then abort. ! + ! ------------------------------------------------------- ! + + ! case(0) + ymdmod(n) = ymd + todmod = tod + if (trim(SDAT%calendar) /= trim(SDAT%stream(n)%calendar)) then + if ((trim(SDAT%calendar) == trim(shr_cal_gregorian)) .and. & + (trim(SDAT%stream(n)%calendar) == trim(shr_cal_noleap))) then + ! case (1), set feb 29 = feb 28 + call shr_cal_date2ymd (ymd,year,month,day) + if (month == 2 .and. day == 29) then + call shr_cal_ymd2date(year,2,28,ymdmod(n)) + endif + else if ((trim(SDAT%calendar) == trim(shr_cal_noleap)) .and. & + (trim(SDAT%stream(n)%calendar) == trim(shr_cal_gregorian))) then + ! case (2), feb 29 input data will be skipped automatically + else + ! case (3), abort + write(logunit,*) trim(subname),' ERROR: mismatch calendar ', & + trim(SDAT%calendar),':',trim(SDAT%stream(n)%calendar) + call shr_sys_abort(trim(subname)//' ERROR: mismatch calendar ') + endif + endif + + call t_barrierf(trim(lstr)//trim(timname)//'_readLBUB_BARRIER',mpicom) + call t_startf(trim(lstr)//trim(timname)//'_readLBUB') + + call shr_dmodel_readLBUB(SDAT%stream(n),SDAT%pio_subsystem,SDAT%io_type,SDAT%pio_iodesc(n), & + ymdmod(n),todmod,mpicom,SDAT%gsmapR(n),& + SDAT%avRLB(n),SDAT%ymdLB(n),SDAT%todLB(n), & + SDAT%avRUB(n),SDAT%ymdUB(n),SDAT%todUB(n),newData(n), & + istr=trim(lstr)//'_readLBUB') + if (newData(n)) then + call shr_cal_date2ymd(SDAT%ymdLB(n),year,month,day) + call shr_cal_timeSet(timeLB,SDAT%ymdLB(n),0,SDAT%stream(n)%calendar) + call shr_cal_timeSet(timeUB,SDAT%ymdUB(n),0,SDAT%stream(n)%calendar) + timeint = timeUB-timeLB + call ESMF_TimeIntervalGet(timeint,StartTimeIn=timeLB,d=dday) + dtime = abs(real(dday,R8) + real(SDAT%todUB(n)-SDAT%todLB(n),R8)/shr_const_cDay) + + SDAT%dtmin(n) = min(SDAT%dtmin(n),dtime) + SDAT%dtmax(n) = max(SDAT%dtmax(n),dtime) + if ((SDAT%dtmax(n)/SDAT%dtmin(n)) > SDAT%dtlimit(n)) then + write(logunit,*) trim(subName),' ERROR: dt limit1 ',SDAT%dtmax(n),SDAT%dtmin(n),SDAT%dtlimit(n) + write(logunit,*) trim(subName),' ERROR: dt limit2 ',SDAT%ymdLB(n),SDAT%todLB(n), & + SDAT%ymdUB(n),SDAT%todUB(n) + call shr_sys_abort(trim(subName)//' ERROR dt limit') + endif + endif + call t_stopf(trim(lstr)//trim(timname)//'_readLBUB') + enddo + + do n = 1,SDAT%nstreams + if (newData(n)) then + + if (SDAT%doFill(n)) then + call t_startf(trim(lstr)//trim(timname)//'_fill') + lsize = mct_aVect_lsize(SDAT%avRLB(n)) + call mct_aVect_init(avRtmp,SDAT%avRLB(n),lsize) + call mct_aVect_copy(SDAT%avRLB(n),avRtmp) + call mct_sMat_avMult(avRtmp,SDAT%sMatPf(n),SDAT%avRLB(n)) + call mct_aVect_copy(SDAT%avRUB(n),avRtmp) + call mct_sMat_avMult(avRtmp,SDAT%sMatPf(n),SDAT%avRUB(n)) + call mct_aVect_clean(avRtmp) + call t_stopf(trim(lstr)//trim(timname)//'_fill') + endif + + if (SDAT%domaps(n)) then + call t_startf(trim(lstr)//trim(timname)//'_map') + call mct_sMat_avMult(SDAT%avRLB(n),SDAT%sMatPs(n),SDAT%avFLB(n)) + call mct_sMat_avMult(SDAT%avRUB(n),SDAT%sMatPs(n),SDAT%avFUB(n)) + call t_stopf(trim(lstr)//trim(timname)//'_map') + else + call t_startf(trim(lstr)//trim(timname)//'_rearr') + call mct_rearr_rearrange(SDAT%avRLB(n),SDAT%avFLB(n),SDAT%rearrR(n)) + call mct_rearr_rearrange(SDAT%avRUB(n),SDAT%avFUB(n),SDAT%rearrR(n)) + call t_stopf(trim(lstr)//trim(timname)//'_rearr') + endif + + endif + enddo + + do m = 1,SDAT%nvectors + nu = SDAT%ustrm(m) + nv = SDAT%vstrm(m) + if ((SDAT%domaps(nu) .or. SDAT%domaps(nv)) .and. & + (newdata(nu) .or. newdata(nv))) then + + call t_startf(trim(lstr)//trim(timname)//'_vect') + call shr_string_listGetName(SDAT%vectors(m),1,uname) + call shr_string_listGetName(SDAT%vectors(m),2,vname) + lsizeR = mct_aVect_lsize(SDAT%avRLB(nu)) + lsizeF = mct_aVect_lsize(SDAT%avFLB(nu)) + call mct_aVect_init(avRV,rlist=SDAT%vectors(m),lsize=lsizeR) + call mct_aVect_init(avFV,rlist=SDAT%vectors(m),lsize=lsizeF) + allocate(xlon(lsizeR)) + allocate(ylon(lsizeF)) + call mct_aVect_exportRattr(SDAT%gridR(nu)%data,'lon',xlon) + call mct_aVect_exportRattr(SDAT%grid %data,'lon',ylon) + xlon = xlon * deg2rad + ylon = ylon * deg2rad + + !--- map LB --- + + uvar = mct_aVect_indexRA(SDAT%avRLB(nu),trim(uname)) + vvar = mct_aVect_indexRA(SDAT%avRLB(nv),trim(vname)) + do i = 1,lsizeR + avRV%rAttr(1,i) = SDAT%avRLB(nu)%rAttr(uvar,i) * cos(xlon(i)) & + -SDAT%avRLB(nv)%rAttr(vvar,i) * sin(xlon(i)) + avRV%rAttr(2,i) = SDAT%avRLB(nu)%rAttr(uvar,i) * sin(xlon(i)) & + +SDAT%avRLB(nv)%rAttr(vvar,i) * cos(xlon(i)) + enddo + call mct_sMat_avMult(avRV,SDAT%sMatPs(nu),avFV) +! --- don't need to recompute uvar and vvar, should be the same +! uvar = mct_aVect_indexRA(SDAT%avFLB(nu),trim(uname)) +! vvar = mct_aVect_indexRA(SDAT%avFLB(nv),trim(vname)) + do i = 1,lsizeF + SDAT%avFLB(nu)%rAttr(uvar,i) = avFV%rAttr(1,i) * cos(ylon(i)) & + +avFV%rAttr(2,i) * sin(ylon(i)) + SDAT%avFLB(nv)%rAttr(vvar,i) = -avFV%rAttr(1,i) * sin(ylon(i)) & + +avFV%rAttr(2,i) * cos(ylon(i)) + enddo + + !--- map UB --- + + uvar = mct_aVect_indexRA(SDAT%avRUB(nu),trim(uname)) + vvar = mct_aVect_indexRA(SDAT%avRUB(nv),trim(vname)) + do i = 1,lsizeR + avRV%rAttr(1,i) = SDAT%avRUB(nu)%rAttr(uvar,i) * cos(xlon(i)) & + -SDAT%avRUB(nv)%rAttr(vvar,i) * sin(xlon(i)) + avRV%rAttr(2,i) = SDAT%avRUB(nu)%rAttr(uvar,i) * sin(xlon(i)) & + +SDAT%avRUB(nv)%rAttr(vvar,i) * cos(xlon(i)) + enddo + call mct_sMat_avMult(avRV,SDAT%sMatPs(nu),avFV) +! --- don't need to recompute uvar and vvar, should be the same +! uvar = mct_aVect_indexRA(SDAT%avFUB(nu),trim(uname)) +! vvar = mct_aVect_indexRA(SDAT%avFUB(nv),trim(vname)) + do i = 1,lsizeF + SDAT%avFUB(nu)%rAttr(uvar,i) = avFV%rAttr(1,i) * cos(ylon(i)) & + +avFV%rAttr(2,i) * sin(ylon(i)) + SDAT%avFUB(nv)%rAttr(vvar,i) = -avFV%rAttr(1,i) * sin(ylon(i)) & + +avFV%rAttr(2,i) * cos(ylon(i)) + enddo + + call mct_aVect_clean(avRV) + call mct_aVect_clean(avFV) + deallocate(xlon,ylon) + + call t_stopf(trim(lstr)//trim(timname)//'_vect') + endif + enddo + + do n = 1,SDAT%nstreams + + !--- method: coszen ------------------------------------------------------- + if (trim(SDAT%tintalgo(n)) == 'coszen') then + call t_startf(trim(lstr)//trim(timname)//'_coszen') + + !--- make sure orb info has been set --- + if (SDAT%eccen == SHR_ORB_UNDEF_REAL) then + call shr_sys_abort(subname//' ERROR in orb params for coszen tinterp') + else if (SDAT%modeldt < 1) then + call shr_sys_abort(subname//' ERROR: model dt < 1 for coszen tinterp') + endif + + !--- allocate avg cosz array --- + lsizeF = mct_aVect_lsize(SDAT%avFLB(n)) + allocate(tavCosz(lsizeF),cosz(lsizeF),lonr(lsizeF),latr(lsizeF)) + + !--- get lat/lon data --- + kf = mct_aVect_indexRA(SDAT%grid%data,'lat') + latr(:) = SDAT%grid%data%rAttr(kf,:) * deg2rad + kf = mct_aVect_indexRA(SDAT%grid%data,'lon') + lonr(:) = SDAT%grid%data%rAttr(kf,:) * deg2rad + + call t_startf(trim(lstr)//trim(timname)//'_coszenC') + cosz = 0.0_r8 + call shr_tInterp_getCosz(cosz,lonr,latr,ymdmod(n),todmod, & + SDAT%eccen,SDAT%mvelpp,SDAT%lambm0,SDAT%obliqr,SDAT%stream(n)%calendar) + call t_stopf(trim(lstr)//trim(timname)//'_coszenC') + + if (newdata(n)) then + !--- compute a new avg cosz --- + call t_startf(trim(lstr)//trim(timname)//'_coszenN') + call shr_tInterp_getAvgCosz(tavCosz,lonr,latr, & + SDAT%ymdLB(n),SDAT%todLB(n), SDAT%ymdUB(n),SDAT%todUB(n), & + SDAT%eccen,SDAT%mvelpp,SDAT%lambm0,SDAT%obliqr,SDAT%modeldt,& + SDAT%stream(n)%calendar) + call mct_avect_importRAttr(SDAT%avCoszen(n),'tavCosz',tavCosz,lsizeF) + call t_stopf(trim(lstr)//trim(timname)//'_coszenN') + else + !--- reuse existing avg cosz --- + call mct_avect_exportRAttr(SDAT%avCoszen(n),'tavCosz',tavCosz) + endif + + !--- t-interp is LB data normalized with this factor: cosz/tavCosz --- + do i = 1,lsizeF + if (cosz(i) > solZenMin) then + + ! The creation of some DATMS can result in slightly negative fluxes. + ! prevent against negative solar fluxes ... temporary measure + ! This is reported in bugzilla 1927 + + SDAT%avFLB(n)%rAttr(:,i) = max(SDAT%avFLB(n)%rAttr(:,i),0._r8) + + SDAT%avs(n)%rAttr(:,i) = SDAT%avFLB(n)%rAttr(:,i)*cosz(i)/tavCosz(i) + else + SDAT%avs(n)%rAttr(:,i) = 0._r8 + endif + enddo + deallocate(tavCosz,cosz,lonr,latr) + call t_stopf(trim(lstr)//trim(timname)//'_coszen') + + !--- method: not coszen --------------------------------------------------- + elseif (trim(SDAT%tintalgo(n)) /= trim(shr_strdata_nullstr)) then + + call t_startf(trim(lstr)//trim(timname)//'_tint') + call shr_tInterp_getFactors(SDAT%ymdlb(n),SDAT%todlb(n),SDAT%ymdub(n),SDAT%todub(n), & + ymdmod(n),todmod,flb,fub, & + calendar=SDAT%stream(n)%calendar,algo=trim(SDAT%tintalgo(n))) + SDAT%avs(n)%rAttr(:,:) = SDAT%avFLB(n)%rAttr(:,:)*flb + SDAT%avFUB(n)%rAttr(:,:)*fub + call t_stopf(trim(lstr)//trim(timname)//'_tint') + + else + call t_startf(trim(lstr)//trim(timname)//'_zero') + call mct_avect_zero(SDAT%avs(n)) + call t_stopf(trim(lstr)//trim(timname)//'_zero') + endif + enddo + + deallocate(newData) + deallocate(ymdmod) + + endif ! nstreams > 0 + + if (.not.ltimers) call t_adj_detailf(-tadj) + + end subroutine shr_strdata_advance + +!=============================================================================== + subroutine shr_strdata_clean(SDAT) + + implicit none + + type(shr_strdata_type),intent(inout) :: SDAT + + integer(IN) :: n + + !----- formats ----- + character(len=*),parameter :: subname = "(shr_strdata_clean) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (SDAT%nxg * SDAT%nyg == 0) then + return + endif + + SDAT%nxg = 0 + SDAT%nyg = 0 + SDAT%strnxg = 0 + SDAT%strnyg = 0 + + SDAT%nstreams = 0 + SDAT%nvectors = 0 + SDAT%ustrm = 0 + SDAT%vstrm = 0 + + SDAT%dofill = .false. + SDAT%domaps = .false. + + call mct_ggrid_clean(SDAT%grid) + call mct_gsmap_clean(SDAT%gsmap) + do n = 1,nStrMax + ! need clean SDAT%stream(n) method + call mct_avect_clean(SDAT%avs(n)) + call mct_avect_clean(SDAT%avRLB(n)) + call mct_avect_clean(SDAT%avRUB(n)) + call mct_avect_clean(SDAT%avFLB(n)) + call mct_avect_clean(SDAT%avFUB(n)) + call mct_ggrid_clean(SDAT%gridR(n)) + call mct_sMatP_clean(SDAT%sMatPf(n)) + call mct_sMatP_clean(SDAT%sMatPs(n)) + call mct_gsmap_clean(SDAT%gsmapR(n)) + enddo + + end subroutine shr_strdata_clean + +!=============================================================================== +!=============================================================================== + subroutine shr_strdata_restWrite(filename,SDAT,mpicom,str1,str2) + + implicit none + + character(len=*) ,intent(in) :: filename + type(shr_strdata_type),intent(inout) :: SDAT + integer(IN) ,intent(in) :: mpicom + character(len=*) ,intent(in) :: str1 + character(len=*) ,intent(in) :: str2 + + !--- local ---- + type(shr_stream_streamtype),pointer :: streams(:) + integer(IN) :: n,my_task,ier + + !----- formats ----- + character(len=*),parameter :: subname = "(shr_strdata_restWrite) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call MPI_COMM_RANK(mpicom,my_task,ier) + + if (my_task == 0) then + call shr_stream_restWrite(SDAT%stream,trim(filename),trim(str1),trim(str2),SDAT%nstreams) + endif + + end subroutine shr_strdata_restWrite + +!=============================================================================== +!=============================================================================== + subroutine shr_strdata_restRead(filename,SDAT,mpicom) + + implicit none + + character(len=*) ,intent(in) :: filename + type(shr_strdata_type),intent(inout) :: SDAT + integer(IN) ,intent(in) :: mpicom + + !--- local ---- + type(shr_stream_streamtype),pointer :: streams(:) + integer(IN) :: n,my_task,ier + + !----- formats ----- + character(len=*),parameter :: subname = "(shr_strdata_restRead) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call MPI_COMM_RANK(mpicom,my_task,ier) + + if (my_task == 0) then + call shr_stream_restRead(SDAT%stream,trim(filename),SDAT%nstreams) + endif + + end subroutine shr_strdata_restRead + +!=============================================================================== +!=============================================================================== + subroutine shr_strdata_setOrbs(SDAT,eccen,mvelpp,lambm0,obliqr,modeldt) + + implicit none + + type(shr_strdata_type),intent(inout) :: SDAT + real(R8),intent(in) :: eccen + real(R8),intent(in) :: mvelpp + real(R8),intent(in) :: lambm0 + real(R8),intent(in) :: obliqr + integer(IN),intent(in) :: modeldt + + !----- formats ----- + character(len=*),parameter :: subname = "(shr_strdata_setOrbs) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + SDAT%eccen = eccen + SDAT%mvelpp = mvelpp + SDAT%lambm0 = lambm0 + SDAT%obliqr = obliqr + SDAT%modeldt = modeldt + + end subroutine shr_strdata_setOrbs + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_strdata_readnml -- read control strdata +! +! !DESCRIPTION: +! Reads strdata common to all data models +! +! !REVISION HISTORY: +! 2004-Dec-15 - J. Schramm - first version +! 2009-Apr-16 - T. Craig - add minimal parallel support +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_strdata_readnml(SDAT,file,rc,mpicom) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_strdata_type),intent(inout):: SDAT ! strdata data data-type + character(*),optional ,intent(in) :: file ! file to read strdata from + integer(IN),optional ,intent(out) :: rc ! return code + integer(IN),optional ,intent(in) :: mpicom ! mpi comm + +!EOP + + integer(IN) :: rCode ! return code + integer(IN) :: nUnit ! fortran i/o unit number + integer(IN) :: n ! generic loop index + integer(IN) :: my_task ! my task number, 0 is default + integer(IN) :: master_task ! master task number, 0 is default + integer(IN) :: ntasks ! total number of tasks + + !----- temporary/local namelist vars to read int ----- + character(CL) :: dataMode ! flags physics options wrt input data + character(CL) :: domainFile ! file containing domain info + character(CL) :: streams(nStrMax) ! stream description file names + character(CL) :: taxMode(nStrMax) ! time axis cycling mode + real(R8) :: dtlimit(nStrMax) ! delta time limiter + character(CL) :: vectors(nVecMax) ! define vectors to vector map + character(CL) :: fillalgo(nStrMax) ! fill algorithm + character(CL) :: fillmask(nStrMax) ! fill mask + character(CL) :: fillread(nStrMax) ! fill mapping file to read + character(CL) :: fillwrite(nStrMax)! fill mapping file to write + character(CL) :: mapalgo(nStrMax) ! scalar map algorithm + character(CL) :: mapmask(nStrMax) ! scalar map mask + character(CL) :: mapread(nStrMax) ! regrid mapping file to read + character(CL) :: mapwrite(nStrMax) ! regrid mapping file to write + character(CL) :: tintalgo(nStrMax) ! time interpolation algorithm + character(CL) :: io_type + integer(IN) :: num_iotasks + integer(IN) :: io_root + integer(IN) :: io_stride + integer(IN) :: num_agg + character(CL) :: fileName ! generic file name + integer(IN) :: yearFirst ! first year to use in data stream + integer(IN) :: yearLast ! last year to use in data stream + integer(IN) :: yearAlign ! data year that aligns with yearFirst + + !----- define namelist ----- + namelist / shr_strdata_nml / & + dataMode & + , domainFile & + , streams & + , taxMode & + , dtlimit & + , vectors & + , fillalgo & + , fillmask & + , fillread & + , fillwrite & + , mapalgo & + , mapmask & + , mapread & + , mapwrite & + , tintalgo + !----- formats ----- + character(*),parameter :: subName = "(shr_strdata_readnml) " + character(*),parameter :: F00 = "('(shr_strdata_readnml) ',8a)" + character(*),parameter :: F01 = "('(shr_strdata_readnml) ',a,i6,a)" + character(*),parameter :: F02 = "('(shr_strdata_readnml) ',a,es13.6)" + character(*),parameter :: F03 = "('(shr_strdata_readnml) ',a,l6)" + character(*),parameter :: F04 = "('(shr_strdata_readnml) ',a,i2,a,a)" + character(*),parameter :: F20 = "('(shr_strdata_readnml) ',a,i6,a)" + character(*),parameter :: F90 = "('(shr_strdata_readnml) ',58('-'))" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (present(rc)) rc = 0 + + my_task = 0 + master_task = 0 + ntasks = 1 + if (present(mpicom)) then + call MPI_COMM_RANK(mpicom,my_task,rCode) + call MPI_COMM_SIZE(mpicom,ntasks,rCode) + endif + +!--master--task-- + if (my_task == master_task) then + + !---------------------------------------------------------------------------- + ! set default values for namelist vars + !---------------------------------------------------------------------------- + dataMode = 'NULL' + domainFile = trim(shr_strdata_nullstr) + streams(:) = trim(shr_strdata_nullstr) + taxMode(:) = trim(shr_stream_taxis_cycle) + dtlimit(:) = dtlimit_default + vectors(:) = trim(shr_strdata_nullstr) + fillalgo(:) = 'nn' + fillmask(:) = 'nomask' + fillread(:) = trim(shr_strdata_unset) + fillwrite(:)= trim(shr_strdata_unset) + mapalgo(:) = 'bilinear' + mapmask(:) = 'dstmask' + mapread(:) = trim(shr_strdata_unset) + mapwrite(:) = trim(shr_strdata_unset) + tintalgo(:) = 'linear' + + + !---------------------------------------------------------------------------- + ! read input namelist + !---------------------------------------------------------------------------- + if (present(file)) then + write(logunit,F00) 'reading input namelist file: ',trim(file) + call shr_sys_flush(logunit) + nUnit = shr_file_getUnit() ! get unused fortran i/o unit number + open (nUnit,file=trim(file),status="old",action="read") + read (nUnit,nml=shr_strdata_nml,iostat=rCode) + close(nUnit) + call shr_file_freeUnit(nUnit) + if (rCode > 0) then + write(logunit,F01) 'ERROR: reading input namelist, '//trim(file)//' iostat=',rCode + call shr_sys_abort(subName//": namelist read error "//trim(file)) + end if + endif + + !---------------------------------------------------------------------------- + ! copy temporary/local namelist vars into data structure + !---------------------------------------------------------------------------- + SDAT%nstreams = 0 + do n=1,nStrMax + call shr_stream_default(SDAT%stream(n)) + enddo + SDAT%dataMode = dataMode + SDAT%domainFile = domainFile + SDAT%streams(:) = streams(:) + SDAT%taxMode(:) = taxMode(:) + SDAT%dtlimit(:) = dtlimit(:) + SDAT%vectors(:) = vectors(:) + SDAT%fillalgo(:) = fillalgo(:) + SDAT%fillmask(:) = fillmask(:) + SDAT%fillread(:) = fillread(:) + SDAT%fillwrit(:) = fillwrite(:) + SDAT%mapalgo(:) = mapalgo(:) + SDAT%mapmask(:) = mapmask(:) + SDAT%mapread(:) = mapread(:) + SDAT%mapwrit(:) = mapwrite(:) + SDAT%tintalgo(:) = tintalgo(:) + do n=1,nStrMax + if (trim(streams(n)) /= trim(shr_strdata_nullstr)) SDAT%nstreams = max(SDAT%nstreams,n) + if (trim(SDAT%taxMode(n)) == trim(shr_stream_taxis_extend)) SDAT%dtlimit(n) = 1.0e30 + end do + SDAT%nvectors = 0 + do n=1,nVecMax + if (trim(vectors(n)) /= trim(shr_strdata_nullstr)) SDAT%nvectors = n + end do + + do n = 1,SDAT%nstreams + call shr_stream_parseInput(SDAT%streams(n),fileName,yearAlign,yearFirst,yearLast) + call shr_stream_init(SDAT%stream(n),fileName,yearFirst,yearLast,yearAlign, & + trim(SDAT%taxMode(n))) + enddo + +! call shr_strdata_print(SDAT,trim(file)//' NML_ONLY') + + endif ! master_task +!--master--task-- + + if (present(mpicom)) then + call shr_strdata_bcastnml(SDAT,mpicom) + endif + + SDAT%ymdLB = -1 + SDAT%todLB = -1 + SDAT%ymdUB = -1 + SDAT%todUB = -1 + SDAT%dtmin = 1.0e30 + SDAT%dtmax = 0.0 + SDAT%nxg = 0 + SDAT%nyg = 0 + SDAT%eccen = SHR_ORB_UNDEF_REAL + SDAT%mvelpp = SHR_ORB_UNDEF_REAL + SDAT%lambm0 = SHR_ORB_UNDEF_REAL + SDAT%obliqr = SHR_ORB_UNDEF_REAL + SDAT%modeldt = 0 + SDAT%calendar = shr_cal_noleap + +end subroutine shr_strdata_readnml + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_strdata_pioinit -- initialize pio layer +! +! !DESCRIPTION: +! Initialize PIO for a component model +! +! !REVISION HISTORY: +! 2010-10-26 Jim Edwards +! +! !INTERFACE: ------------------------------------------------------------------ +subroutine shr_strdata_pioinit(SDAT,io_subsystem, io_type ) + type(shr_strdata_type),intent(inout):: SDAT ! strdata data data-type + type(iosystem_desc_t), pointer :: io_subsystem + integer, intent(in) :: io_type + + SDAT%pio_subsystem => io_subsystem + SDAT%io_type=io_type + +end subroutine shr_strdata_pioinit + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_strdata_create -- set strdata and stream info from interface +! +! !DESCRIPTION: +! Set strdata and stream info from fortran interface. +! Note: When this is called, previous settings are reset to defaults +! and then the values passed are used. +! +! !REVISION HISTORY: +! 2004-Dec-15 - J. Schramm - first version +! 2009-Apr-16 - T. Craig - add minimal parallel support +! +! !INTERFACE: ------------------------------------------------------------------ +subroutine shr_strdata_create(SDAT, name, mpicom, compid, gsmap, ggrid, nxg, nyg, & +!--- streams stuff required --- + yearFirst, yearLast, yearAlign, offset, & + domFilePath, domFileName, & + domTvarName, domXvarName, domYvarName, domAreaName, domMaskName, & + filePath, filename, fldListFile, fldListModel, & + pio_subsystem, pio_iotype, & +!--- strdata optional --- + taxMode, dtlimit, tintalgo, & + fillalgo, fillmask, fillread, fillwrite, & + mapalgo, mapmask, mapread, mapwrite, & + calendar) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_strdata_type),intent(inout):: SDAT ! strdata data data-type + character(*) ,intent(in) :: name ! name of strdata + integer(IN) ,intent(in) :: mpicom ! mpi comm + integer(IN) ,intent(in) :: compid + type(mct_gsmap) ,intent(in) :: gsmap + type(mct_ggrid) ,intent(in) :: ggrid + integer(IN) ,intent(in) :: nxg + integer(IN) ,intent(in) :: nyg + + integer(IN) ,intent(in) :: yearFirst ! first year to use + integer(IN) ,intent(in) :: yearLast ! last year to use + integer(IN) ,intent(in) :: yearAlign ! align yearFirst with this model year + integer(IN) ,intent(in) :: offset ! offset in seconds of stream data + character(*) ,intent(in) :: domFilePath ! domain file path + character(*) ,intent(in) :: domFileName ! domain file name + character(*) ,intent(in) :: domTvarName ! domain time dim name + character(*) ,intent(in) :: domXvarName ! domain x dim name + character(*) ,intent(in) :: domYvarName ! domain y dim nam + character(*) ,intent(in) :: domAreaName ! domain area name + character(*) ,intent(in) :: domMaskName ! domain mask name + character(*) ,intent(in) :: filePath ! path to filenames + character(*) ,intent(in) :: filename(:) ! filename for index filenumber + character(*) ,intent(in) :: fldListFile ! file field names, colon delim list + character(*) ,intent(in) :: fldListModel ! model field names, colon delim list + type(iosystem_desc_t), pointer :: pio_subsystem ! PIO subsystem pointer + integer(IN) , intent(in) :: pio_iotype ! PIO file type + + character(*),optional ,intent(in) :: taxMode + real(R8) ,optional ,intent(in) :: dtlimit + character(*),optional ,intent(in) :: fillalgo ! fill algorithm + character(*),optional ,intent(in) :: fillmask ! fill mask + character(*),optional ,intent(in) :: fillread ! fill mapping file to read + character(*),optional ,intent(in) :: fillwrite ! fill mapping file to write + character(*),optional ,intent(in) :: mapalgo ! scalar map algorithm + character(*),optional ,intent(in) :: mapmask ! scalar map mask + character(*),optional ,intent(in) :: mapread ! regrid mapping file to read + character(*),optional ,intent(in) :: mapwrite ! regrid mapping file to write + character(*),optional ,intent(in) :: tintalgo ! time interpolation algorithm + character(*),optional, intent(in) :: calendar + +!EOP + +! --- local --- +! --- formats --- + character(*),parameter :: subName = "(shr_strdata_create) " + character(*),parameter :: F00 = "('(shr_strdata_create) ',8a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call shr_strdata_readnml(SDAT,mpicom=mpicom) + + SDAT%nstreams = 1 + + call shr_strdata_pioinit(sdat, pio_subsystem, pio_iotype) + + if (present(taxMode)) then + SDAT%taxMode(1) = taxMode + if (trim(SDAT%taxMode(1)) == trim(shr_stream_taxis_extend)) SDAT%dtlimit(1) = 1.0e30 + endif + if (present(dtlimit)) then + SDAT%dtlimit(1) = dtlimit + endif + if (present(fillalgo)) then + SDAT%fillalgo(1) = fillalgo + endif + if (present(fillmask)) then + SDAT%fillmask(1) = fillmask + endif + if (present(fillread)) then + SDAT%fillread(1) = fillread + endif + if (present(fillwrite)) then + SDAT%fillwrit(1) = fillwrite + endif + if (present(mapalgo)) then + SDAT%mapalgo(1) = mapalgo + endif + if (present(mapmask)) then + SDAT%mapmask(1) = mapmask + endif + if (present(mapread)) then + SDAT%mapread(1) = mapread + endif + if (present(mapwrite)) then + SDAT%mapwrit(1) = mapwrite + endif + if (present(tintalgo)) then + SDAT%tintalgo(1) = tintalgo + endif + if (present(mapmask)) then + SDAT%mapmask(1) = mapmask + endif + if (present(calendar)) then + SDAT%calendar = trim(shr_cal_calendarName(trim(calendar))) + endif + + call shr_stream_set(SDAT%stream(1),yearFirst,yearLast,yearAlign,offset,taxMode, & + fldListFile,fldListModel,domFilePath,domFileName, & + domTvarName,domXvarName,domYvarName,domAreaName,domMaskName, & + filePath,filename,trim(name)) + + call shr_strdata_init(SDAT, mpicom, compid, & + gsmap=gsmap, ggrid=ggrid, nxg=nxg, nyg=nyg) + +end subroutine shr_strdata_create + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_strdata_print -- read control strdata +! +! !DESCRIPTION: +! Reads strdata common to all data models +! +! !REVISION HISTORY: +! 2004-Dec-15 - J. Schramm - first version +! 2009-Apr-16 - T. Craig - add minimal parallel support +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_strdata_print(SDAT,name) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_strdata_type) ,intent(in) :: SDAT ! strdata data data-type + character(len=*),optional,intent(in) :: name ! just a name for tracking + +!EOP + + integer(IN) :: n + character(CL) :: lname + + !----- formats ----- + character(*),parameter :: subName = "(shr_strdata_print) " + character(*),parameter :: F00 = "('(shr_strdata_print) ',8a)" + character(*),parameter :: F01 = "('(shr_strdata_print) ',a,i6,a)" + character(*),parameter :: F02 = "('(shr_strdata_print) ',a,es13.6)" + character(*),parameter :: F03 = "('(shr_strdata_print) ',a,l6)" + character(*),parameter :: F04 = "('(shr_strdata_print) ',a,i2,a,a)" + character(*),parameter :: F05 = "('(shr_strdata_print) ',a,i2,a,i6)" + character(*),parameter :: F06 = "('(shr_strdata_print) ',a,i2,a,l2)" + character(*),parameter :: F07 = "('(shr_strdata_print) ',a,i2,a,es13.6)" + character(*),parameter :: F20 = "('(shr_strdata_print) ',a,i6,a)" + character(*),parameter :: F90 = "('(shr_strdata_print) ',58('-'))" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lname = 'unknown' + if (present(name)) then + lname = trim(name) + endif + !---------------------------------------------------------------------------- + ! document datatype settings + !---------------------------------------------------------------------------- + write(logunit,F90) + write(logunit,F00) "name = ",trim(lname) + write(logunit,F00) "dataMode = ",trim(SDAT%dataMode) + write(logunit,F00) "domainFile = ",trim(SDAT%domainFile) + write(logunit,F01) "nxg = ",SDAT%nxg + write(logunit,F01) "nyg = ",SDAT%nyg + write(logunit,F00) "calendar = ",trim(SDAT%calendar) + write(logunit,F01) "io_type = ",SDAT%io_type + write(logunit,F02) "eccen = ",SDAT%eccen + write(logunit,F02) "mvelpp = ",SDAT%mvelpp + write(logunit,F02) "lambm0 = ",SDAT%lambm0 + write(logunit,F02) "obliqr = ",SDAT%obliqr + write(logunit,F01) "nstreams = ",SDAT%nstreams + write(logunit,F01) "pio_iotype = ",sdat%io_type + + do n=1, SDAT%nstreams + write(logunit,F04) " streams (",n,") = ",trim(SDAT%streams(n)) + write(logunit,F04) " taxMode (",n,") = ",trim(SDAT%taxMode(n)) + write(logunit,F07) " dtlimit (",n,") = ",SDAT%dtlimit(n) + write(logunit,F05) " strnxg (",n,") = ",SDAT%strnxg(n) + write(logunit,F05) " strnyg (",n,") = ",SDAT%strnyg(n) + write(logunit,F06) " dofill (",n,") = ",SDAT%dofill(n) + write(logunit,F04) " fillalgo(",n,") = ",trim(SDAT%fillalgo(n)) + write(logunit,F04) " fillmask(",n,") = ",trim(SDAT%fillmask(n)) + write(logunit,F04) " fillread(",n,") = ",trim(SDAT%fillread(n)) + write(logunit,F04) " fillwrit(",n,") = ",trim(SDAT%fillwrit(n)) + write(logunit,F06) " domaps (",n,") = ",SDAT%domaps(n) + write(logunit,F04) " mapalgo (",n,") = ",trim(SDAT%mapalgo(n)) + write(logunit,F04) " mapmask (",n,") = ",trim(SDAT%mapmask(n)) + write(logunit,F04) " mapread (",n,") = ",trim(SDAT%mapread(n)) + write(logunit,F04) " mapwrit (",n,") = ",trim(SDAT%mapwrit(n)) + write(logunit,F04) " tintalgo(",n,") = ",trim(SDAT%tintalgo(n)) + write(logunit,F01) " " + end do + write(logunit,F01) "nvectors = ",SDAT%nvectors + do n=1, SDAT%nvectors + write(logunit,F04) " vectors (",n,") = ",trim(SDAT%vectors(n)) + end do + write(logunit,F90) + call shr_sys_flush(logunit) + +end subroutine shr_strdata_print + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_strdata_bcastnml -- broadcast control strdata +! +! !DESCRIPTION: +! Broadcast strdata +! +! !REVISION HISTORY: +! 2009-Apr-16 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_strdata_bcastnml(SDAT,mpicom,rc) + + use shr_mpi_mod, only : shr_mpi_bcast + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_strdata_type),intent(inout) :: SDAT ! strdata data data-type + integer(IN) ,intent(in) :: mpicom ! mpi communicator + integer(IN),optional ,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer(IN) :: lrc + + !----- formats ----- + character(*),parameter :: subName = "(shr_strdata_bcastnml) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lrc = 0 + + call shr_mpi_bcast(SDAT%dataMode ,mpicom,'dataMode') + call shr_mpi_bcast(SDAT%domainFile,mpicom,'domainFile') + call shr_mpi_bcast(SDAT%calendar ,mpicom,'calendar') + call shr_mpi_bcast(SDAT%nstreams ,mpicom,'nstreams') + call shr_mpi_bcast(SDAT%nvectors ,mpicom,'nvectors') + call shr_mpi_bcast(SDAT%streams ,mpicom,'streams') + call shr_mpi_bcast(SDAT%taxMode ,mpicom,'taxMode') + call shr_mpi_bcast(SDAT%dtlimit ,mpicom,'dtlimit') + call shr_mpi_bcast(SDAT%vectors ,mpicom,'vectors') + call shr_mpi_bcast(SDAT%fillalgo ,mpicom,'fillalgo') + call shr_mpi_bcast(SDAT%fillmask ,mpicom,'fillmask') + call shr_mpi_bcast(SDAT%fillread ,mpicom,'fillread') + call shr_mpi_bcast(SDAT%fillwrit ,mpicom,'fillwrit') + call shr_mpi_bcast(SDAT%mapalgo ,mpicom,'mapalgo') + call shr_mpi_bcast(SDAT%mapmask ,mpicom,'mapmask') + call shr_mpi_bcast(SDAT%mapread ,mpicom,'mapread') + call shr_mpi_bcast(SDAT%mapwrit ,mpicom,'mapwrit') + call shr_mpi_bcast(SDAT%tintalgo ,mpicom,'tintalgo') + + if (present(rc)) then + rc = lrc + endif + +end subroutine shr_strdata_bcastnml + +!=============================================================================== + +subroutine shr_strdata_setlogunit(nu) + + integer(IN),intent(in) :: nu + character(len=*),parameter :: subname = "(shr_strdata_setlogunit) " + + ! tcx DOES NOTHING, REMOVE + +end subroutine shr_strdata_setlogunit + +!=============================================================================== +!=============================================================================== + +end module shr_strdata_mod + diff --git a/models/clm/DART_SourceMods/cesm1_2_1/rtm.buildnml.csh b/models/clm/DART_SourceMods/cesm1_2_1/rtm.buildnml.csh new file mode 100755 index 0000000000..bca0fbaa75 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm1_2_1/rtm.buildnml.csh @@ -0,0 +1,110 @@ +#! /bin/csh -f + +if !(-d $CASEBUILD/rtmconf) mkdir -p $CASEBUILD/rtmconf + +#------------------------------ +# Verify rof grid is supported + +set check_grid = "fail" +if (${ROF_GRID} == "null")set check_grid = "OK" +if (${ROF_GRID} == "r05") set check_grid = "OK" +if (${ROF_GRID} == "r01") set check_grid = "OK" + +if (${check_grid} != "OK") then + echo "ROF_GRID=${ROF_GRID} not supported in rtm" + echo " rtm support on null (for single point runs), r05 and r01 ROF_GRIDs only" + exit -2 +endif + +#------------------------------ + +set default_rof_in_filename = "rof_in" + +set inst_counter = 1 +while ($inst_counter <= $NINST_ROF) + +if ($NINST_ROF > 1) then + set inst_string = `printf _%04d $inst_counter` +else + set inst_string = "" +endif +set rof_in_filename = ${default_rof_in_filename}${inst_string} + +setenv INST_STRING $inst_string + +cd $CASEBUILD/rtmconf + +if (-e $CASEBUILD/rtm.input_data_list) rm $CASEBUILD/rtm.input_data_list + +# The following is for backwards compatibility when runoff restart data was on clm restart files +set finidat_rtm = "" +set nrevsn_rtm = "" +if (${ROF_GRID} != "null") then +if ($RUN_TYPE == 'hybrid' || $RUN_TYPE == "branch" ) then + + # set search directory + if ($GET_REFCASE == 'TRUE') then + set refdir = "$DIN_LOC_ROOT/ccsm4_init/$RUN_REFCASE/$RUN_REFDATE" + else + set refdir = "$RUNDIR" + endif + + # search for clm or rtm files with instance or not + set fncheck = "${RUN_REFCASE}.rtm${inst_string}.r.${RUN_REFDATE}-${RUN_REFTOD}.nc" + if !(-e "$refdir/$fncheck") then + set fncheck = "${RUN_REFCASE}.rtm.r.${RUN_REFDATE}-${RUN_REFTOD}.nc" + if !(-e "$refdir/$fncheck") then + set fncheck = "${RUN_REFCASE}.clm2${inst_string}.r.${RUN_REFDATE}-${RUN_REFTOD}.nc" + if !(-e "$refdir/$fncheck") then + set fncheck = "${RUN_REFCASE}.clm2.r.${RUN_REFDATE}-${RUN_REFTOD}.nc" + if !(-e "$refdir/$fncheck") then + echo "WARNING: rtm.buildnml.csh could not find restart file for branch or hybrid start" + echo "WARNING: looking for a file with a name like:" + echo " ${refdir}/${RUN_REFCASE}.[rtm${inst_string},clm2${inst_string}].r.${RUN_REFDATE}-${RUN_REFTOD}.nc" +# exit -8 + set fncheck = "unknown at this time" + endif + endif + endif + endif + + # set the namelist variable needed + if ($RUN_TYPE == "hybrid") then + set finidat_rtm = "finidat_rtm = '$fncheck'" + endif + if ($RUN_TYPE == "branch") then + set nrevsn_rtm = "nrevsn_rtm = '$refdir/$fncheck'" + endif + +endif +endif + +cat >! $CASEBUILD/rtmconf/cesm_namelist << EOF2 +&rtm_inparm + $finidat_rtm + $nrevsn_rtm + $RTM_NAMELIST_OPTS +EOF2 +if (-e $CASEROOT/user_nl_rtm${inst_string}) then + $UTILROOT/Tools/user_nl_add -user_nl_file $CASEROOT/user_nl_rtm${inst_string} >> $CASEBUILD/rtmconf/cesm_namelist || exit -2 +endif +cat >> $CASEBUILD/rtmconf/cesm_namelist << EOF2 +/ +EOF2 + +cd $CASEBUILD/rtmconf +$CODEROOT/rof/rtm/bld/build-namelist \ + -infile $CASEBUILD/rtmconf/cesm_namelist \ + -caseroot $CASEROOT \ + -scriptsroot $SCRIPTSROOT \ + -inst_string "$inst_string" $RTM_BLDNML_OPTS || exit -4 + +if (-d ${RUNDIR}) then + cp $CASEBUILD/rtmconf/rof_in ${RUNDIR}/$rof_in_filename || exit -2 +endif + +@ inst_counter = $inst_counter + 1 + +end + + diff --git a/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.cime/README.txt b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.cime/README.txt new file mode 100644 index 0000000000..196a2bda1b --- /dev/null +++ b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.cime/README.txt @@ -0,0 +1,8 @@ + +cime/src/drivers/mct/main/seq_rest_mod.F90 no longer needs modifications. + +! Jim Edwards 6/7/17: "It turns out that a diagnostic field in the coupler was changed +! (from cesm1_5) in a non-backward compatible way. But I have a workaround. On your +! first run comment out lines 258-276 of file seq_rest_mod.F90 that will get you +! started and after the first restart you can remove that modification." + diff --git a/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/README.txt b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/README.txt new file mode 100644 index 0000000000..b46084ca43 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/README.txt @@ -0,0 +1,32 @@ +#!/bin/csh +# +# biogeochem/CNBalanceCheckMod.F90 +# biogeophys/SurfaceRadiationMod.F90 +# biogeophys/PhotosynthesisMod.F90 +# biogeophys/CanopyFluxesMod.F90 +# cpl/lnd_import_export.F90 + +foreach FILE ( \ + biogeochem/CNBalanceCheckMod.F90 \ + biogeophys/SurfaceRadiationMod.F90 \ + biogeophys/PhotosynthesisMod.F90 \ + biogeophys/CanopyFluxesMod.F90 ) + + set OLD = /glade/work/thoar/CESM/cesm2.1.0/components/clm/src/$FILE + set NEW = /glade/work/thoar/CESM/my_cesm_sandbox/components/clm/src/$FILE + +# diffuse $OLD $FILE +# diffuse $OLD $FILE $NEW + diffuse $FILE $NEW + +end + +# The lnd_import_export.F90 is not in the same directory as it was ... I am not sure it is needed + + set FILE = cpl/lnd_import_export.F90 + set OLD = /glade/work/thoar/CESM/cesm2.1.0/components/clm/src/cpl/lnd_import_export.F90 + set NEW = /glade/work/thoar/CESM/my_cesm_sandbox/components/clm/src/cpl/mct/lnd_import_export.F90 + + diffuse $OLD $FILE + diffuse $OLD $FILE $NEW + diffuse $FILE $NEW diff --git a/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/biogeochem/CNBalanceCheckMod.F90 b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/biogeochem/CNBalanceCheckMod.F90 new file mode 100644 index 0000000000..52e483f71d --- /dev/null +++ b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/biogeochem/CNBalanceCheckMod.F90 @@ -0,0 +1,638 @@ + +! DART note: this file started life as release-cesm2.2.01 : +! /glade/work/thoar/CESM/my_cesm_sandbox/components/clm/src/biogeochem/CNBalanceCheckMod.F90 +! +! The point of the this sourcemod is to skip the balance checks for the first restart step +! and then use them for the remaining timesteps. Since the DA algorithm is free to +! create and destroy energy or mass during the assimilation, there is no reason to +! check for balance consistency during startup. Some users have found it necessary +! to entirely disable balance checks - i.e. for all timesteps. + +module CNBalanceCheckMod + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module for carbon/nitrogen mass balance checking. + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod , only : errMsg => shr_log_errMsg + use decompMod , only : bounds_type + use abortutils , only : endrun + use clm_varctl , only : iulog, use_nitrif_denitrif + use clm_time_manager , only : get_step_size_real, is_first_restart_step + use CNVegNitrogenFluxType , only : cnveg_nitrogenflux_type + use CNVegNitrogenStateType , only : cnveg_nitrogenstate_type + use CNVegCarbonFluxType , only : cnveg_carbonflux_type + use CNVegCarbonStateType , only : cnveg_carbonstate_type + use SoilBiogeochemNitrogenfluxType , only : soilbiogeochem_nitrogenflux_type + use SoilBiogeochemCarbonfluxType , only : soilbiogeochem_carbonflux_type + use CNProductsMod , only : cn_products_type + use ColumnType , only : col + use GridcellType , only : grc + use CNSharedParamsMod , only : use_fun + + ! + implicit none + private + ! + ! !PUBLIC TYPES: + type, public :: cn_balance_type + private + real(r8), pointer :: begcb_col(:) ! (gC/m2) column carbon mass, beginning of time step + real(r8), pointer :: endcb_col(:) ! (gC/m2) column carbon mass, end of time step + real(r8), pointer :: begnb_col(:) ! (gN/m2) column nitrogen mass, beginning of time step + real(r8), pointer :: endnb_col(:) ! (gN/m2) column nitrogen mass, end of time step + real(r8), pointer :: begcb_grc(:) ! (gC/m2) gridcell carbon mass, beginning of time step + real(r8), pointer :: endcb_grc(:) ! (gC/m2) gridcell carbon mass, end of time step + real(r8), pointer :: begnb_grc(:) ! (gN/m2) gridcell nitrogen mass, beginning of time step + real(r8), pointer :: endnb_grc(:) ! (gN/m2) gridcell nitrogen mass, end of time step + contains + procedure , public :: Init + procedure , public :: BeginCNGridcellBalance + procedure , public :: BeginCNColumnBalance + procedure , public :: CBalanceCheck + procedure , public :: NBalanceCheck + procedure , private :: InitAllocate + end type cn_balance_type + ! + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine Init(this, bounds) + class(cn_balance_type) :: this + type(bounds_type) , intent(in) :: bounds + + call this%InitAllocate(bounds) + end subroutine Init + + !----------------------------------------------------------------------- + subroutine InitAllocate(this, bounds) + class(cn_balance_type) :: this + type(bounds_type) , intent(in) :: bounds + + integer :: begc, endc + integer :: begg, endg + + begg = bounds%begg; endg = bounds%endg + + allocate(this%begcb_grc(begg:endg)) ; this%begcb_grc(:) = nan + allocate(this%endcb_grc(begg:endg)) ; this%endcb_grc(:) = nan + allocate(this%begnb_grc(begg:endg)) ; this%begnb_grc(:) = nan + allocate(this%endnb_grc(begg:endg)) ; this%endnb_grc(:) = nan + + begc = bounds%begc; endc= bounds%endc + + allocate(this%begcb_col(begc:endc)) ; this%begcb_col(:) = nan + allocate(this%endcb_col(begc:endc)) ; this%endcb_col(:) = nan + allocate(this%begnb_col(begc:endc)) ; this%begnb_col(:) = nan + allocate(this%endnb_col(begc:endc)) ; this%endnb_col(:) = nan + end subroutine InitAllocate + + !----------------------------------------------------------------------- + subroutine BeginCNGridcellBalance(this, bounds, cnveg_carbonflux_inst, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst, & + c_products_inst, n_products_inst) + ! + ! !DESCRIPTION: + ! Calculate beginning gridcell-level carbon/nitrogen balance + ! for mass conservation check + ! + ! Should be called after CN state summaries have been computed + ! and before the dynamic landunit area updates + ! + ! !USES: + ! + ! !ARGUMENTS: + class(cn_balance_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + type(cnveg_carbonflux_type) , intent(in) :: cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + type(cn_products_type) , intent(in) :: c_products_inst + type(cn_products_type) , intent(in) :: n_products_inst + ! + ! !LOCAL VARIABLES: + integer :: g + integer :: begg, endg + real(r8) :: hrv_xsmrpool_amount_left_to_dribble(bounds%begg:bounds%endg) + real(r8) :: dwt_conv_cflux_amount_left_to_dribble(bounds%begg:bounds%endg) + !----------------------------------------------------------------------- + + associate( & + begcb => this%begcb_grc , & ! Output: [real(r8) (:)] (gC/m2) gridcell carbon mass, beginning of time step + begnb => this%begnb_grc , & ! Output: [real(r8) (:)] (gN/m2) gridcell nitrogen mass, beginning of time step + totc => cnveg_carbonstate_inst%totc_grc , & ! Input: [real(r8) (:)] (gC/m2) total gridcell carbon, incl veg and cpool + totn => cnveg_nitrogenstate_inst%totn_grc, & ! Input: [real(r8) (:)] (gN/m2) total gridcell nitrogen, incl veg + c_cropprod1 => c_products_inst%cropprod1_grc , & ! Input: [real(r8) (:)] (gC/m2) carbon in crop products + n_cropprod1 => n_products_inst%cropprod1_grc , & ! Input: [real(r8) (:)] (gC/m2) nitrogen in crop products + c_tot_woodprod => c_products_inst%tot_woodprod_grc , & ! Input: [real(r8) (:)] (gC/m2) total carbon in wood products + n_tot_woodprod => n_products_inst%tot_woodprod_grc & ! Input: [real(r8) (:)] (gC/m2) total nitrogen in wood products + ) + + begg = bounds%begg; endg = bounds%endg + + call cnveg_carbonflux_inst%hrv_xsmrpool_to_atm_dribbler%get_amount_left_to_dribble_beg( & + bounds, hrv_xsmrpool_amount_left_to_dribble(bounds%begg:bounds%endg)) + call cnveg_carbonflux_inst%dwt_conv_cflux_dribbler%get_amount_left_to_dribble_beg( & + bounds, dwt_conv_cflux_amount_left_to_dribble(bounds%begg:bounds%endg)) + + do g = begg, endg + begcb(g) = totc(g) + c_tot_woodprod(g) + c_cropprod1(g) + & + hrv_xsmrpool_amount_left_to_dribble(g) + & + dwt_conv_cflux_amount_left_to_dribble(g) + begnb(g) = totn(g) + n_tot_woodprod(g) + n_cropprod1(g) + end do + + end associate + + end subroutine BeginCNGridcellBalance + + !----------------------------------------------------------------------- + subroutine BeginCNColumnBalance(this, bounds, num_soilc, filter_soilc, & + cnveg_carbonstate_inst, cnveg_nitrogenstate_inst) + ! + ! !DESCRIPTION: + ! Calculate beginning column-level carbon/nitrogen balance, for mass conservation check + ! + ! Should be called after CN state summaries have been recomputed for this time step + ! (which should be after the dynamic landunit area updates and the associated filter + ! updates - i.e., using the new version of the filters) + ! + ! !ARGUMENTS: + class(cn_balance_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(cnveg_carbonstate_type) , intent(in) :: cnveg_carbonstate_inst + type(cnveg_nitrogenstate_type) , intent(in) :: cnveg_nitrogenstate_inst + ! + ! !LOCAL VARIABLES: + integer :: fc,c + !----------------------------------------------------------------------- + + associate( & + col_begcb => this%begcb_col , & ! Output: [real(r8) (:)] (gC/m2) column carbon mass, beginning of time step + col_begnb => this%begnb_col , & ! Output: [real(r8) (:)] (gN/m2) column nitrogen mass, beginning of time step + totcolc => cnveg_carbonstate_inst%totc_col , & ! Input: [real(r8) (:)] (gC/m2) total column carbon, incl veg and cpool + totcoln => cnveg_nitrogenstate_inst%totn_col & ! Input: [real(r8) (:)] (gN/m2) total column nitrogen, incl veg + ) + + do fc = 1,num_soilc + c = filter_soilc(fc) + col_begcb(c) = totcolc(c) + col_begnb(c) = totcoln(c) + end do + + end associate + + end subroutine BeginCNColumnBalance + + !----------------------------------------------------------------------- + subroutine CBalanceCheck(this, bounds, num_soilc, filter_soilc, & + soilbiogeochem_carbonflux_inst, cnveg_carbonflux_inst, & + cnveg_carbonstate_inst, c_products_inst) + ! + ! !USES: + use subgridAveMod, only: c2g + ! + ! !DESCRIPTION: + ! Perform carbon mass conservation check for column and patch + ! + ! !ARGUMENTS: + class(cn_balance_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc(:) ! filter for soil columns + type(soilbiogeochem_carbonflux_type) , intent(in) :: soilbiogeochem_carbonflux_inst + type(cnveg_carbonflux_type) , intent(in) :: cnveg_carbonflux_inst + type(cnveg_carbonstate_type) , intent(inout) :: cnveg_carbonstate_inst + type(cn_products_type) , intent(in) :: c_products_inst + ! + ! !LOCAL VARIABLES: + integer :: c, g, err_index ! indices + integer :: fc ! lake filter indices + logical :: err_found ! error flag + real(r8) :: dt ! radiation time step (seconds) + real(r8) :: col_cinputs, grc_cinputs + real(r8) :: col_coutputs, grc_coutputs + real(r8) :: col_errcb(bounds%begc:bounds%endc) + real(r8) :: grc_errcb(bounds%begg:bounds%endg) + real(r8) :: som_c_leached_grc(bounds%begg:bounds%endg) + real(r8) :: hrv_xsmrpool_amount_left_to_dribble(bounds%begg:bounds%endg) + real(r8) :: dwt_conv_cflux_amount_left_to_dribble(bounds%begg:bounds%endg) + !----------------------------------------------------------------------- + + associate( & + grc_begcb => this%begcb_grc , & ! Input: [real(r8) (:) ] (gC/m2) gridcell-level carbon mass, beginning of time step + grc_endcb => this%endcb_grc , & ! Output: [real(r8) (:) ] (gC/m2) gridcell-level carbon mass, end of time step + totgrcc => cnveg_carbonstate_inst%totc_grc , & ! Input: [real(r8) (:)] (gC/m2) total gridcell carbon, incl veg and cpool + nbp_grc => cnveg_carbonflux_inst%nbp_grc , & ! Input: [real(r8) (:) ] (gC/m2/s) net biome production (positive for sink) + cropprod1_grc => c_products_inst%cropprod1_grc , & ! Input: [real(r8) (:)] (gC/m2) carbon in crop products + tot_woodprod_grc => c_products_inst%tot_woodprod_grc , & ! Input: [real(r8) (:)] (gC/m2) total carbon in wood products + dwt_seedc_to_leaf_grc => cnveg_carbonflux_inst%dwt_seedc_to_leaf_grc , & ! Input: [real(r8) (:)] (gC/m2/s) seed source sent to leaf + dwt_seedc_to_deadstem_grc => cnveg_carbonflux_inst%dwt_seedc_to_deadstem_grc , & ! Input: [real(r8) (:)] (gC/m2/s) seed source sent to deadstem + col_begcb => this%begcb_col , & ! Input: [real(r8) (:) ] (gC/m2) carbon mass, beginning of time step + col_endcb => this%endcb_col , & ! Output: [real(r8) (:) ] (gC/m2) carbon mass, end of time step + wood_harvestc => cnveg_carbonflux_inst%wood_harvestc_col , & ! Input: [real(r8) (:) ] (gC/m2/s) wood harvest (to product pools) + grainc_to_cropprodc => cnveg_carbonflux_inst%grainc_to_cropprodc_col , & ! Input: [real(r8) (:) ] (gC/m2/s) grain C to 1-year crop product pool + gpp => cnveg_carbonflux_inst%gpp_col , & ! Input: [real(r8) (:) ] (gC/m2/s) gross primary production + er => cnveg_carbonflux_inst%er_col , & ! Input: [real(r8) (:) ] (gC/m2/s) total ecosystem respiration, autotrophic + heterotrophic + col_fire_closs => cnveg_carbonflux_inst%fire_closs_col , & ! Input: [real(r8) (:) ] (gC/m2/s) total column-level fire C loss + col_hrv_xsmrpool_to_atm => cnveg_carbonflux_inst%hrv_xsmrpool_to_atm_col , & ! Input: [real(r8) (:) ] (gC/m2/s) excess MR pool harvest mortality + col_xsmrpool_to_atm => cnveg_carbonflux_inst%xsmrpool_to_atm_col , & ! Input: [real(r8) (:) ] (gC/m2/s) excess MR pool crop harvest loss to atm + som_c_leached => soilbiogeochem_carbonflux_inst%som_c_leached_col , & ! Input: [real(r8) (:) ] (gC/m2/s) total SOM C loss from vertical transport + + totcolc => cnveg_carbonstate_inst%totc_col & ! Input: [real(r8) (:) ] (gC/m2) total column carbon, incl veg and cpool + ) + + ! set time steps + dt = get_step_size_real() + + err_found = .false. + do fc = 1,num_soilc + c = filter_soilc(fc) + + ! calculate the total column-level carbon storage, for mass conservation check + col_endcb(c) = totcolc(c) + + ! calculate total column-level inputs + col_cinputs = gpp(c) + + ! calculate total column-level outputs + ! er = ar + hr, col_fire_closs includes patch-level fire losses + col_coutputs = er(c) + col_fire_closs(c) + col_hrv_xsmrpool_to_atm(c) + & + col_xsmrpool_to_atm(c) + + ! Fluxes to product pools are included in column-level outputs: the product + ! pools are not included in totcolc, so are outside the system with respect to + ! these balance checks. (However, the dwt flux to product pools is NOT included, + ! since col_begcb is initialized after the dynamic area adjustments - i.e., + ! after the dwt term has already been taken out.) + col_coutputs = col_coutputs + & + wood_harvestc(c) + & + grainc_to_cropprodc(c) + + ! subtract leaching flux + col_coutputs = col_coutputs - som_c_leached(c) + + ! calculate the total column-level carbon balance error for this time step + col_errcb(c) = (col_cinputs - col_coutputs)*dt - & + (col_endcb(c) - col_begcb(c)) + + ! check for significant errors + if (abs(col_errcb(c)) > 1e-7_r8) then + err_found = .true. + err_index = c + end if + if (abs(col_errcb(c)) > 1e-8_r8) then + write(iulog,*) 'cbalance warning at c =', c, col_errcb(c), col_endcb(c) + end if + + + + end do ! end of columns loop + + if (err_found .and. (.not. is_first_restart_step()) ) then + c = err_index + write(iulog,*)'column cbalance error = ', col_errcb(c), c + write(iulog,*)'Latdeg,Londeg=',grc%latdeg(col%gridcell(c)),grc%londeg(col%gridcell(c)) + write(iulog,*)'begcb = ',col_begcb(c) + write(iulog,*)'endcb = ',col_endcb(c) + write(iulog,*)'delta store = ',col_endcb(c)-col_begcb(c) + write(iulog,*)'--- Inputs ---' + write(iulog,*)'gpp = ',gpp(c)*dt + write(iulog,*)'--- Outputs ---' + write(iulog,*)'er = ',er(c)*dt + write(iulog,*)'col_fire_closs = ',col_fire_closs(c)*dt + write(iulog,*)'col_hrv_xsmrpool_to_atm = ',col_hrv_xsmrpool_to_atm(c)*dt + write(iulog,*)'col_xsmrpool_to_atm = ',col_xsmrpool_to_atm(c)*dt + write(iulog,*)'wood_harvestc = ',wood_harvestc(c)*dt + write(iulog,*)'grainc_to_cropprodc = ',grainc_to_cropprodc(c)*dt + write(iulog,*)'-1*som_c_leached = ',som_c_leached(c)*dt + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Repeat error check at the gridcell level + call c2g( bounds = bounds, & + carr = totcolc(bounds%begc:bounds%endc), & + garr = totgrcc(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + call c2g( bounds = bounds, & + carr = som_c_leached(bounds%begc:bounds%endc), & + garr = som_c_leached_grc(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + + err_found = .false. + do g = bounds%begg, bounds%endg + ! calculate gridcell-level carbon storage for mass conservation check + ! Notes: + ! totgrcc = totcolc = totc_p2c_col(c) + soilbiogeochem_cwdc_col(c) + soilbiogeochem_totlitc_col(c) + soilbiogeochem_totsomc_col(c) + soilbiogeochem_ctrunc_col(c) + ! totc_p2c_col = totc_patch = totvegc_patch(p) + xsmrpool_patch(p) + ctrunc_patch(p) + cropseedc_deficit_patch(p) + ! Not including seedc_grc in grc_begcb and grc_endcb because + ! seedc_grc forms out of thin air, for now, and equals + ! -1 * (dwt_seedc_to_leaf_grc(g) + dwt_seedc_to_deadstem_grc(g)) + ! We account for the latter fluxes as inputs below; the same + ! fluxes have entered the pools earlier in the timestep. For true + ! conservation we would need to add a flux out of npp into seed. + call cnveg_carbonflux_inst%hrv_xsmrpool_to_atm_dribbler%get_amount_left_to_dribble_end( & + bounds, hrv_xsmrpool_amount_left_to_dribble(bounds%begg:bounds%endg)) + call cnveg_carbonflux_inst%dwt_conv_cflux_dribbler%get_amount_left_to_dribble_end( & + bounds, dwt_conv_cflux_amount_left_to_dribble(bounds%begg:bounds%endg)) + grc_endcb(g) = totgrcc(g) + tot_woodprod_grc(g) + cropprod1_grc(g) + & + hrv_xsmrpool_amount_left_to_dribble(g) + & + dwt_conv_cflux_amount_left_to_dribble(g) + + ! calculate total gridcell-level inputs + ! slevis notes: + ! nbp_grc = nep_grc - fire_closs_grc - hrv_xsmrpool_to_atm_dribbled_grc - dwt_conv_cflux_dribbled_grc - product_closs_grc + grc_cinputs = nbp_grc(g) + & + dwt_seedc_to_leaf_grc(g) + dwt_seedc_to_deadstem_grc(g) + + ! calculate total gridcell-level outputs + grc_coutputs = - som_c_leached_grc(g) + + ! calculate the total gridcell-level carbon balance error + ! for this time step + grc_errcb(g) = (grc_cinputs - grc_coutputs) * dt - & + (grc_endcb(g) - grc_begcb(g)) + + ! check for significant errors + if (abs(grc_errcb(g)) > 1e-7_r8) then + err_found = .true. + err_index = g + end if + if (abs(grc_errcb(g)) > 1e-8_r8) then + write(iulog,*) 'cbalance warning at g =', g, grc_errcb(g), grc_endcb(g) + end if + end do ! end of gridcell loop + + if (err_found .and. (.not. is_first_restart_step()) ) then + g = err_index + write(iulog,*)'gridcell cbalance error =', grc_errcb(g), g + write(iulog,*)'latdeg, londeg =', grc%latdeg(g), grc%londeg(g) + write(iulog,*)'begcb =', grc_begcb(g) + write(iulog,*)'endcb =', grc_endcb(g) + write(iulog,*)'delta store =', grc_endcb(g) - grc_begcb(g) + write(iulog,*)'--- Inputs ---' + write(iulog,*)'nbp_grc =', nbp_grc(g) * dt + write(iulog,*)'dwt_seedc_to_leaf_grc =', dwt_seedc_to_leaf_grc(g) * dt + write(iulog,*)'dwt_seedc_to_deadstem_grc =', dwt_seedc_to_deadstem_grc(g) * dt + write(iulog,*)'--- Outputs ---' + write(iulog,*)'-1*som_c_leached_grc = ', som_c_leached_grc(g) * dt + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end associate + + end subroutine CBalanceCheck + + !----------------------------------------------------------------------- + subroutine NBalanceCheck(this, bounds, num_soilc, filter_soilc, & + soilbiogeochem_nitrogenflux_inst, cnveg_nitrogenflux_inst, & + cnveg_nitrogenstate_inst, n_products_inst, atm2lnd_inst) + ! + ! !DESCRIPTION: + ! Perform nitrogen mass conservation check + ! + ! !USES: + use clm_varctl, only : use_crop + use subgridAveMod, only: c2g + use atm2lndType, only: atm2lnd_type + ! + ! !ARGUMENTS: + class(cn_balance_type) , intent(inout) :: this + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_soilc ! number of soil columns in filter + integer , intent(in) :: filter_soilc (:) ! filter for soil columns + type(soilbiogeochem_nitrogenflux_type) , intent(in) :: soilbiogeochem_nitrogenflux_inst + type(cnveg_nitrogenflux_type) , intent(in) :: cnveg_nitrogenflux_inst + type(cnveg_nitrogenstate_type) , intent(inout) :: cnveg_nitrogenstate_inst + type(cn_products_type) , intent(in) :: n_products_inst + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + ! + ! !LOCAL VARIABLES: + integer :: c,err_index,j ! indices + integer :: g ! gridcell index + integer :: fc ! lake filter indices + logical :: err_found ! error flag + real(r8):: dt ! radiation time step (seconds) + real(r8):: col_ninputs(bounds%begc:bounds%endc) + real(r8):: col_noutputs(bounds%begc:bounds%endc) + real(r8):: col_errnb(bounds%begc:bounds%endc) + real(r8):: col_ninputs_partial(bounds%begc:bounds%endc) + real(r8):: col_noutputs_partial(bounds%begc:bounds%endc) + real(r8):: grc_ninputs_partial(bounds%begg:bounds%endg) + real(r8):: grc_noutputs_partial(bounds%begg:bounds%endg) + real(r8):: grc_ninputs(bounds%begg:bounds%endg) + real(r8):: grc_noutputs(bounds%begg:bounds%endg) + real(r8):: grc_errnb(bounds%begg:bounds%endg) + !----------------------------------------------------------------------- + + associate( & + grc_begnb => this%begnb_grc , & ! Input: [real(r8) (:) ] (gN/m2) gridcell nitrogen mass, beginning of time step + grc_endnb => this%endnb_grc , & ! Output: [real(r8) (:) ] (gN/m2) gridcell nitrogen mass, end of time step + totgrcn => cnveg_nitrogenstate_inst%totn_grc , & ! Input: [real(r8) (:) ] (gN/m2) total gridcell nitrogen, incl veg + cropprod1_grc => n_products_inst%cropprod1_grc , & ! Input: [real(r8) (:)] (gN/m2) nitrogen in crop products + product_loss_grc => n_products_inst%product_loss_grc , & ! Input: [real(r8) (:)] (gN/m2) losses from wood & crop products + tot_woodprod_grc => n_products_inst%tot_woodprod_grc , & ! Input: [real(r8) (:)] (gN/m2) total nitrogen in wood products + dwt_seedn_to_leaf_grc => cnveg_nitrogenflux_inst%dwt_seedn_to_leaf_grc , & ! Input: [real(r8) (:)] (gN/m2/s) seed source sent to leaf + dwt_seedn_to_deadstem_grc => cnveg_nitrogenflux_inst%dwt_seedn_to_deadstem_grc , & ! Input: [real(r8) (:)] (gN/m2/s) seed source sent to deadstem + dwt_conv_nflux_grc => cnveg_nitrogenflux_inst%dwt_conv_nflux_grc , & ! Input: [real(r8) (:)] (gN/m2/s) dwt_conv_nflux_patch summed to the gridcell-level + col_begnb => this%begnb_col , & ! Input: [real(r8) (:) ] (gN/m2) column nitrogen mass, beginning of time step + col_endnb => this%endnb_col , & ! Output: [real(r8) (:) ] (gN/m2) column nitrogen mass, end of time step + ndep_to_sminn => soilbiogeochem_nitrogenflux_inst%ndep_to_sminn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) atmospheric N deposition to soil mineral N + nfix_to_sminn => soilbiogeochem_nitrogenflux_inst%nfix_to_sminn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) symbiotic/asymbiotic N fixation to soil mineral N + ffix_to_sminn => soilbiogeochem_nitrogenflux_inst%ffix_to_sminn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) free living N fixation to soil mineral N + fert_to_sminn => soilbiogeochem_nitrogenflux_inst%fert_to_sminn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) + soyfixn_to_sminn => soilbiogeochem_nitrogenflux_inst%soyfixn_to_sminn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) + supplement_to_sminn => soilbiogeochem_nitrogenflux_inst%supplement_to_sminn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) supplemental N supply + denit => soilbiogeochem_nitrogenflux_inst%denit_col , & ! Input: [real(r8) (:) ] (gN/m2/s) total rate of denitrification + sminn_leached => soilbiogeochem_nitrogenflux_inst%sminn_leached_col , & ! Input: [real(r8) (:) ] (gN/m2/s) soil mineral N pool loss to leaching + smin_no3_leached => soilbiogeochem_nitrogenflux_inst%smin_no3_leached_col , & ! Input: [real(r8) (:) ] (gN/m2/s) soil mineral NO3 pool loss to leaching + smin_no3_runoff => soilbiogeochem_nitrogenflux_inst%smin_no3_runoff_col , & ! Input: [real(r8) (:) ] (gN/m2/s) soil mineral NO3 pool loss to runoff + f_n2o_nit => soilbiogeochem_nitrogenflux_inst%f_n2o_nit_col , & ! Input: [real(r8) (:) ] (gN/m2/s) flux of N2o from nitrification + som_n_leached => soilbiogeochem_nitrogenflux_inst%som_n_leached_col , & ! Input: [real(r8) (:) ] (gN/m2/s) total SOM N loss from vertical transport + + col_fire_nloss => cnveg_nitrogenflux_inst%fire_nloss_col , & ! Input: [real(r8) (:) ] (gN/m2/s) total column-level fire N loss + wood_harvestn => cnveg_nitrogenflux_inst%wood_harvestn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) wood harvest (to product pools) + grainn_to_cropprodn => cnveg_nitrogenflux_inst%grainn_to_cropprodn_col , & ! Input: [real(r8) (:) ] (gN/m2/s) grain N to 1-year crop product pool + + totcoln => cnveg_nitrogenstate_inst%totn_col & ! Input: [real(r8) (:) ] (gN/m2) total column nitrogen, incl veg + ) + + ! set time steps + dt = get_step_size_real() + + ! initialize local arrays + col_ninputs_partial(:) = 0._r8 + col_noutputs_partial(:) = 0._r8 + + err_found = .false. + do fc = 1,num_soilc + c=filter_soilc(fc) + + ! calculate the total column-level nitrogen storage, for mass conservation check + col_endnb(c) = totcoln(c) + + ! calculate total column-level inputs + col_ninputs(c) = ndep_to_sminn(c) + nfix_to_sminn(c) + supplement_to_sminn(c) + + if(use_fun)then + col_ninputs(c) = col_ninputs(c) + ffix_to_sminn(c) ! for FUN, free living fixation is a seprate flux. RF. + endif + + if (use_crop) then + col_ninputs(c) = col_ninputs(c) + fert_to_sminn(c) + soyfixn_to_sminn(c) + end if + + col_ninputs_partial(c) = col_ninputs(c) + + ! calculate total column-level outputs + col_noutputs(c) = denit(c) + col_fire_nloss(c) + + ! Fluxes to product pools are included in column-level outputs: the product + ! pools are not included in totcoln, so are outside the system with respect to + ! these balance checks. (However, the dwt flux to product pools is NOT included, + ! since col_begnb is initialized after the dynamic area adjustments - i.e., + ! after the dwt term has already been taken out.) + col_noutputs(c) = col_noutputs(c) + & + wood_harvestn(c) + & + grainn_to_cropprodn(c) + + if (.not. use_nitrif_denitrif) then + col_noutputs(c) = col_noutputs(c) + sminn_leached(c) + else + col_noutputs(c) = col_noutputs(c) + f_n2o_nit(c) + + col_noutputs(c) = col_noutputs(c) + smin_no3_leached(c) + smin_no3_runoff(c) + end if + + col_noutputs(c) = col_noutputs(c) - som_n_leached(c) + + col_noutputs_partial(c) = col_noutputs(c) - & + wood_harvestn(c) - & + grainn_to_cropprodn(c) + + ! calculate the total column-level nitrogen balance error for this time step + col_errnb(c) = (col_ninputs(c) - col_noutputs(c))*dt - & + (col_endnb(c) - col_begnb(c)) + + if (abs(col_errnb(c)) > 1e-3_r8) then + err_found = .true. + err_index = c + end if + + if (abs(col_errnb(c)) > 1e-7_r8) then + write(iulog,*) 'nbalance warning at c =', c, col_errnb(c), col_endnb(c) + write(iulog,*)'inputs,ffix,nfix,ndep = ',ffix_to_sminn(c)*dt,nfix_to_sminn(c)*dt,ndep_to_sminn(c)*dt + write(iulog,*)'outputs,lch,roff,dnit = ',smin_no3_leached(c)*dt, smin_no3_runoff(c)*dt,f_n2o_nit(c)*dt + end if + + end do ! end of columns loop + + if (err_found .and. (.not. is_first_restart_step()) ) then + c = err_index + write(iulog,*)'column nbalance error = ',col_errnb(c), c + write(iulog,*)'Latdeg,Londeg = ',grc%latdeg(col%gridcell(c)),grc%londeg(col%gridcell(c)) + write(iulog,*)'begnb = ',col_begnb(c) + write(iulog,*)'endnb = ',col_endnb(c) + write(iulog,*)'delta store = ',col_endnb(c)-col_begnb(c) + write(iulog,*)'input mass = ',col_ninputs(c)*dt + write(iulog,*)'output mass = ',col_noutputs(c)*dt + write(iulog,*)'net flux = ',(col_ninputs(c)-col_noutputs(c))*dt + write(iulog,*)'inputs,ffix,nfix,ndep = ',ffix_to_sminn(c)*dt,nfix_to_sminn(c)*dt,ndep_to_sminn(c)*dt + write(iulog,*)'outputs,ffix,nfix,ndep = ',smin_no3_leached(c)*dt, smin_no3_runoff(c)*dt,f_n2o_nit(c)*dt + + + + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Repeat error check at the gridcell level + call c2g( bounds = bounds, & + carr = totcoln(bounds%begc:bounds%endc), & + garr = totgrcn(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + call c2g( bounds = bounds, & + carr = col_ninputs_partial(bounds%begc:bounds%endc), & + garr = grc_ninputs_partial(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + call c2g( bounds = bounds, & + carr = col_noutputs_partial(bounds%begc:bounds%endc), & + garr = grc_noutputs_partial(bounds%begg:bounds%endg), & + c2l_scale_type = 'unity', & + l2g_scale_type = 'unity') + + err_found = .false. + do g = bounds%begg, bounds%endg + ! calculate the total gridcell-level nitrogen storage, for mass conservation check + ! Notes: + ! Not including seedn_grc in grc_begnb and grc_endnb because + ! seedn_grc forms out of thin air, for now, and equals + ! -1 * (dwt_seedn_to_leaf_grc(g) + dwt_seedn_to_deadstem_grc(g)) + ! We account for the latter fluxes as inputs below; the same + ! fluxes have entered the pools earlier in the timestep. For true + ! conservation we would need to add a flux out of nfix into seed. + grc_endnb(g) = totgrcn(g) + tot_woodprod_grc(g) + cropprod1_grc(g) + + ! calculate total gridcell-level inputs + grc_ninputs(g) = grc_ninputs_partial(g) + & + dwt_seedn_to_leaf_grc(g) + & + dwt_seedn_to_deadstem_grc(g) + + ! calculate total gridcell-level outputs + grc_noutputs(g) = grc_noutputs_partial(g) + & + dwt_conv_nflux_grc(g) + & + product_loss_grc(g) + + ! calculate the total gridcell-level nitrogen balance error for this time step + grc_errnb(g) = (grc_ninputs(g) - grc_noutputs(g)) * dt - & + (grc_endnb(g) - grc_begnb(g)) + + if (abs(grc_errnb(g)) > 1e-3_r8) then + err_found = .true. + err_index = g + end if + + if (abs(grc_errnb(g)) > 1e-7_r8) then + write(iulog,*) 'nbalance warning at g =', g, grc_errnb(g), grc_endnb(g) + end if + end do + + if (err_found .and. (.not. is_first_restart_step()) ) then + g = err_index + write(iulog,*) 'gridcell nbalance error =', grc_errnb(g), g + write(iulog,*) 'latdeg, londeg =', grc%latdeg(g), grc%londeg(g) + write(iulog,*) 'begnb =', grc_begnb(g) + write(iulog,*) 'endnb =', grc_endnb(g) + write(iulog,*) 'delta store =', grc_endnb(g) - grc_begnb(g) + write(iulog,*) 'input mass =', grc_ninputs(g) * dt + write(iulog,*) 'output mass =', grc_noutputs(g) * dt + write(iulog,*) 'net flux =', (grc_ninputs(g) - grc_noutputs(g)) * dt + write(iulog,*) '--- Inputs ---' + write(iulog,*) 'grc_ninputs_partial =', grc_ninputs_partial(g) * dt + write(iulog,*) 'dwt_seedn_to_leaf_grc =', dwt_seedn_to_leaf_grc(g) * dt + write(iulog,*) 'dwt_seedn_to_deadstem_grc =', dwt_seedn_to_deadstem_grc(g) * dt + write(iulog,*) '--- Outputs ---' + write(iulog,*) 'grc_noutputs_partial =', grc_noutputs_partial(g) * dt + write(iulog,*) 'dwt_conv_nflux_grc =', dwt_conv_nflux_grc(g) * dt + write(iulog,*) 'product_loss_grc =', product_loss_grc(g) * dt + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end associate + + end subroutine NBalanceCheck + +end module CNBalanceCheckMod diff --git a/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/biogeophys/CanopyFluxesMod.F90 b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/biogeophys/CanopyFluxesMod.F90 new file mode 100644 index 0000000000..e25518d633 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/biogeophys/CanopyFluxesMod.F90 @@ -0,0 +1,1421 @@ + +! DART note: this file started life as release-cesm2.2.01 : +! /glade/work/thoar/CESM/my_cesm_sandbox/components/clm/src/biogeophys/CanopyFluxesMod.F90 +! +! This sourcemod is required for the SIF forward operator. +! The PhotosyntesisMod.F90 also needs changes to support the SIF forward operator. + +module CanopyFluxesMod + +#include "shr_assert.h" + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Performs calculation of leaf temperature and surface fluxes. + ! SoilFluxes then determines soil/snow and ground temperatures and updates the surface + ! fluxes for the new ground temperature. + ! + ! !USES: + use shr_sys_mod , only : shr_sys_flush + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use abortutils , only : endrun + use clm_varctl , only : iulog, use_cn, use_lch4, use_c13, use_c14, use_cndv, use_fates, & + use_luna, use_hydrstress + use clm_varpar , only : nlevgrnd, nlevsno + use clm_varcon , only : namep + use pftconMod , only : pftcon + use decompMod , only : bounds_type + use ActiveLayerMod , only : active_layer_type + use PhotosynthesisMod , only : Photosynthesis, PhotoSynthesisHydraulicStress, PhotosynthesisTotal, Fractionation + use EDAccumulateFluxesMod , only : AccumulateFluxes_ED + use SoilMoistStressMod , only : calc_effective_soilporosity, calc_volumetric_h2oliq + use SoilMoistStressMod , only : calc_root_moist_stress, set_perchroot_opt + use SimpleMathMod , only : array_div_vector + use SurfaceResistanceMod , only : do_soilevap_beta,do_soil_resistance_sl14 + use atm2lndType , only : atm2lnd_type + use CanopyStateType , only : canopystate_type + use EnergyFluxType , only : energyflux_type + use FrictionvelocityMod , only : frictionvel_type + use OzoneBaseMod , only : ozone_base_type + use SoilStateType , only : soilstate_type + use SolarAbsorbedType , only : solarabs_type + use SurfaceAlbedoType , only : surfalb_type + use TemperatureType , only : temperature_type + use WaterFluxBulkType , only : waterfluxbulk_type + use WaterStateBulkType , only : waterstatebulk_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use Wateratm2lndBulkType , only : wateratm2lndbulk_type + use HumanIndexMod , only : humanindex_type + use ch4Mod , only : ch4_type + use PhotosynthesisMod , only : photosyns_type + use GridcellType , only : grc + use ColumnType , only : col + use PatchType , only : patch + use EDTypesMod , only : ed_site_type + use SoilWaterRetentionCurveMod, only : soil_water_retention_curve_type + use LunaMod , only : Update_Photosynthesis_Capacity, Acc24_Climate_LUNA,Acc240_Climate_LUNA,Clear24_Climate_LUNA + ! + ! !PUBLIC TYPES: + implicit none + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: CanopyFluxesReadNML ! Read in namelist settings + public :: CanopyFluxes ! Calculate canopy fluxes + public :: readParams + + type, private :: params_type + real(r8) :: lai_dl ! Plant litter area index (m2/m2) + real(r8) :: z_dl ! Litter layer thickness (m) + real(r8) :: a_coef ! Drag coefficient under less dense canopy (unitless) + real(r8) :: a_exp ! Drag exponent under less dense canopy (unitless) + real(r8) :: csoilc ! Soil drag coefficient under dense canopy (unitless) + real(r8) :: cv ! Turbulent transfer coeff. between canopy surface and canopy air (m/s^(1/2)) + real(r8) :: wind_min ! Minimum wind speed at the atmospheric forcing height (m/s) + end type params_type + type(params_type), private :: params_inst + ! + ! !PUBLIC DATA MEMBERS: + ! true => btran is based only on unfrozen soil levels + logical, public :: perchroot = .false. + + ! true => btran is based on active layer (defined over two years); + ! false => btran is based on currently unfrozen levels + logical, public :: perchroot_alt = .false. + ! + ! !PRIVATE DATA MEMBERS: + logical, private :: use_undercanopy_stability = .true. ! use undercanopy stability term or not + integer, private :: itmax_canopy_fluxes = -1 ! max # of iterations used in subroutine CanopyFluxes + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine CanopyFluxesReadNML(NLFilename) + ! + ! !DESCRIPTION: + ! Read the namelist for Canopy Fluxes + ! + ! !USES: + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use spmdMod , only : masterproc, mpicom + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + ! + ! !ARGUMENTS: + character(len=*), intent(IN) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + + character(len=*), parameter :: subname = 'CanopyFluxesReadNML' + character(len=*), parameter :: nmlname = 'canopyfluxes_inparm' + !----------------------------------------------------------------------- + + namelist /canopyfluxes_inparm/ use_undercanopy_stability + namelist /canopyfluxes_inparm/ itmax_canopy_fluxes + + ! Initialize options to default values, in case they are not specified in + ! the namelist + + if (masterproc) then + unitn = getavu() + write(iulog,*) 'Read in '//nmlname//' namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=canopyfluxes_inparm, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + else + call endrun(msg="ERROR could NOT find "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + + if (itmax_canopy_fluxes < 1) then + call endrun(msg=' ERROR: expecting itmax_canopy_fluxes > 0 ' // & + errMsg(sourcefile, __LINE__)) + end if + + call relavu( unitn ) + end if + + call shr_mpi_bcast (use_undercanopy_stability, mpicom) + call shr_mpi_bcast (itmax_canopy_fluxes, mpicom) + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=canopyfluxes_inparm) + write(iulog,*) ' ' + end if + + end subroutine CanopyFluxesReadNML + + !------------------------------------------------------------------------------ + subroutine readParams( ncid ) + ! + ! !USES: + use ncdio_pio, only: file_desc_t + use paramUtilMod, only: readNcdioScalar + ! + ! !ARGUMENTS: + implicit none + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=*), parameter :: subname = 'readParams_CanopyFluxes' + !-------------------------------------------------------------------- + + !added by K.Sakaguchi for litter resistance: Plant litter area index (m2/m2) + call readNcdioScalar(ncid, 'lai_dl', subname, params_inst%lai_dl) + !added by K.Sakaguchi for litter resistance: Litter layer thickness (m) + call readNcdioScalar(ncid, 'z_dl', subname, params_inst%z_dl) + ! Drag coefficient under less dense canopy (unitless) + call readNcdioScalar(ncid, 'a_coef', subname, params_inst%a_coef) + ! Drag exponent under less dense canopy (unitless) + call readNcdioScalar(ncid, 'a_exp', subname, params_inst%a_exp) + ! Drag coefficient for soil under dense canopy (unitless) + call readNcdioScalar(ncid, 'csoilc', subname, params_inst%csoilc) + ! Turbulent transfer coeff between canopy surface and canopy air (m/s^(1/2)) + call readNcdioScalar(ncid, 'cv', subname, params_inst%cv) + ! Minimum wind speed at the atmospheric forcing height (m/s) + call readNcdioScalar(ncid, 'wind_min', subname, params_inst%wind_min) + + end subroutine readParams + + !------------------------------------------------------------------------------ + subroutine CanopyFluxes(bounds, num_exposedvegp, filter_exposedvegp, & + clm_fates, nc, active_layer_inst, atm2lnd_inst, canopystate_inst, & + energyflux_inst, frictionvel_inst, soilstate_inst, solarabs_inst, surfalb_inst, & + temperature_inst, waterfluxbulk_inst, waterstatebulk_inst, & + waterdiagnosticbulk_inst, wateratm2lndbulk_inst, ch4_inst, ozone_inst, & + photosyns_inst, & + humanindex_inst, soil_water_retention_curve, & + downreg_patch, leafn_patch, froot_carbon, croot_carbon) + ! + ! !DESCRIPTION: + ! 1. Calculates the leaf temperature: + ! 2. Calculates the leaf fluxes, transpiration, photosynthesis and + ! updates the dew accumulation due to evaporation. + ! + ! Method: + ! Use the Newton-Raphson iteration to solve for the foliage + ! temperature that balances the surface energy budget: + ! + ! f(t_veg) = Net radiation - Sensible - Latent = 0 + ! f(t_veg) + d(f)/d(t_veg) * dt_veg = 0 (*) + ! + ! Note: + ! (1) In solving for t_veg, t_grnd is given from the previous timestep. + ! (2) The partial derivatives of aerodynamical resistances, which cannot + ! be determined analytically, are ignored for d(H)/dT and d(LE)/dT + ! (3) The weighted stomatal resistance of sunlit and shaded foliage is used + ! (4) Canopy air temperature and humidity are derived from => Hc + Hg = Ha + ! => Ec + Eg = Ea + ! (5) Energy loss is due to: numerical truncation of energy budget equation + ! (*); and "ecidif" (see the code) which is dropped into the sensible + ! heat + ! (6) The convergence criteria: the difference, del = t_veg(n+1)-t_veg(n) + ! and del2 = t_veg(n)-t_veg(n-1) less than 0.01 K, and the difference + ! of water flux from the leaf between the iteration step (n+1) and (n) + ! less than 0.1 W/m2; or the iterative steps over 40. + ! + ! !USES: + use shr_const_mod , only : SHR_CONST_RGAS + use clm_time_manager , only : get_step_size_real, get_prev_date,is_end_curr_day + use clm_varcon , only : sb, cpair, hvap, vkc, grav, denice + use clm_varcon , only : denh2o, tfrz, tlsai_crit, alpha_aero + use clm_varcon , only : c14ratio + use perf_mod , only : t_startf, t_stopf + use QSatMod , only : QSat + use CLMFatesInterfaceMod, only : hlm_fates_interface_type + use HumanIndexMod , only : all_human_stress_indices, fast_human_stress_indices, & + Wet_Bulb, Wet_BulbS, HeatIndex, AppTemp, & + swbgt, hmdex, dis_coi, dis_coiS, THIndex, & + SwampCoolEff, KtoC, VaporPres + use SoilWaterRetentionCurveMod, only : soil_water_retention_curve_type + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_exposedvegp ! number of points in filter_exposedvegp + integer , intent(in) :: filter_exposedvegp(:) ! patch filter for non-snow-covered veg + type(hlm_fates_interface_type) , intent(inout) :: clm_fates + integer , intent(in) :: nc ! clump index + type(active_layer_type) , intent(in) :: active_layer_inst + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(energyflux_type) , intent(inout) :: energyflux_inst + type(frictionvel_type) , intent(inout) :: frictionvel_inst + type(solarabs_type) , intent(inout) :: solarabs_inst + type(surfalb_type) , intent(in) :: surfalb_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + type(temperature_type) , intent(inout) :: temperature_inst + type(waterstatebulk_type) , intent(inout) :: waterstatebulk_inst + type(waterdiagnosticbulk_type) , intent(inout) :: waterdiagnosticbulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(wateratm2lndbulk_type) , intent(inout) :: wateratm2lndbulk_inst + type(ch4_type) , intent(inout) :: ch4_inst + class(ozone_base_type) , intent(inout) :: ozone_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + type(humanindex_type) , intent(inout) :: humanindex_inst + class(soil_water_retention_curve_type) , intent(in) :: soil_water_retention_curve + real(r8), intent(in) :: downreg_patch(bounds%begp:) ! fractional reduction in GPP due to N limitation (dimensionless) + real(r8), intent(in) :: leafn_patch(bounds%begp:) ! leaf N (gN/m2) + real(r8), intent(inout) :: froot_carbon(bounds%begp:) ! fine root biomass (gC/m2) + real(r8), intent(inout) :: croot_carbon(bounds%begp:) ! live coarse root biomass (gC/m2) + ! + ! !LOCAL VARIABLES: + real(r8), pointer :: bsun(:) ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8), pointer :: bsha(:) ! shaded canopy transpiration wetness factor (0 to 1) + real(r8), parameter :: btran0 = 0.0_r8 ! initial value + real(r8), parameter :: zii = 1000.0_r8 ! convective boundary layer height [m] + real(r8), parameter :: beta = 1.0_r8 ! coefficient of conective velocity [-] + real(r8), parameter :: delmax = 1.0_r8 ! maxchange in leaf temperature [K] + real(r8), parameter :: dlemin = 0.1_r8 ! max limit for energy flux convergence [w/m2] + real(r8), parameter :: dtmin = 0.01_r8 ! max limit for temperature convergence [K] + integer , parameter :: itmin = 2 ! minimum number of iteration [-] + + !added by K.Sakaguchi for stability formulation + real(r8), parameter :: ria = 0.5_r8 ! free parameter for stable formulation (currently = 0.5, "gamma" in Sakaguchi&Zeng,2008) + + real(r8) :: dtime ! land model time step (sec) + real(r8) :: zldis(bounds%begp:bounds%endp) ! reference height "minus" zero displacement height [m] + real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) :: wc ! convective velocity [m/s] + real(r8) :: dth(bounds%begp:bounds%endp) ! diff of virtual temp. between ref. height and surface + real(r8) :: dthv(bounds%begp:bounds%endp) ! diff of vir. poten. temp. between ref. height and surface + real(r8) :: dqh(bounds%begp:bounds%endp) ! diff of humidity between ref. height and surface + real(r8) :: obu(bounds%begp:bounds%endp) ! Monin-Obukhov length (m) + real(r8) :: um(bounds%begp:bounds%endp) ! wind speed including the stablity effect [m/s] + real(r8) :: ur(bounds%begp:bounds%endp) ! wind speed at reference height [m/s] + real(r8) :: uaf(bounds%begp:bounds%endp) ! velocity of air within foliage [m/s] + real(r8) :: temp1(bounds%begp:bounds%endp) ! relation for potential temperature profile + real(r8) :: temp12m(bounds%begp:bounds%endp) ! relation for potential temperature profile applied at 2-m + real(r8) :: temp2(bounds%begp:bounds%endp) ! relation for specific humidity profile + real(r8) :: temp22m(bounds%begp:bounds%endp) ! relation for specific humidity profile applied at 2-m + real(r8) :: ustar(bounds%begp:bounds%endp) ! friction velocity [m/s] + real(r8) :: tstar ! temperature scaling parameter + real(r8) :: qstar ! moisture scaling parameter + real(r8) :: thvstar ! virtual potential temperature scaling parameter + real(r8) :: taf(bounds%begp:bounds%endp) ! air temperature within canopy space [K] + real(r8) :: qaf(bounds%begp:bounds%endp) ! humidity of canopy air [kg/kg] + real(r8) :: rpp ! fraction of potential evaporation from leaf [-] + real(r8) :: rppdry ! fraction of potential evaporation through transp [-] + real(r8) :: cf ! heat transfer coefficient from leaves [-] + real(r8) :: rb(bounds%begp:bounds%endp) ! leaf boundary layer resistance [s/m] + real(r8) :: rah(bounds%begp:bounds%endp,2) ! thermal resistance [s/m] + real(r8) :: raw(bounds%begp:bounds%endp,2) ! moisture resistance [s/m] + real(r8) :: wta ! heat conductance for air [m/s] + real(r8) :: wtg(bounds%begp:bounds%endp) ! heat conductance for ground [m/s] + real(r8) :: wtl ! heat conductance for leaf [m/s] + real(r8) :: wta0(bounds%begp:bounds%endp) ! normalized heat conductance for air [-] + real(r8) :: wtl0(bounds%begp:bounds%endp) ! normalized heat conductance for leaf [-] + real(r8) :: wtg0 ! normalized heat conductance for ground [-] + real(r8) :: wtal(bounds%begp:bounds%endp) ! normalized heat conductance for air and leaf [-] + real(r8) :: wtga ! normalized heat cond. for air and ground [-] + real(r8) :: wtaq ! latent heat conductance for air [m/s] + real(r8) :: wtlq ! latent heat conductance for leaf [m/s] + real(r8) :: wtgq(bounds%begp:bounds%endp) ! latent heat conductance for ground [m/s] + real(r8) :: wtaq0(bounds%begp:bounds%endp) ! normalized latent heat conductance for air [-] + real(r8) :: wtlq0(bounds%begp:bounds%endp) ! normalized latent heat conductance for leaf [-] + real(r8) :: wtgq0 ! normalized heat conductance for ground [-] + real(r8) :: wtalq(bounds%begp:bounds%endp) ! normalized latent heat cond. for air and leaf [-] + real(r8) :: wtgaq ! normalized latent heat cond. for air and ground [-] + real(r8) :: el(bounds%begp:bounds%endp) ! vapor pressure on leaf surface [pa] + real(r8) :: deldT ! derivative of "el" on "t_veg" [pa/K] + real(r8) :: qsatl(bounds%begp:bounds%endp) ! leaf specific humidity [kg/kg] + real(r8) :: qsatldT(bounds%begp:bounds%endp) ! derivative of "qsatl" on "t_veg" + real(r8) :: e_ref2m ! 2 m height surface saturated vapor pressure [Pa] + real(r8) :: de2mdT ! derivative of 2 m height surface saturated vapor pressure on t_ref2m + real(r8) :: qsat_ref2m ! 2 m height surface saturated specific humidity [kg/kg] + real(r8) :: dqsat2mdT ! derivative of 2 m height surface saturated specific humidity on t_ref2m + real(r8) :: air(bounds%begp:bounds%endp) ! atmos. radiation temporay set + real(r8) :: bir(bounds%begp:bounds%endp) ! atmos. radiation temporay set + real(r8) :: cir(bounds%begp:bounds%endp) ! atmos. radiation temporay set + real(r8) :: dc1,dc2 ! derivative of energy flux [W/m2/K] + real(r8) :: delt ! temporary + real(r8) :: delq(bounds%begp:bounds%endp) ! temporary + real(r8) :: del(bounds%begp:bounds%endp) ! absolute change in leaf temp in current iteration [K] + real(r8) :: del2(bounds%begp:bounds%endp) ! change in leaf temperature in previous iteration [K] + real(r8) :: dele(bounds%begp:bounds%endp) ! change in latent heat flux from leaf [K] + real(r8) :: dels ! change in leaf temperature in current iteration [K] + real(r8) :: det(bounds%begp:bounds%endp) ! maximum leaf temp. change in two consecutive iter [K] + real(r8) :: efeb(bounds%begp:bounds%endp) ! latent heat flux from leaf (previous iter) [mm/s] + real(r8) :: efeold ! latent heat flux from leaf (previous iter) [mm/s] + real(r8) :: efpot ! potential latent energy flux [kg/m2/s] + real(r8) :: efe(bounds%begp:bounds%endp) ! water flux from leaf [mm/s] + real(r8) :: efsh ! sensible heat from leaf [mm/s] + real(r8) :: obuold(bounds%begp:bounds%endp) ! monin-obukhov length from previous iteration + real(r8) :: tlbef(bounds%begp:bounds%endp) ! leaf temperature from previous iteration [K] + real(r8) :: ecidif ! excess energies [W/m2] + real(r8) :: err(bounds%begp:bounds%endp) ! balance error + real(r8) :: erre ! balance error + real(r8) :: co2(bounds%begp:bounds%endp) ! atmospheric co2 partial pressure (pa) + real(r8) :: c13o2(bounds%begp:bounds%endp) ! atmospheric c13o2 partial pressure (pa) + real(r8) :: o2(bounds%begp:bounds%endp) ! atmospheric o2 partial pressure (pa) + real(r8) :: svpts(bounds%begp:bounds%endp) ! saturation vapor pressure at t_veg (pa) + real(r8) :: eah(bounds%begp:bounds%endp) ! canopy air vapor pressure (pa) + real(r8) :: s_node ! vol_liq/eff_porosity + real(r8) :: smp_node ! matrix potential + real(r8) :: smp_node_lf ! F. Li and S. Levis + real(r8) :: vol_liq ! partial volume of liquid water in layer + integer :: itlef ! counter for leaf temperature iteration [-] + integer :: nmozsgn(bounds%begp:bounds%endp) ! number of times stability changes sign + real(r8) :: w ! exp(-LSAI) + real(r8) :: csoilcn ! interpolated csoilc for less than dense canopies + real(r8) :: fm(bounds%begp:bounds%endp) ! needed for BGC only to diagnose 10m wind speed + real(r8) :: wtshi ! sensible heat resistance for air, grnd and leaf [-] + real(r8) :: wtsqi ! latent heat resistance for air, grnd and leaf [-] + integer :: j ! soil/snow level index + integer :: p ! patch index + integer :: c ! column index + integer :: l ! landunit index + integer :: g ! gridcell index + integer :: fn ! number of values in vegetated patch filter + integer :: filterp(bounds%endp-bounds%begp+1) ! vegetated patch filter + integer :: fnorig ! number of values in patch filter copy + integer :: fporig(bounds%endp-bounds%begp+1) ! temporary filter + integer :: fnold ! temporary copy of patch count + integer :: f ! filter index + logical :: found ! error flag for canopy above forcing hgt + integer :: index ! patch index for error + real(r8) :: egvf ! effective green vegetation fraction + real(r8) :: lt ! elai+esai + real(r8) :: ri ! stability parameter for under canopy air (unitless) + real(r8) :: csoilb ! turbulent transfer coefficient over bare soil (unitless) + real(r8) :: ricsoilc ! modified transfer coefficient under dense canopy (unitless) + real(r8) :: snow_depth_c ! critical snow depth to cover plant litter (m) + real(r8) :: rdl ! dry litter layer resistance for water vapor (s/m) + real(r8) :: elai_dl ! exposed (dry) plant litter area index + real(r8) :: fsno_dl ! effective snow cover over plant litter + real(r8) :: dayl_factor(bounds%begp:bounds%endp) ! scalar (0-1) for daylength effect on Vcmax + ! If no unfrozen layers, put all in the top layer. + real(r8) :: rootsum(bounds%begp:bounds%endp) + real(r8) :: delt_snow + real(r8) :: delt_soil + real(r8) :: delt_h2osfc + real(r8) :: lw_grnd + real(r8) :: delq_snow + real(r8) :: delq_soil + real(r8) :: delq_h2osfc + real(r8) :: dt_veg(bounds%begp:bounds%endp) ! change in t_veg, last iteration (Kelvin) + integer :: jtop(bounds%begc:bounds%endc) ! lbning + integer :: filterc_tmp(bounds%endp-bounds%begp+1) ! temporary variable + integer :: ft ! plant functional type index + real(r8) :: h2ocan ! total canopy water (mm H2O) + real(r8) :: dt_veg_temp(bounds%begp:bounds%endp) + integer :: iv + logical :: is_end_day ! is end of current day + + integer :: dummy_to_make_pgi_happy + !------------------------------------------------------------------------------ + + SHR_ASSERT_ALL_FL((ubound(downreg_patch) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(leafn_patch) == (/bounds%endp/)), sourcefile, __LINE__) + + associate( & + soilresis => soilstate_inst%soilresis_col , & ! Input: [real(r8) (:) ] soil evaporative resistance + snl => col%snl , & ! Input: [integer (:) ] number of snow layers + dayl => grc%dayl , & ! Input: [real(r8) (:) ] daylength (s) + max_dayl => grc%max_dayl , & ! Input: [real(r8) (:) ] maximum daylength for this grid cell (s) + + dleaf => pftcon%dleaf , & ! Input: characteristic leaf dimension (m) + + forc_lwrad => atm2lnd_inst%forc_lwrad_downscaled_col , & ! Input: [real(r8) (:) ] downward infrared (longwave) radiation (W/m**2) + forc_q => wateratm2lndbulk_inst%forc_q_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric specific humidity (kg/kg) + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + forc_th => atm2lnd_inst%forc_th_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric potential temperature (Kelvin) + forc_rho => atm2lnd_inst%forc_rho_downscaled_col , & ! Input: [real(r8) (:) ] density (kg/m**3) + forc_t => atm2lnd_inst%forc_t_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric temperature (Kelvin) + forc_u => atm2lnd_inst%forc_u_grc , & ! Input: [real(r8) (:) ] atmospheric wind speed in east direction (m/s) + forc_v => atm2lnd_inst%forc_v_grc , & ! Input: [real(r8) (:) ] atmospheric wind speed in north direction (m/s) + forc_pco2 => atm2lnd_inst%forc_pco2_grc , & ! Input: [real(r8) (:) ] partial pressure co2 (Pa) + forc_pc13o2 => atm2lnd_inst%forc_pc13o2_grc , & ! Input: [real(r8) (:) ] partial pressure c13o2 (Pa) + forc_po2 => atm2lnd_inst%forc_po2_grc , & ! Input: [real(r8) (:) ] partial pressure o2 (Pa) + + tc_ref2m => humanindex_inst%tc_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m height surface air temperature (C) + vap_ref2m => humanindex_inst%vap_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m height vapor pressure (Pa) + appar_temp_ref2m => humanindex_inst%appar_temp_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m apparent temperature (C) + appar_temp_ref2m_r => humanindex_inst%appar_temp_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m apparent temperature (C) + swbgt_ref2m => humanindex_inst%swbgt_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m Simplified Wetbulb Globe temperature (C) + swbgt_ref2m_r => humanindex_inst%swbgt_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m Simplified Wetbulb Globe temperature (C) + humidex_ref2m => humanindex_inst%humidex_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m Humidex (C) + humidex_ref2m_r => humanindex_inst%humidex_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m Humidex (C) + wbt_ref2m => humanindex_inst%wbt_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m Stull Wet Bulb temperature (C) + wbt_ref2m_r => humanindex_inst%wbt_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m Stull Wet Bulb temperature (C) + wb_ref2m => humanindex_inst%wb_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m Wet Bulb temperature (C) + wb_ref2m_r => humanindex_inst%wb_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m Wet Bulb temperature (C) + teq_ref2m => humanindex_inst%teq_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m height Equivalent temperature (K) + teq_ref2m_r => humanindex_inst%teq_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m Equivalent temperature (K) + ept_ref2m => humanindex_inst%ept_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m height Equivalent Potential temperature (K) + ept_ref2m_r => humanindex_inst%ept_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m height Equivalent Potential temperature (K) + discomf_index_ref2m => humanindex_inst%discomf_index_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m Discomfort Index temperature (C) + discomf_index_ref2m_r => humanindex_inst%discomf_index_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m Discomfort Index temperature (C) + discomf_index_ref2mS => humanindex_inst%discomf_index_ref2mS_patch , & ! Output: [real(r8) (:) ] 2 m height Discomfort Index Stull temperature (C) + discomf_index_ref2mS_r => humanindex_inst%discomf_index_ref2mS_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m Discomfort Index Stull temperature (K) + nws_hi_ref2m => humanindex_inst%nws_hi_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m NWS Heat Index (C) + nws_hi_ref2m_r => humanindex_inst%nws_hi_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m NWS Heat Index (C) + thip_ref2m => humanindex_inst%thip_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m Temperature Humidity Index Physiology (C) + thip_ref2m_r => humanindex_inst%thip_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m Temperature Humidity Index Physiology (C) + thic_ref2m => humanindex_inst%thic_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m Temperature Humidity Index Comfort (C) + thic_ref2m_r => humanindex_inst%thic_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m Temperature Humidity Index Comfort (C) + swmp65_ref2m => humanindex_inst%swmp65_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m Swamp Cooler temperature 65% effi (C) + swmp65_ref2m_r => humanindex_inst%swmp65_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m Swamp Cooler temperature 65% effi (C) + swmp80_ref2m => humanindex_inst%swmp80_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m Swamp Cooler temperature 80% effi (C) + swmp80_ref2m_r => humanindex_inst%swmp80_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m Swamp Cooler temperature 80% effi (C) + + sabv => solarabs_inst%sabv_patch , & ! Input: [real(r8) (:) ] solar radiation absorbed by vegetation (W/m**2) + + frac_veg_nosno => canopystate_inst%frac_veg_nosno_patch , & ! Input: [integer (:) ] fraction of vegetation not covered by snow (0 OR 1) [-] + elai => canopystate_inst%elai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index with burying by snow + esai => canopystate_inst%esai_patch , & ! Input: [real(r8) (:) ] one-sided stem area index with burying by snow + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit leaf area + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded leaf area + displa => canopystate_inst%displa_patch , & ! Input: [real(r8) (:) ] displacement height (m) + htop => canopystate_inst%htop_patch , & ! Input: [real(r8) (:) ] canopy top(m) + dleaf_patch => canopystate_inst%dleaf_patch , & ! Output: [real(r8) (:) ] mean leaf diameter for this patch/pft + + watsat => soilstate_inst%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) (constant) + watdry => soilstate_inst%watdry_col , & ! Input: [real(r8) (:,:) ] btran parameter for btran=0 (constant) + watopt => soilstate_inst%watopt_col , & ! Input: [real(r8) (:,:) ] btran parameter for btran=1 (constant) + eff_porosity => soilstate_inst%eff_porosity_col , & ! Output: [real(r8) (:,:) ] effective soil porosity + soilbeta => soilstate_inst%soilbeta_col , & ! Input: [real(r8) (:) ] soil wetness relative to field capacity + + u10_clm => frictionvel_inst%u10_clm_patch , & ! Input: [real(r8) (:) ] 10 m height winds (m/s) + forc_hgt_u_patch => frictionvel_inst%forc_hgt_u_patch , & ! Input: [real(r8) (:) ] observational height of wind at patch level [m] + z0mg => frictionvel_inst%z0mg_col , & ! Input: [real(r8) (:) ] roughness length of ground, momentum [m] + zetamax => frictionvel_inst%zetamaxstable , & ! Input: [real(r8) ] max zeta value under stable conditions + ram1 => frictionvel_inst%ram1_patch , & ! Output: [real(r8) (:) ] aerodynamical resistance (s/m) + z0mv => frictionvel_inst%z0mv_patch , & ! Output: [real(r8) (:) ] roughness length over vegetation, momentum [m] + z0hv => frictionvel_inst%z0hv_patch , & ! Output: [real(r8) (:) ] roughness length over vegetation, sensible heat [m] + z0qv => frictionvel_inst%z0qv_patch , & ! Output: [real(r8) (:) ] roughness length over vegetation, latent heat [m] + rb1 => frictionvel_inst%rb1_patch , & ! Output: [real(r8) (:) ] boundary layer resistance (s/m) + + t_h2osfc => temperature_inst%t_h2osfc_col , & ! Input: [real(r8) (:) ] surface water temperature + t_soisno => temperature_inst%t_soisno_col , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) + t_grnd => temperature_inst%t_grnd_col , & ! Input: [real(r8) (:) ] ground surface temperature [K] + thv => temperature_inst%thv_col , & ! Input: [real(r8) (:) ] virtual potential temperature (kelvin) + thm => temperature_inst%thm_patch , & ! Input: [real(r8) (:) ] intermediate variable (forc_t+0.0098*forc_hgt_t_patch) + emv => temperature_inst%emv_patch , & ! Input: [real(r8) (:) ] vegetation emissivity + emg => temperature_inst%emg_col , & ! Input: [real(r8) (:) ] vegetation emissivity + t_veg => temperature_inst%t_veg_patch , & ! Output: [real(r8) (:) ] vegetation temperature (Kelvin) + t_ref2m => temperature_inst%t_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m height surface air temperature (Kelvin) + t_ref2m_r => temperature_inst%t_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m height surface air temperature (Kelvin) + t_skin_patch => temperature_inst%t_skin_patch , & ! Output: [real(r8) (:) ] patch skin temperature (K) + + frac_h2osfc => waterdiagnosticbulk_inst%frac_h2osfc_col , & ! Input: [real(r8) (:) ] fraction of surface water + fwet => waterdiagnosticbulk_inst%fwet_patch , & ! Input: [real(r8) (:) ] fraction of canopy that is wet (0 to 1) + fdry => waterdiagnosticbulk_inst%fdry_patch , & ! Input: [real(r8) (:) ] fraction of foliage that is green and dry [-] + frac_sno => waterdiagnosticbulk_inst%frac_sno_eff_col , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) + snow_depth => waterdiagnosticbulk_inst%snow_depth_col , & ! Input: [real(r8) (:) ] snow height (m) + qg_snow => waterdiagnosticbulk_inst%qg_snow_col , & ! Input: [real(r8) (:) ] specific humidity at snow surface [kg/kg] + qg_soil => waterdiagnosticbulk_inst%qg_soil_col , & ! Input: [real(r8) (:) ] specific humidity at soil surface [kg/kg] + qg_h2osfc => waterdiagnosticbulk_inst%qg_h2osfc_col , & ! Input: [real(r8) (:) ] specific humidity at h2osfc surface [kg/kg] + qg => waterdiagnosticbulk_inst%qg_col , & ! Input: [real(r8) (:) ] specific humidity at ground surface [kg/kg] + dqgdT => waterdiagnosticbulk_inst%dqgdT_col , & ! Input: [real(r8) (:) ] temperature derivative of "qg" + h2osoi_ice => waterstatebulk_inst%h2osoi_ice_col , & ! Input: [real(r8) (:,:) ] ice lens (kg/m2) + h2osoi_vol => waterstatebulk_inst%h2osoi_vol_col , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] by F. Li and S. Levis + h2osoi_liq => waterstatebulk_inst%h2osoi_liq_col , & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) + h2osoi_liqvol => waterdiagnosticbulk_inst%h2osoi_liqvol_col , & ! Output: [real(r8) (:,:) ] volumetric liquid water (v/v) + snocan => waterstatebulk_inst%snocan_patch , & ! Output: [real(r8) (:) ] canopy snow (mm H2O) + liqcan => waterstatebulk_inst%liqcan_patch , & ! Output: [real(r8) (:) ] canopy liquid (mm H2O) + + q_ref2m => waterdiagnosticbulk_inst%q_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m height surface specific humidity (kg/kg) + rh_ref2m_r => waterdiagnosticbulk_inst%rh_ref2m_r_patch , & ! Output: [real(r8) (:) ] Rural 2 m height surface relative humidity (%) + rh_ref2m => waterdiagnosticbulk_inst%rh_ref2m_patch , & ! Output: [real(r8) (:) ] 2 m height surface relative humidity (%) + rhaf => waterdiagnosticbulk_inst%rh_af_patch , & ! Output: [real(r8) (:) ] fractional humidity of canopy air [dimensionless] + + qflx_tran_veg => waterfluxbulk_inst%qflx_tran_veg_patch , & ! Output: [real(r8) (:) ] vegetation transpiration (mm H2O/s) (+ = to atm) + qflx_evap_veg => waterfluxbulk_inst%qflx_evap_veg_patch , & ! Output: [real(r8) (:) ] vegetation evaporation (mm H2O/s) (+ = to atm) + qflx_evap_soi => waterfluxbulk_inst%qflx_evap_soi_patch , & ! Output: [real(r8) (:) ] soil evaporation (mm H2O/s) (+ = to atm) + qflx_ev_snow => waterfluxbulk_inst%qflx_ev_snow_patch , & ! Output: [real(r8) (:) ] evaporation flux from snow (mm H2O/s) [+ to atm] + qflx_ev_soil => waterfluxbulk_inst%qflx_ev_soil_patch , & ! Output: [real(r8) (:) ] evaporation flux from soil (mm H2O/s) [+ to atm] + qflx_ev_h2osfc => waterfluxbulk_inst%qflx_ev_h2osfc_patch , & ! Output: [real(r8) (:) ] evaporation flux from h2osfc (mm H2O/s) [+ to atm] + + rssun => photosyns_inst%rssun_patch , & ! Output: [real(r8) (:) ] leaf sunlit stomatal resistance (s/m) (output from Photosynthesis) + rssha => photosyns_inst%rssha_patch , & ! Output: [real(r8) (:) ] leaf shaded stomatal resistance (s/m) (output from Photosynthesis) + + grnd_ch4_cond => ch4_inst%grnd_ch4_cond_patch , & ! Output: [real(r8) (:) ] tracer conductance for boundary layer [m/s] + + htvp => energyflux_inst%htvp_col , & ! Input: [real(r8) (:) ] latent heat of evaporation (/sublimation) [J/kg] (constant) + btran2 => energyflux_inst%btran2_patch , & ! Output: [real(r8) (:) ] F. Li and S. Levis + btran => energyflux_inst%btran_patch , & ! Output: [real(r8) (:) ] transpiration wetness factor (0 to 1) + rresis => energyflux_inst%rresis_patch , & ! Output: [real(r8) (:,:) ] root resistance by layer (0-1) (nlevgrnd) + taux => energyflux_inst%taux_patch , & ! Output: [real(r8) (:) ] wind (shear) stress: e-w (kg/m/s**2) + tauy => energyflux_inst%tauy_patch , & ! Output: [real(r8) (:) ] wind (shear) stress: n-s (kg/m/s**2) + canopy_cond => energyflux_inst%canopy_cond_patch , & ! Output: [real(r8) (:) ] tracer conductance for canopy [m/s] + cgrnds => energyflux_inst%cgrnds_patch , & ! Output: [real(r8) (:) ] deriv. of soil sensible heat flux wrt soil temp [w/m2/k] + cgrndl => energyflux_inst%cgrndl_patch , & ! Output: [real(r8) (:) ] deriv. of soil latent heat flux wrt soil temp [w/m**2/k] + dlrad => energyflux_inst%dlrad_patch , & ! Output: [real(r8) (:) ] downward longwave radiation below the canopy [W/m2] + ulrad => energyflux_inst%ulrad_patch , & ! Output: [real(r8) (:) ] upward longwave radiation above the canopy [W/m2] + cgrnd => energyflux_inst%cgrnd_patch , & ! Output: [real(r8) (:) ] deriv. of soil energy flux wrt to soil temp [w/m2/k] + eflx_sh_snow => energyflux_inst%eflx_sh_snow_patch , & ! Output: [real(r8) (:) ] sensible heat flux from snow (W/m**2) [+ to atm] + eflx_sh_h2osfc => energyflux_inst%eflx_sh_h2osfc_patch , & ! Output: [real(r8) (:) ] sensible heat flux from soil (W/m**2) [+ to atm] + eflx_sh_soil => energyflux_inst%eflx_sh_soil_patch , & ! Output: [real(r8) (:) ] sensible heat flux from soil (W/m**2) [+ to atm] + eflx_sh_veg => energyflux_inst%eflx_sh_veg_patch , & ! Output: [real(r8) (:) ] sensible heat flux from leaves (W/m**2) [+ to atm] + eflx_sh_grnd => energyflux_inst%eflx_sh_grnd_patch , & ! Output: [real(r8) (:) ] sensible heat flux from ground (W/m**2) [+ to atm] + begp => bounds%begp , & + endp => bounds%endp , & + begg => bounds%begg , & + endg => bounds%endg & + ) + if (use_hydrstress) then + bsun => energyflux_inst%bsun_patch ! Output: [real(r8) (:) ] sunlit canopy transpiration wetness factor (0 to 1) + bsha => energyflux_inst%bsha_patch ! Output: [real(r8) (:) ] sunlit canopy transpiration wetness factor (0 to 1) + end if + + ! Determine step size + + dtime = get_step_size_real() + is_end_day = is_end_curr_day() + + ! Make a local copy of the exposedvegp filter. With the current implementation, + ! this is needed because the filter is modified in the iteration loop. + ! + ! TODO(wjs, 2014-09-24) Determine if this is really needed. I suspect that we could + ! do away with either this temporary fn/filterp, or the temporary fnorig/fporig, + ! with one of these simply using the passed-in filter (num_exposedvegp / + ! filter_exposedvegp) + + fn = num_exposedvegp + filterp(1:fn) = filter_exposedvegp(1:fn) + + ! ----------------------------------------------------------------- + ! Time step initialization of photosynthesis variables + ! ----------------------------------------------------------------- + + call photosyns_inst%TimeStepInit(bounds) + + + ! ----------------------------------------------------------------- + ! Prep some IO variables and some checks on patch pointers if FATES + ! is running. + ! Filter explanation: The patch filter in this routine identifies all + ! non-lake, non-urban patches that are not covered by ice. The + ! filter is set over a few steps: + ! + ! 1a) for CN: + ! clm_drv() -> + ! bgc_vegetation_inst%EcosystemDynamicsPostDrainage() -> + ! CNVegStructUpdate() + ! if(elai(p)+esai(p)>0) frac_veg_nosno_alb(p) = 1 + ! + ! 1b) for FATES: + ! clm_drv() -> + ! clm_fates%dynamics_driv() -> + ! ed_clm_link() -> + ! ed_clm_leaf_area_profile(): + ! if(elai(p)+esai(p)>0) frac_veg_nosno_alb(p) = 1 + ! + ! 2) during clm_drv()->clm_drv_init(): + ! frac_veg_nosno_alb(p) is then combined with the active(p) + ! flag via union to create frac_veg_nosno_patch(p) + ! 3) immediately after, during clm_drv()->setExposedvegpFilter() + ! the list used here "exposedvegp(fe)" is incremented if + ! frac_veg_nosno_patch > 0 + ! ----------------------------------------------------------------- + + if (use_fates) then + call clm_fates%prep_canopyfluxes(nc, fn, filterp, photosyns_inst) + end if + + ! Initialize + + do f = 1, fn + p = filterp(f) + del(p) = 0._r8 ! change in leaf temperature from previous iteration + efeb(p) = 0._r8 ! latent head flux from leaf for previous iteration + wtlq0(p) = 0._r8 + wtalq(p) = 0._r8 + wtgq(p) = 0._r8 + wtaq0(p) = 0._r8 + obuold(p) = 0._r8 + btran(p) = btran0 + btran2(p) = btran0 + end do + + ! calculate daylength control for Vcmax + do f = 1, fn + p=filterp(f) + g=patch%gridcell(p) + ! calculate dayl_factor as the ratio of (current:max dayl)^2 + ! set a minimum of 0.01 (1%) for the dayl_factor + dayl_factor(p)=min(1._r8,max(0.01_r8,(dayl(g)*dayl(g))/(max_dayl(g)*max_dayl(g)))) + end do + + rb1(begp:endp) = 0._r8 + + !assign the temporary filter + do f = 1, fn + p = filterp(f) + filterc_tmp(f)=patch%column(p) + enddo + + !compute effective soil porosity + call calc_effective_soilporosity(bounds, & + ubj = nlevgrnd, & + numf = fn, & + filter = filterc_tmp(1:fn), & + watsat = watsat(bounds%begc:bounds%endc, 1:nlevgrnd), & + h2osoi_ice = h2osoi_ice(bounds%begc:bounds%endc,1:nlevgrnd), & + denice = denice, & + eff_por=eff_porosity(bounds%begc:bounds%endc, 1:nlevgrnd) ) + + !compute volumetric liquid water content + jtop(bounds%begc:bounds%endc) = 1 + + call calc_volumetric_h2oliq(bounds, & + jtop = jtop(bounds%begc:bounds%endc), & + lbj = 1, & + ubj = nlevgrnd, & + numf = fn, & + filter = filterc_tmp(1:fn), & + eff_porosity = eff_porosity(bounds%begc:bounds%endc, 1:nlevgrnd), & + h2osoi_liq = h2osoi_liq(bounds%begc:bounds%endc, 1:nlevgrnd), & + denh2o = denh2o, & + vol_liq = h2osoi_liqvol(bounds%begc:bounds%endc, 1:nlevgrnd) ) + + !set up perchroot options + call set_perchroot_opt(perchroot, perchroot_alt) + + ! -------------------------------------------------------------------------- + ! if this is a FATES simulation + ! ask fates to calculate btran functions and distribution of uptake + ! this will require boundary conditions from CLM, boundary conditions which + ! may only be available from a smaller subset of patches that meet the + ! exposed veg. + ! calc_root_moist_stress already calculated root soil water stress 'rresis' + ! this is the input boundary condition to calculate the transpiration + ! wetness factor btran and the root weighting factors for FATES. These + ! values require knowledge of the belowground root structure. + ! -------------------------------------------------------------------------- + + if(use_fates)then + call clm_fates%wrap_btran(nc, fn, filterc_tmp(1:fn), soilstate_inst, & + waterdiagnosticbulk_inst, temperature_inst, energyflux_inst, soil_water_retention_curve) + + else + + !calculate root moisture stress + call calc_root_moist_stress(bounds, & + nlevgrnd = nlevgrnd, & + fn = fn, & + filterp = filterp, & + active_layer_inst=active_layer_inst, & + energyflux_inst=energyflux_inst, & + soilstate_inst=soilstate_inst, & + temperature_inst=temperature_inst, & + waterstatebulk_inst=waterstatebulk_inst, & + waterdiagnosticbulk_inst=waterdiagnosticbulk_inst, & + soil_water_retention_curve=soil_water_retention_curve) + + + end if + + ! Modify aerodynamic parameters for sparse/dense canopy (X. Zeng) + do f = 1, fn + p = filterp(f) + c = patch%column(p) + + lt = min(elai(p)+esai(p), tlsai_crit) + egvf =(1._r8 - alpha_aero * exp(-lt)) / (1._r8 - alpha_aero * exp(-tlsai_crit)) + displa(p) = egvf * displa(p) + z0mv(p) = exp(egvf * log(z0mv(p)) + (1._r8 - egvf) * log(z0mg(c))) + z0hv(p) = z0mv(p) + z0qv(p) = z0mv(p) + end do + + found = .false. + do f = 1, fn + p = filterp(f) + c = patch%column(p) + g = patch%gridcell(p) + + ! Net absorbed longwave radiation by canopy and ground + ! =air+bir*t_veg**4+cir*t_grnd(c)**4 + + air(p) = emv(p) * (1._r8+(1._r8-emv(p))*(1._r8-emg(c))) * forc_lwrad(c) + bir(p) = - (2._r8-emv(p)*(1._r8-emg(c))) * emv(p) * sb + cir(p) = emv(p)*emg(c)*sb + + ! Saturated vapor pressure, specific humidity, and their derivatives + ! at the leaf surface + + call QSat (t_veg(p), forc_pbot(c), el(p), deldT, qsatl(p), qsatldT(p)) + + ! Determine atmospheric co2 and o2 + + co2(p) = forc_pco2(g) + o2(p) = forc_po2(g) + + if ( use_c13 ) then + c13o2(p) = forc_pc13o2(g) + end if + + ! Initialize flux profile + + nmozsgn(p) = 0 + + taf(p) = (t_grnd(c) + thm(p))/2._r8 + qaf(p) = (forc_q(c)+qg(c))/2._r8 + + ur(p) = max(params_inst%wind_min,sqrt(forc_u(g)*forc_u(g)+forc_v(g)*forc_v(g))) + dth(p) = thm(p)-taf(p) + dqh(p) = forc_q(c)-qaf(p) + delq(p) = qg(c) - qaf(p) + dthv(p) = dth(p)*(1._r8+0.61_r8*forc_q(c))+0.61_r8*forc_th(c)*dqh(p) + zldis(p) = forc_hgt_u_patch(p) - displa(p) + + ! Check to see if the forcing height is below the canopy height + if (zldis(p) < 0._r8) then + found = .true. + index = p + end if + + end do + + if (found) then + if ( .not. use_fates ) then + write(iulog,*)'Error: Forcing height is below canopy height for patch index ' + call endrun(decomp_index=index, clmlevel=namep, msg=errmsg(sourcefile, __LINE__)) + end if + end if + + do f = 1, fn + p = filterp(f) + c = patch%column(p) + + ! Initialize Monin-Obukhov length and wind speed + + call frictionvel_inst%MoninObukIni(ur(p), thv(c), dthv(p), zldis(p), z0mv(p), um(p), obu(p)) + + end do + + ! Set counter for leaf temperature iteration (itlef) + + itlef = 0 + fnorig = fn + fporig(1:fn) = filterp(1:fn) + + ! Begin stability iteration + + call t_startf('can_iter') + ITERATION : do while (itlef <= itmax_canopy_fluxes .and. fn > 0) + + ! Determine friction velocity, and potential temperature and humidity + ! profiles of the surface boundary layer + + call frictionvel_inst%FrictionVelocity (begp, endp, fn, filterp, & + displa(begp:endp), z0mv(begp:endp), z0hv(begp:endp), z0qv(begp:endp), & + obu(begp:endp), itlef+1, ur(begp:endp), um(begp:endp), ustar(begp:endp), & + temp1(begp:endp), temp2(begp:endp), temp12m(begp:endp), temp22m(begp:endp), fm(begp:endp)) + + do f = 1, fn + p = filterp(f) + c = patch%column(p) + g = patch%gridcell(p) + + tlbef(p) = t_veg(p) + del2(p) = del(p) + + ! Determine aerodynamic resistances + + ram1(p) = 1._r8/(ustar(p)*ustar(p)/um(p)) + rah(p,1) = 1._r8/(temp1(p)*ustar(p)) + raw(p,1) = 1._r8/(temp2(p)*ustar(p)) + + ! Bulk boundary layer resistance of leaves + + uaf(p) = um(p)*sqrt( 1._r8/(ram1(p)*um(p)) ) + + ! Use pft parameter for leaf characteristic width + ! dleaf_patch if this is not an fates patch. + ! Otherwise, the value has already been loaded + ! during the FATES dynamics call + if(.not.patch%is_fates(p)) then + dleaf_patch(p) = dleaf(patch%itype(p)) + end if + + cf = params_inst%cv / (sqrt(uaf(p)) * sqrt(dleaf_patch(p))) + rb(p) = 1._r8/(cf*uaf(p)) + rb1(p) = rb(p) + + ! Parameterization for variation of csoilc with canopy density from + ! X. Zeng, University of Arizona + + w = exp(-(elai(p)+esai(p))) + + ! changed by K.Sakaguchi from here + ! transfer coefficient over bare soil is changed to a local variable + ! just for readability of the code (from line 680) + csoilb = vkc / (params_inst%a_coef * (z0mg(c) * uaf(p) / 1.5e-5_r8)**params_inst%a_exp) + + !compute the stability parameter for ricsoilc ("S" in Sakaguchi&Zeng,2008) + + ri = ( grav*htop(p) * (taf(p) - t_grnd(c)) ) / (taf(p) * uaf(p) **2.00_r8) + + !! modify csoilc value (0.004) if the under-canopy is in stable condition + + if (use_undercanopy_stability .and. (taf(p) - t_grnd(c) ) > 0._r8) then + ! decrease the value of csoilc by dividing it with (1+gamma*min(S, 10.0)) + ! ria ("gmanna" in Sakaguchi&Zeng, 2008) is a constant (=0.5) + ricsoilc = params_inst%csoilc / (1.00_r8 + ria*min( ri, 10.0_r8) ) + csoilcn = csoilb*w + ricsoilc*(1._r8-w) + else + csoilcn = csoilb*w + params_inst%csoilc*(1._r8-w) + end if + + !! Sakaguchi changes for stability formulation ends here + + rah(p,2) = 1._r8/(csoilcn*uaf(p)) + raw(p,2) = rah(p,2) + if (use_lch4) then + grnd_ch4_cond(p) = 1._r8/(raw(p,1)+raw(p,2)) + end if + + ! Stomatal resistances for sunlit and shaded fractions of canopy. + ! Done each iteration to account for differences in eah, tv. + + svpts(p) = el(p) ! pa + eah(p) = forc_pbot(c) * qaf(p) / 0.622_r8 ! pa + rhaf(p) = eah(p)/svpts(p) + end do + + if ( use_fates ) then + + call clm_fates%wrap_photosynthesis(nc, bounds, fn, filterp(1:fn), & + svpts(begp:endp), eah(begp:endp), o2(begp:endp), & + co2(begp:endp), rb(begp:endp), dayl_factor(begp:endp), & + atm2lnd_inst, temperature_inst, canopystate_inst, photosyns_inst) + + else ! not use_fates + + if ( use_hydrstress ) then + call PhotosynthesisHydraulicStress (bounds, fn, filterp, & + svpts(begp:endp), eah(begp:endp), o2(begp:endp), co2(begp:endp), rb(begp:endp), bsun(begp:endp), & + bsha(begp:endp), btran(begp:endp), dayl_factor(begp:endp), leafn_patch(begp:endp), & + downreg_patch(begp:endp), & + qsatl(begp:endp), qaf(begp:endp), & + atm2lnd_inst, temperature_inst, soilstate_inst, waterdiagnosticbulk_inst, surfalb_inst, solarabs_inst, & + canopystate_inst, ozone_inst, photosyns_inst, waterfluxbulk_inst, & + froot_carbon(begp:endp), croot_carbon(begp:endp)) ! MS added downreg + else + call Photosynthesis (bounds, fn, filterp, & + svpts(begp:endp), eah(begp:endp), o2(begp:endp), co2(begp:endp), rb(begp:endp), btran(begp:endp), & + dayl_factor(begp:endp), leafn_patch(begp:endp), & + downreg_patch(begp:endp), & + atm2lnd_inst, temperature_inst, surfalb_inst, solarabs_inst, & + canopystate_inst, ozone_inst, photosyns_inst, phase='sun') ! MS added downreg + endif + + if ( use_cn .and. use_c13 ) then + call Fractionation (bounds, fn, filterp, downreg_patch(begp:endp), & + atm2lnd_inst, canopystate_inst, solarabs_inst, surfalb_inst, photosyns_inst, & + phase='sun') + endif + + if ( .not.(use_hydrstress) ) then + call Photosynthesis (bounds, fn, filterp, & + svpts(begp:endp), eah(begp:endp), o2(begp:endp), co2(begp:endp), rb(begp:endp), btran(begp:endp), & + dayl_factor(begp:endp), leafn_patch(begp:endp), & + downreg_patch(begp:endp), & + atm2lnd_inst, temperature_inst, surfalb_inst, solarabs_inst, & + canopystate_inst, ozone_inst, photosyns_inst, phase='sha') ! MS added downreg + end if + + if ( use_cn .and. use_c13 ) then + call Fractionation (bounds, fn, filterp, downreg_patch(begp:endp), & + atm2lnd_inst, canopystate_inst, solarabs_inst, surfalb_inst, photosyns_inst, & + phase='sha') + end if + + end if ! end of if use_fates + + do f = 1, fn + p = filterp(f) + c = patch%column(p) + g = patch%gridcell(p) + + ! Sensible heat conductance for air, leaf and ground + ! Moved the original subroutine in-line... + + wta = 1._r8/rah(p,1) ! air + wtl = (elai(p)+esai(p))/rb(p) ! leaf + wtg(p) = 1._r8/rah(p,2) ! ground + wtshi = 1._r8/(wta+wtl+wtg(p)) + + wtl0(p) = wtl*wtshi ! leaf + wtg0 = wtg(p)*wtshi ! ground + wta0(p) = wta*wtshi ! air + + wtga = wta0(p)+wtg0 ! ground + air + wtal(p) = wta0(p)+wtl0(p) ! air + leaf + + ! Fraction of potential evaporation from leaf + + if (fdry(p) > 0._r8) then + rppdry = fdry(p)*rb(p)*(laisun(p)/(rb(p)+rssun(p)) + laisha(p)/(rb(p)+rssha(p)))/elai(p) + else + rppdry = 0._r8 + end if + + ! Calculate canopy conductance for methane / oxygen (e.g. stomatal conductance & leaf bdy cond) + if (use_lch4) then + canopy_cond(p) = (laisun(p)/(rb(p)+rssun(p)) + laisha(p)/(rb(p)+rssha(p)))/max(elai(p), 0.01_r8) + end if + + efpot = forc_rho(c)*wtl*(qsatl(p)-qaf(p)) + h2ocan = liqcan(p) + snocan(p) + + ! When the hydraulic stress parameterization is active calculate rpp + ! but not transpiration + if ( use_hydrstress ) then + if (efpot > 0._r8) then + if (btran(p) > btran0) then + rpp = rppdry + fwet(p) + else + rpp = fwet(p) + end if + !Check total evapotranspiration from leaves + rpp = min(rpp, (qflx_tran_veg(p)+h2ocan/dtime)/efpot) + else + rpp = 1._r8 + end if + else + if (efpot > 0._r8) then + if (btran(p) > btran0) then + qflx_tran_veg(p) = efpot*rppdry + rpp = rppdry + fwet(p) + else + !No transpiration if btran below 1.e-10 + rpp = fwet(p) + qflx_tran_veg(p) = 0._r8 + end if + !Check total evapotranspiration from leaves + rpp = min(rpp, (qflx_tran_veg(p)+h2ocan/dtime)/efpot) + else + !No transpiration if potential evaporation less than zero + rpp = 1._r8 + qflx_tran_veg(p) = 0._r8 + end if + end if + + ! Update conductances for changes in rpp + ! Latent heat conductances for ground and leaf. + ! Air has same conductance for both sensible and latent heat. + ! Moved the original subroutine in-line... + + wtaq = frac_veg_nosno(p)/raw(p,1) ! air + wtlq = frac_veg_nosno(p)*(elai(p)+esai(p))/rb(p) * rpp ! leaf + + !Litter layer resistance. Added by K.Sakaguchi + snow_depth_c = params_inst%z_dl ! critical depth for 100% litter burial by snow (=litter thickness) + fsno_dl = snow_depth(c)/snow_depth_c ! effective snow cover for (dry)plant litter + elai_dl = params_inst%lai_dl * (1._r8 - min(fsno_dl,1._r8)) ! exposed (dry)litter area index + rdl = ( 1._r8 - exp(-elai_dl) ) / ( 0.004_r8*uaf(p)) ! dry litter layer resistance + + ! add litter resistance and Lee and Pielke 1992 beta + if (delq(p) < 0._r8) then !dew. Do not apply beta for negative flux (follow old rsoil) + wtgq(p) = frac_veg_nosno(p)/(raw(p,2)+rdl) + else + if (do_soilevap_beta()) then + wtgq(p) = soilbeta(c)*frac_veg_nosno(p)/(raw(p,2)+rdl) + endif + if (do_soil_resistance_sl14()) then + wtgq(p) = frac_veg_nosno(p)/(raw(p,2)+soilresis(c)) + endif + end if + + wtsqi = 1._r8/(wtaq+wtlq+wtgq(p)) + + wtgq0 = wtgq(p)*wtsqi ! ground + wtlq0(p) = wtlq*wtsqi ! leaf + wtaq0(p) = wtaq*wtsqi ! air + + wtgaq = wtaq0(p)+wtgq0 ! air + ground + wtalq(p) = wtaq0(p)+wtlq0(p) ! air + leaf + + dc1 = forc_rho(c)*cpair*wtl + dc2 = hvap*forc_rho(c)*wtlq + + efsh = dc1*(wtga*t_veg(p)-wtg0*t_grnd(c)-wta0(p)*thm(p)) + efe(p) = dc2*(wtgaq*qsatl(p)-wtgq0*qg(c)-wtaq0(p)*forc_q(c)) + + ! Evaporation flux from foliage + + erre = 0._r8 + if (efe(p)*efeb(p) < 0._r8) then + efeold = efe(p) + efe(p) = 0.1_r8*efeold + erre = efe(p) - efeold + end if + ! fractionate ground emitted longwave + lw_grnd=(frac_sno(c)*t_soisno(c,snl(c)+1)**4 & + +(1._r8-frac_sno(c)-frac_h2osfc(c))*t_soisno(c,1)**4 & + +frac_h2osfc(c)*t_h2osfc(c)**4) + + dt_veg(p) = (sabv(p) + air(p) + bir(p)*t_veg(p)**4 + & + cir(p)*lw_grnd - efsh - efe(p)) / & + (- 4._r8*bir(p)*t_veg(p)**3 +dc1*wtga +dc2*wtgaq*qsatldT(p)) + t_veg(p) = tlbef(p) + dt_veg(p) + dels = dt_veg(p) + del(p) = abs(dels) + err(p) = 0._r8 + if (del(p) > delmax) then + dt_veg(p) = delmax*dels/del(p) + t_veg(p) = tlbef(p) + dt_veg(p) + err(p) = sabv(p) + air(p) + bir(p)*tlbef(p)**3*(tlbef(p) + & + 4._r8*dt_veg(p)) + cir(p)*lw_grnd - & + (efsh + dc1*wtga*dt_veg(p)) - (efe(p) + & + dc2*wtgaq*qsatldT(p)*dt_veg(p)) + end if + + ! Fluxes from leaves to canopy space + ! "efe" was limited as its sign changes frequently. This limit may + ! result in an imbalance in "hvap*qflx_evap_veg" and + ! "efe + dc2*wtgaq*qsatdt_veg" + + efpot = forc_rho(c)*wtl*(wtgaq*(qsatl(p)+qsatldT(p)*dt_veg(p)) & + -wtgq0*qg(c)-wtaq0(p)*forc_q(c)) + qflx_evap_veg(p) = rpp*efpot + + ! Calculation of evaporative potentials (efpot) and + ! interception losses; flux in kg m**-2 s-1. ecidif + ! holds the excess energy if all intercepted water is evaporated + ! during the timestep. This energy is later added to the + ! sensible heat flux. + + ! Note that when the hydraulic stress parameterization is active we don't + ! adjust transpiration for the new values of potential evaporation and rppdry + ! as calculated above because transpiration would then no longer be consistent + ! with the vertical transpiration sink terms that are passed to Compute_VertTranSink_PHS, + ! thereby causing a water balance error. However, because this adjustment occurs + ! within the leaf temperature iteration, this ends up being a small inconsistency. + if ( use_hydrstress ) then + ecidif = max(0._r8, qflx_evap_veg(p)-qflx_tran_veg(p)-h2ocan/dtime) + qflx_evap_veg(p) = min(qflx_evap_veg(p),qflx_tran_veg(p)+h2ocan/dtime) + else + ecidif = 0._r8 + if (efpot > 0._r8 .and. btran(p) > btran0) then + qflx_tran_veg(p) = efpot*rppdry + else + qflx_tran_veg(p) = 0._r8 + end if + ecidif = max(0._r8, qflx_evap_veg(p)-qflx_tran_veg(p)-h2ocan/dtime) + qflx_evap_veg(p) = min(qflx_evap_veg(p),qflx_tran_veg(p)+h2ocan/dtime) + end if + + ! The energy loss due to above two limits is added to + ! the sensible heat flux. + + eflx_sh_veg(p) = efsh + dc1*wtga*dt_veg(p) + err(p) + erre + hvap*ecidif + + ! Re-calculate saturated vapor pressure, specific humidity, and their + ! derivatives at the leaf surface + + call QSat(t_veg(p), forc_pbot(c), el(p), deldT, qsatl(p), qsatldT(p)) + + ! Update vegetation/ground surface temperature, canopy air + ! temperature, canopy vapor pressure, aerodynamic temperature, and + ! Monin-Obukhov stability parameter for next iteration. + + taf(p) = wtg0*t_grnd(c) + wta0(p)*thm(p) + wtl0(p)*t_veg(p) + qaf(p) = wtlq0(p)*qsatl(p) + wtgq0*qg(c) + forc_q(c)*wtaq0(p) + + ! Update Monin-Obukhov length and wind speed including the + ! stability effect + + dth(p) = thm(p)-taf(p) + dqh(p) = forc_q(c)-qaf(p) + delq(p) = wtalq(p)*qg(c)-wtlq0(p)*qsatl(p)-wtaq0(p)*forc_q(c) + + tstar = temp1(p)*dth(p) + qstar = temp2(p)*dqh(p) + + thvstar = tstar*(1._r8+0.61_r8*forc_q(c)) + 0.61_r8*forc_th(c)*qstar + zeta = zldis(p)*vkc*grav*thvstar/(ustar(p)**2*thv(c)) + + if (zeta >= 0._r8) then !stable + zeta = min(zetamax,max(zeta,0.01_r8)) + um(p) = max(ur(p),0.1_r8) + else !unstable + zeta = max(-100._r8,min(zeta,-0.01_r8)) + wc = beta*(-grav*ustar(p)*thvstar*zii/thv(c))**0.333_r8 + um(p) = sqrt(ur(p)*ur(p)+wc*wc) + end if + obu(p) = zldis(p)/zeta + + if (obuold(p)*obu(p) < 0._r8) nmozsgn(p) = nmozsgn(p)+1 + if (nmozsgn(p) >= 4) obu(p) = zldis(p)/(-0.01_r8) + obuold(p) = obu(p) + + end do ! end of filtered patch loop + + ! Test for convergence + + itlef = itlef+1 + if (itlef > itmin) then + do f = 1, fn + p = filterp(f) + dele(p) = abs(efe(p)-efeb(p)) + efeb(p) = efe(p) + det(p) = max(del(p),del2(p)) + end do + fnold = fn + fn = 0 + do f = 1, fnold + p = filterp(f) + if (.not. (det(p) < dtmin .and. dele(p) < dlemin)) then + fn = fn + 1 + filterp(fn) = p + end if + end do + end if + + end do ITERATION ! End stability iteration + call t_stopf('can_iter') + + fn = fnorig + filterp(1:fn) = fporig(1:fn) + + do f = 1, fn + p = filterp(f) + c = patch%column(p) + g = patch%gridcell(p) + + ! Energy balance check in canopy + + lw_grnd=(frac_sno(c)*t_soisno(c,snl(c)+1)**4 & + +(1._r8-frac_sno(c)-frac_h2osfc(c))*t_soisno(c,1)**4 & + +frac_h2osfc(c)*t_h2osfc(c)**4) + + err(p) = sabv(p) + air(p) + bir(p)*tlbef(p)**3*(tlbef(p) + 4._r8*dt_veg(p)) & + !+ cir(p)*t_grnd(c)**4 - eflx_sh_veg(p) - hvap*qflx_evap_veg(p) + + cir(p)*lw_grnd - eflx_sh_veg(p) - hvap*qflx_evap_veg(p) + + ! Fluxes from ground to canopy space + + delt = wtal(p)*t_grnd(c)-wtl0(p)*t_veg(p)-wta0(p)*thm(p) + taux(p) = -forc_rho(c)*forc_u(g)/ram1(p) + tauy(p) = -forc_rho(c)*forc_v(g)/ram1(p) + eflx_sh_grnd(p) = cpair*forc_rho(c)*wtg(p)*delt + + ! compute individual sensible heat fluxes + delt_snow = wtal(p)*t_soisno(c,snl(c)+1)-wtl0(p)*t_veg(p)-wta0(p)*thm(p) + eflx_sh_snow(p) = cpair*forc_rho(c)*wtg(p)*delt_snow + + delt_soil = wtal(p)*t_soisno(c,1)-wtl0(p)*t_veg(p)-wta0(p)*thm(p) + eflx_sh_soil(p) = cpair*forc_rho(c)*wtg(p)*delt_soil + + delt_h2osfc = wtal(p)*t_h2osfc(c)-wtl0(p)*t_veg(p)-wta0(p)*thm(p) + eflx_sh_h2osfc(p) = cpair*forc_rho(c)*wtg(p)*delt_h2osfc + qflx_evap_soi(p) = forc_rho(c)*wtgq(p)*delq(p) + + ! compute individual latent heat fluxes + delq_snow = wtalq(p)*qg_snow(c)-wtlq0(p)*qsatl(p)-wtaq0(p)*forc_q(c) + qflx_ev_snow(p) = forc_rho(c)*wtgq(p)*delq_snow + + delq_soil = wtalq(p)*qg_soil(c)-wtlq0(p)*qsatl(p)-wtaq0(p)*forc_q(c) + qflx_ev_soil(p) = forc_rho(c)*wtgq(p)*delq_soil + + delq_h2osfc = wtalq(p)*qg_h2osfc(c)-wtlq0(p)*qsatl(p)-wtaq0(p)*forc_q(c) + qflx_ev_h2osfc(p) = forc_rho(c)*wtgq(p)*delq_h2osfc + + ! 2 m height air temperature + + t_ref2m(p) = thm(p) + temp1(p)*dth(p)*(1._r8/temp12m(p) - 1._r8/temp1(p)) + t_ref2m_r(p) = t_ref2m(p) + + ! 2 m height specific humidity + + q_ref2m(p) = forc_q(c) + temp2(p)*dqh(p)*(1._r8/temp22m(p) - 1._r8/temp2(p)) + + ! 2 m height relative humidity + + call QSat(t_ref2m(p), forc_pbot(c), e_ref2m, de2mdT, qsat_ref2m, dqsat2mdT) + rh_ref2m(p) = min(100._r8, q_ref2m(p) / qsat_ref2m * 100._r8) + rh_ref2m_r(p) = rh_ref2m(p) + + ! Human Heat Stress + if ( all_human_stress_indices .or. fast_human_stress_indices ) then + call KtoC(t_ref2m(p), tc_ref2m(p)) + call VaporPres(rh_ref2m(p), e_ref2m, vap_ref2m(p)) + call Wet_BulbS(tc_ref2m(p),rh_ref2m(p), wbt_ref2m(p)) + call HeatIndex(tc_ref2m(p), rh_ref2m(p), nws_hi_ref2m(p)) + call AppTemp(tc_ref2m(p), vap_ref2m(p), u10_clm(p), appar_temp_ref2m(p)) + call swbgt(tc_ref2m(p), vap_ref2m(p), swbgt_ref2m(p)) + call hmdex(tc_ref2m(p), vap_ref2m(p), humidex_ref2m(p)) + call dis_coiS(tc_ref2m(p), rh_ref2m(p), wbt_ref2m(p), discomf_index_ref2mS(p)) + if ( all_human_stress_indices ) then + call Wet_Bulb(t_ref2m(p), vap_ref2m(p), forc_pbot(c), rh_ref2m(p), q_ref2m(p), & + teq_ref2m(p), ept_ref2m(p), wb_ref2m(p)) + call dis_coi(tc_ref2m(p), wb_ref2m(p), discomf_index_ref2m(p)) + call THIndex(tc_ref2m(p), wb_ref2m(p), thic_ref2m(p), thip_ref2m(p)) + call SwampCoolEff(tc_ref2m(p), wb_ref2m(p), swmp80_ref2m(p), swmp65_ref2m(p)) + end if + wbt_ref2m_r(p) = wbt_ref2m(p) + nws_hi_ref2m_r(p) = nws_hi_ref2m(p) + appar_temp_ref2m_r(p) = appar_temp_ref2m(p) + swbgt_ref2m_r(p) = swbgt_ref2m(p) + humidex_ref2m_r(p) = humidex_ref2m(p) + discomf_index_ref2mS_r(p) = discomf_index_ref2mS(p) + if ( all_human_stress_indices ) then + teq_ref2m_r(p) = teq_ref2m(p) + ept_ref2m_r(p) = ept_ref2m(p) + wb_ref2m_r(p) = wb_ref2m(p) + discomf_index_ref2m_r(p) = discomf_index_ref2m(p) + thic_ref2m_r(p) = thic_ref2m(p) + thip_ref2m_r(p) = thip_ref2m(p) + swmp80_ref2m_r(p) = swmp80_ref2m(p) + swmp65_ref2m_r(p) = swmp65_ref2m(p) + end if + + end if + + ! Downward longwave radiation below the canopy + + dlrad(p) = (1._r8-emv(p))*emg(c)*forc_lwrad(c) + & + emv(p)*emg(c)*sb*tlbef(p)**3*(tlbef(p) + 4._r8*dt_veg(p)) + + ! Upward longwave radiation above the canopy + + ulrad(p) = ((1._r8-emg(c))*(1._r8-emv(p))*(1._r8-emv(p))*forc_lwrad(c) & + + emv(p)*(1._r8+(1._r8-emg(c))*(1._r8-emv(p)))*sb*tlbef(p)**3*(tlbef(p) + & + 4._r8*dt_veg(p)) + emg(c)*(1._r8-emv(p))*sb*lw_grnd) + + ! Calculate the skin temperature as a weighted sum of all the ground and vegetated fraction + ! The weight is the so-called vegetation emissivity, but not that emv is actually an attentuation + ! function that goes to zero as LAI (ELAI + ESAI) go to zero. + + t_skin_patch(p) = emv(p)*t_veg(p) + (1._r8 - emv(p))*sqrt(sqrt(lw_grnd)) + + ! Derivative of soil energy flux with respect to soil temperature + + cgrnds(p) = cgrnds(p) + cpair*forc_rho(c)*wtg(p)*wtal(p) + cgrndl(p) = cgrndl(p) + forc_rho(c)*wtgq(p)*wtalq(p)*dqgdT(c) + cgrnd(p) = cgrnds(p) + cgrndl(p)*htvp(c) + + ! Update dew accumulation (kg/m2) + if (t_veg(p) > tfrz ) then ! above freezing, update accumulation in liqcan + if ((qflx_evap_veg(p)-qflx_tran_veg(p))*dtime > liqcan(p)) then ! all liq evap + ! In this case, all liqcan will evap. Take remainder from snocan + snocan(p)=snocan(p)+liqcan(p)+(qflx_tran_veg(p)-qflx_evap_veg(p))*dtime + end if + liqcan(p) = max(0._r8,liqcan(p)+(qflx_tran_veg(p)-qflx_evap_veg(p))*dtime) + + else if (t_veg(p) <= tfrz) then ! below freezing, update accumulation in snocan + if ((qflx_evap_veg(p)-qflx_tran_veg(p))*dtime > snocan(p)) then ! all sno evap + ! In this case, all snocan will evap. Take remainder from liqcan + liqcan(p)=liqcan(p)+snocan(p)+(qflx_tran_veg(p)-qflx_evap_veg(p))*dtime + end if + snocan(p) = max(0._r8,snocan(p)+(qflx_tran_veg(p)-qflx_evap_veg(p))*dtime) + end if + + end do + + if ( use_fates ) then + + + call clm_fates%wrap_accumulatefluxes(nc,fn,filterp(1:fn)) + call clm_fates%wrap_hydraulics_drive(bounds,nc,soilstate_inst, & + waterstatebulk_inst,waterdiagnosticbulk_inst,waterfluxbulk_inst,solarabs_inst,energyflux_inst) + + else + + ! Determine total photosynthesis + + call PhotosynthesisTotal(fn, filterp, & + atm2lnd_inst, canopystate_inst, photosyns_inst) + + ! Calculate ozone stress. This needs to be done after rssun and rsshade are + ! computed by the Photosynthesis routine. However, Photosynthesis also uses the + ! ozone stress computed here. Thus, the ozone stress computed in timestep i is + ! applied in timestep (i+1). + + ! COMPILER_BUG(wjs, 2014-11-29, pgi 14.7) The following dummy variable assignment is + ! needed with pgi 14.7 on yellowstone; without it, forc_pbot_downscaled_col gets + ! resized inappropriately in the following subroutine call, due to a compiler bug. + dummy_to_make_pgi_happy = ubound(atm2lnd_inst%forc_pbot_downscaled_col, 1) + call ozone_inst%CalcOzoneStress( & + bounds, fn, filterp, & + forc_pbot = atm2lnd_inst%forc_pbot_downscaled_col(bounds%begc:bounds%endc), & + forc_th = atm2lnd_inst%forc_th_downscaled_col(bounds%begc:bounds%endc), & + rssun = photosyns_inst%rssun_patch(bounds%begp:bounds%endp), & + rssha = photosyns_inst%rssha_patch(bounds%begp:bounds%endp), & + rb = frictionvel_inst%rb1_patch(bounds%begp:bounds%endp), & + ram = frictionvel_inst%ram1_patch(bounds%begp:bounds%endp), & + tlai = canopystate_inst%tlai_patch(bounds%begp:bounds%endp)) + + !--------------------------------------------------------- + !update Vc,max and Jmax by LUNA model + if(use_luna)then + call Acc24_Climate_LUNA(bounds, fn, filterp, & + canopystate_inst, photosyns_inst, & + surfalb_inst, solarabs_inst, & + temperature_inst) + + if(is_end_day)then + + call Acc240_Climate_LUNA(bounds, fn, filterp, & + o2(begp:endp), & + co2(begp:endp), & + rb(begp:endp), & + rhaf(begp:endp),& + temperature_inst, & + photosyns_inst, & + surfalb_inst, & + solarabs_inst, & + waterdiagnosticbulk_inst,& + frictionvel_inst) + + call Update_Photosynthesis_Capacity(bounds, fn, filterp, & + dayl_factor(begp:endp), & + atm2lnd_inst, & + temperature_inst, & + canopystate_inst, & + photosyns_inst, & + surfalb_inst, & + solarabs_inst, & + waterdiagnosticbulk_inst,& + frictionvel_inst) + + call Clear24_Climate_LUNA(bounds, fn, filterp, & + canopystate_inst, photosyns_inst, & + surfalb_inst, solarabs_inst, & + temperature_inst) + endif + + endif + end if + + ! Filter out patches which have small energy balance errors; report others + + fnold = fn + fn = 0 + do f = 1, fnold + p = filterp(f) + if (abs(err(p)) > 0.1_r8) then + fn = fn + 1 + filterp(fn) = p + end if + end do + + do f = 1, fn + p = filterp(f) + write(iulog,*) 'energy balance in canopy ',p,', err=',err(p) + end do + + + end associate + + + end subroutine CanopyFluxes + +end module CanopyFluxesMod + diff --git a/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/biogeophys/PhotosynthesisMod.F90 b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/biogeophys/PhotosynthesisMod.F90 new file mode 100644 index 0000000000..b93bb7619a --- /dev/null +++ b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/biogeophys/PhotosynthesisMod.F90 @@ -0,0 +1,5428 @@ + +! DART note: this file started life as release-cesm2.2.01 : +! /glade/work/thoar/CESM/my_cesm_sandbox/components/clm/src/biogeophys/PhotosynthesisMod.F90 +! +! These changes support creating the Solar Induced Fluorescence (SIF), +! as well as writing out the 'FSIF' (and related) variable(s) to a history file. + +module PhotosynthesisMod + +#include "shr_assert.h" + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Leaf photosynthesis and stomatal conductance calculation as described by + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 and extended to + ! a multi-layer canopy + ! + ! !USES: + use shr_sys_mod , only : shr_sys_flush + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use abortutils , only : endrun + use clm_varctl , only : use_c13, use_c14, use_cn, use_cndv, use_fates, use_luna, use_hydrstress + use clm_varctl , only : iulog + use clm_varpar , only : nlevcan, nvegwcs, mxpft + use clm_varcon , only : namep, c14ratio, spval + use decompMod , only : bounds_type + use QuadraticMod , only : quadratic + use pftconMod , only : pftcon + use CIsoAtmTimeseriesMod, only : C14BombSpike, use_c14_bombspike, C13TimeSeries, use_c13_timeseries, nsectors_c14 + use atm2lndType , only : atm2lnd_type + use CanopyStateType , only : canopystate_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use WaterFluxBulkType , only : waterfluxbulk_type + use SoilStateType , only : soilstate_type + use TemperatureType , only : temperature_type + use SolarAbsorbedType , only : solarabs_type + use SurfaceAlbedoType , only : surfalb_type + use OzoneBaseMod , only : ozone_base_type + use LandunitType , only : lun + use PatchType , only : patch + use GridcellType , only : grc +! MS added--------------------------------------------- +! use CNVegStateType , only : cnveg_state_type +! MS ends --------------------------------------------- + ! + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: Photosynthesis ! Leaf stomatal resistance and leaf photosynthesis + public :: PhotosynthesisTotal ! Determine of total photosynthesis + public :: Fractionation ! C13 fractionation during photosynthesis + ! For plant hydraulics approach + public :: PhotosynthesisHydraulicStress ! Leaf stomatal resistance and leaf photosynthesis + ! Simultaneous solution of sunlit/shaded per Pierre + ! Gentine/Daniel Kennedy plant hydraulic stress method + public :: plc ! Return value of vulnerability curve at x + + ! !PRIVATE MEMBER FUNCTIONS: + private :: hybrid ! hybrid solver for ci + private :: ci_func ! ci function + private :: brent ! brent solver for root of a single variable function + private :: ft ! photosynthesis temperature response + private :: fth ! photosynthesis temperature inhibition + private :: fth25 ! scaling factor for photosynthesis temperature inhibition + private :: fluorescence ! fluorescence yield function !!! Added By MS + + ! For plant hydraulics approach + private :: hybrid_PHS ! hybrid solver for ci + private :: ci_func_PHS ! ci function + private :: brent_PHS ! brent solver for root of a single variable function + private :: calcstress ! compute the root water stress + private :: getvegwp ! calculate vegetation water potential (sun, sha, xylem, root) + private :: getqflx ! calculate sunlit and shaded transpiration + private :: spacF ! flux divergence across each vegetation segment + private :: spacA ! the inverse Jacobian matrix relating delta(vegwp) to f, d(vegwp)=A*f + private :: d1plc ! compute 1st deriv of conductance attenuation for each segment + + ! !PRIVATE DATA: + integer, parameter, private :: leafresp_mtd_ryan1991 = 1 ! Ryan 1991 method for lmr25top + integer, parameter, private :: leafresp_mtd_atkin2015 = 2 ! Atkin 2015 method for lmr25top + integer, parameter, private :: sun=1 ! index for sunlit + integer, parameter, private :: sha=2 ! index for shaded + integer, parameter, private :: xyl=3 ! index for xylem + integer, parameter, private :: root=4 ! index for root + integer, parameter, private :: veg=0 ! index for vegetation + integer, parameter, private :: soil=1 ! index for soil + integer, parameter, private :: stomatalcond_mtd_bb1987 = 1 ! Ball-Berry 1987 method for photosynthesis + integer, parameter, private :: stomatalcond_mtd_medlyn2011 = 2 ! Medlyn 2011 method for photosynthesis + ! !PUBLIC VARIABLES: + + type :: photo_params_type + real(r8) :: act25 ! Rubisco activity at 25 C (umol CO2/gRubisco/s) + real(r8) :: fnr ! Mass ratio of total Rubisco molecular mass to nitrogen in Rubisco (gRubisco/gN in Rubisco) + real(r8) :: cp25_yr2000 ! CO2 compensation point at 25°C at present day O2 (mol/mol) + real(r8) :: kc25_coef ! Michaelis-Menten const. at 25°C for CO2 (unitless) + real(r8) :: ko25_coef ! Michaelis-Menten const. at 25°C for O2 (unitless) + real(r8) :: fnps ! Fraction of light absorbed by non-photosynthetic pigment (unitless) + real(r8) :: theta_psii ! Empirical curvature parameter for electron transport rate (unitless) + real(r8) :: theta_ip ! Empirical curvature parameter for ap photosynthesis co-limitation (unitless) + real(r8) :: vcmaxha ! Activation energy for vcmax (J/mol) + real(r8) :: jmaxha ! Activation energy for jmax (J/mol) + real(r8) :: tpuha ! Activation energy for tpu (J/mol) + real(r8) :: lmrha ! Activation energy for lmr (J/mol) + real(r8) :: kcha ! Activation energy for kc (J/mol) + real(r8) :: koha ! Activation energy for ko (J/mol) + real(r8) :: cpha ! Activation energy for cp (J/mol) + real(r8) :: vcmaxhd ! Deactivation energy for vcmax (J/mol) + real(r8) :: jmaxhd ! Deactivation energy for jmax (J/mol) + real(r8) :: tpuhd ! Deactivation energy for tpu (J/mol) + real(r8) :: lmrhd ! Deactivation energy for lmr (J/mol) + real(r8) :: lmrse ! Entropy term for lmr (J/mol/K) + real(r8) :: tpu25ratio ! Ratio of tpu25top to vcmax25top (unitless) + real(r8) :: kp25ratio ! Ratio of kp25top to vcmax25top (unitless) + real(r8), allocatable, public :: krmax (:) + real(r8), allocatable, private :: kmax (:,:) + real(r8), allocatable, private :: psi50 (:,:) + real(r8), allocatable, private :: ck (:,:) + real(r8), allocatable, private :: lmr_intercept_atkin(:) + real(r8), allocatable, private :: theta_cj (:) ! Empirical curvature parameter for ac, aj photosynthesis co-limitation (unitless) + contains + procedure, private :: allocParams + end type photo_params_type + ! + type(photo_params_type), public, protected :: params_inst ! params_inst is populated in readParamsMod + + type, public :: photosyns_type + + logical , pointer, private :: c3flag_patch (:) ! patch true if C3 and false if C4 + ! Plant hydraulic stress specific variables + real(r8), pointer, private :: ac_phs_patch (:,:,:) ! patch Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: aj_phs_patch (:,:,:) ! patch RuBP-limited gross photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: ap_phs_patch (:,:,:) ! patch product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: ag_phs_patch (:,:,:) ! patch co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: an_sun_patch (:,:) ! patch sunlit net leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: an_sha_patch (:,:) ! patch shaded net leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: vcmax_z_phs_patch (:,:,:) ! patch maximum rate of carboxylation (umol co2/m**2/s) + real(r8), pointer, private :: kp_z_phs_patch (:,:,:) ! patch initial slope of CO2 response curve (C4 plants) + real(r8), pointer, private :: tpu_z_phs_patch (:,:,:) ! patch triose phosphate utilization rate (umol CO2/m**2/s) + real(r8), pointer, private :: gs_mol_sun_patch (:,:) ! patch sunlit leaf stomatal conductance (umol H2O/m**2/s) + real(r8), pointer, private :: gs_mol_sha_patch (:,:) ! patch shaded leaf stomatal conductance (umol H2O/m**2/s) + real(r8), pointer, private :: gs_mol_sun_ln_patch (:,:) ! patch sunlit leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon (umol H2O/m**2/s) + real(r8), pointer, private :: gs_mol_sha_ln_patch (:,:) ! patch shaded leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon (umol H2O/m**2/s) + real(r8), pointer, private :: ac_patch (:,:) ! patch Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: aj_patch (:,:) ! patch RuBP-limited gross photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: ap_patch (:,:) ! patch product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: ag_patch (:,:) ! patch co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: an_patch (:,:) ! patch net leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: vcmax_z_patch (:,:) ! patch maximum rate of carboxylation (umol co2/m**2/s) + real(r8), pointer, private :: cp_patch (:) ! patch CO2 compensation point (Pa) + real(r8), pointer, private :: kc_patch (:) ! patch Michaelis-Menten constant for CO2 (Pa) + real(r8), pointer, private :: ko_patch (:) ! patch Michaelis-Menten constant for O2 (Pa) + real(r8), pointer, private :: qe_patch (:) ! patch quantum efficiency, used only for C4 (mol CO2 / mol photons) + real(r8), pointer, private :: tpu_z_patch (:,:) ! patch triose phosphate utilization rate (umol CO2/m**2/s) + real(r8), pointer, private :: kp_z_patch (:,:) ! patch initial slope of CO2 response curve (C4 plants) + real(r8), pointer, private :: bbb_patch (:) ! patch Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8), pointer, private :: mbb_patch (:) ! patch Ball-Berry slope of conductance-photosynthesis relationship + real(r8), pointer, private :: gs_mol_patch (:,:) ! patch leaf stomatal conductance (umol H2O/m**2/s) + real(r8), pointer, private :: gb_mol_patch (:) ! patch leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), pointer, private :: rh_leaf_patch (:) ! patch fractional humidity at leaf surface (dimensionless) + + real(r8), pointer, private :: alphapsnsun_patch (:) ! patch sunlit 13c fractionation ([]) + real(r8), pointer, private :: alphapsnsha_patch (:) ! patch shaded 13c fractionation ([]) + + real(r8), pointer, public :: rc13_canair_patch (:) ! patch C13O2/C12O2 in canopy air + real(r8), pointer, public :: rc13_psnsun_patch (:) ! patch C13O2/C12O2 in sunlit canopy psn flux + real(r8), pointer, public :: rc13_psnsha_patch (:) ! patch C13O2/C12O2 in shaded canopy psn flux + + real(r8), pointer, public :: psnsun_patch (:) ! patch sunlit leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, public :: psnsha_patch (:) ! patch shaded leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, public :: c13_psnsun_patch (:) ! patch c13 sunlit leaf photosynthesis (umol 13CO2/m**2/s) + real(r8), pointer, public :: c13_psnsha_patch (:) ! patch c13 shaded leaf photosynthesis (umol 13CO2/m**2/s) + real(r8), pointer, public :: c14_psnsun_patch (:) ! patch c14 sunlit leaf photosynthesis (umol 14CO2/m**2/s) + real(r8), pointer, public :: c14_psnsha_patch (:) ! patch c14 shaded leaf photosynthesis (umol 14CO2/m**2/s) + + real(r8), pointer, private :: psnsun_z_patch (:,:) ! patch canopy layer: sunlit leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsha_z_patch (:,:) ! patch canopy layer: shaded leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsun_wc_patch (:) ! patch Rubsico-limited sunlit leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsha_wc_patch (:) ! patch Rubsico-limited shaded leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsun_wj_patch (:) ! patch RuBP-limited sunlit leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsha_wj_patch (:) ! patch RuBP-limited shaded leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsun_wp_patch (:) ! patch product-limited sunlit leaf photosynthesis (umol CO2/m**2/s) + real(r8), pointer, private :: psnsha_wp_patch (:) ! patch product-limited shaded leaf photosynthesis (umol CO2/m**2/s) + + real(r8), pointer, public :: fpsn_patch (:) ! patch photosynthesis (umol CO2/m**2 ground/s) + real(r8), pointer, private :: fpsn_wc_patch (:) ! patch Rubisco-limited photosynthesis (umol CO2/m**2 ground/s) + real(r8), pointer, private :: fpsn_wj_patch (:) ! patch RuBP-limited photosynthesis (umol CO2/m**2 ground/s) + real(r8), pointer, private :: fpsn_wp_patch (:) ! patch product-limited photosynthesis (umol CO2/m**2 ground/s) + + real(r8), pointer, public :: lnca_patch (:) ! top leaf layer leaf N concentration (gN leaf/m^2) + + real(r8), pointer, public :: lmrsun_patch (:) ! patch sunlit leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), pointer, public :: lmrsha_patch (:) ! patch shaded leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), pointer, private :: lmrsun_z_patch (:,:) ! patch canopy layer: sunlit leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), pointer, private :: lmrsha_z_patch (:,:) ! patch canopy layer: shaded leaf maintenance respiration rate (umol CO2/m**2/s) + + real(r8), pointer, public :: cisun_z_patch (:,:) ! patch intracellular sunlit leaf CO2 (Pa) + real(r8), pointer, public :: cisha_z_patch (:,:) ! patch intracellular shaded leaf CO2 (Pa) + + real(r8), pointer, private :: rssun_z_patch (:,:) ! patch canopy layer: sunlit leaf stomatal resistance (s/m) + real(r8), pointer, private :: rssha_z_patch (:,:) ! patch canopy layer: shaded leaf stomatal resistance (s/m) + real(r8), pointer, public :: rssun_patch (:) ! patch sunlit stomatal resistance (s/m) + real(r8), pointer, public :: rssha_patch (:) ! patch shaded stomatal resistance (s/m) + real(r8), pointer, public :: luvcmax25top_patch (:) ! vcmax25 ! (umol/m2/s) + real(r8), pointer, public :: lujmax25top_patch (:) ! vcmax25 (umol/m2/s) + real(r8), pointer, public :: lutpu25top_patch (:) ! vcmax25 (umol/m2/s) +!! + + + ! LUNA specific variables + real(r8), pointer, public :: vcmx25_z_patch (:,:) ! patch leaf Vc,max25 (umol CO2/m**2/s) for canopy layer + real(r8), pointer, public :: jmx25_z_patch (:,:) ! patch leaf Jmax25 (umol electron/m**2/s) for canopy layer + real(r8), pointer, public :: vcmx_prevyr (:,:) ! patch leaf Vc,max25 previous year running avg + real(r8), pointer, public :: jmx_prevyr (:,:) ! patch leaf Jmax25 previous year running avg + real(r8), pointer, public :: pnlc_z_patch (:,:) ! patch proportion of leaf nitrogen allocated for light capture for canopy layer + real(r8), pointer, public :: enzs_z_patch (:,:) ! enzyme decay status 1.0-fully active; 0-all decayed during stress + real(r8), pointer, public :: fpsn24_patch (:) ! 24 hour mean patch photosynthesis (umol CO2/m**2 ground/day) + + ! SIF specific variables-----------MS Added----------------------------------------------------------------------------- + real(r8) , pointer, public :: sifsun_patch (:) ! canopy layer: solar-induced fluorescence (W/m**2) [always +] + real(r8) , pointer, public :: sifsha_patch (:) ! canopy layer: solar-induced fluorescence (W/m**2) [always +] + real(r8) , pointer, public :: anetsun_patch (:) ! foliage net assimilation (umol co2 /m**2/ s) [always +] + real(r8) , pointer, public :: anetsha_patch (:) ! foliage net assimilation (umol co2 /m**2/ s) [always +] + real(r8) , pointer, public :: fyieldsun_patch (:) ! fluorescence yield at Fs [photon emitted photon absorbed-1 of PAR] + real(r8) , pointer, public :: fyieldsha_patch (:) ! fluorescence yield at Fs [photon emitted photon absorbed-1 of PAR] + real(r8) , pointer, public :: pyieldsun_patch (:) ! photochemical yield at Fs [photon emitted photon absorbed-1 of PAR] + real(r8) , pointer, public :: pyieldsha_patch (:) ! photochemical yield at Fs [photon emitted photon absorbed-1 of PAR] + real(r8) , pointer, public :: xsatsun_patch (:) ! sun-lid light saturation used in fluorescence model (ja/qabs) + real(r8) , pointer, public :: xsatsha_patch (:) ! shaded light saturation used in fluorescence model (ja/qabs) +! real(r8) , pointer, private:: sif_z_sun_patch (:,:) ! sun-lid canopy layer: solar-induced fluorescence (W/m**2) [always +] +! real(r8) , pointer, private:: sif_z_sha_patch (:,:) ! shaded canopy layer: solar-induced fluorescence (W/m**2) [always +] +! real(r8) , pointer, private:: an_z_sun_patch (:,:) ! sun-lid canopy layer: foliage net assimilation (umol co2 /m**2/ s) [always +] +! real(r8) , pointer, private:: an_z_sha_patch (:,:) ! shaded canopy layer: foliage net assimilation (umol co2 /m**2/ s) + real(r8) , pointer, public :: fsif_patch (:) ! solar-induced fluorescence per unit ground area (W /m**2) + real(r8) , pointer, public :: fan_patch (:) ! net assimilation (umol CO2 /m**2 /s) + real(r8) , pointer, public :: fyield_patch (:) ! fluorescence yield at Fs [photon emitted photon absorbed-1 of PAR] + real(r8) , pointer, public :: pyield_patch (:) ! photochemical yield at Fs [photon emitted photon absorbed-1 of PAR] + real(r8) , pointer, public :: fxsat_patch (:) ! light saturation used in fluorescence model (ja/qabs) + real(r8) , pointer, public :: parsun_patch (:) ! sun-lit par (W /m**2) + real(r8) , pointer, public :: parsha_patch (:) ! shaded par (W /m**2) + + ! Logical switches for different options + logical, public :: rootstem_acc ! Respiratory acclimation for roots and stems + logical, private :: light_inhibit ! If light should inhibit respiration + integer, private :: leafresp_method ! leaf maintencence respiration at 25C for canopy top method to use + integer, private :: stomatalcond_mtd ! Stomatal conduction method type + logical, private :: modifyphoto_and_lmr_forcrop ! Modify photosynthesis and LMR for crop + contains + + ! Public procedures + procedure, public :: Init + procedure, public :: Restart + procedure, public :: ReadNML + procedure, public :: ReadParams + procedure, public :: TimeStepInit + procedure, public :: NewPatchInit + + ! Private procedures + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + + end type photosyns_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + class(photosyns_type) :: this + type(bounds_type), intent(in) :: bounds + + call this%InitAllocate (bounds) + call this%InitHistory (bounds) + call this%InitCold (bounds) + + end subroutine Init + + !------------------------------------------------------------------------ + subroutine InitAllocate(this, bounds) + ! + ! !ARGUMENTS: + class(photosyns_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + !------------------------------------------------------------------------ + + begp = bounds%begp; endp= bounds%endp + begc = bounds%begc; endc= bounds%endc + + allocate(this%c3flag_patch (begp:endp)) ; this%c3flag_patch (:) =.false. + allocate(this%ac_phs_patch (begp:endp,2,1:nlevcan)) ; this%ac_phs_patch (:,:,:) = nan + allocate(this%aj_phs_patch (begp:endp,2,1:nlevcan)) ; this%aj_phs_patch (:,:,:) = nan + allocate(this%ap_phs_patch (begp:endp,2,1:nlevcan)) ; this%ap_phs_patch (:,:,:) = nan + allocate(this%ag_phs_patch (begp:endp,2,1:nlevcan)) ; this%ag_phs_patch (:,:,:) = nan + allocate(this%an_sun_patch (begp:endp,1:nlevcan)) ; this%an_sun_patch (:,:) = nan + allocate(this%an_sha_patch (begp:endp,1:nlevcan)) ; this%an_sha_patch (:,:) = nan + allocate(this%vcmax_z_phs_patch (begp:endp,2,1:nlevcan)) ; this%vcmax_z_phs_patch (:,:,:) = nan + allocate(this%tpu_z_phs_patch (begp:endp,2,1:nlevcan)) ; this%tpu_z_phs_patch (:,:,:) = nan + allocate(this%kp_z_phs_patch (begp:endp,2,1:nlevcan)) ; this%kp_z_phs_patch (:,:,:) = nan + allocate(this%gs_mol_sun_patch (begp:endp,1:nlevcan)) ; this%gs_mol_sun_patch (:,:) = nan + allocate(this%gs_mol_sha_patch (begp:endp,1:nlevcan)) ; this%gs_mol_sha_patch (:,:) = nan + allocate(this%gs_mol_sun_ln_patch (begp:endp,1:nlevcan)) ; this%gs_mol_sun_ln_patch (:,:) = nan + allocate(this%gs_mol_sha_ln_patch (begp:endp,1:nlevcan)) ; this%gs_mol_sha_ln_patch (:,:) = nan + allocate(this%ac_patch (begp:endp,1:nlevcan)) ; this%ac_patch (:,:) = nan + allocate(this%aj_patch (begp:endp,1:nlevcan)) ; this%aj_patch (:,:) = nan + allocate(this%ap_patch (begp:endp,1:nlevcan)) ; this%ap_patch (:,:) = nan + allocate(this%ag_patch (begp:endp,1:nlevcan)) ; this%ag_patch (:,:) = nan + allocate(this%an_patch (begp:endp,1:nlevcan)) ; this%an_patch (:,:) = nan + allocate(this%vcmax_z_patch (begp:endp,1:nlevcan)) ; this%vcmax_z_patch (:,:) = nan + allocate(this%tpu_z_patch (begp:endp,1:nlevcan)) ; this%tpu_z_patch (:,:) = nan + allocate(this%kp_z_patch (begp:endp,1:nlevcan)) ; this%kp_z_patch (:,:) = nan + allocate(this%gs_mol_patch (begp:endp,1:nlevcan)) ; this%gs_mol_patch (:,:) = nan + allocate(this%cp_patch (begp:endp)) ; this%cp_patch (:) = nan + allocate(this%kc_patch (begp:endp)) ; this%kc_patch (:) = nan + allocate(this%ko_patch (begp:endp)) ; this%ko_patch (:) = nan + allocate(this%qe_patch (begp:endp)) ; this%qe_patch (:) = nan + allocate(this%bbb_patch (begp:endp)) ; this%bbb_patch (:) = nan + allocate(this%mbb_patch (begp:endp)) ; this%mbb_patch (:) = nan + allocate(this%gb_mol_patch (begp:endp)) ; this%gb_mol_patch (:) = nan + allocate(this%rh_leaf_patch (begp:endp)) ; this%rh_leaf_patch (:) = nan + + allocate(this%psnsun_patch (begp:endp)) ; this%psnsun_patch (:) = nan + allocate(this%psnsha_patch (begp:endp)) ; this%psnsha_patch (:) = nan + allocate(this%c13_psnsun_patch (begp:endp)) ; this%c13_psnsun_patch (:) = nan + allocate(this%c13_psnsha_patch (begp:endp)) ; this%c13_psnsha_patch (:) = nan + allocate(this%c14_psnsun_patch (begp:endp)) ; this%c14_psnsun_patch (:) = nan + allocate(this%c14_psnsha_patch (begp:endp)) ; this%c14_psnsha_patch (:) = nan + + allocate(this%psnsun_z_patch (begp:endp,1:nlevcan)) ; this%psnsun_z_patch (:,:) = nan + allocate(this%psnsha_z_patch (begp:endp,1:nlevcan)) ; this%psnsha_z_patch (:,:) = nan + allocate(this%psnsun_wc_patch (begp:endp)) ; this%psnsun_wc_patch (:) = nan + allocate(this%psnsha_wc_patch (begp:endp)) ; this%psnsha_wc_patch (:) = nan + allocate(this%psnsun_wj_patch (begp:endp)) ; this%psnsun_wj_patch (:) = nan + allocate(this%psnsha_wj_patch (begp:endp)) ; this%psnsha_wj_patch (:) = nan + allocate(this%psnsun_wp_patch (begp:endp)) ; this%psnsun_wp_patch (:) = nan + allocate(this%psnsha_wp_patch (begp:endp)) ; this%psnsha_wp_patch (:) = nan + allocate(this%fpsn_patch (begp:endp)) ; this%fpsn_patch (:) = nan + allocate(this%fpsn_wc_patch (begp:endp)) ; this%fpsn_wc_patch (:) = nan + allocate(this%fpsn_wj_patch (begp:endp)) ; this%fpsn_wj_patch (:) = nan + allocate(this%fpsn_wp_patch (begp:endp)) ; this%fpsn_wp_patch (:) = nan + + allocate(this%lnca_patch (begp:endp)) ; this%lnca_patch (:) = nan + + allocate(this%lmrsun_z_patch (begp:endp,1:nlevcan)) ; this%lmrsun_z_patch (:,:) = nan + allocate(this%lmrsha_z_patch (begp:endp,1:nlevcan)) ; this%lmrsha_z_patch (:,:) = nan + allocate(this%lmrsun_patch (begp:endp)) ; this%lmrsun_patch (:) = nan + allocate(this%lmrsha_patch (begp:endp)) ; this%lmrsha_patch (:) = nan + + allocate(this%alphapsnsun_patch (begp:endp)) ; this%alphapsnsun_patch (:) = nan + allocate(this%alphapsnsha_patch (begp:endp)) ; this%alphapsnsha_patch (:) = nan + allocate(this%rc13_canair_patch (begp:endp)) ; this%rc13_canair_patch (:) = nan + allocate(this%rc13_psnsun_patch (begp:endp)) ; this%rc13_psnsun_patch (:) = nan + allocate(this%rc13_psnsha_patch (begp:endp)) ; this%rc13_psnsha_patch (:) = nan + + allocate(this%cisun_z_patch (begp:endp,1:nlevcan)) ; this%cisun_z_patch (:,:) = nan + allocate(this%cisha_z_patch (begp:endp,1:nlevcan)) ; this%cisha_z_patch (:,:) = nan + + allocate(this%rssun_z_patch (begp:endp,1:nlevcan)) ; this%rssun_z_patch (:,:) = nan + allocate(this%rssha_z_patch (begp:endp,1:nlevcan)) ; this%rssha_z_patch (:,:) = nan + allocate(this%rssun_patch (begp:endp)) ; this%rssun_patch (:) = nan + allocate(this%rssha_patch (begp:endp)) ; this%rssha_patch (:) = nan + allocate(this%luvcmax25top_patch(begp:endp)) ; this%luvcmax25top_patch(:) = nan + allocate(this%lujmax25top_patch (begp:endp)) ; this%lujmax25top_patch(:) = nan + allocate(this%lutpu25top_patch (begp:endp)) ; this%lutpu25top_patch(:) = nan +!! +! allocate(this%psncanopy_patch (begp:endp)) ; this%psncanopy_patch (:) = nan +! allocate(this%lmrcanopy_patch (begp:endp)) ; this%lmrcanopy_patch (:) = nan + if(use_luna)then + ! NOTE(bja, 2015-09) because these variables are only allocated + ! when luna is turned on, they can not be placed into associate + ! statements. + allocate(this%vcmx25_z_patch (begp:endp,1:nlevcan)) ; this%vcmx25_z_patch (:,:) = 30._r8 + allocate(this%jmx25_z_patch (begp:endp,1:nlevcan)) ; this%jmx25_z_patch (:,:) = 60._r8 + allocate(this%vcmx_prevyr (begp:endp,1:nlevcan)) ; this%vcmx_prevyr (:,:) = 85._r8 + allocate(this%jmx_prevyr (begp:endp,1:nlevcan)) ; this%jmx_prevyr (:,:) = 50._r8 + allocate(this%pnlc_z_patch (begp:endp,1:nlevcan)) ; this%pnlc_z_patch (:,:) = 0.01_r8 + allocate(this%fpsn24_patch (begp:endp)) ; this%fpsn24_patch (:) = nan + allocate(this%enzs_z_patch (begp:endp,1:nlevcan)) ; this%enzs_z_patch (:,:) = 1._r8 + endif +! MS Added + allocate(this%sifsun_patch (begp:endp)) ; this%sifsun_patch(:) = nan + allocate(this%sifsha_patch (begp:endp)) ; this%sifsha_patch(:) = nan + allocate(this%anetsun_patch (begp:endp)) ; this%anetsun_patch(:) = nan + allocate(this%anetsha_patch (begp:endp)) ; this%anetsha_patch(:) = nan + allocate(this%fyieldsun_patch (begp:endp)) ; this%fyieldsun_patch(:) = nan + allocate(this%fyieldsha_patch (begp:endp)) ; this%fyieldsha_patch(:) = nan + allocate(this%pyieldsun_patch (begp:endp)) ; this%pyieldsun_patch(:) = nan + allocate(this%pyieldsha_patch (begp:endp)) ; this%pyieldsha_patch(:) = nan + allocate(this%xsatsun_patch (begp:endp)) ; this%xsatsun_patch(:) = nan + allocate(this%xsatsha_patch (begp:endp)) ; this%xsatsha_patch(:) = nan +! allocate(this%sif_z_sun_patch (begp:endp,1:nlevcan)) ; this%sif_z_sun_patch(:,:)= nan +! allocate(this%sif_z_sha_patch (begp:endp,1:nlevcan)) ; this%sif_z_sha_patch(:,:)= nan +! allocate(this%an_z_sun_patch (begp:endp,1:nlevcan)) ; this%an_z_sun_patch(:,:) = nan +! allocate(this%an_z_sha_patch (begp:endp,1:nlevcan)) ; this%an_z_sha_patch(:,:) = nan + + allocate(this%fsif_patch (begp:endp)) ; this%fsif_patch(:) = nan + allocate(this%fan_patch (begp:endp)) ; this%fan_patch(:) = nan + allocate(this%fyield_patch (begp:endp)) ; this%fyield_patch(:) = nan + allocate(this%pyield_patch (begp:endp)) ; this%pyield_patch(:) = nan + allocate(this%fxsat_patch (begp:endp)) ; this%fxsat_patch(:) = nan + + allocate(this%parsun_patch (begp:endp)) ; this%parsun_patch(:) = nan + allocate(this%parsha_patch (begp:endp)) ; this%parsha_patch(:) = nan +! MS ends + end subroutine InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! + ! !USES: + use histFileMod , only: hist_addfld1d, hist_addfld2d + ! + ! !ARGUMENTS: + class(photosyns_type) :: this + type(bounds_type), intent(in) :: bounds + real(r8), pointer :: ptr_1d(:) ! pointer to 1d patch array + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + !--------------------------------------------------------------------- + + begp = bounds%begp; endp= bounds%endp + + this%rh_leaf_patch(begp:endp) = spval + call hist_addfld1d (fname='RH_LEAF', units='fraction', & + avgflag='A', long_name='fractional humidity at leaf surface', & + ptr_patch=this%rh_leaf_patch, set_spec=spval, default='inactive') + this%lnca_patch(begp:endp) = spval + call hist_addfld1d (fname='LNC', units='gN leaf/m^2', & + avgflag='A', long_name='leaf N concentration', & + ptr_patch=this%lnca_patch, set_spec=spval) + + ! Don't output photosynthesis variables when FATES is on as they aren't calculated + if (.not. use_fates) then + this%fpsn_patch(begp:endp) = spval + call hist_addfld1d (fname='FPSN', units='umol m-2 s-1', & + avgflag='A', long_name='photosynthesis', & + ptr_patch=this%fpsn_patch, set_lake=0._r8, set_urb=0._r8) + + ! Don't by default output this rate limiting step as only makes sense if you are outputing + ! the others each time-step + this%fpsn_wc_patch(begp:endp) = spval + call hist_addfld1d (fname='FPSN_WC', units='umol m-2 s-1', & + avgflag='I', long_name='Rubisco-limited photosynthesis', & + ptr_patch=this%fpsn_wc_patch, set_lake=0._r8, set_urb=0._r8, & + default='inactive') + + ! Don't by default output this rate limiting step as only makes sense if you are outputing + ! the others each time-step + this%fpsn_wj_patch(begp:endp) = spval + call hist_addfld1d (fname='FPSN_WJ', units='umol m-2 s-1', & + avgflag='I', long_name='RuBP-limited photosynthesis', & + ptr_patch=this%fpsn_wj_patch, set_lake=0._r8, set_urb=0._r8, & + default='inactive') + + ! Don't by default output this rate limiting step as only makes sense if you are outputing + ! the others each time-step + this%fpsn_wp_patch(begp:endp) = spval + call hist_addfld1d (fname='FPSN_WP', units='umol m-2 s-1', & + avgflag='I', long_name='Product-limited photosynthesis', & + ptr_patch=this%fpsn_wp_patch, set_lake=0._r8, set_urb=0._r8, & + default='inactive') + + ! MS added + this%fsif_patch = spval + call hist_addfld1d (fname='FSIF' , units='W/m**2', & + avgflag='A', long_name='solar-induced fluorescence', & + ptr_patch=this%fsif_patch) + + this%fan_patch = spval + call hist_addfld1d (fname='FANET', units='umol CO2 /m**2 /s', & + avgflag='A', long_name='net CO2 assimilation', & + ptr_patch=this%fan_patch) + + this%fyield_patch = spval + call hist_addfld1d (fname='FYIELD', units='unitless', & + avgflag='A', long_name='fluorescence yield, canopy weighted diagnostic (photon absorbed photon emitted-1 of PAR)', & + ptr_patch=this%fyield_patch) + + this%pyield_patch = spval + call hist_addfld1d (fname='PYIELD', units='unitless', & + avgflag='A', long_name='photochemical yield canopy weighted diagnostic (photon absorbed photon emitted-1 of PAR)', & + ptr_patch=this%pyield_patch) + + this%fxsat_patch = spval + call hist_addfld1d (fname='FXSAT', units='unitless', & + avgflag='A', long_name='degree of light saturation for fluorescence model, canopy weighted diagnostic', & + ptr_patch=this%fxsat_patch) + ! MS ends + end if + + if (use_cn) then + this%psnsun_patch(begp:endp) = spval + call hist_addfld1d (fname='PSNSUN', units='umolCO2/m^2/s', & + avgflag='A', long_name='sunlit leaf photosynthesis', & + ptr_patch=this%psnsun_patch) + + this%psnsha_patch(begp:endp) = spval + call hist_addfld1d (fname='PSNSHA', units='umolCO2/m^2/s', & + avgflag='A', long_name='shaded leaf photosynthesis', & + ptr_patch=this%psnsha_patch) + end if + + if ( use_c13 ) then + this%c13_psnsun_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_PSNSUN', units='umolCO2/m^2/s', & + avgflag='A', long_name='C13 sunlit leaf photosynthesis', & + ptr_patch=this%c13_psnsun_patch, default='inactive') + + this%c13_psnsha_patch(begp:endp) = spval + call hist_addfld1d (fname='C13_PSNSHA', units='umolCO2/m^2/s', & + avgflag='A', long_name='C13 shaded leaf photosynthesis', & + ptr_patch=this%c13_psnsha_patch, default='inactive') + end if + + if ( use_c14 ) then + this%c14_psnsun_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_PSNSUN', units='umolCO2/m^2/s', & + avgflag='A', long_name='C14 sunlit leaf photosynthesis', & + ptr_patch=this%c14_psnsun_patch, default='inactive') + + this%c14_psnsha_patch(begp:endp) = spval + call hist_addfld1d (fname='C14_PSNSHA', units='umolCO2/m^2/s', & + avgflag='A', long_name='C14 shaded leaf photosynthesis', & + ptr_patch=this%c14_psnsha_patch, default='inactive') + end if + + if ( use_c13 ) then + this%rc13_canair_patch(begp:endp) = spval + call hist_addfld1d (fname='RC13_CANAIR', units='proportion', & + avgflag='A', long_name='C13/C(12+13) for canopy air', & + ptr_patch=this%rc13_canair_patch, default='inactive') + + this%rc13_psnsun_patch(begp:endp) = spval + call hist_addfld1d (fname='RC13_PSNSUN', units='proportion', & + avgflag='A', long_name='C13/C(12+13) for sunlit photosynthesis', & + ptr_patch=this%rc13_psnsun_patch, default='inactive') + + this%rc13_psnsha_patch(begp:endp) = spval + call hist_addfld1d (fname='RC13_PSNSHA', units='proportion', & + avgflag='A', long_name='C13/C(12+13) for shaded photosynthesis', & + ptr_patch=this%rc13_psnsha_patch, default='inactive') + endif + + ! Canopy physiology + + if ( use_c13 ) then + this%alphapsnsun_patch(begp:endp) = spval + call hist_addfld1d (fname='ALPHAPSNSUN', units='proportion', & + avgflag='A', long_name='sunlit c13 fractionation', & + ptr_patch=this%alphapsnsun_patch, default='inactive') + + this%alphapsnsha_patch(begp:endp) = spval + call hist_addfld1d (fname='ALPHAPSNSHA', units='proportion', & + avgflag='A', long_name='shaded c13 fractionation', & + ptr_patch=this%alphapsnsha_patch, default='inactive') + endif + + this%rssun_patch(begp:endp) = spval + call hist_addfld1d (fname='RSSUN', units='s/m', & + avgflag='M', long_name='sunlit leaf stomatal resistance', & + ptr_patch=this%rssun_patch, l2g_scale_type='veg') + + this%rssha_patch(begp:endp) = spval + call hist_addfld1d (fname='RSSHA', units='s/m', & + avgflag='M', long_name='shaded leaf stomatal resistance', & + ptr_patch=this%rssha_patch, l2g_scale_type='veg') + + this%gs_mol_sun_patch(begp:endp,:) = spval + this%gs_mol_sha_patch(begp:endp,:) = spval + if (nlevcan>1) then + call hist_addfld2d (fname='GSSUN', units='umol H20/m2/s', type2d='nlevcan', & + avgflag='A', long_name='sunlit leaf stomatal conductance', & + ptr_patch=this%gs_mol_sun_patch, set_lake=spval, set_urb=spval) + + call hist_addfld2d (fname='GSSHA', units='umol H20/m2/s', type2d='nlevcan', & + avgflag='A', long_name='shaded leaf stomatal conductance', & + ptr_patch=this%gs_mol_sha_patch, set_lake=spval, set_urb=spval) + else + ptr_1d => this%gs_mol_sun_patch(begp:endp,1) + call hist_addfld1d (fname='GSSUN', units='umol H20/m2/s', & + avgflag='A', long_name='sunlit leaf stomatal conductance', & + ptr_patch=ptr_1d) + + ptr_1d => this%gs_mol_sha_patch(begp:endp,1) + call hist_addfld1d (fname='GSSHA', units='umol H20/m2/s', & + avgflag='A', long_name='shaded leaf stomatal conductance', & + ptr_patch=ptr_1d) + + endif + this%gs_mol_sun_ln_patch(begp:endp,:) = spval + this%gs_mol_sha_ln_patch(begp:endp,:) = spval + if (nlevcan>1) then + call hist_addfld2d (fname='GSSUNLN', units='umol H20/m2/s', type2d='nlevcan', & + avgflag='A', long_name='sunlit leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon', & + ptr_patch=this%gs_mol_sun_ln_patch, set_lake=spval, set_urb=spval) + + call hist_addfld2d (fname='GSSHALN', units='umol H20/m2/s', type2d='nlevcan', & + avgflag='A', long_name='shaded leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon', & + ptr_patch=this%gs_mol_sha_ln_patch, set_lake=spval, set_urb=spval) + else + ptr_1d => this%gs_mol_sun_ln_patch(begp:endp,1) + call hist_addfld1d (fname='GSSUNLN', units='umol H20/m2/s', & + avgflag='A', long_name='sunlit leaf stomatal conductance at local noon', & + ptr_patch=ptr_1d) + + ptr_1d => this%gs_mol_sha_ln_patch(begp:endp,1) + call hist_addfld1d (fname='GSSHALN', units='umol H20/m2/s', & + avgflag='A', long_name='shaded leaf stomatal conductance at local noon', & + ptr_patch=ptr_1d) + + endif + if(use_luna)then + if(nlevcan>1)then + call hist_addfld2d (fname='Vcmx25Z', units='umol/m2/s', type2d='nlevcan', & + avgflag='A', long_name='canopy profile of vcmax25 predicted by LUNA model', & + ptr_patch=this%vcmx25_z_patch) + + call hist_addfld2d (fname='Jmx25Z', units='umol/m2/s', type2d='nlevcan', & + avgflag='A', long_name='canopy profile of vcmax25 predicted by LUNA model', & + ptr_patch=this%jmx25_z_patch) + + call hist_addfld2d (fname='PNLCZ', units='unitless', type2d='nlevcan', & + avgflag='A', long_name='Proportion of nitrogen allocated for light capture', & + ptr_patch=this%pnlc_z_patch,default='inactive') + else + ptr_1d => this%vcmx25_z_patch(:,1) + call hist_addfld1d (fname='Vcmx25Z', units='umol/m2/s',& + avgflag='A', long_name='canopy profile of vcmax25 predicted by LUNA model', & + ptr_patch=ptr_1d) + ptr_1d => this%jmx25_z_patch(:,1) + call hist_addfld1d (fname='Jmx25Z', units='umol/m2/s',& + avgflag='A', long_name='canopy profile of vcmax25 predicted by LUNA model', & + ptr_patch=ptr_1d) + ptr_1d => this%pnlc_z_patch(:,1) + call hist_addfld1d (fname='PNLCZ', units='unitless', & + avgflag='A', long_name='Proportion of nitrogen allocated for light capture', & + ptr_patch=ptr_1d,default='inactive') + + this%luvcmax25top_patch(begp:endp) = spval + call hist_addfld1d (fname='VCMX25T', units='umol/m2/s', & + avgflag='M', long_name='canopy profile of vcmax25', & + ptr_patch=this%luvcmax25top_patch, set_lake=spval, set_urb=spval) + + this%lujmax25top_patch(begp:endp) = spval + call hist_addfld1d (fname='JMX25T', units='umol/m2/s', & + avgflag='M', long_name='canopy profile of jmax', & + ptr_patch=this%lujmax25top_patch, set_lake=spval, set_urb=spval) + + this%lutpu25top_patch(begp:endp) = spval + call hist_addfld1d (fname='TPU25T', units='umol/m2/s', & + avgflag='M', long_name='canopy profile of tpu', & + ptr_patch=this%lutpu25top_patch, set_lake=spval, set_urb=spval) + + endif + this%fpsn24_patch = spval + call hist_addfld1d (fname='FPSN24', units='umol CO2/m**2 ground/day',& + avgflag='A', long_name='24 hour accumulative patch photosynthesis starting from mid-night', & + ptr_patch=this%fpsn24_patch, default='inactive') + + endif + + end subroutine InitHistory + + !----------------------------------------------------------------------- + subroutine InitCold(this, bounds) + ! + ! !ARGUMENTS: + class(photosyns_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: p,l ! indices + !----------------------------------------------------------------------- + + do p = bounds%begp,bounds%endp + l = patch%landunit(p) + + this%alphapsnsun_patch(p) = spval + this%alphapsnsha_patch(p) = spval + + if (lun%ifspecial(l)) then + this%psnsun_patch(p) = 0._r8 + this%psnsha_patch(p) = 0._r8 + if ( use_c13 ) then + this%c13_psnsun_patch(p) = 0._r8 + this%c13_psnsha_patch(p) = 0._r8 + endif + if ( use_c14 ) then + this%c14_psnsun_patch(p) = 0._r8 + this%c14_psnsha_patch(p) = 0._r8 + endif + end if + end do + + end subroutine InitCold + + !----------------------------------------------------------------------- + subroutine allocParams ( this ) + ! + implicit none + + ! !ARGUMENTS: + class(photo_params_type) :: this + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'allocParams' + !----------------------------------------------------------------------- + + ! allocate parameters + + allocate( this%krmax (0:mxpft) ) ; this%krmax(:) = nan + allocate( this%theta_cj (0:mxpft) ) ; this%theta_cj(:) = nan + allocate( this%kmax (0:mxpft,nvegwcs) ) ; this%kmax(:,:) = nan + allocate( this%psi50 (0:mxpft,nvegwcs) ) ; this%psi50(:,:) = nan + allocate( this%ck (0:mxpft,nvegwcs) ) ; this%ck(:,:) = nan + + if ( use_hydrstress .and. nvegwcs /= 4 )then + call endrun(msg='Error:: the Plant Hydraulics Stress methodology is for the spacA function is hardcoded for nvegwcs==4' & + //errMsg(__FILE__, __LINE__)) + end if + + end subroutine allocParams + + !----------------------------------------------------------------------- + subroutine readParams ( this, ncid ) + ! + ! !USES: + use ncdio_pio , only : file_desc_t,ncd_io + use paramUtilMod, only: readNcdioScalar + implicit none + + ! !ARGUMENTS: + class(photosyns_type) :: this + type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id + ! + ! !LOCAL VARIABLES: + character(len=32) :: subname = 'readParams' + character(len=100) :: errCode = '-Error reading in parameters file:' + logical :: readv ! has variable been read in or not + real(r8) :: temp1d(0:mxpft) ! temporary to read in parameter + real(r8) :: temp2d(0:mxpft,nvegwcs) ! temporary to read in parameter + character(len=100) :: tString ! temp. var for reading + !----------------------------------------------------------------------- + + ! read in parameters + + + call params_inst%allocParams() + + tString = "krmax" + call ncd_io(varname=trim(tString),data=temp1d, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%krmax=temp1d + tString = "lmr_intercept_atkin" + call ncd_io(varname=trim(tString),data=temp1d, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%lmr_intercept_atkin=temp1d + tString = "theta_cj" + call ncd_io(varname=trim(tString),data=temp1d, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%theta_cj=temp1d + tString = "kmax" + call ncd_io(varname=trim(tString),data=temp2d, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%kmax=temp2d + tString = "psi50" + call ncd_io(varname=trim(tString),data=temp2d, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%psi50=temp2d + tString = "ck" + call ncd_io(varname=trim(tString),data=temp2d, flag='read', ncid=ncid, readvar=readv) + if ( .not. readv ) call endrun(msg=trim(errCode)//trim(tString)//errMsg(sourcefile, __LINE__)) + params_inst%ck=temp2d + + ! read in the scalar parameters + + ! Michaelis-Menten constant at 25°C for O2 (unitless) + call readNcdioScalar(ncid, 'ko25_coef', subname, params_inst%ko25_coef) + ! Michaelis-Menten constant at 25°C for CO2 (unitless) + call readNcdioScalar(ncid, 'kc25_coef', subname, params_inst%kc25_coef) + ! CO2 compensation point at 25°C at present day O2 levels + call readNcdioScalar(ncid, 'cp25_yr2000', subname, params_inst%cp25_yr2000) + ! Rubisco activity at 25 C (umol CO2/gRubisco/s) + call readNcdioScalar(ncid, 'act25', subname, params_inst%act25) + ! Mass ratio of total Rubisco molecular mass to nitrogen in Rubisco (gRubisco/gN(Rubisco)) + call readNcdioScalar(ncid, 'fnr', subname, params_inst%fnr) + ! Fraction of light absorbed by non-photosynthetic pigment (unitless) + call readNcdioScalar(ncid, 'fnps', subname, params_inst%fnps) + ! Empirical curvature parameter for electron transport rate (unitless) + call readNcdioScalar(ncid, 'theta_psii', subname, params_inst%theta_psii) + ! Empirical curvature parameter for ap photosynthesis co-limitation (unitless) + call readNcdioScalar(ncid, 'theta_ip', subname, params_inst%theta_ip) + ! Activation energy for vcmax (J/mol) + call readNcdioScalar(ncid, 'vcmaxha', subname, params_inst%vcmaxha) + ! Activation energy for jmax (J/mol) + call readNcdioScalar(ncid, 'jmaxha', subname, params_inst%jmaxha) + ! Activation energy for tpu (J/mol) + call readNcdioScalar(ncid, 'tpuha', subname, params_inst%tpuha) + ! Activation energy for lmr (J/mol) + call readNcdioScalar(ncid, 'lmrha', subname, params_inst%lmrha) + ! Activation energy for kc (J/mol) + call readNcdioScalar(ncid, 'kcha', subname, params_inst%kcha) + ! Activation energy for ko (J/mol) + call readNcdioScalar(ncid, 'koha', subname, params_inst%koha) + ! Activation energy for cp (J/mol) + call readNcdioScalar(ncid, 'cpha', subname, params_inst%cpha) + ! Deactivation energy for vcmax (J/mol) + call readNcdioScalar(ncid, 'vcmaxhd', subname, params_inst%vcmaxhd) + ! Deactivation energy for jmax (J/mol) + call readNcdioScalar(ncid, 'jmaxhd', subname, params_inst%jmaxhd) + ! Deactivation energy for tpu (J/mol) + call readNcdioScalar(ncid, 'tpuhd', subname, params_inst%tpuhd) + ! Deactivation energy for lmr (J/mol) + call readNcdioScalar(ncid, 'lmrhd', subname, params_inst%lmrhd) + ! Entropy term for lmr (J/mol/K) + call readNcdioScalar(ncid, 'lmrse', subname, params_inst%lmrse) + ! Ratio of tpu25top to vcmax25top (unitless) + call readNcdioScalar(ncid, 'tpu25ratio', subname, params_inst%tpu25ratio) + ! Ratio of kp25top to vcmax25top (unitless) + call readNcdioScalar(ncid, 'kp25ratio', subname, params_inst%kp25ratio) + + end subroutine readParams + + + !------------------------------------------------------------------------ + subroutine ReadNML(this, NLFilename) + ! + ! !DESCRIPTION: + ! Read the namelist for Photosynthesis + ! + ! !USES: + use fileutils , only : getavu, relavu, opnfil + use shr_nl_mod , only : shr_nl_find_group_name + use spmdMod , only : masterproc, mpicom + use shr_mpi_mod , only : shr_mpi_bcast + use clm_varctl , only : iulog + ! + ! !ARGUMENTS: + class(photosyns_type) :: this + character(len=*), intent(IN) :: NLFilename ! Namelist filename + ! + ! !LOCAL VARIABLES: + integer :: ierr ! error code + integer :: unitn ! unit for namelist file + + character(len=*), parameter :: subname = 'Photosyn::ReadNML' + character(len=*), parameter :: nmlname = 'photosyns_inparm' + logical :: rootstem_acc = .false. ! Respiratory acclimation for roots and stems + logical :: light_inhibit = .false. ! If light should inhibit respiration + integer :: leafresp_method = leafresp_mtd_ryan1991 ! leaf maintencence respiration at 25C for canopy top method to use + logical :: modifyphoto_and_lmr_forcrop = .false. ! Modify photosynthesis and LMR for crop + character(len=50) :: stomatalcond_method = 'Ball-Berry1987' ! Photosynthesis method string + !----------------------------------------------------------------------- + + namelist /photosyns_inparm/ leafresp_method, light_inhibit, & + rootstem_acc, stomatalcond_method, modifyphoto_and_lmr_forcrop + + ! Initialize options to default values, in case they are not specified in + ! the namelist + + if (masterproc) then + unitn = getavu() + write(iulog,*) 'Read in '//nmlname//' namelist' + call opnfil (NLFilename, unitn, 'F') + call shr_nl_find_group_name(unitn, nmlname, status=ierr) + if (ierr == 0) then + read(unitn, nml=photosyns_inparm, iostat=ierr) + if (ierr /= 0) then + call endrun(msg="ERROR reading "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + else + call endrun(msg="ERROR could NOT find "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + call relavu( unitn ) + this%rootstem_acc = rootstem_acc + this%leafresp_method = leafresp_method + this%light_inhibit = light_inhibit + this%modifyphoto_and_lmr_forcrop = modifyphoto_and_lmr_forcrop + if ( trim(stomatalcond_method) == 'Ball-Berry1987' ) then + this%stomatalcond_mtd = stomatalcond_mtd_bb1987 + else if ( trim(stomatalcond_method) == 'Medlyn2011' ) then + this%stomatalcond_mtd = stomatalcond_mtd_medlyn2011 + else + call endrun(msg="ERROR bad value for stomtalcond_method in "//nmlname//"namelist"//errmsg(sourcefile, __LINE__)) + end if + end if + + call shr_mpi_bcast (this%rootstem_acc , mpicom) + call shr_mpi_bcast (this%leafresp_method, mpicom) + call shr_mpi_bcast (this%light_inhibit , mpicom) + call shr_mpi_bcast (this%stomatalcond_mtd, mpicom) + call shr_mpi_bcast (this%modifyphoto_and_lmr_forcrop, mpicom) + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) nmlname//' settings:' + write(iulog,nml=photosyns_inparm) + write(iulog,*) ' ' + end if + + end subroutine ReadNML + + !------------------------------------------------------------------------ + subroutine Restart(this, bounds, ncid, flag) + ! + ! !USES: + use ncdio_pio , only : file_desc_t, ncd_defvar, ncd_io, ncd_double, ncd_int, ncd_inqvdlen + use restUtilMod + ! + ! !ARGUMENTS: + class(photosyns_type) :: this + type(bounds_type), intent(in) :: bounds + type(file_desc_t), intent(inout) :: ncid ! netcdf id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + ! + ! !LOCAL VARIABLES: + integer :: j,c ! indices + logical :: readvar ! determine if variable is on initial file + !----------------------------------------------------------------------- + + if ( use_c13 ) then + call restartvar(ncid=ncid, flag=flag, varname='rc13_canair', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%rc13_canair_patch) + + call restartvar(ncid=ncid, flag=flag, varname='rc13_psnsun', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%rc13_psnsun_patch) + + call restartvar(ncid=ncid, flag=flag, varname='rc13_psnsha', xtype=ncd_double, & + dim1name='pft', long_name='', units='', & + interpinic_flag='interp', readvar=readvar, data=this%rc13_psnsha_patch) + endif + + call restartvar(ncid=ncid, flag=flag, varname='GSSUN', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='sunlit leaf stomatal conductance', units='umol H20/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%gs_mol_sun_patch) + + call restartvar(ncid=ncid, flag=flag, varname='GSSHA', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='shaded leaf stomatal conductance', units='umol H20/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%gs_mol_sha_patch) + + call restartvar(ncid=ncid, flag=flag, varname='GSSUNLN', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='sunlit leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon', & + units='umol H20/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%gs_mol_sun_ln_patch) + + call restartvar(ncid=ncid, flag=flag, varname='GSSHALN', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='shaded leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon', & + units='umol H20/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%gs_mol_sha_ln_patch) + + call restartvar(ncid=ncid, flag=flag, varname='lnca', xtype=ncd_double, & + dim1name='pft', long_name='leaf N concentration', units='gN leaf/m^2', & + interpinic_flag='interp', readvar=readvar, data=this%lnca_patch) + + if(use_luna) then + call restartvar(ncid=ncid, flag=flag, varname='vcmx25_z', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='Maximum carboxylation rate at 25 celcius for canopy layers', units='umol CO2/m**2/s', & + interpinic_flag='interp', readvar=readvar, data=this%vcmx25_z_patch) + call restartvar(ncid=ncid, flag=flag, varname='jmx25_z', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='Maximum carboxylation rate at 25 celcius for canopy layers', units='umol CO2/m**2/s', & + interpinic_flag='interp', readvar=readvar, data=this%jmx25_z_patch) + call restartvar(ncid=ncid, flag=flag, varname='vcmx_prevyr', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='avg carboxylation rate at 25 celsius for canopy layers', units='umol CO2/m**2/s', & + interpinic_flag='interp', readvar=readvar, data=this%vcmx_prevyr) + call restartvar(ncid=ncid, flag=flag, varname='jmx_prevyr', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='avg carboxylation rate at 25 celsius for canopy layers', units='umol CO2/m**2/s', & + interpinic_flag='interp', readvar=readvar, data=this%jmx_prevyr) + call restartvar(ncid=ncid, flag=flag, varname='pnlc_z', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='proportion of leaf nitrogen allocated for light capture', units='unitless', & + interpinic_flag='interp', readvar=readvar, data=this%pnlc_z_patch ) + call restartvar(ncid=ncid, flag=flag, varname='enzs_z', xtype=ncd_double, & + dim1name='pft', dim2name='levcan', switchdim=.true., & + long_name='enzyme decay status during stress: 1.0-fully active; 0.0-all decayed', units='unitless', & + interpinic_flag='interp', readvar=readvar, data=this%enzs_z_patch ) + call restartvar(ncid=ncid, flag=flag, varname='gpp24', xtype=ncd_double, & + dim1name='pft', long_name='accumulative gross primary production', units='umol CO2/m**2 ground/day', & + interpinic_flag='interp', readvar=readvar, data=this%fpsn24_patch) + endif + call restartvar(ncid=ncid, flag=flag, varname='vcmx25t', xtype=ncd_double, & + dim1name='pft', long_name='canopy profile of vcmax25', & + units='umol/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%luvcmax25top_patch) + + call restartvar(ncid=ncid, flag=flag, varname='jmx25t', xtype=ncd_double, & + dim1name='pft', long_name='canopy profile of jmax', & + units='umol/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%lujmax25top_patch) + + call restartvar(ncid=ncid, flag=flag, varname='tpu25t', xtype=ncd_double, & + dim1name='pft', long_name='canopy profile of tpu', & + units='umol/m2/s', & + interpinic_flag='interp', readvar=readvar, data=this%lutpu25top_patch) + + end subroutine Restart + + !------------------------------------------------------------------------------ + subroutine TimeStepInit (this, bounds) + ! + ! Time step initialization + ! + ! !USES: + use landunit_varcon, only : istsoil, istcrop, istice_mec, istwet + ! + ! !ARGUMENTS: + class(photosyns_type) :: this + type(bounds_type) , intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: p,l ! indices + !----------------------------------------------------------------------- + + do p = bounds%begp, bounds%endp + l = patch%landunit(p) + if (.not. lun%lakpoi(l)) then + this%psnsun_patch(p) = 0._r8 + this%psnsun_wc_patch(p) = 0._r8 + this%psnsun_wj_patch(p) = 0._r8 + this%psnsun_wp_patch(p) = 0._r8 + + this%psnsha_patch(p) = 0._r8 + this%psnsha_wc_patch(p) = 0._r8 + this%psnsha_wj_patch(p) = 0._r8 + this%psnsha_wp_patch(p) = 0._r8 + + this%fpsn_patch(p) = 0._r8 + this%fpsn_wc_patch(p) = 0._r8 + this%fpsn_wj_patch(p) = 0._r8 + this%fpsn_wp_patch(p) = 0._r8 +! MS added --------------------------------------------------------- + this%fsif_patch(p) = 0._r8 + this%fan_patch(p) = 0._r8 + this%fyield_patch(p) = 0._r8 + this%pyield_patch(p) = 0._r8 + this%fxsat_patch(p) = 0._r8 + + this%sifsun_patch(p) = 0._r8 + this%anetsun_patch(p) = 0._r8 + this%fyieldsun_patch(p) = 0._r8 + this%pyieldsun_patch(p) = 0._r8 + this%xsatsun_patch(p) = 0._r8 + + this%sifsha_patch(p) = 0._r8 + this%anetsha_patch(p) = 0._r8 + this%fyieldsha_patch(p) = 0._r8 + this%pyieldsha_patch(p) = 0._r8 + this%xsatsha_patch(p) = 0._r8 + + this%parsun_patch(p) = 0._r8 + this%parsha_patch(p) = 0._r8 +! MS ends ----------------------------------------------------------- + if ( use_c13 ) then + this%alphapsnsun_patch(p) = 0._r8 + this%alphapsnsha_patch(p) = 0._r8 + this%c13_psnsun_patch(p) = 0._r8 + this%c13_psnsha_patch(p) = 0._r8 + endif + if ( use_c14 ) then + this%c14_psnsun_patch(p) = 0._r8 + this%c14_psnsha_patch(p) = 0._r8 + endif + end if + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop & + .or. lun%itype(l) == istice_mec & + .or. lun%itype(l) == istwet) then + if (use_c13) then + this%rc13_canair_patch(p) = 0._r8 + this%rc13_psnsun_patch(p) = 0._r8 + this%rc13_psnsha_patch(p) = 0._r8 + end if + end if + end do + + end subroutine TimeStepInit + + !------------------------------------------------------------------------------ + subroutine NewPatchInit (this, p) + ! + ! For new run-time pft, modify state and flux variables to maintain + ! carbon and nitrogen balance with dynamic pft-weights. + ! Called from dyn_cnbal_patch + ! + ! !ARGUMENTS: + class(photosyns_type) :: this + integer, intent(in) :: p + !----------------------------------------------------------------------- + + if ( use_c13 ) then + this%alphapsnsun_patch(p) = 0._r8 + this%alphapsnsha_patch(p) = 0._r8 + this%rc13_canair_patch(p) = 0._r8 + this%rc13_psnsun_patch(p) = 0._r8 + this%rc13_psnsha_patch(p) = 0._r8 + endif + + this%psnsun_patch(p) = 0._r8 + this%psnsha_patch(p) = 0._r8 + + if (use_c13) then + this%c13_psnsun_patch(p) = 0._r8 + this%c13_psnsha_patch(p) = 0._r8 + end if + if ( use_c14 ) then + this%c14_psnsun_patch(p) = 0._r8 + this%c14_psnsha_patch(p) = 0._r8 + end if + + end subroutine NewPatchInit + + !------------------------------------------------------------------------------ + !------------------------------------------------------------------------------ + subroutine Photosynthesis ( bounds, fn, filterp, & + esat_tv, eair, oair, cair, rb, btran, & + dayl_factor, leafn, downreg, & + atm2lnd_inst, temperature_inst, surfalb_inst, solarabs_inst, & + canopystate_inst, ozone_inst, photosyns_inst, phase) ! MS added downreg + ! + ! !DESCRIPTION: + ! Leaf photosynthesis and stomatal conductance calculation as described by + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 and extended to + ! a multi-layer canopy + ! + ! !USES: + use clm_varcon , only : rgas, tfrz, spval + use GridcellType , only : grc + use clm_time_manager , only : get_step_size_real, is_near_local_noon + use clm_varctl , only : cnallocate_carbon_only + use clm_varctl , only : lnc_opt, reduce_dayl_factor, vcmax_opt + use pftconMod , only : nbrdlf_dcd_tmp_shrub, npcropmin + + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: fn ! size of pft filter + integer , intent(in) :: filterp(fn) ! patch filter + real(r8) , intent(in) :: esat_tv( bounds%begp: ) ! saturation vapor pressure at t_veg (Pa) [pft] + real(r8) , intent(in) :: eair( bounds%begp: ) ! vapor pressure of canopy air (Pa) [pft] + real(r8) , intent(in) :: oair( bounds%begp: ) ! Atmospheric O2 partial pressure (Pa) [pft] + real(r8) , intent(in) :: cair( bounds%begp: ) ! Atmospheric CO2 partial pressure (Pa) [pft] + real(r8) , intent(in) :: rb( bounds%begp: ) ! boundary layer resistance (s/m) [pft] + real(r8) , intent(in) :: btran( bounds%begp: ) ! transpiration wetness factor (0 to 1) [pft] + real(r8) , intent(in) :: dayl_factor( bounds%begp: ) ! scalar (0-1) for daylength + real(r8) , intent(in) :: leafn( bounds%begp: ) ! leaf N (gN/m2) + real(r8) , intent(in) :: downreg( bounds%begp: ) ! fractional reduction in GPP due to N limitation (dimensionless) ! MS Added + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(temperature_type) , intent(in) :: temperature_inst + type(surfalb_type) , intent(in) :: surfalb_inst + type(solarabs_type) , intent(in) :: solarabs_inst + type(canopystate_type) , intent(in) :: canopystate_inst + class(ozone_base_type) , intent(in) :: ozone_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + character(len=*) , intent(in) :: phase ! 'sun' or 'sha' +! MS added ------------------------------------------------------------------------ +! type(cnveg_state_type) , intent(in) :: cnveg_state_inst +! MS ends ------------------------------------------------------------------------- + ! + ! !LOCAL VARIABLES: + ! + ! Leaf photosynthesis parameters + real(r8) :: jmax_z(bounds%begp:bounds%endp,nlevcan) ! maximum electron transport rate (umol electrons/m**2/s) + !real(r8) :: lnc(bounds%begp:bounds%endp) ! leaf N concentration (gN leaf/m^2) + real(r8) :: bbbopt(bounds%begp:bounds%endp)! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) + real(r8) :: kn(bounds%begp:bounds%endp) ! leaf nitrogen decay coefficient + real(r8) :: vcmax25top ! canopy top: maximum rate of carboxylation at 25C (umol CO2/m**2/s) + real(r8) :: jmax25top ! canopy top: maximum electron transport rate at 25C (umol electrons/m**2/s) + real(r8) :: tpu25top ! canopy top: triose phosphate utilization rate at 25C (umol CO2/m**2/s) + real(r8) :: lmr25top ! canopy top: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: kp25top ! canopy top: initial slope of CO2 response curve (C4 plants) at 25C + + real(r8) :: vcmax25 ! leaf layer: maximum rate of carboxylation at 25C (umol CO2/m**2/s) + real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C (umol electrons/m**2/s) + real(r8) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C (umol CO2/m**2/s) + real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: kp25 ! leaf layer: Initial slope of CO2 response curve (C4 plants) at 25C + real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) + real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) + real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) + + real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) + real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) + real(r8) :: tpuse ! entropy term for tpu (J/mol/K) + + real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: tpuc ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: lmrc ! scaling factor for high temperature inhibition (25 C = 1.0) + + ! Other + integer :: f,p,c,iv ! indices + real(r8) :: cf ! s m**2/umol -> s/m + real(r8) :: rsmax0 ! maximum stomatal resistance [s/m] + real(r8) :: gb ! leaf boundary layer conductance (m/s) + real(r8) :: cs ! CO2 partial pressure at leaf surface (Pa) + real(r8) :: gs ! leaf stomatal conductance (m/s) + real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) + real(r8) :: sco ! relative specificity of rubisco + real(r8) :: ft ! photosynthesis temperature response (statement function) + real(r8) :: fth ! photosynthesis temperature inhibition (statement function) + real(r8) :: fth25 ! ccaling factor for photosynthesis temperature inhibition (statement function) + real(r8) :: tl ! leaf temperature in photosynthesis temperature function (K) + real(r8) :: ha ! activation energy in photosynthesis temperature function (J/mol) + real(r8) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) + real(r8) :: se ! entropy term in photosynthesis temperature function (J/mol/K) + real(r8) :: scaleFactor ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: ciold ! previous value of Ci for convergence check + real(r8) :: gs_mol_err ! gs_mol for error check + real(r8) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) + real(r8) :: aquad,bquad,cquad ! terms for quadratic equations + real(r8) :: r1,r2 ! roots of quadratic equation + real(r8) :: ceair ! vapor pressure of air, constrained (Pa) + integer :: niter ! iteration loop index + real(r8) :: nscaler ! leaf nitrogen scaling coefficient + + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + + real(r8) :: psn_wc_z(bounds%begp:bounds%endp,nlevcan) ! Rubisco-limited contribution to psn_z (umol CO2/m**2/s) + real(r8) :: psn_wj_z(bounds%begp:bounds%endp,nlevcan) ! RuBP-limited contribution to psn_z (umol CO2/m**2/s) + real(r8) :: psn_wp_z(bounds%begp:bounds%endp,nlevcan) ! product-limited contribution to psn_z (umol CO2/m**2/s) + + real(r8) :: psncan ! canopy sum of psn_z + real(r8) :: psncan_wc ! canopy sum of psn_wc_z + real(r8) :: psncan_wj ! canopy sum of psn_wj_z + real(r8) :: psncan_wp ! canopy sum of psn_wp_z + real(r8) :: lmrcan ! canopy sum of lmr_z + real(r8) :: gscan ! canopy sum of leaf conductance + real(r8) :: laican ! canopy sum of lai_z + real(r8) :: rh_can + real(r8) , pointer :: lai_z (:,:) + real(r8) , pointer :: par_z (:,:) + real(r8) , pointer :: vcmaxcint (:) + real(r8) , pointer :: alphapsn (:) + real(r8) , pointer :: psn (:) + real(r8) , pointer :: psn_wc (:) + real(r8) , pointer :: psn_wj (:) + real(r8) , pointer :: psn_wp (:) + real(r8) , pointer :: psn_z (:,:) + real(r8) , pointer :: lmr (:) + real(r8) , pointer :: lmr_z (:,:) + real(r8) , pointer :: rs (:) + real(r8) , pointer :: rs_z (:,:) + real(r8) , pointer :: ci_z (:,:) + real(r8) , pointer :: o3coefv (:) ! o3 coefficient used in photo calculation + real(r8) , pointer :: o3coefg (:) ! o3 coefficient used in rs calculation + real(r8) , pointer :: alphapsnsun (:) + real(r8) , pointer :: alphapsnsha (:) + + real(r8) :: sum_nscaler + real(r8) :: total_lai + integer :: nptreemax + + real(r8) :: dtime ! land model time step (sec) + integer :: g ! index +! MS Added + real(r8) , pointer :: sif (:) ! canopy layer: solar-induced fluorescence (W /m**2/) [always +] + real(r8) , pointer :: anet (:) ! canopy layer: net assimilation (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: fs (:) ! fluorescence yield at Fs [photon emitted photon absorbed-1 of PAR] + real(r8) , pointer :: ps (:) ! photochemical yield at Fs [photon emitted photon absorbed-1 of PAR] + real(r8) , pointer :: xsat (:) ! saturation used in fluorescence model (ja/qabs) +! real(r8) , pointer :: sif_z (:,:) ! canopy layer: solar-induced fluorescence (W /m**2/) [always +] +! real(r8) , pointer :: an_z (:,:) ! canopy layer: net assimilation (umol co2 /m**2/ s) [always +] + + ! Local variables + real(r8) :: ja ! electron transport rate as defined by Lee et al. 2015. (umol electrons/m**2/s) + real(r8) :: po0 ! dark adapted photochemical yield + real(r8) :: co2(bounds%begp:bounds%endp) ! partial pressure co2 (Pa) + real(r8) :: sif_z(bounds%begp:bounds%endp,nlevcan) ! canopy layer: solar-induced fluorescence (W /m**2/) [always +] + real(r8) :: an_z(bounds%begp:bounds%endp,nlevcan) ! canopy layer: net assimilation (umol co2 /m**2/ s) [always +] + real(r8) :: fs_z(bounds%begp:bounds%endp,nlevcan) ! canopy layer: fluorescence yield + real(r8) :: ps_z(bounds%begp:bounds%endp,nlevcan) ! canopy layer: photochemical yield + real(r8) :: xsat_z(bounds%begp:bounds%endp,nlevcan) ! canopy layer: light saturation + + real(r8) :: ci_z_downreg(bounds%begp:bounds%endp,nlevcan) ! downregulated intracellular leaf CO2 (Pa) + real(r8) :: sifcan ! canopy sum of sif_z + real(r8) :: ancan ! canopy sum of an_z + real(r8) :: fyieldcan ! canopy sum of fs_z + real(r8) :: pyieldcan ! canopy sum of ps_z + real(r8) :: xsatcan ! canopy sum of xsat_z + real(r8) :: gpp_downreg ! BMR 7/29/15 edit + real(r8) :: julday ! BMR 7/29/15 edit +! MS ends + !------------------------------------------------------------------------------ + + ! Temperature and soil water response functions + + ft(tl,ha) = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + fth(tl,hd,se,scaleFactor) = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + fth25(hd,se) = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + + ! Enforce expected array sizes + + SHR_ASSERT_ALL_FL((ubound(esat_tv) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(eair) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(oair) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(cair) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(rb) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(btran) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dayl_factor) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(leafn) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(downreg) == (/bounds%endp/)), sourcefile, __LINE__) ! MS Added + + associate( & + c3psn => pftcon%c3psn , & ! Input: photosynthetic pathway: 0. = c4, 1. = c3 + crop => pftcon%crop , & ! Input: crop or not (0 =not crop and 1 = crop) + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + flnr => pftcon%flnr , & ! Input: fraction of leaf N in the Rubisco enzyme (gN Rubisco / gN leaf) + fnitr => pftcon%fnitr , & ! Input: foliage nitrogen limitation factor (-) + slatop => pftcon%slatop , & ! Input: specific leaf area at top of canopy, projected area basis [m^2/gC] + dsladlai => pftcon%dsladlai , & ! Input: change in sla per unit lai + i_vcad => pftcon%i_vcad , & ! Input: [real(r8) (:) ] + s_vcad => pftcon%s_vcad , & ! Input: [real(r8) (:) ] + i_flnr => pftcon%i_flnr , & ! Input: [real(r8) (:) ] + s_flnr => pftcon%s_flnr , & ! Input: [real(r8) (:) ] + mbbopt => pftcon%mbbopt , & ! Input: [real(r8) (:) ] Ball-Berry slope of conduct/photosyn (umol H2O/umol CO2) + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + + t_veg => temperature_inst%t_veg_patch , & ! Input: [real(r8) (:) ] vegetation temperature (Kelvin) + t10 => temperature_inst%t_a10_patch , & ! Input: [real(r8) (:) ] 10-day running mean of the 2 m temperature (K) + tgcm => temperature_inst%thm_patch , & ! Input: [real(r8) (:) ] air temperature at agcm reference height (kelvin) + + nrad => surfalb_inst%nrad_patch , & ! Input: [integer (:) ] pft number of canopy layers, above snow for radiative transfer + tlai_z => surfalb_inst%tlai_z_patch , & ! Input: [real(r8) (:,:) ] pft total leaf area index for canopy layer + tlai => canopystate_inst%tlai_patch , & ! Input: [real(r8)(:) ] one-sided leaf area index, no burying by snow + c3flag => photosyns_inst%c3flag_patch , & ! Output: [logical (:) ] true if C3 and false if C4 + ac => photosyns_inst%ac_patch , & ! Output: [real(r8) (:,:) ] Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + aj => photosyns_inst%aj_patch , & ! Output: [real(r8) (:,:) ] RuBP-limited gross photosynthesis (umol CO2/m**2/s) + ap => photosyns_inst%ap_patch , & ! Output: [real(r8) (:,:) ] product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) + ag => photosyns_inst%ag_patch , & ! Output: [real(r8) (:,:) ] co-limited gross leaf photosynthesis (umol CO2/m**2/s) + an => photosyns_inst%an_patch , & ! Output: [real(r8) (:,:) ] net leaf photosynthesis (umol CO2/m**2/s) + gb_mol => photosyns_inst%gb_mol_patch , & ! Output: [real(r8) (:) ] leaf boundary layer conductance (umol H2O/m**2/s) + gs_mol => photosyns_inst%gs_mol_patch , & ! Output: [real(r8) (:,:) ] leaf stomatal conductance (umol H2O/m**2/s) + gs_mol_sun_ln => photosyns_inst%gs_mol_sun_ln_patch , & ! Output: [real(r8) (:,:) ] sunlit leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon (umol H2O/m**2/s) + gs_mol_sha_ln => photosyns_inst%gs_mol_sha_ln_patch , & ! Output: [real(r8) (:,:) ] shaded leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon (umol H2O/m**2/s) + vcmax_z => photosyns_inst%vcmax_z_patch , & ! Output: [real(r8) (:,:) ] maximum rate of carboxylation (umol co2/m**2/s) + cp => photosyns_inst%cp_patch , & ! Output: [real(r8) (:) ] CO2 compensation point (Pa) + kc => photosyns_inst%kc_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for CO2 (Pa) + ko => photosyns_inst%ko_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for O2 (Pa) + qe => photosyns_inst%qe_patch , & ! Output: [real(r8) (:) ] quantum efficiency, used only for C4 (mol CO2 / mol photons) + tpu_z => photosyns_inst%tpu_z_patch , & ! Output: [real(r8) (:,:) ] triose phosphate utilization rate (umol CO2/m**2/s) + kp_z => photosyns_inst%kp_z_patch , & ! Output: [real(r8) (:,:) ] initial slope of CO2 response curve (C4 plants) + bbb => photosyns_inst%bbb_patch , & ! Output: [real(r8) (:) ] Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + mbb => photosyns_inst%mbb_patch , & ! Output: [real(r8) (:) ] Ball-Berry slope of conductance-photosynthesis relationship + rh_leaf => photosyns_inst%rh_leaf_patch , & ! Output: [real(r8) (:) ] fractional humidity at leaf surface (dimensionless) + lnc => photosyns_inst%lnca_patch , & ! Output: [real(r8) (:) ] top leaf layer leaf N concentration (gN leaf/m^2) + light_inhibit=> photosyns_inst%light_inhibit , & ! Input: [logical ] flag if light should inhibit respiration + leafresp_method=> photosyns_inst%leafresp_method , & ! Input: [integer ] method type to use for leaf-maint.-respiration at 25C canopy top + stomatalcond_mtd=> photosyns_inst%stomatalcond_mtd , & ! Input: [integer ] method type to use for stomatal conductance.GC.fnlprmsn15_r22845 + leaf_mr_vcm => canopystate_inst%leaf_mr_vcm , & ! Input: [real(r8) ] scalar constant of leaf respiration with Vcmax +! MS added variables (bmr)-------- + forc_pco2 => atm2lnd_inst%forc_pco2_grc & ! Input: [real(r8) (:) ] partial pressure co2 (Pa) +! MS ends------------------------- + ) + + if (phase == 'sun') then + par_z => solarabs_inst%parsun_z_patch ! Input: [real(r8) (:,:) ] par absorbed per unit lai for canopy layer (w/m**2) + lai_z => canopystate_inst%laisun_z_patch ! Input: [real(r8) (:,:) ] leaf area index for canopy layer, sunlit or shaded + vcmaxcint => surfalb_inst%vcmaxcintsun_patch ! Input: [real(r8) (:) ] leaf to canopy scaling coefficient + alphapsn => photosyns_inst%alphapsnsun_patch ! Input: [real(r8) (:) ] 13C fractionation factor for PSN () + o3coefv => ozone_inst%o3coefvsun_patch ! Input: [real(r8) (:) ] O3 coefficient used in photosynthesis calculation + o3coefg => ozone_inst%o3coefgsun_patch ! Input: [real(r8) (:) ] O3 coefficient used in rs calculation + ci_z => photosyns_inst%cisun_z_patch ! Output: [real(r8) (:,:) ] intracellular leaf CO2 (Pa) + rs => photosyns_inst%rssun_patch ! Output: [real(r8) (:) ] leaf stomatal resistance (s/m) + rs_z => photosyns_inst%rssun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf stomatal resistance (s/m) + lmr => photosyns_inst%lmrsun_patch ! Output: [real(r8) (:) ] leaf maintenance respiration rate (umol CO2/m**2/s) + lmr_z => photosyns_inst%lmrsun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + psn => photosyns_inst%psnsun_patch ! Output: [real(r8) (:) ] foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_z => photosyns_inst%psnsun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wc => photosyns_inst%psnsun_wc_patch ! Output: [real(r8) (:) ] Rubisco-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wj => photosyns_inst%psnsun_wj_patch ! Output: [real(r8) (:) ] RuBP-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wp => photosyns_inst%psnsun_wp_patch ! Output: [real(r8) (:) ] product-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] +! MS added------------------------------- + sif => photosyns_inst%sifsun_patch ! Output: [real(r8) (:) ] canopy layer: solar-induced fluorescence (W /m**2/) [always +] + anet => photosyns_inst%anetsun_patch ! Output: [real(r8) (:) ] canopy layer: net assimilation (umol co2 /m**2/ s) [always +] + fs => photosyns_inst%fyieldsun_patch ! Output: [real(r8) (:) ] fluorescence yield at Fs [photon emitted photon absorbed-1 of PAR] + ps => photosyns_inst%pyieldsun_patch ! Output: [real(r8) (:) ] photochemical yield at Fs [photon emitted photon absorbed-1 of PAR] + xsat => photosyns_inst%xsatsun_patch ! Output: [real(r8) (:) ] light saturation used in fluorescence model (ja/qabs) +! sif_z => photosyns_inst%sif_z_sun_patch ! Output: [real(r8) (:,:) ] canopy layer: solar-induced fluorescence (W /m**2/) [always +] +! an_z => photosyns_inst%an_z_sun_patch ! Output: [real(r8) (:,:) ] canopy layer: net assimilation (umol co2 /m**2/ s) [always +] +! MS ends-------------------------------- + else if (phase == 'sha') then + par_z => solarabs_inst%parsha_z_patch ! Input: [real(r8) (:,:) ] par absorbed per unit lai for canopy layer (w/m**2) + lai_z => canopystate_inst%laisha_z_patch ! Input: [real(r8) (:,:) ] leaf area index for canopy layer, sunlit or shaded + vcmaxcint => surfalb_inst%vcmaxcintsha_patch ! Input: [real(r8) (:) ] leaf to canopy scaling coefficient + alphapsn => photosyns_inst%alphapsnsha_patch ! Input: [real(r8) (:) ] 13C fractionation factor for PSN () + o3coefv => ozone_inst%o3coefvsha_patch ! Input: [real(r8) (:) ] O3 coefficient used in photosynthesis calculation + o3coefg => ozone_inst%o3coefgsha_patch ! Input: [real(r8) (:) ] O3 coefficient used in rs calculation + ci_z => photosyns_inst%cisha_z_patch ! Output: [real(r8) (:,:) ] intracellular leaf CO2 (Pa) + rs => photosyns_inst%rssha_patch ! Output: [real(r8) (:) ] leaf stomatal resistance (s/m) + rs_z => photosyns_inst%rssha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf stomatal resistance (s/m) + lmr => photosyns_inst%lmrsha_patch ! Output: [real(r8) (:) ] leaf maintenance respiration rate (umol CO2/m**2/s) + lmr_z => photosyns_inst%lmrsha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + psn => photosyns_inst%psnsha_patch ! Output: [real(r8) (:) ] foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_z => photosyns_inst%psnsha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wc => photosyns_inst%psnsha_wc_patch ! Output: [real(r8) (:) ] Rubisco-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wj => photosyns_inst%psnsha_wj_patch ! Output: [real(r8) (:) ] RuBP-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wp => photosyns_inst%psnsha_wp_patch ! Output: [real(r8) (:) ] product-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] +! MS added------------------------------- + sif => photosyns_inst%sifsha_patch ! Output: [real(r8) (:) ] canopy layer: solar-induced fluorescence (W /m**2/) [always +] + anet => photosyns_inst%anetsha_patch ! Output: [real(r8) (:) ] canopy layer: net assimilation (umol co2 /m**2/ s) [always +] + fs => photosyns_inst%fyieldsha_patch ! Output: [real(r8) (:) ] fluorescence yield at Fs [photon emitted photon absorbed-1 of PAR] + ps => photosyns_inst%pyieldsha_patch ! Output: [real(r8) (:) ] photochemical yield at Fs [photon emitted photon absorbed-1 of PAR] + xsat => photosyns_inst%xsatsha_patch ! Output: [real(r8) (:) ] light saturation used in fluorescence model (ja/qabs) +! sif_z => photosyns_inst%sif_z_sha_patch ! Output: [real(r8) (:,:) ] canopy layer: solar-induced fluorescence (W /m**2/) [always +] +! an_z => photosyns_inst%an_z_sha_patch ! Output: [real(r8) (:,:) ] canopy layer: net assimilation (umol co2 /m**2/ s) [always +] +! MS ends-------------------------------- + end if + + !==============================================================================! + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + !==============================================================================! + + ! Determine seconds of current time step + + dtime = get_step_size_real() + + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 + + ! High temperature deactivation, from: + ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 + ! The factor "c" scales the deactivation to a value of 1.0 at 25C + + lmrc = fth25 (params_inst%lmrhd, params_inst%lmrse) + + ! Miscellaneous parameters, from Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + + do f = 1, fn + p = filterp(f) + c = patch%column(p) + g = patch%gridcell(p) ! MS added + + ! C3 or C4 photosynthesis logical variable + + if (nint(c3psn(patch%itype(p))) == 1) then + c3flag(p) = .true. + else if (nint(c3psn(patch%itype(p))) == 0) then + c3flag(p) = .false. + end if + + ! C3 and C4 dependent parameters + + if (c3flag(p)) then + qe(p) = 0._r8 + bbbopt(p) = 10000._r8 + else + qe(p) = 0.05_r8 + bbbopt(p) = 40000._r8 + end if + + ! Soil water stress applied to Ball-Berry parameters + + bbb(p) = max (bbbopt(p)*btran(p), 1._r8) + mbb(p) = mbbopt(patch%itype(p)) + + ! kc, ko, cp, from: Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! + ! kc25_coef = 404.9e-6 mol/mol + ! ko25_coef = 278.4e-3 mol/mol + ! cp25_yr2000 = 42.75e-6 mol/mol + ! + ! Derive sco from cp and O2 using present-day O2 (0.209 mol/mol) and re-calculate + ! cp to account for variation in O2 using cp = 0.5 O2 / sco + ! + + kc25 = params_inst%kc25_coef * forc_pbot(c) + ko25 = params_inst%ko25_coef * forc_pbot(c) + sco = 0.5_r8 * 0.209_r8 / params_inst%cp25_yr2000 + cp25 = 0.5_r8 * oair(p) / sco + + kc(p) = kc25 * ft(t_veg(p), params_inst%kcha) + ko(p) = ko25 * ft(t_veg(p), params_inst%koha) + cp(p) = cp25 * ft(t_veg(p), params_inst%cpha) + + end do + + ! Multi-layer parameters scaled by leaf nitrogen profile. + ! Loop through each canopy layer to calculate nitrogen profile using + ! cumulative lai at the midpoint of the layer + + do f = 1, fn + p = filterp(f) + + if (lnc_opt .eqv. .false.) then + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) + + if ( (slatop(patch%itype(p)) *leafcn(patch%itype(p))) .le. 0.0_r8)then + call endrun( "ERROR: slatop or leafcn is zero" ) + end if + lnc(p) = 1._r8 / (slatop(patch%itype(p)) * leafcn(patch%itype(p))) + end if + + ! Using the actual nitrogen allocated to the leaf after + ! uptake rather than fixing leaf nitrogen based on SLA and CN + ! ratio + if (lnc_opt .eqv. .true.) then + ! nlevcan and nrad(p) look like the same variable ?? check this later + sum_nscaler = 0.0_r8 + laican = 0.0_r8 + total_lai = 0.0_r8 + + do iv = 1, nrad(p) + + if (iv == 1) then + laican = 0.5_r8 * tlai_z(p,iv) + total_lai = tlai_z(p,iv) + else + laican = laican + 0.5_r8 * (tlai_z(p,iv-1)+tlai_z(p,iv)) + total_lai = total_lai + tlai_z(p,iv) + end if + + ! Scale for leaf nitrogen profile. If multi-layer code, use explicit + ! profile. If sun/shade big leaf code, use canopy integrated factor. + if (nlevcan == 1) then + nscaler = 1.0_r8 + else if (nlevcan > 1) then + nscaler = exp(-kn(p) * laican) + end if + + sum_nscaler = sum_nscaler + nscaler + + end do + + if (tlai(p) > 0.0_r8 .AND. sum_nscaler > 0.0_r8) then + ! dividing by LAI to convert total leaf nitrogen + ! from m2 ground to m2 leaf; dividing by sum_nscaler to + ! convert total leaf N to leaf N at canopy top + lnc(p) = leafn(p) / (tlai(p) * sum_nscaler) + else + lnc(p) = 0.0_r8 + end if + + end if + + + ! reduce_dayl_factor .eqv. .false. + if (reduce_dayl_factor .eqv. .true.) then + if (dayl_factor(p) > 0.25_r8) then + ! dayl_factor(p) = 1.0_r8 + end if + end if + + + ! Default + if (vcmax_opt == 0) then + ! vcmax25 at canopy top, as in CN but using lnc at top of the canopy + vcmax25top = lnc(p) * flnr(patch%itype(p)) * params_inst%fnr * params_inst%act25 * dayl_factor(p) + if (.not. use_cn) then + vcmax25top = vcmax25top * fnitr(patch%itype(p)) + else + if ( CNAllocate_Carbon_only() ) vcmax25top = vcmax25top * fnitr(patch%itype(p)) + end if + else if (vcmax_opt == 3) then + vcmax25top = ( i_vcad(patch%itype(p)) + s_vcad(patch%itype(p)) * lnc(p) ) * dayl_factor(p) + else if (vcmax_opt == 4) then + nptreemax = 9 ! is this number correct? check later + if (patch%itype(p) >= nptreemax) then ! if not tree + ! for shrubs and herbs + vcmax25top = lnc(p) * ( i_flnr(patch%itype(p)) + s_flnr(patch%itype(p)) * lnc(p) ) * params_inst%fnr * params_inst%act25 * & + dayl_factor(p) + else + ! if tree + vcmax25top = lnc(p) * ( i_flnr(patch%itype(p)) * exp(s_flnr(patch%itype(p)) * lnc(p)) ) * params_inst%fnr * params_inst%act25 * & + dayl_factor(p) + ! for trees + end if + end if + + + ! Parameters derived from vcmax25top. Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + ! used jmax25 = 1.97 vcmax25, from Wullschleger (1993) Journal of Experimental Botany 44:907-920. + + jmax25top = (2.59_r8 - 0.035_r8*min(max((t10(p)-tfrz),11._r8),35._r8)) * vcmax25top + tpu25top = params_inst%tpu25ratio * vcmax25top + kp25top = params_inst%kp25ratio * vcmax25top + + ! Nitrogen scaling factor. Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used + ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al (2010) Biogeosciences, 7, 1833-1859 + ! Remove daylength factor from vcmax25 so that kn is based on maximum vcmax25 + ! But not used as defined here if using sun/shade big leaf code. Instead, + ! will use canopy integrated scaling factors from SurfaceAlbedo. + + if (dayl_factor(p) < 1.0e-12_r8) then + kn(p) = 0._r8 + else + kn(p) = exp(0.00963_r8 * vcmax25top/dayl_factor(p) - 2.43_r8) + end if + + if (use_cn) then + if ( leafresp_method == leafresp_mtd_ryan1991 ) then + ! Leaf maintenance respiration to match the base rate used in CN + ! but with the new temperature functions for C3 and C4 plants. + ! + ! Base rate for maintenance respiration is from: + ! M. Ryan, 1991. Effects of climate change on plant respiration. + ! Ecological Applications, 1(2), 157-167. + ! Original expression is br = 0.0106 molC/(molN h) + ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) + ! + ! Base rate is at 20C. Adjust to 25C using the CN Q10 = 1.5 + ! + ! CN respiration has units: g C / g N [leaf] / s. This needs to be + ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s + ! + ! Then scale this value at the top of the canopy for canopy depth + + lmr25top = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) + lmr25top = lmr25top * lnc(p) / 12.e-06_r8 + + else if ( leafresp_method == leafresp_mtd_atkin2015 ) then + !using new form for respiration base rate from Atkin + !communication. + if ( lnc(p) > 0.0_r8 ) then + lmr25top = params_inst%lmr_intercept_atkin(ivt(p)) + (lnc(p) * 0.2061_r8) - (0.0402_r8 * (t10(p)-tfrz)) + else + lmr25top = 0.0_r8 + end if + end if + + else + ! Leaf maintenance respiration in proportion to vcmax25top + + if (c3flag(p)) then + lmr25top = vcmax25top * leaf_mr_vcm + else + lmr25top = vcmax25top * 0.025_r8 + end if + end if + + ! Loop through canopy layers (above snow). Respiration needs to be + ! calculated every timestep. Others are calculated only if daytime + + laican = 0._r8 + do iv = 1, nrad(p) + + ! Cumulative lai at middle of layer + + if (iv == 1) then + laican = 0.5_r8 * tlai_z(p,iv) + else + laican = laican + 0.5_r8 * (tlai_z(p,iv-1)+tlai_z(p,iv)) + end if + + ! Scale for leaf nitrogen profile. If multi-layer code, use explicit + ! profile. If sun/shade big leaf code, use canopy integrated factor. + + if (nlevcan == 1) then + nscaler = vcmaxcint(p) + else if (nlevcan > 1) then + nscaler = exp(-kn(p) * laican) + end if + + ! Maintenance respiration + + lmr25 = lmr25top * nscaler + + if(use_luna.and.c3flag(p).and.crop(patch%itype(p))== 0) then + if(.not.use_cn)then ! If CN is on, use leaf N to predict respiration (above). Otherwise, use Vcmax term from LUNA. RF + lmr25 = leaf_mr_vcm * photosyns_inst%vcmx25_z_patch(p,iv) + endif + endif + + if (c3flag(p)) then + lmr_z(p,iv) = lmr25 * ft(t_veg(p), params_inst%lmrha) * fth(t_veg(p), params_inst%lmrhd, & + params_inst%lmrse, lmrc) + else + lmr_z(p,iv) = lmr25 * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + lmr_z(p,iv) = lmr_z(p,iv) / (1._r8 + exp( 1.3_r8*(t_veg(p)-(tfrz+55._r8)) )) + end if + + if (par_z(p,iv) <= 0._r8) then ! night time + + vcmax_z(p,iv) = 0._r8 + jmax_z(p,iv) = 0._r8 + tpu_z(p,iv) = 0._r8 + kp_z(p,iv) = 0._r8 + + if ( use_c13 ) then + alphapsn(p) = 1._r8 + end if + + else ! day time + + if(use_luna.and.c3flag(p).and.crop(patch%itype(p))== 0)then + vcmax25 = photosyns_inst%vcmx25_z_patch(p,iv) + jmax25 = photosyns_inst%jmx25_z_patch(p,iv) + tpu25 = params_inst%tpu25ratio * vcmax25 + !Implement scaling of Vcmax25 from sunlit average to shaded canopy average value. RF & GBB. 1 July 2016 + if(phase == 'sha'.and.surfalb_inst%vcmaxcintsun_patch(p).gt.0._r8.and.nlevcan==1) then + vcmax25 = vcmax25 * surfalb_inst%vcmaxcintsha_patch(p)/surfalb_inst%vcmaxcintsun_patch(p) + jmax25 = jmax25 * surfalb_inst%vcmaxcintsha_patch(p)/surfalb_inst%vcmaxcintsun_patch(p) + tpu25 = tpu25 * surfalb_inst%vcmaxcintsha_patch(p)/surfalb_inst%vcmaxcintsun_patch(p) + end if + + else + vcmax25 = vcmax25top * nscaler + jmax25 = jmax25top * nscaler + tpu25 = tpu25top * nscaler + endif + kp25 = kp25top * nscaler + + ! Adjust for temperature + + vcmaxse = 668.39_r8 - 1.07_r8 * min(max((t10(p)-tfrz),11._r8),35._r8) + jmaxse = 659.70_r8 - 0.75_r8 * min(max((t10(p)-tfrz),11._r8),35._r8) + tpuse = vcmaxse + vcmaxc = fth25 (params_inst%vcmaxhd, vcmaxse) + jmaxc = fth25 (params_inst%jmaxhd, jmaxse) + tpuc = fth25 (params_inst%tpuhd, tpuse) + vcmax_z(p,iv) = vcmax25 * ft(t_veg(p), params_inst%vcmaxha) * fth(t_veg(p), & + params_inst%vcmaxhd, vcmaxse, vcmaxc) + jmax_z(p,iv) = jmax25 * ft(t_veg(p), params_inst%jmaxha) * fth(t_veg(p), & + params_inst%jmaxhd, jmaxse, jmaxc) + tpu_z(p,iv) = tpu25 * ft(t_veg(p), params_inst%tpuha) * fth(t_veg(p), params_inst%tpuhd, tpuse, tpuc) + + if (.not. c3flag(p)) then + vcmax_z(p,iv) = vcmax25 * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + vcmax_z(p,iv) = vcmax_z(p,iv) / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-t_veg(p)) )) + vcmax_z(p,iv) = vcmax_z(p,iv) / (1._r8 + exp( 0.3_r8*(t_veg(p)-(tfrz+40._r8)) )) + end if + + kp_z(p,iv) = kp25 * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + + end if + + ! Adjust for soil water + + vcmax_z(p,iv) = vcmax_z(p,iv) * btran(p) + lmr_z(p,iv) = lmr_z(p,iv) * btran(p) + + ! Change to add in light inhibition of respiration. 0.67 from Lloyd et al. 2010, & Metcalfe et al. 2012 + ! Also pers. comm from Peter Reich (Nov 2015). Might potentially be updated pending findings of Atkin et al. (in prep) + ! review of light inhibition database. + if ( light_inhibit .and. par_z(p,1) > 0._r8) then ! are the lights on? + lmr_z(p,iv) = lmr_z(p,iv) * 0.67_r8 ! inhibit respiration accordingly. + end if + + end do ! canopy layer loop + end do ! patch loop + + !==============================================================================! + ! Leaf-level photosynthesis and stomatal conductance + !==============================================================================! + + rsmax0 = 2.e4_r8 + + do f = 1, fn + p = filterp(f) + c = patch%column(p) + g = patch%gridcell(p) + + ! Leaf boundary layer conductance, umol/m**2/s + + cf = forc_pbot(c)/(rgas*1.e-3_r8*tgcm(p))*1.e06_r8 + gb = 1._r8/rb(p) + gb_mol(p) = gb * cf + + ! Loop through canopy layers (above snow). Only do calculations if daytime + + do iv = 1, nrad(p) + + if (par_z(p,iv) <= 0._r8) then ! night time + + ac(p,iv) = 0._r8 + aj(p,iv) = 0._r8 + ap(p,iv) = 0._r8 + ag(p,iv) = 0._r8 + an(p,iv) = ag(p,iv) - lmr_z(p,iv) + psn_z(p,iv) = 0._r8 + psn_wc_z(p,iv) = 0._r8 + psn_wj_z(p,iv) = 0._r8 + psn_wp_z(p,iv) = 0._r8 + rs_z(p,iv) = min(rsmax0, 1._r8/bbb(p) * cf) + ci_z(p,iv) = 0._r8 + rh_leaf(p) = 0._r8 +! MS added & based on the code from LJE, XY & BMR------------- + sif_z(p,iv) = 0._r8 + an_z(p,iv) = 0._r8 + fs_z(p,iv) = 0._r8 + ps_z(p,iv) = 0._r8 + xsat_z(p,iv)= 0._r8 + fs(p) = 0._r8 ! All yields and light saturation go to zero at night + ps(p) = 0._r8 + xsat(p) = 0._r8 +! MS ends-------------------------------------------------------------- + else ! day time + + !now the constraint is no longer needed, Jinyun Tang + ceair = min( eair(p), esat_tv(p) ) + if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + rh_can = ceair / esat_tv(p) + else if ( stomatalcond_mtd == stomatalcond_mtd_medlyn2011 )then + ! Put some constraints on RH in the canopy when Medlyn stomatal conductance is being used + rh_can = max((esat_tv(p) - ceair), 50._r8) * 0.001_r8 + end if + + ! Electron transport rate for C3 plants. Convert par from W/m2 to + ! umol photons/m**2/s using the factor 4.6 + + qabs = 0.5_r8 * (1._r8 - params_inst%fnps) * par_z(p,iv) * 4.6_r8 + aquad = params_inst%theta_psii + bquad = -(qabs + jmax_z(p,iv)) + cquad = qabs * jmax_z(p,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + je = min(r1,r2) + + ! Iterative loop for ci beginning with initial guess + + if (c3flag(p)) then + ci_z(p,iv) = 0.7_r8 * cair(p) + else + ci_z(p,iv) = 0.4_r8 * cair(p) + end if + + niter = 0 + + ! Increment iteration counter. Stop if too many iterations + + niter = niter + 1 + + ! Save old ci + + ciold = ci_z(p,iv) + + !find ci and stomatal conductance + call hybrid(ciold, p, iv, c, gb_mol(p), je, cair(p), oair(p), & + lmr_z(p,iv), par_z(p,iv), rh_can, gs_mol(p,iv), niter, & + atm2lnd_inst, photosyns_inst) + + ! End of ci iteration. Check for an < 0, in which case gs_mol = bbb + + if (an(p,iv) < 0._r8) gs_mol(p,iv) = bbb(p) + + ! Use time period 1 hour before and 1 hour after local noon inclusive (11AM-1PM) + if ( is_near_local_noon( grc%londeg(g), deltasec=3600 ) )then + if (phase == 'sun') then + gs_mol_sun_ln(p,iv) = gs_mol(p,iv) + else if (phase == 'sha') then + gs_mol_sha_ln(p,iv) = gs_mol(p,iv) + end if + else + if (phase == 'sun') then + gs_mol_sun_ln(p,iv) = spval + else if (phase == 'sha') then + gs_mol_sha_ln(p,iv) = spval + end if + end if + + ! Final estimates for cs and ci (needed for early exit of ci iteration when an < 0) + + cs = cair(p) - 1.4_r8/gb_mol(p) * an(p,iv) * forc_pbot(c) + cs = max(cs,1.e-06_r8) + ci_z(p,iv) = cair(p) - an(p,iv) * forc_pbot(c) * (1.4_r8*gs_mol(p,iv)+1.6_r8*gb_mol(p)) / (gb_mol(p)*gs_mol(p,iv)) + + ! Trap for values of ci_z less than 1.e-06. This is needed for + ! Megan (which can crash with negative values) + ci_z(p,iv) = max( ci_z(p,iv), 1.e-06_r8 ) + + ! Convert gs_mol (umol H2O/m**2/s) to gs (m/s) and then to rs (s/m) + + gs = gs_mol(p,iv) / cf + rs_z(p,iv) = min(1._r8/gs, rsmax0) + rs_z(p,iv) = rs_z(p,iv) / o3coefg(p) + + ! Photosynthesis. Save rate-limiting photosynthesis + + psn_z(p,iv) = ag(p,iv) + psn_z(p,iv) = psn_z(p,iv) * o3coefv(p) + + psn_wc_z(p,iv) = 0._r8 + psn_wj_z(p,iv) = 0._r8 + psn_wp_z(p,iv) = 0._r8 + + an_z(p,iv) = ag(p,iv)-lmr_z(p,iv) ! MS included + + if (ac(p,iv) <= aj(p,iv) .and. ac(p,iv) <= ap(p,iv)) then + psn_wc_z(p,iv) = psn_z(p,iv) + else if (aj(p,iv) < ac(p,iv) .and. aj(p,iv) <= ap(p,iv)) then + psn_wj_z(p,iv) = psn_z(p,iv) + else if (ap(p,iv) < ac(p,iv) .and. ap(p,iv) < aj(p,iv)) then + psn_wp_z(p,iv) = psn_z(p,iv) + end if + +! MS added into CLM5 and based on the code from LJE, XY & BMR -------------------- + + po0 = 1._r8-params_inst%fnps ! Defining dark adapted max photochemical yield + + if(c3flag(p)) then + + ! Original potential Ja without nitrogen downscaling + ! ja= max(4._r8*psn_z(p,iv)*(ci_z(p,iv)+2._r8*cp(p))/(ci_z(p,iv)-cp(p)), 0._r8) ! Lee et al. (2015) (umol electrons m-2 s-1) + + ! BMR Start actual Ja that includes nitrogen downscaling + + co2(p) = forc_pco2(g) + + ci_z_downreg(p,iv) = co2(p) - ((an(p,iv) * (1._r8-downreg(p))) * forc_pbot(g) * & + (1.4_r8*gs_mol(p,iv)+1.6_r8*gb_mol(p)) / (gb_mol(p)*gs_mol(p,iv))) ! Following subroutine Fractionation + + ja= max(psn_z(p,iv)*(1._r8-downreg(p))*(ci_z_downreg(p,iv)+2._r8*cp(p))/(ci_z_downreg(p,iv)-cp(p)), 0._r8) ! (umol electrons m-2 s-1) + + ! BMR End actual Ja that includes nitrogen downscaling + + xsat_z(p,iv)= ja/qabs + ps_z(p,iv) = xsat_z(p,iv)*po0 + else + ps_z(p,iv) = psn_z(p,iv)/aj(p,iv)*po0 + + end if + + + if (psn_z(p,iv) <= 0._r8) xsat_z(p,iv)=0._r8 + call fluorescence(ps_z(p,iv),po0,fs_z(p,iv)) + + sif_z(p,iv) = fs_z(p,iv) * par_z(p,iv) ! (W m-2) = (photon absorbed photon emitted of PAR)*(W m-2) + ! (W m-2) = (W W-1)*(W m-2) equivalent expression for fluorescence yield +!-----MS ends -------------------------------------------------------------------- + ! Make sure iterative solution is correct + + if (gs_mol(p,iv) < 0._r8) then + write (iulog,*)'Negative stomatal conductance:' + write (iulog,*)'p,iv,gs_mol= ',p,iv,gs_mol(p,iv) + call endrun(decomp_index=p, clmlevel=namep, msg=errmsg(sourcefile, __LINE__)) + end if + + ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b + + hs = (gb_mol(p)*ceair + gs_mol(p,iv)*esat_tv(p)) / ((gb_mol(p)+gs_mol(p,iv))*esat_tv(p)) + rh_leaf(p) = hs + gs_mol_err = mbb(p)*max(an(p,iv), 0._r8)*hs/cs*forc_pbot(c) + bbb(p) + + if (abs(gs_mol(p,iv)-gs_mol_err) > 1.e-01_r8) then + write (iulog,*) 'Ball-Berry error check - stomatal conductance error:' + write (iulog,*) gs_mol(p,iv), gs_mol_err + end if + + end if ! night or day if branch + end do ! canopy layer loop + end do ! patch loop + + !==============================================================================! + ! Canopy photosynthesis and stomatal conductance + !==============================================================================! + + ! Sum canopy layer fluxes and then derive effective leaf-level fluxes (per + ! unit leaf area), which are used in other parts of the model. Here, laican + ! sums to either laisun or laisha. + + do f = 1, fn + p = filterp(f) + + psncan = 0._r8 + psncan_wc = 0._r8 + psncan_wj = 0._r8 + psncan_wp = 0._r8 + lmrcan = 0._r8 + gscan = 0._r8 + laican = 0._r8 +! MS added the code from LJE & XY & BMR------------- + sifcan = 0._r8 + ancan = 0._r8 + fyieldcan = 0._r8 + pyieldcan = 0._r8 + xsatcan = 0._r8 +! MS ends ------------------------------------------ + do iv = 1, nrad(p) + psncan = psncan + psn_z(p,iv) * lai_z(p,iv) + psncan_wc = psncan_wc + psn_wc_z(p,iv) * lai_z(p,iv) + psncan_wj = psncan_wj + psn_wj_z(p,iv) * lai_z(p,iv) + psncan_wp = psncan_wp + psn_wp_z(p,iv) * lai_z(p,iv) + lmrcan = lmrcan + lmr_z(p,iv) * lai_z(p,iv) + gscan = gscan + lai_z(p,iv) / (rb(p)+rs_z(p,iv)) + laican = laican + lai_z(p,iv) +! MS added the code from LJE, XY & BMR--------------------------- + sifcan = sifcan + sif_z(p,iv) * lai_z(p,iv) + ancan = ancan + an_z(p,iv) * lai_z(p,iv) + fyieldcan = fyieldcan + fs_z(p,iv) * lai_z(p,iv) + pyieldcan = pyieldcan + ps_z(p,iv) * lai_z(p,iv) + xsatcan = xsatcan + xsat_z(p,iv)* lai_z(p,iv) +! MS ends-------------------------------------------------------- + end do + if (laican > 0._r8) then + psn(p) = psncan / laican + psn_wc(p) = psncan_wc / laican + psn_wj(p) = psncan_wj / laican + psn_wp(p) = psncan_wp / laican + lmr(p) = lmrcan / laican + rs(p) = laican / gscan - rb(p) +! MS added the code from LJE, XY & BMR-------------Per leaf area basis for sunlit or shaded layer---- + sif(p) = sifcan / laican + anet(p) = ancan / laican + fs(p) = fyieldcan / laican + ps(p) = pyieldcan / laican + xsat(p) = xsatcan / laican +! MS ends------------------------------------------------------------------------------------------- + else + psn(p) = 0._r8 + psn_wc(p) = 0._r8 + psn_wj(p) = 0._r8 + psn_wp(p) = 0._r8 + lmr(p) = 0._r8 + rs(p) = 0._r8 +! MS added the code from LJE, XY & BMR------------- + sif(p) = 0._r8 + anet(p)= 0._r8 ! BMR 8/6/15 + fs(p) = 0._r8 + ps(p) = 0._r8 + xsat(p)= 0._r8 +! MS ends------------------------------------------ + end if + end do + + end associate + + end subroutine Photosynthesis + + !------------------------------------------------------------------------------ + subroutine PhotosynthesisTotal (fn, filterp, & + atm2lnd_inst, canopystate_inst, photosyns_inst) + ! + ! Determine total photosynthesis + ! + ! !ARGUMENTS: + integer , intent(in) :: fn ! size of pft filter + integer , intent(in) :: filterp(fn) ! patch filter + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + ! + ! !LOCAL VARIABLES: + integer :: f,fp,p,l,g ! indices + + real(r8) :: rc14_atm(nsectors_c14), rc13_atm + integer :: sector_c14 + !----------------------------------------------------------------------- + + associate( & + forc_pco2 => atm2lnd_inst%forc_pco2_grc , & ! Input: [real(r8) (:) ] partial pressure co2 (Pa) + forc_pc13o2 => atm2lnd_inst%forc_pc13o2_grc , & ! Input: [real(r8) (:) ] partial pressure c13o2 (Pa) + forc_po2 => atm2lnd_inst%forc_po2_grc , & ! Input: [real(r8) (:) ] partial pressure o2 (Pa) + + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit leaf area + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded leaf area + + psnsun => photosyns_inst%psnsun_patch , & ! Input: [real(r8) (:) ] sunlit leaf photosynthesis (umol CO2 /m**2/ s) + psnsha => photosyns_inst%psnsha_patch , & ! Input: [real(r8) (:) ] shaded leaf photosynthesis (umol CO2 /m**2/ s) + rc13_canair => photosyns_inst%rc13_canair_patch , & ! Output: [real(r8) (:) ] C13O2/C12O2 in canopy air + rc13_psnsun => photosyns_inst%rc13_psnsun_patch , & ! Output: [real(r8) (:) ] C13O2/C12O2 in sunlit canopy psn flux + rc13_psnsha => photosyns_inst%rc13_psnsha_patch , & ! Output: [real(r8) (:) ] C13O2/C12O2 in shaded canopy psn flux + alphapsnsun => photosyns_inst%alphapsnsun_patch , & ! Output: [real(r8) (:) ] fractionation factor in sunlit canopy psn flux + alphapsnsha => photosyns_inst%alphapsnsha_patch , & ! Output: [real(r8) (:) ] fractionation factor in shaded canopy psn flux + psnsun_wc => photosyns_inst%psnsun_wc_patch , & ! Output: [real(r8) (:) ] Rubsico-limited sunlit leaf photosynthesis (umol CO2 /m**2/ s) + psnsun_wj => photosyns_inst%psnsun_wj_patch , & ! Output: [real(r8) (:) ] RuBP-limited sunlit leaf photosynthesis (umol CO2 /m**2/ s) + psnsun_wp => photosyns_inst%psnsun_wp_patch , & ! Output: [real(r8) (:) ] product-limited sunlit leaf photosynthesis (umol CO2 /m**2/ s) + psnsha_wc => photosyns_inst%psnsha_wc_patch , & ! Output: [real(r8) (:) ] Rubsico-limited shaded leaf photosynthesis (umol CO2 /m**2/ s) + psnsha_wj => photosyns_inst%psnsha_wj_patch , & ! Output: [real(r8) (:) ] RuBP-limited shaded leaf photosynthesis (umol CO2 /m**2/ s) + psnsha_wp => photosyns_inst%psnsha_wp_patch , & ! Output: [real(r8) (:) ] product-limited shaded leaf photosynthesis (umol CO2 /m**2/ s) + c13_psnsun => photosyns_inst%c13_psnsun_patch , & ! Output: [real(r8) (:) ] sunlit leaf photosynthesis (umol 13CO2 /m**2/ s) + c13_psnsha => photosyns_inst%c13_psnsha_patch , & ! Output: [real(r8) (:) ] shaded leaf photosynthesis (umol 13CO2 /m**2/ s) + c14_psnsun => photosyns_inst%c14_psnsun_patch , & ! Output: [real(r8) (:) ] sunlit leaf photosynthesis (umol 14CO2 /m**2/ s) + c14_psnsha => photosyns_inst%c14_psnsha_patch , & ! Output: [real(r8) (:) ] shaded leaf photosynthesis (umol 14CO2 /m**2/ s) + fpsn => photosyns_inst%fpsn_patch , & ! Output: [real(r8) (:) ] photosynthesis (umol CO2 /m**2 /s) + fpsn_wc => photosyns_inst%fpsn_wc_patch , & ! Output: [real(r8) (:) ] Rubisco-limited photosynthesis (umol CO2 /m**2 /s) + fpsn_wj => photosyns_inst%fpsn_wj_patch , & ! Output: [real(r8) (:) ] RuBP-limited photosynthesis (umol CO2 /m**2 /s) + fpsn_wp => photosyns_inst%fpsn_wp_patch , & ! Output: [real(r8) (:) ] product-limited photosynthesis (umol CO2 /m**2 /s) +! MS added -------------------------------------------------------------------------------------- + fsif => photosyns_inst%fsif_patch , & ! Output: [real(r8) (:) ] canopy layer: solar-induced fluorescence (W /m**2/) [always +] + fan => photosyns_inst%fan_patch , & ! Output: [real(r8) (:) ] net assimilation (umol CO2 /m**2 /s) + fyield => photosyns_inst%fyield_patch , & ! Output: [real(r8) (:) ] fluorescence yield at Fs [photon emitted photon absorbed-1 of PAR] + pyield => photosyns_inst%pyield_patch , & ! Output: [real(r8) (:) ] photochemical yield at Fs [photon emitted photon absorbed-1 of PAR] + fxsat => photosyns_inst%fxsat_patch , & ! Output: [real(r8) (:) ] + sifsun => photosyns_inst%sifsun_patch , & ! Output: [real(r8) (:) ] canopy sun-lid layer: solar-induced fluorescence (W /m**2/) [always +] + sifsha => photosyns_inst%sifsha_patch , & ! Output: [real(r8) (:) ] canopy shaded layer: solar-induced fluorescence (W /m**2/) [always +] + anetsun => photosyns_inst%anetsun_patch , & ! Output: [real(r8) (:) ] canopy sun-lid layer: net assimilation (umol CO2 /m**2 /s) + anetsha => photosyns_inst%anetsha_patch , & ! Output: [real(r8) (:) ] canopy shaded layer: net assimilation (umol CO2 /m**2 /s) + fyieldsun => photosyns_inst%fyieldsun_patch , & ! Output: [real(r8) (:) ] canopy sun-lid fluorescence yield at Fs [photon emitted photon absorbed-1 of PAR] + fyieldsha => photosyns_inst%fyieldsha_patch , & ! Output: [real(r8) (:) ] canopy shaded fluorescence yield at Fs [photon emitted photon absorbed-1 of PAR] + pyieldsun => photosyns_inst%pyieldsun_patch , & ! Output: [real(r8) (:) ] canopy sun-lid photochemical yield at Fs [photon emitted photon absorbed-1 of PAR] + pyieldsha => photosyns_inst%pyieldsha_patch , & ! Output: [real(r8) (:) ] canopy shaded photochemical yield at Fs [photon emitted photon absorbed-1 of PAR] + xsatsun => photosyns_inst%xsatsun_patch , & ! Output: [real(r8) (:) ] sun-lid light saturation used in fluorescence model (ja/qabs) + xsatsha => photosyns_inst%xsatsha_patch , & ! Output: [real(r8) (:) ] shaded light saturation used in fluorescence model (ja/qabs) + elai => canopystate_inst%elai_patch & ! Input: [real(r8) (:) ] one-sided leaf area index with burying by snow + ) + + if ( use_c14 ) then + if (use_c14_bombspike) then + call C14BombSpike(rc14_atm) + else + rc14_atm(:) = c14ratio + end if + end if + + if ( use_c13 ) then + if (use_c13_timeseries) then + call C13TimeSeries(rc13_atm) + end if + end if + + do f = 1, fn + p = filterp(f) + g = patch%gridcell(p) + + if (.not. use_fates) then + fpsn(p) = psnsun(p) *laisun(p) + psnsha(p) *laisha(p) + fpsn_wc(p) = psnsun_wc(p)*laisun(p) + psnsha_wc(p)*laisha(p) + fpsn_wj(p) = psnsun_wj(p)*laisun(p) + psnsha_wj(p)*laisha(p) + fpsn_wp(p) = psnsun_wp(p)*laisun(p) + psnsha_wp(p)*laisha(p) +! MS added ------------------------------------------------------------------------------------------------------------- + fsif(p) = sifsun(p) *laisun(p) + sifsha(p) *laisha(p) + fan(p) = anetsun(p) *laisun(p) + anetsha(p) *laisha(p) + !bmr ***** Calculating sun/shaded weighted version of fyield and pyield for diagnosis + if (elai(p) > 0._r8) then + fyield(p) = (laisun(p)*fyieldsun(p) + laisha(p)*fyieldsha(p))/ max(elai(p), 0.01_r8) + pyield(p) = (laisun(p)*pyieldsun(p) + laisha(p)*pyieldsha(p))/ max(elai(p), 0.01_r8) + fxsat(p) = (laisun(p)*xsatsun(p) + laisha(p)*xsatsha(p))/ max(elai(p), 0.01_r8) + else + fyield(p) = 0._r8 + pyield(p) = 0._r8 + fxsat(p) = 0._r8 + end if +! MS ends ----------------------------------------------------The C13 related part from BMR is not included ------------ + end if + + if (use_cn) then + if ( use_c13 ) then + if (use_c13_timeseries) then + rc13_canair(p) = rc13_atm + else + rc13_canair(p) = forc_pc13o2(g)/(forc_pco2(g) - forc_pc13o2(g)) + endif + rc13_psnsun(p) = rc13_canair(p)/alphapsnsun(p) + rc13_psnsha(p) = rc13_canair(p)/alphapsnsha(p) + c13_psnsun(p) = psnsun(p) * (rc13_psnsun(p)/(1._r8+rc13_psnsun(p))) + c13_psnsha(p) = psnsha(p) * (rc13_psnsha(p)/(1._r8+rc13_psnsha(p))) + + ! use fixed c13 ratio with del13C of -25 to test the overall c13 structure + ! c13_psnsun(p) = 0.01095627 * psnsun(p) + ! c13_psnsha(p) = 0.01095627 * psnsha(p) + endif + if ( use_c14 ) then + + ! determine latitute sector for radiocarbon bomb spike inputs + if ( grc%latdeg(g) .ge. 30._r8 ) then + sector_c14 = 1 + else if ( grc%latdeg(g) .ge. -30._r8 ) then + sector_c14 = 2 + else + sector_c14 = 3 + endif + + c14_psnsun(p) = rc14_atm(sector_c14) * psnsun(p) + c14_psnsha(p) = rc14_atm(sector_c14) * psnsha(p) + endif + end if + + end do + + end associate + + end subroutine PhotosynthesisTotal + + !------------------------------------------------------------------------------ + subroutine Fractionation(bounds, fn, filterp, downreg, & + atm2lnd_inst, canopystate_inst, solarabs_inst, surfalb_inst, photosyns_inst, & + phase) + ! + ! !DESCRIPTION: + ! C13 fractionation during photosynthesis is calculated here after the nitrogen + ! limitation is taken into account in the CNAllocation module. + ! + ! As of CLM5, nutrient downregulation occurs prior to photosynthesis via leafcn, so we may + ! ignore the downregulation term in this and assume that the Ci/Ca used in the photosynthesis + ! calculation is consistent with that in the isotope calculation + ! + !!USES: + use clm_varctl , only : use_hydrstress + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: fn ! size of pft filter + integer , intent(in) :: filterp(fn) ! patch filter + real(r8) , intent(in) :: downreg( bounds%begp: ) ! fractional reduction in GPP due to N limitation (dimensionless) + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(solarabs_type) , intent(in) :: solarabs_inst + type(surfalb_type) , intent(in) :: surfalb_inst + type(photosyns_type) , intent(in) :: photosyns_inst + character(len=*) , intent(in) :: phase ! 'sun' or 'sha' + ! + ! !LOCAL VARIABLES: + real(r8) , pointer :: par_z (:,:) ! needed for backwards compatiblity + real(r8) , pointer :: alphapsn (:) ! needed for backwards compatiblity + real(r8) , pointer :: gs_mol(:,:) ! leaf stomatal conductance (umol H2O/m**2/s) + real(r8) , pointer :: an(:,:) ! net leaf photosynthesis (umol CO2/m**2/s) + integer :: f,p,c,g,iv ! indices + real(r8) :: co2(bounds%begp:bounds%endp) ! atmospheric co2 partial pressure (pa) + real(r8) :: ci + !------------------------------------------------------------------------------ + + SHR_ASSERT_ALL_FL((ubound(downreg) == (/bounds%endp/)), sourcefile, __LINE__) + + associate( & + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + forc_pco2 => atm2lnd_inst%forc_pco2_grc , & ! Input: [real(r8) (:) ] partial pressure co2 (Pa) + + c3psn => pftcon%c3psn , & ! Input: photosynthetic pathway: 0. = c4, 1. = c3 + + nrad => surfalb_inst%nrad_patch , & ! Input: [integer (:) ] number of canopy layers, above snow for radiative transfer + + gb_mol => photosyns_inst%gb_mol_patch & ! Input: [real(r8) (:) ] leaf boundary layer conductance (umol H2O/m**2/s) + ) + + if (phase == 'sun') then + par_z => solarabs_inst%parsun_z_patch ! Input : [real(r8) (:,:)] par absorbed per unit lai for canopy layer (w/m**2) + alphapsn => photosyns_inst%alphapsnsun_patch ! Output: [real(r8) (:)] + if (use_hydrstress) then + gs_mol => photosyns_inst%gs_mol_sun_patch ! Input: [real(r8) (:,:) ] sunlit leaf stomatal conductance (umol H2O/m**2/s) + an => photosyns_inst%an_sun_patch ! Input: [real(r8) (:,:) ] net sunlit leaf photosynthesis (umol CO2/m**2/s) + else + gs_mol => photosyns_inst%gs_mol_patch ! Input: [real(r8) (:,:) ] leaf stomatal conductance (umol H2O/m**2/s) + an => photosyns_inst%an_patch ! Input: [real(r8) (:,:) ] net leaf photosynthesis (umol CO2/m**2/s) + end if + else if (phase == 'sha') then + par_z => solarabs_inst%parsha_z_patch ! Input : [real(r8) (:,:)] par absorbed per unit lai for canopy layer (w/m**2) + alphapsn => photosyns_inst%alphapsnsha_patch ! Output: [real(r8) (:)] + if (use_hydrstress) then + gs_mol => photosyns_inst%gs_mol_sha_patch ! Input: [real(r8) (:,:) ] shaded leaf stomatal conductance (umol H2O/m**2/s) + an => photosyns_inst%an_sha_patch ! Input: [real(r8) (:,:) ] net shaded leaf photosynthesis (umol CO2/m**2/s) + else + gs_mol => photosyns_inst%gs_mol_patch ! Input: [real(r8) (:,:) ] leaf stomatal conductance (umol H2O/m**2/s) + an => photosyns_inst%an_patch ! Input: [real(r8) (:,:) ] net leaf photosynthesis (umol CO2/m**2/s) + end if + end if + + do f = 1, fn + p = filterp(f) + c= patch%column(p) + g= patch%gridcell(p) + + co2(p) = forc_pco2(g) + do iv = 1,nrad(p) + if (par_z(p,iv) <= 0._r8) then ! night time + alphapsn(p) = 1._r8 + else ! day time + ci = co2(p) - (an(p,iv) * & + forc_pbot(c) * & + (1.4_r8*gs_mol(p,iv)+1.6_r8*gb_mol(p)) / (gb_mol(p)*gs_mol(p,iv))) + alphapsn(p) = 1._r8 + (((c3psn(patch%itype(p)) * & + (4.4_r8 + (22.6_r8*(ci/co2(p))))) + & + ((1._r8 - c3psn(patch%itype(p))) * 4.4_r8))/1000._r8) + end if + end do + end do + + end associate + + end subroutine Fractionation + + !------------------------------------------------------------------------------- + subroutine hybrid(x0, p, iv, c, gb_mol, je, cair, oair, lmr_z, par_z,& + rh_can, gs_mol,iter, & + atm2lnd_inst, photosyns_inst) + ! + !! DESCRIPTION: + ! use a hybrid solver to find the root of equation + ! f(x) = x- h(x), + !we want to find x, s.t. f(x) = 0. + !the hybrid approach combines the strength of the newton secant approach (find the solution domain) + !and the bisection approach implemented with the Brent's method to guarrantee convergence. + + ! + !! REVISION HISTORY: + !Dec 14/2012: created by Jinyun Tang + ! + !!USES: + ! + !! ARGUMENTS: + implicit none + real(r8), intent(inout) :: x0 !initial guess and final value of the solution + real(r8), intent(in) :: lmr_z ! canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), intent(in) :: par_z ! par absorbed per unit lai for canopy layer (w/m**2) + real(r8), intent(in) :: rh_can ! canopy air relative humidity + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(in) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: cair ! Atmospheric CO2 partial pressure (Pa) + real(r8), intent(in) :: oair ! Atmospheric O2 partial pressure (Pa) + integer, intent(in) :: p, iv, c ! pft, c3/c4, and column index + real(r8), intent(out) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + integer, intent(out) :: iter !number of iterations used, for record only + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(photosyns_type), intent(inout) :: photosyns_inst + ! + !! LOCAL VARIABLES + real(r8) :: a, b + real(r8) :: fa, fb + real(r8) :: x1, f0, f1 + real(r8) :: x, dx + real(r8), parameter :: eps = 1.e-2_r8 !relative accuracy + real(r8), parameter :: eps1= 1.e-4_r8 + integer, parameter :: itmax = 40 !maximum number of iterations + real(r8) :: tol,minx,minf + + call ci_func(x0, f0, p, iv, c, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & + atm2lnd_inst, photosyns_inst) + + if(f0 == 0._r8)return + + minx=x0 + minf=f0 + x1 = x0 * 0.99_r8 + + call ci_func(x1,f1, p, iv, c, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & + atm2lnd_inst, photosyns_inst) + + if(f1==0._r8)then + x0 = x1 + return + endif + if(f1itmax)then + !in case of failing to converge within itmax iterations + !stop at the minimum function + !this happens because of some other issues besides the stomatal conductance calculation + !and it happens usually in very dry places and more likely with c4 plants. + + call ci_func(minx,f1, p, iv, c, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & + atm2lnd_inst, photosyns_inst) + + exit + endif + enddo + + end subroutine hybrid + + !------------------------------------------------------------------------------ + subroutine brent(x, x1,x2,f1, f2, tol, ip, iv, ic, gb_mol, je, cair, oair,& + lmr_z, par_z, rh_can, gs_mol, & + atm2lnd_inst, photosyns_inst) + ! + !!DESCRIPTION: + !Use Brent's method to find the root of a single variable function ci_func, which is known to exist between x1 and x2. + !The found root will be updated until its accuracy is tol. + + !!REVISION HISTORY: + !Dec 14/2012: Jinyun Tang, modified from numerical recipes in F90 by press et al. 1188-1189 + ! + !!ARGUMENTS: + real(r8), intent(out) :: x ! indepedent variable of the single value function ci_func(x) + real(r8), intent(in) :: x1, x2, f1, f2 ! minimum and maximum of the variable domain to search for the solution ci_func(x1) = f1, ci_func(x2)=f2 + real(r8), intent(in) :: tol ! the error tolerance + real(r8), intent(in) :: lmr_z ! canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), intent(in) :: par_z ! par absorbed per unit lai for canopy layer (w/m**2) + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(in) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: cair ! Atmospheric CO2 partial pressure (Pa) + real(r8), intent(in) :: oair ! Atmospheric O2 partial pressure (Pa) + real(r8), intent(in) :: rh_can ! inside canopy relative humidity + integer, intent(in) :: ip, iv, ic ! pft, c3/c4, and column index + real(r8), intent(out) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(photosyns_type), intent(inout) :: photosyns_inst + ! + !!LOCAL VARIABLES: + integer, parameter :: itmax=20 !maximum number of iterations + real(r8), parameter :: eps=1.e-2_r8 !relative error tolerance + integer :: iter + real(r8) :: a,b,c,d,e,fa,fb,fc,p,q,r,s,tol1,xm + !------------------------------------------------------------------------------ + + a=x1 + b=x2 + fa=f1 + fb=f2 + if((fa > 0._r8 .and. fb > 0._r8).or.(fa < 0._r8 .and. fb < 0._r8))then + write(iulog,*) 'root must be bracketed for brent' + call endrun(msg=errmsg(sourcefile, __LINE__)) + endif + c=b + fc=fb + iter = 0 + do + if(iter==itmax)exit + iter=iter+1 + if((fb > 0._r8 .and. fc > 0._r8) .or. (fb < 0._r8 .and. fc < 0._r8))then + c=a !Rename a, b, c and adjust bounding interval d. + fc=fa + d=b-a + e=d + endif + if( abs(fc) < abs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + endif + tol1=2._r8*eps*abs(b)+0.5_r8*tol !Convergence check. + xm=0.5_r8*(c-b) + if(abs(xm) <= tol1 .or. fb == 0.)then + x=b + return + endif + if(abs(e) >= tol1 .and. abs(fa) > abs(fb)) then + s=fb/fa !Attempt inverse quadratic interpolation. + if(a == c) then + p=2._r8*xm*s + q=1._r8-s + else + q=fa/fc + r=fb/fc + p=s*(2._r8*xm*q*(q-r)-(b-a)*(r-1._r8)) + q=(q-1._r8)*(r-1._r8)*(s-1._r8) + endif + if(p > 0._r8) q=-q !Check whether in bounds. + p=abs(p) + if(2._r8*p < min(3._r8*xm*q-abs(tol1*q),abs(e*q))) then + e=d !Accept interpolation. + d=p/q + else + d=xm !Interpolation failed, use bisection. + e=d + endif + else !Bounds decreasing too slowly, use bisection. + d=xm + e=d + endif + a=b !Move last best guess to a. + fa=fb + if(abs(d) > tol1) then !Evaluate new trial root. + b=b+d + else + b=b+sign(tol1,xm) + endif + + call ci_func(b, fb, ip, iv, ic, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & + atm2lnd_inst, photosyns_inst) + + if(fb==0._r8)exit + + enddo + + if(iter==itmax)write(iulog,*) 'brent exceeding maximum iterations', b, fb + x=b + + return + end subroutine brent + + !------------------------------------------------------------------------------- + function ft(tl, ha) result(ans) + ! + !!DESCRIPTION: + ! photosynthesis temperature response + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! + !!USES + use clm_varcon , only : rgas, tfrz + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) + real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + + return + end function ft + + !------------------------------------------------------------------------------- + function fth(tl,hd,se,scaleFactor) result(ans) + ! + !!DESCRIPTION: + !photosynthesis temperature inhibition + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! + use clm_varcon , only : rgas, tfrz + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temperature function (J/mol/K) + real(r8), intent(in) :: scaleFactor ! scaling factor for high temperature inhibition (25 C = 1.0) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + + return + end function fth + + !------------------------------------------------------------------------------- + function fth25(hd,se)result(ans) + ! + !!DESCRIPTION: + ! scaling factor for photosynthesis temperature inhibition + ! + ! !REVISION HISTORY: + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! + !!USES + use clm_varcon , only : rgas, tfrz + ! + ! !ARGUMENTS: + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temperature function (J/mol/K) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + + return + end function fth25 + + !------------------------------------------------------------------------------ + subroutine ci_func(ci, fval, p, iv, c, gb_mol, je, cair, oair, lmr_z, par_z,& + rh_can, gs_mol, atm2lnd_inst, photosyns_inst) + ! + !! DESCRIPTION: + ! evaluate the function + ! f(ci)=ci - (ca - (1.37rb+1.65rs))*patm*an + ! + ! remark: I am attempting to maintain the original code structure, also + ! considering one may be interested to output relevant variables for the + ! photosynthesis model, I have decided to add these relevant variables to + ! the relevant data types. + ! + !!ARGUMENTS: + real(r8) , intent(in) :: ci ! intracellular leaf CO2 (Pa) + real(r8) , intent(in) :: lmr_z ! canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8) , intent(in) :: par_z ! par absorbed per unit lai for canopy layer (w/m**2) + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8) , intent(in) :: cair ! Atmospheric CO2 partial pressure (Pa) + real(r8) , intent(in) :: oair ! Atmospheric O2 partial pressure (Pa) + real(r8) , intent(in) :: rh_can ! canopy air realtive humidity + integer , intent(in) :: p, iv, c ! pft, vegetation type and column indexes + real(r8) , intent(out) :: fval ! return function of the value f(ci) + real(r8) , intent(out) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + ! + !local variables + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + real(r8) :: cs ! CO2 partial pressure at leaf surface (Pa) + + real(r8) :: aquad, bquad, cquad ! terms for quadratic equations + real(r8) :: r1, r2 ! roots of quadratic equation + !------------------------------------------------------------------------------ + + associate(& + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Output: [real(r8) (:) ] atmospheric pressure (Pa) + c3flag => photosyns_inst%c3flag_patch , & ! Output: [logical (:) ] true if C3 and false if C4 + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + ac => photosyns_inst%ac_patch , & ! Output: [real(r8) (:,:) ] Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + aj => photosyns_inst%aj_patch , & ! Output: [real(r8) (:,:) ] RuBP-limited gross photosynthesis (umol CO2/m**2/s) + ap => photosyns_inst%ap_patch , & ! Output: [real(r8) (:,:) ] product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) + ag => photosyns_inst%ag_patch , & ! Output: [real(r8) (:,:) ] co-limited gross leaf photosynthesis (umol CO2/m**2/s) + an => photosyns_inst%an_patch , & ! Output: [real(r8) (:,:) ] net leaf photosynthesis (umol CO2/m**2/s) + vcmax_z => photosyns_inst%vcmax_z_patch , & ! Input: [real(r8) (:,:) ] maximum rate of carboxylation (umol co2/m**2/s) + cp => photosyns_inst%cp_patch , & ! Output: [real(r8) (:) ] CO2 compensation point (Pa) + kc => photosyns_inst%kc_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for CO2 (Pa) + ko => photosyns_inst%ko_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for O2 (Pa) + qe => photosyns_inst%qe_patch , & ! Output: [real(r8) (:) ] quantum efficiency, used only for C4 (mol CO2 / mol photons) + tpu_z => photosyns_inst%tpu_z_patch , & ! Output: [real(r8) (:,:) ] triose phosphate utilization rate (umol CO2/m**2/s) + kp_z => photosyns_inst%kp_z_patch , & ! Output: [real(r8) (:,:) ] initial slope of CO2 response curve (C4 plants) + bbb => photosyns_inst%bbb_patch , & ! Output: [real(r8) (:) ] Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + mbb => photosyns_inst%mbb_patch & ! Output: [real(r8) (:) ] Ball-Berry slope of conductance-photosynthesis relationship + ) + + if (c3flag(p)) then + ! C3: Rubisco-limited photosynthesis + ac(p,iv) = vcmax_z(p,iv) * max(ci-cp(p), 0._r8) / (ci+kc(p)*(1._r8+oair/ko(p))) + + ! C3: RuBP-limited photosynthesis + aj(p,iv) = je * max(ci-cp(p), 0._r8) / (4._r8*ci+8._r8*cp(p)) + + ! C3: Product-limited photosynthesis + ap(p,iv) = 3._r8 * tpu_z(p,iv) + + else + + ! C4: Rubisco-limited photosynthesis + ac(p,iv) = vcmax_z(p,iv) + + ! C4: RuBP-limited photosynthesis + aj(p,iv) = qe(p) * par_z * 4.6_r8 + + ! C4: PEP carboxylase-limited (CO2-limited) + ap(p,iv) = kp_z(p,iv) * max(ci, 0._r8) / forc_pbot(c) + + end if + + ! Gross photosynthesis. First co-limit ac and aj. Then co-limit ap + + aquad = params_inst%theta_cj(ivt(p)) + bquad = -(ac(p,iv) + aj(p,iv)) + cquad = ac(p,iv) * aj(p,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = params_inst%theta_ip + bquad = -(ai + ap(p,iv)) + cquad = ai * ap(p,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + ag(p,iv) = max(0._r8,min(r1,r2)) + + ! Net photosynthesis. Exit iteration if an < 0 + + an(p,iv) = ag(p,iv) - lmr_z + if (an(p,iv) < 0._r8) then + fval = 0._r8 + return + endif + ! Quadratic gs_mol calculation with an known. Valid for an >= 0. + ! With an <= 0, then gs_mol = bbb + + cs = cair - 1.4_r8/gb_mol * an(p,iv) * forc_pbot(c) + cs = max(cs,1.e-06_r8) + aquad = cs + bquad = cs*(gb_mol - bbb(p)) - mbb(p)*an(p,iv)*forc_pbot(c) + cquad = -gb_mol*(cs*bbb(p) + mbb(p)*an(p,iv)*forc_pbot(c)*rh_can) + call quadratic (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + + ! Derive new estimate for ci + + fval =ci - cair + an(p,iv) * forc_pbot(c) * (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) + + end associate + + end subroutine ci_func + +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Fluorescence +! +! !INTERFACE: +subroutine fluorescence(ps, po0, fs) + + ! + !! DESCRIPTION: + ! Chlorophyll fluorescence + + ! !REVISION HISTORY: + ! writen by Jung-Eun Lee using van der Tol and Berry (2012) + ! modified by Mengxi Wu + ! Adopted by Raczka 10/15/17 + ! Integrated into CLM5.0 By MS 02/21/2018 + + !!USES + use shr_kind_mod , only : r8 => shr_kind_r8 + ! + !ARGUMENTS: + implicit none + real(r8), intent(in) :: ps ! photochemical yield + real(r8), intent(in) :: po0 ! dark adapted photochemical yield + real(r8), intent(out) :: fs ! fluorescence yield + real(r8) :: Kf ! rate constant for fluorescence + real(r8) :: Kd ! rate constant for thermal deactivation + real(r8) :: Kn ! rate constant for non-photochemical quenching + real(r8) :: x ! degree of light saturation + real(r8) :: fm ! light adapted fluorescence yield Fm + + Kf = 0.05_r8 + Kd = 0.95_r8 ! by following Lee et al (2015), MS tweaked this number from 0.95 to 0.87 for testing + + x = 1._r8 - ps / po0 + Kn = (6.2473_r8 * x - 0.5944_r8) * x ! empirical fit to Flexas' data +! Kn = (3.9867_r8 * x - 1.0589_r8) * x ! empirical fit to Flexas, Daumard, Rascher, Berry data + + fm = Kf / (Kf + Kd + Kn) + fs = fm * (1._r8 - ps) +end subroutine fluorescence +!------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------ + subroutine PhotosynthesisHydraulicStress ( bounds, fn, filterp, & + esat_tv, eair, oair, cair, rb, bsun, bsha, btran, dayl_factor, leafn, downreg,& + qsatl, qaf, & + atm2lnd_inst, temperature_inst, soilstate_inst, waterdiagnosticbulk_inst, & + surfalb_inst, solarabs_inst, canopystate_inst, ozone_inst, & + photosyns_inst, waterfluxbulk_inst, froot_carbon, croot_carbon) + ! + ! !DESCRIPTION: + ! Leaf photosynthesis and stomatal conductance calculation as described by + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 and extended to + ! a multi-layer canopy + ! Here, sunlit and shaded photosynthesis and stomatal conductance are solved + ! simultaneously per Pierre Gentine/Daniel Kennedy plant hydraulic stress + ! method + ! + ! !USES: + use clm_varcon , only : rgas, tfrz, rpi, spval + use GridcellType , only : grc + use clm_time_manager , only : get_step_size_real, is_near_local_noon + use clm_varctl , only : cnallocate_carbon_only + use clm_varctl , only : lnc_opt, reduce_dayl_factor, vcmax_opt + use clm_varpar , only : nlevsoi + use pftconMod , only : nbrdlf_dcd_tmp_shrub, npcropmin + use ColumnType , only : col + use shr_infnan_mod , only : shr_infnan_isnan + + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: fn ! size of pft filter + integer , intent(in) :: filterp(fn) ! patch filter + real(r8) , intent(in) :: esat_tv( bounds%begp: ) ! saturation vapor pressure at t_veg (Pa) [pft] + real(r8) , intent(in) :: eair( bounds%begp: ) ! vapor pressure of canopy air (Pa) [pft] + real(r8) , intent(in) :: oair( bounds%begp: ) ! Atmospheric O2 partial pressure (Pa) [pft] + real(r8) , intent(in) :: cair( bounds%begp: ) ! Atmospheric CO2 partial pressure (Pa) [pft] + real(r8) , intent(in) :: rb( bounds%begp: ) ! boundary layer resistance (s/m) [pft] + real(r8) , intent(in) :: dayl_factor( bounds%begp: ) ! scalar (0-1) for daylength + real(r8) , intent(in) :: qsatl ( bounds%begp: ) ! leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qaf ( bounds%begp: ) ! humidity of canopy air [kg/kg] + real(r8) , intent(in) :: leafn( bounds%begp: ) ! leaf N (gN/m2) + real(r8) , intent(in) :: downreg( bounds%begp: ) ! fractional reduction in GPP due to N limitation (dimensionless) ! MS Added + real(r8) , intent(out) :: bsun( bounds%begp: ) ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8) , intent(out) :: bsha( bounds%begp: ) ! shaded canopy transpiration wetness factor (0 to 1) + real(r8) , intent(out) :: btran( bounds%begp: ) ! transpiration wetness factor (0 to 1) [pft] + real(r8) , intent(in) :: froot_carbon( bounds%begp: ) ! fine root carbon (gC/m2) [pft] + real(r8) , intent(in) :: croot_carbon( bounds%begp: ) ! live coarse root carbon (gC/m2) [pft] + + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(temperature_type) , intent(in) :: temperature_inst + type(surfalb_type) , intent(in) :: surfalb_inst + type(solarabs_type) , intent(in) :: solarabs_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(waterdiagnosticbulk_type) , intent(inout) :: waterdiagnosticbulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + class(ozone_base_type) , intent(in) :: ozone_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + ! + ! !LOCAL VARIABLES: + ! + ! Leaf photosynthesis parameters + real(r8) :: jmax_z(bounds%begp:bounds%endp,2,nlevcan) ! maximum electron transport rate (umol electrons/m**2/s) + real(r8) :: bbbopt(bounds%begp:bounds%endp) ! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) + real(r8) :: kn(bounds%begp:bounds%endp) ! leaf nitrogen decay coefficient + real(r8) :: vcmax25top ! canopy top: maximum rate of carboxylation at 25C (umol CO2/m**2/s) + real(r8) :: jmax25top ! canopy top: maximum electron transport rate at 25C (umol electrons/m**2/s) + real(r8) :: tpu25top ! canopy top: triose phosphate utilization rate at 25C (umol CO2/m**2/s) + real(r8) :: lmr25top ! canopy top: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: kp25top ! canopy top: initial slope of CO2 response curve (C4 plants) at 25C + + real(r8) :: vcmax25_sun ! sunlit leaf layer: maximum rate of carboxylation at 25C (umol CO2/m**2/s) + real(r8) :: vcmax25_sha ! shaded leaf layer: maximum rate of carboxylation at 25C (umol CO2/m**2/s) + real(r8) :: jmax25_sun ! sunlit leaf layer: maximum electron transport rate at 25C (umol electrons/m**2/s) + real(r8) :: jmax25_sha ! shaded leaf layer: maximum electron transport rate at 25C (umol electrons/m**2/s) + real(r8) :: tpu25_sun ! sunlit leaf layer: triose phosphate utilization rate at 25C (umol CO2/m**2/s) + real(r8) :: tpu25_sha ! shaded leaf layer: triose phosphate utilization rate at 25C (umol CO2/m**2/s) + real(r8) :: lmr25_sun ! sunlit leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: lmr25_sha ! shaded leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: kp25_sun ! sunlit leaf layer: Initial slope of CO2 response curve (C4 plants) at 25C + real(r8) :: kp25_sha ! shaded leaf layer: Initial slope of CO2 response curve (C4 plants) at 25C + real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) + real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) + real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) + + real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) + real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) + real(r8) :: tpuse ! entropy term for tpu (J/mol/K) + + real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: tpuc ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: lmrc ! scaling factor for high temperature inhibition (25 C = 1.0) + + ! Other + integer :: f,p,c,iv ! indices + real(r8) :: cf ! s m**2/umol -> s/m + real(r8) :: rsmax0 ! maximum stomatal resistance [s/m] + real(r8) :: gb ! leaf boundary layer conductance (m/s) + real(r8) :: cs_sun ! CO2 partial pressure at sunlit leaf surface (Pa) + real(r8) :: cs_sha ! CO2 partial pressure at shaded leaf surface (Pa) + real(r8) :: gs ! leaf stomatal conductance (m/s) + real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) + real(r8) :: sco ! relative specificity of rubisco + real(r8) :: ft ! photosynthesis temperature response (statement function) + real(r8) :: fth ! photosynthesis temperature inhibition (statement function) + real(r8) :: fth25 ! ccaling factor for photosynthesis temperature inhibition (statement function) + real(r8) :: tl ! leaf temperature in photosynthesis temperature function (K) + real(r8) :: ha ! activation energy in photosynthesis temperature function (J/mol) + real(r8) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) + real(r8) :: se ! entropy term in photosynthesis temperature function (J/mol/K) + real(r8) :: scaleFactor ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: ciold ! previous value of Ci for convergence check + real(r8) :: gs_mol_err ! gs_mol for error check + real(r8) :: je_sun ! sunlit leaf electron transport rate (umol electrons/m**2/s) + real(r8) :: je_sha ! shaded leaf electron transport rate (umol electrons/m**2/s) + real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) + real(r8) :: aquad,bquad,cquad ! terms for quadratic equations + real(r8) :: r1,r2 ! roots of quadratic equation + real(r8) :: ceair ! vapor pressure of air, constrained (Pa) + integer :: iter1 ! number of iterations used, for record only + integer :: iter2 ! number of iterations used, for record only + real(r8) :: nscaler ! leaf nitrogen scaling coefficient + real(r8) :: nscaler_sun ! sunlit leaf nitrogen scaling coefficient + real(r8) :: nscaler_sha ! shaded leaf nitrogen scaling coefficient + + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + + real(r8) :: psn_wc_z_sun(bounds%begp:bounds%endp,nlevcan) ! Rubisco-limited contribution to sunlit psn_z (umol CO2/m**2/s) + real(r8) :: psn_wj_z_sun(bounds%begp:bounds%endp,nlevcan) ! RuBP-limited contribution to sunlit psn_z (umol CO2/m**2/s) + real(r8) :: psn_wp_z_sun(bounds%begp:bounds%endp,nlevcan) ! product-limited contribution to sunlit psn_z (umol CO2/m**2/s) + real(r8) :: psn_wc_z_sha(bounds%begp:bounds%endp,nlevcan) ! Rubisco-limited contribution to shaded psn_z (umol CO2/m**2/s) + real(r8) :: psn_wj_z_sha(bounds%begp:bounds%endp,nlevcan) ! RuBP-limited contribution to shaded psn_z (umol CO2/m**2/s) + real(r8) :: psn_wp_z_sha(bounds%begp:bounds%endp,nlevcan) ! product-limited contribution to shaded psn_z (umol CO2/m**2/s) + real(r8) :: rh_leaf_sun(bounds%begp:bounds%endp) ! fractional humidity at sunlit leaf surface (dimensionless) + real(r8) :: rh_leaf_sha(bounds%begp:bounds%endp) ! fractional humidity at shaded leaf surface (dimensionless) + + real(r8) :: psncan_sun ! canopy sum of sunlit psn_z + real(r8) :: psncan_wc_sun ! canopy sum of sunlit psn_wc_z + real(r8) :: psncan_wj_sun ! canopy sum of sunlit psn_wj_z + real(r8) :: psncan_wp_sun ! canopy sum of sunlit psn_wp_z + real(r8) :: lmrcan_sun ! canopy sum of sunlit lmr_z + real(r8) :: gscan_sun ! canopy sum of sunlit leaf conductance + real(r8) :: laican_sun ! canopy sum of sunlit lai_z + real(r8) :: psncan_sha ! canopy sum of shaded psn_z + real(r8) :: psncan_wc_sha ! canopy sum of shaded psn_wc_z + real(r8) :: psncan_wj_sha ! canopy sum of shaded psn_wj_z + real(r8) :: psncan_wp_sha ! canopy sum of shaded psn_wp_z + real(r8) :: lmrcan_sha ! canopy sum of shaded lmr_z + real(r8) :: gscan_sha ! canopy sum of shaded leaf conductance + real(r8) :: laican_sha ! canopy sum of shaded lai_z + real(r8) :: laican ! canopy sum of lai_z + real(r8) :: rh_can ! canopy air relative humidity + + real(r8) , pointer :: lai_z_sun (:,:) ! leaf area index for canopy layer, sunlit + real(r8) , pointer :: par_z_sun (:,:) ! par absorbed per unit lai for canopy layer, sunlit (w/m**2) + real(r8) , pointer :: vcmaxcint_sun (:) ! leaf to canopy scaling coefficient, sunlit + real(r8) , pointer :: alphapsn_sun (:) ! 13C fractionation factor for PSN, sunlit () + real(r8) , pointer :: psn_sun (:) ! foliage photosynthesis, sunlit (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_wc_sun (:) ! Rubisco-limited foliage photosynthesis, sunlit (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_wj_sun (:) ! RuBP-limited foliage photosynthesis, sunlit (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_wp_sun (:) ! product-limited foliage photosynthesis, sunlit (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_z_sun (:,:) ! canopy layer: foliage photosynthesis, sunlit (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: lmr_sun (:) ! leaf maintenance respiration rate, sunlit (umol CO2/m**2/s) + real(r8) , pointer :: lmr_z_sun (:,:) ! canopy layer: leaf maintenance respiration rate, sunlit (umol CO2/m**2/s) + real(r8) , pointer :: rs_sun (:) ! leaf stomatal resistance, sunlit (s/m) + real(r8) , pointer :: rs_z_sun (:,:) ! canopy layer: leaf stomatal resistance, sunlit (s/m) + real(r8) , pointer :: ci_z_sun (:,:) ! intracellular leaf CO2, sunlit (Pa) + real(r8) , pointer :: o3coefv_sun (:) ! o3 coefficient used in photo calculation, sunlit + real(r8) , pointer :: o3coefg_sun (:) ! o3 coefficient used in rs calculation, sunlit + real(r8) , pointer :: lai_z_sha (:,:) ! leaf area index for canopy layer, shaded + real(r8) , pointer :: par_z_sha (:,:) ! par absorbed per unit lai for canopy layer, shaded (w/m**2) + real(r8) , pointer :: vcmaxcint_sha (:) ! leaf to canopy scaling coefficient, shaded + real(r8) , pointer :: alphapsn_sha (:) ! 13C fractionation factor for PSN, shaded () + real(r8) , pointer :: psn_sha (:) ! foliage photosynthesis, shaded (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_wc_sha (:) ! Rubisco-limited foliage photosynthesis, shaded (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_wj_sha (:) ! RuBP-limited foliage photosynthesis, shaded (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_wp_sha (:) ! product-limited foliage photosynthesis, shaded (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: psn_z_sha (:,:) ! canopy layer: foliage photosynthesis, shaded (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: lmr_sha (:) ! leaf maintenance respiration rate, shaded (umol CO2/m**2/s) + real(r8) , pointer :: lmr_z_sha (:,:) ! canopy layer: leaf maintenance respiration rate, shaded (umol CO2/m**2/s) + real(r8) , pointer :: rs_sha (:) ! leaf stomatal resistance, shaded (s/m) + real(r8) , pointer :: rs_z_sha (:,:) ! canopy layer: leaf stomatal resistance, shaded (s/m) + real(r8) , pointer :: ci_z_sha (:,:) ! intracellular leaf CO2, shaded (Pa) + real(r8) , pointer :: o3coefv_sha (:) ! o3 coefficient used in photo calculation, shaded + real(r8) , pointer :: o3coefg_sha (:) ! o3 coefficient used in rs calculation, shaded + real(r8) :: sum_nscaler + real(r8) :: total_lai + integer :: nptreemax + real(r8) :: dtime ! land model time step (sec) + integer :: j,g ! index + real(r8) :: rs_resis ! combined soil-root resistance [s] + real(r8) :: r_soil ! root spacing [m] + real(r8) :: root_biomass_density ! root biomass density [g/m3] + real(r8) :: root_cross_sec_area ! root cross sectional area [m2] + real(r8) :: root_length_density ! root length density [m/m3] + real(r8) :: froot_average_length ! average coarse root length [m] + real(r8) :: croot_average_length ! average coarse root length [m] + real(r8) :: soil_conductance ! soil to root hydraulic conductance [1/s] + real(r8) :: root_conductance ! root hydraulic conductance [1/s] + real(r8) :: rai(nlevsoi) ! root area index [m2/m2] + real(r8) :: fs(nlevsoi) ! root conductance scale factor (reduction in conductance due to decreasing (more negative) root water potential) + real(r8) :: gsminsun ! Minimum stomatal conductance sunlit + real(r8) :: gsminsha ! Minimum stomatal conductance shaded + real(r8) :: gs_slope_sun ! Slope stomatal conductance sunlit + real(r8) :: gs_slope_sha ! Slope stomatal conductance shaded + real(r8), parameter :: croot_lateral_length = 0.25_r8 ! specified lateral coarse root length [m] + real(r8), parameter :: c_to_b = 2.0_r8 !(g biomass /g C) +!Note that root density is for dry biomass not carbon. CLM provides root biomass as carbon. The conversion is 0.5 g C / g biomass + ! MS Added + real(r8) , pointer :: sifsun (:) ! canopy layer: solar-induced fluorescence (W /m**2/) [always +] + real(r8) , pointer :: anetsun (:) ! canopy layer: net assimilation (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: fyieldsun (:) ! fluorescence yield at Fs [photon emitted photon absorbed-1 of PAR] + real(r8) , pointer :: pyieldsun (:) ! photochemical yield at Fs [photon emitted photon absorbed-1 of PAR] + real(r8) , pointer :: xsatsun (:) ! saturation used in fluorescence model (ja/qabs) + + real(r8) , pointer :: sifsha (:) ! canopy layer: solar-induced fluorescence (W /m**2/) [always +] + real(r8) , pointer :: anetsha (:) ! canopy layer: net assimilation (umol co2 /m**2/ s) [always +] + real(r8) , pointer :: fyieldsha (:) ! fluorescence yield at Fs [photon emitted photon absorbed-1 of PAR] + real(r8) , pointer :: pyieldsha (:) ! photochemical yield at Fs [photon emitted photon absorbed-1 of PAR] + real(r8) , pointer :: xsatsha (:) ! saturation used in fluorescence model (ja/qabs) + + real(r8) , pointer :: par_sun (:) ! sun-lit par (W/m**2) + real(r8) , pointer :: par_sha (:) ! shaded par (W/m**2) + + ! Local variables + real(r8) :: ja_sun ! electron transport rate as defined by Lee et al. 2015. (umol electrons/m**2/s) + real(r8) :: ja_sha ! electron transport rate as defined by Lee et al. 2015. (umol electrons/m**2/s) + real(r8) :: po0 ! dark adapted photochemical yield + real(r8) :: co2(bounds%begp:bounds%endp) ! partial pressure co2 (Pa) + real(r8) :: sif_z_sun(bounds%begp:bounds%endp,nlevcan) ! canopy layer: solar-induced fluorescence (W /m**2/) [always +] + real(r8) :: sif_z_sha(bounds%begp:bounds%endp,nlevcan) ! canopy layer: solar-induced fluorescence (W /m**2/) [always +] + real(r8) :: an_z_sun(bounds%begp:bounds%endp,nlevcan) ! canopy layer: net assimilation (umol co2 /m**2/ s) [always +] + real(r8) :: an_z_sha(bounds%begp:bounds%endp,nlevcan) ! canopy layer: net assimilation (umol co2 /m**2/ s) [always +] + real(r8) :: fs_z_sun(bounds%begp:bounds%endp,nlevcan) ! canopy layer: fluorescence yield + real(r8) :: fs_z_sha(bounds%begp:bounds%endp,nlevcan) ! canopy layer: fluorescence yield + real(r8) :: ps_z_sun(bounds%begp:bounds%endp,nlevcan) ! canopy layer: photochemical yield + real(r8) :: ps_z_sha(bounds%begp:bounds%endp,nlevcan) ! canopy layer: photochemical yield + real(r8) :: xsat_z_sun(bounds%begp:bounds%endp,nlevcan) ! canopy layer: light saturation + real(r8) :: xsat_z_sha(bounds%begp:bounds%endp,nlevcan) ! canopy layer: light saturation + real(r8) :: sifcan_sun ! canopy sum of sif_z + real(r8) :: sifcan_sha ! canopy sum of sif_z + real(r8) :: ancan_sun ! can_sunopy sum of an_z + real(r8) :: ancan_sha ! can_shaopy sum of an_z + real(r8) :: fyieldcan_sun ! can_sunopy sum of fs_z + real(r8) :: fyieldcan_sha ! can_shaopy sum of fs_z + real(r8) :: pyieldcan_sun ! can_sunopy sum of ps_z + real(r8) :: pyieldcan_sha ! can_shaopy sum of ps_z + real(r8) :: xsatcan_sun ! can_sunopy sum of xsat_z + real(r8) :: xsatcan_sha ! can_shaopy sum of xsat_z + real(r8) :: parcan_sun ! canopy sum of par_z_sun + real(r8) :: parcan_sha ! canopy sum of par_z_sha + ! MS ends + !------------------------------------------------------------------------------ + + ! Temperature and soil water response functions + + ft(tl,ha) = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + fth(tl,hd,se,scaleFactor) = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + fth25(hd,se) = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + + ! Enforce expected array sizes + + SHR_ASSERT_ALL_FL((ubound(esat_tv) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(eair) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(oair) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(cair) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(rb) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(bsun) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(bsha) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(btran) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(dayl_factor) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(qsatl) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(qaf) == (/bounds%endp/)), sourcefile, __LINE__) + SHR_ASSERT_ALL_FL((ubound(downreg) == (/bounds%endp/)), sourcefile, __LINE__) ! MS Added + + associate( & + k_soil_root => soilstate_inst%k_soil_root_patch , & ! Input: [real(r8) (:,:) ] soil-root interface conductance (mm/s) + hk_l => soilstate_inst%hk_l_col , & ! Input: [real(r8) (:,:) ] hydraulic conductivity (mm/s) + hksat => soilstate_inst%hksat_col , & ! Input: [real(r8) (:,:) ] hydraulic conductivity at saturation (mm H2O /s) + smp => soilstate_inst%smp_l_col , & ! Input: [real(r8) (:,:) ] soil matrix potential [mm] + + froot_leaf => pftcon%froot_leaf , & ! fine root to leaf ratio + root_conductance_patch => soilstate_inst%root_conductance_patch , & ! Output: [real(r8) (:,:)] root conductance + soil_conductance_patch => soilstate_inst%soil_conductance_patch , & ! Output: [real(r8) (:,:)] soil conductance + rootfr => soilstate_inst%rootfr_patch , & ! Input: [real(r8) (:,:)] + dz => col%dz , & ! Input: [real(r8) (:,:) ] layer thickness (m) + z => col%z , & ! Input: [real(r8) (:,:) ] layer depth (m) + root_radius => pftcon%root_radius , & ! Input: 0.29e-03_r8 !(m) + root_density => pftcon%root_density , & ! Input: 0.31e06_r8 !(g biomass / m3 root) + tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] patch canopy one-sided stem area index, no burying by snow + c3psn => pftcon%c3psn , & ! Input: photosynthetic pathway: 0. = c4, 1. = c3 + crop => pftcon%crop , & ! Input: crop or not (0 =not crop and 1 = crop) + leafcn => pftcon%leafcn , & ! Input: leaf C:N (gC/gN) + flnr => pftcon%flnr , & ! Input: fraction of leaf N in the Rubisco enzyme (gN Rubisco / gN leaf) + fnitr => pftcon%fnitr , & ! Input: foliage nitrogen limitation factor (-) + slatop => pftcon%slatop , & ! Input: specific leaf area at top of canopy, projected area basis [m^2/gC] + dsladlai => pftcon%dsladlai , & ! Input: change in sla per unit lai + i_vcad => pftcon%i_vcad , & ! Input: [real(r8) (:) ] + s_vcad => pftcon%s_vcad , & ! Input: [real(r8) (:) ] + i_flnr => pftcon%i_flnr , & ! Input: [real(r8) (:) ] + s_flnr => pftcon%s_flnr , & ! Input: [real(r8) (:) ] + mbbopt => pftcon%mbbopt , & + medlynintercept=> pftcon%medlynintercept , & ! Input: [real(r8) (:) ] Intercept for Medlyn stomatal conductance model method + medlynslope=> pftcon%medlynslope , & ! Input: [real(r8) (:) ] Slope for Medlyn stomatal conductance model method + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + + t_veg => temperature_inst%t_veg_patch , & ! Input: [real(r8) (:) ] vegetation temperature (Kelvin) + t10 => temperature_inst%t_a10_patch , & ! Input: [real(r8) (:) ] 10-day running mean of the 2 m temperature (K) + tgcm => temperature_inst%thm_patch , & ! Input: [real(r8) (:) ] air temperature at agcm reference height (kelvin) + nrad => surfalb_inst%nrad_patch , & ! Input: [integer (:) ] pft number of canopy layers, above snow for radiative transfer + tlai_z => surfalb_inst%tlai_z_patch , & ! Input: [real(r8) (:,:) ] pft total leaf area index for canopy layer + tlai => canopystate_inst%tlai_patch , & ! Input: [real(r8)(:) ] one-sided leaf area index, no burying by snow + c3flag => photosyns_inst%c3flag_patch , & ! Output: [logical (:) ] true if C3 and false if C4 + ac => photosyns_inst%ac_phs_patch , & ! Output: [real(r8) (:,:,:) ] Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + aj => photosyns_inst%aj_phs_patch , & ! Output: [real(r8) (:,:,:) ] RuBP-limited gross photosynthesis (umol CO2/m**2/s) + ap => photosyns_inst%ap_phs_patch , & ! Output: [real(r8) (:,:,:) ] product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) + ag => photosyns_inst%ag_phs_patch , & ! Output: [real(r8) (:,:,:) ] co-limited gross leaf photosynthesis (umol CO2/m**2/s) + vcmax_z => photosyns_inst%vcmax_z_phs_patch , & ! Output: [real(r8) (:,:,:) ] maximum rate of carboxylation (umol co2/m**2/s) + luvcmax25top => photosyns_inst%luvcmax25top_patch , & ! Output: [real(r8) (:) ] maximum rate of carboxylation (umol co2/m**2/s) + lujmax25top => photosyns_inst%lujmax25top_patch , & ! Output: [real(r8) (:) ] maximum rate of carboxylation (umol co2/m**2/s) + lutpu25top => photosyns_inst%lutpu25top_patch , & ! Output: [real(r8) (:) ] maximum rate of carboxylation (umol co2/m**2/s) +!!! + tpu_z => photosyns_inst%tpu_z_phs_patch , & ! Output: [real(r8) (:,:,:) ] triose phosphate utilization rate (umol CO2/m**2/s) + kp_z => photosyns_inst%kp_z_phs_patch , & ! Output: [real(r8) (:,:,:) ] initial slope of CO2 response curve (C4 plants) + gb_mol => photosyns_inst%gb_mol_patch , & ! Output: [real(r8) (:) ] leaf boundary layer conductance (umol H2O/m**2/s) + cp => photosyns_inst%cp_patch , & ! Output: [real(r8) (:) ] CO2 compensation point (Pa) + kc => photosyns_inst%kc_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for CO2 (Pa) + ko => photosyns_inst%ko_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for O2 (Pa) + qe => photosyns_inst%qe_patch , & ! Output: [real(r8) (:) ] quantum efficiency, used only for C4 (mol CO2 / mol photons) + bbb => photosyns_inst%bbb_patch , & ! Output: [real(r8) (:) ] Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + mbb => photosyns_inst%mbb_patch , & ! Output: [real(r8) (:) ] Ball-Berry slope of conductance-photosynthesis relationship + rh_leaf => photosyns_inst%rh_leaf_patch , & ! Output: [real(r8) (:) ] fractional humidity at leaf surface (dimensionless) + lnc => photosyns_inst%lnca_patch , & ! Output: [real(r8) (:) ] top leaf layer leaf N concentration (gN leaf/m^2) + light_inhibit=> photosyns_inst%light_inhibit , & ! Input: [logical ] flag if light should inhibit respiration + leafresp_method=> photosyns_inst%leafresp_method , & ! Input: [integer ] method type to use for leaf-maint.-respiration at 25C canopy top + stomatalcond_mtd=> photosyns_inst%stomatalcond_mtd , & ! Input: [integer ] method type to use for stomatal conductance + modifyphoto_and_lmr_forcrop=> photosyns_inst%modifyphoto_and_lmr_forcrop, & ! Input: [logical ] modifyphoto_and_lmr_forcrop + leaf_mr_vcm => canopystate_inst%leaf_mr_vcm , & ! Input: [real(r8) ] scalar constant of leaf respiration with Vcmax + vegwp => canopystate_inst%vegwp_patch , & ! Input/Output: [real(r8) (:,:) ] vegetation water matric potential (mm) + an_sun => photosyns_inst%an_sun_patch , & ! Output: [real(r8) (:,:) ] net sunlit leaf photosynthesis (umol CO2/m**2/s) + an_sha => photosyns_inst%an_sha_patch , & ! Output: [real(r8) (:,:) ] net shaded leaf photosynthesis (umol CO2/m**2/s) + gs_mol_sun => photosyns_inst%gs_mol_sun_patch , & ! Output: [real(r8) (:,:) ] sunlit leaf stomatal conductance (umol H2O/m**2/s) + gs_mol_sha => photosyns_inst%gs_mol_sha_patch , & ! Output: [real(r8) (:,:) ] shaded leaf stomatal conductance (umol H2O/m**2/s) + gs_mol_sun_ln => photosyns_inst%gs_mol_sun_ln_patch , & ! Output: [real(r8) (:,:) ] sunlit leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon (umol H2O/m**2/s) + gs_mol_sha_ln => photosyns_inst%gs_mol_sha_ln_patch , & ! Output: [real(r8) (:,:) ] shaded leaf stomatal conductance averaged over 1 hour before to 1 hour after local noon (umol H2O/m**2/s) +! MS added variables (bmr)-------- + forc_pco2 => atm2lnd_inst%forc_pco2_grc & ! Input: [real(r8) (:) ] partial pressure co2 (Pa) +! MS ends------------------------- + ) + + par_z_sun => solarabs_inst%parsun_z_patch ! Input: [real(r8) (:,:) ] par absorbed per unit lai for canopy layer (w/m**2) + lai_z_sun => canopystate_inst%laisun_z_patch ! Input: [real(r8) (:,:) ] leaf area index for canopy layer, sunlit or shaded + vcmaxcint_sun => surfalb_inst%vcmaxcintsun_patch ! Input: [real(r8) (:) ] leaf to canopy scaling coefficient + alphapsn_sun => photosyns_inst%alphapsnsun_patch ! Input: [real(r8) (:) ] 13C fractionation factor for PSN () + o3coefv_sun => ozone_inst%o3coefvsun_patch ! Input: [real(r8) (:) ] O3 coefficient used in photosynthesis calculation + o3coefg_sun => ozone_inst%o3coefgsun_patch ! Input: [real(r8) (:) ] O3 coefficient used in rs calculation + ci_z_sun => photosyns_inst%cisun_z_patch ! Output: [real(r8) (:,:) ] intracellular leaf CO2 (Pa) + rs_sun => photosyns_inst%rssun_patch ! Output: [real(r8) (:) ] leaf stomatal resistance (s/m) + rs_z_sun => photosyns_inst%rssun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf stomatal resistance (s/m) + lmr_sun => photosyns_inst%lmrsun_patch ! Output: [real(r8) (:) ] leaf maintenance respiration rate (umol CO2/m**2/s) + lmr_z_sun => photosyns_inst%lmrsun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + psn_sun => photosyns_inst%psnsun_patch ! Output: [real(r8) (:) ] foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_z_sun => photosyns_inst%psnsun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wc_sun => photosyns_inst%psnsun_wc_patch ! Output: [real(r8) (:) ] Rubisco-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wj_sun => photosyns_inst%psnsun_wj_patch ! Output: [real(r8) (:) ] RuBP-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wp_sun => photosyns_inst%psnsun_wp_patch ! Output: [real(r8) (:) ] product-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + par_z_sha => solarabs_inst%parsha_z_patch ! Input: [real(r8) (:,:) ] par absorbed per unit lai for canopy layer (w/m**2) + lai_z_sha => canopystate_inst%laisha_z_patch ! Input: [real(r8) (:,:) ] leaf area index for canopy layer, sunlit or shaded + vcmaxcint_sha => surfalb_inst%vcmaxcintsha_patch ! Input: [real(r8) (:) ] leaf to canopy scaling coefficient + alphapsn_sha => photosyns_inst%alphapsnsha_patch ! Input: [real(r8) (:) ] 13C fractionation factor for PSN () + o3coefv_sha => ozone_inst%o3coefvsha_patch ! Input: [real(r8) (:) ] O3 coefficient used in photosynthesis calculation + o3coefg_sha => ozone_inst%o3coefgsha_patch ! Input: [real(r8) (:) ] O3 coefficient used in rs calculation + ci_z_sha => photosyns_inst%cisha_z_patch ! Output: [real(r8) (:,:) ] intracellular leaf CO2 (Pa) + rs_sha => photosyns_inst%rssha_patch ! Output: [real(r8) (:) ] leaf stomatal resistance (s/m) + rs_z_sha => photosyns_inst%rssha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf stomatal resistance (s/m) + lmr_sha => photosyns_inst%lmrsha_patch ! Output: [real(r8) (:) ] leaf maintenance respiration rate (umol CO2/m**2/s) + lmr_z_sha => photosyns_inst%lmrsha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + psn_sha => photosyns_inst%psnsha_patch ! Output: [real(r8) (:) ] foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_z_sha => photosyns_inst%psnsha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wc_sha => photosyns_inst%psnsha_wc_patch ! Output: [real(r8) (:) ] Rubisco-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wj_sha => photosyns_inst%psnsha_wj_patch ! Output: [real(r8) (:) ] RuBP-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + psn_wp_sha => photosyns_inst%psnsha_wp_patch ! Output: [real(r8) (:) ] product-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] +! MS Added + sifsun => photosyns_inst%sifsun_patch ! Output: [real(r8) (:) ] canopy layer: solar-induced fluorescence (W /m**2/) [always +] + anetsun => photosyns_inst%anetsun_patch ! Output: [real(r8) (:) ] canopy layer: net assimilation (umol co2 /m**2/ s) [always +] + fyieldsun => photosyns_inst%fyieldsun_patch ! Output: [real(r8) (:) ] fluorescence yield at Fs [photon emitted photon absorbed-1 of PAR] + pyieldsun => photosyns_inst%pyieldsun_patch ! Output: [real(r8) (:) ] photochemical yield at Fs [photon emitted photon absorbed-1 of PAR] + xsatsun => photosyns_inst%xsatsun_patch ! Output: [real(r8) (:) ] light saturation used in fluorescence model (ja/qabs) + sifsha => photosyns_inst%sifsha_patch ! Output: [real(r8) (:) ] canopy layer: solar-induced fluorescence (W /m**2/) [always +] + anetsha => photosyns_inst%anetsha_patch ! Output: [real(r8) (:) ] canopy layer: net assimilation (umol co2 /m**2/ s) [always +] + fyieldsha => photosyns_inst%fyieldsha_patch ! Output: [real(r8) (:) ] fluorescence yield at Fs [photon emitted photon absorbed-1 of PAR] + pyieldsha => photosyns_inst%pyieldsha_patch ! Output: [real(r8) (:) ] photochemical yield at Fs [photon emitted photon absorbed-1 of PAR] + xsatsha => photosyns_inst%xsatsha_patch ! Output: [real(r8) (:) ] light saturation used in fluorescence model (ja/qabs) + par_sun => photosyns_inst%parsun_patch ! Output: [real(r8) (:) ] canopy layer: sun-lit par (W /m**2/) [always +] + par_sha => photosyns_inst%parsha_patch ! Output: [real(r8) (:) ] canopy layer: shaded par (W /m**2/) [always +] +! MS ends + + !==============================================================================! + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + !==============================================================================! + + ! Determine seconds off current time step + + dtime = get_step_size_real() + + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 + + ! High temperature deactivation, from: + ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 + ! The factor "c" scales the deactivation to a value of 1.0 at 25C + + lmrc = fth25 (params_inst%lmrhd, params_inst%lmrse) + +! calculate root-soil interface conductance + do f = 1, fn + p = filterp(f) + c = patch%column(p) + + do j = 1,nlevsoi + +! calculate conversion from conductivity to conductance + root_biomass_density = c_to_b * froot_carbon(p) * rootfr(p,j) / dz(c,j) +! ensure minimum root biomass (using 1gC/m2) + root_biomass_density = max(c_to_b*1._r8,root_biomass_density) + + ! Root length density: m root per m3 soil + root_cross_sec_area = rpi*root_radius(ivt(p))**2 + root_length_density = root_biomass_density / (root_density(ivt(p)) * root_cross_sec_area) + + ! Root-area index (RAI) + rai(j) = (tsai(p)+tlai(p)) * froot_leaf(ivt(p)) * rootfr(p,j) + +! fix coarse root_average_length to specified length + croot_average_length = croot_lateral_length + +! calculate r_soil using Gardner/spa equation (Bonan, GMD, 2014) + r_soil = sqrt(1./(rpi*root_length_density)) + + ! length scale approach + soil_conductance = min(hksat(c,j),hk_l(c,j))/(1.e3*r_soil) + +! use vegetation plc function to adjust root conductance + fs(j)= plc(smp(c,j),p,c,root,veg) + +! krmax is root conductance per area per length + root_conductance = (fs(j)*rai(j)*params_inst%krmax(ivt(p)))/(croot_average_length + z(c,j)) + + soil_conductance = max(soil_conductance, 1.e-16_r8) + root_conductance = max(root_conductance, 1.e-16_r8) + + root_conductance_patch(p,j) = root_conductance + soil_conductance_patch(p,j) = soil_conductance + +! sum resistances in soil and root + rs_resis = 1._r8/soil_conductance + 1._r8/root_conductance + +! conductance is inverse resistance +! explicitly set conductance to zero for top soil layer + if(rai(j)*rootfr(p,j) > 0._r8 .and. j > 1) then + k_soil_root(p,j) = 1._r8/rs_resis + else + k_soil_root(p,j) = 0. + endif + + end do + enddo + + ! Miscellaneous parameters, from Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + + do f = 1, fn + p = filterp(f) + c = patch%column(p) + g = patch%gridcell(p) ! MS added + + ! C3 or C4 photosynthesis logical variable + + if (nint(c3psn(patch%itype(p))) == 1) then + c3flag(p) = .true. + else if (nint(c3psn(patch%itype(p))) == 0) then + c3flag(p) = .false. + end if + + ! C3 and C4 dependent parameters + + if (c3flag(p)) then + qe(p) = 0._r8 + bbbopt(p) = 10000._r8 + else + qe(p) = 0.05_r8 + bbbopt(p) = 40000._r8 + end if + + if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + ! Soil water stress applied to Ball-Berry parameters later in ci_func_PHS + bbb(p) = bbbopt(p) + mbb(p) = mbbopt(patch%itype(p)) + end if + ! kc, ko, cp, from: Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! + ! kc25_coef = 404.9e-6 mol/mol + ! ko25_coef = 278.4e-3 mol/mol + ! cp25_yr2000 = 42.75e-6 mol/mol + ! + ! Derive sco from cp and O2 using present-day O2 (0.209 mol/mol) and re-calculate + ! cp to account for variation in O2 using cp = 0.5 O2 / sco + ! + + kc25 = params_inst%kc25_coef * forc_pbot(c) + ko25 = params_inst%ko25_coef * forc_pbot(c) + sco = 0.5_r8 * 0.209_r8 / params_inst%cp25_yr2000 + cp25 = 0.5_r8 * oair(p) / sco + + kc(p) = kc25 * ft(t_veg(p), params_inst%kcha) + ko(p) = ko25 * ft(t_veg(p), params_inst%koha) + cp(p) = cp25 * ft(t_veg(p), params_inst%cpha) + + end do + + ! Multi-layer parameters scaled by leaf nitrogen profile. + ! Loop through each canopy layer to calculate nitrogen profile using + ! cumulative lai at the midpoint of the layer + + do f = 1, fn + p = filterp(f) + + if (lnc_opt .eqv. .false.) then + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) + lnc(p) = 1._r8 / (slatop(patch%itype(p)) * leafcn(patch%itype(p))) + end if + + ! Using the actual nitrogen allocated to the leaf after + ! uptake rather than fixing leaf nitrogen based on SLA and CN + ! ratio + if (lnc_opt .eqv. .true.) then + ! nlevcan and nrad(p) look like the same variable ?? check this later + sum_nscaler = 0.0_r8 + laican = 0.0_r8 + total_lai = 0.0_r8 + + do iv = 1, nrad(p) + + if (iv == 1) then + laican = 0.5_r8 * tlai_z(p,iv) + total_lai = tlai_z(p,iv) + else + laican = laican + 0.5_r8 * (tlai_z(p,iv-1)+tlai_z(p,iv)) + total_lai = total_lai + tlai_z(p,iv) + end if + + ! Scale for leaf nitrogen profile. If multi-layer code, use explicit + ! profile. If sun/shade big leaf code, use canopy integrated factor. + if (nlevcan == 1) then + nscaler = 1.0_r8 + else if (nlevcan > 1) then + nscaler = exp(-kn(p) * laican) + end if + + sum_nscaler = sum_nscaler + nscaler + + end do + + if (tlai(p) > 0.0_r8 .AND. sum_nscaler > 0.0_r8) then + ! dividing by LAI to convert total leaf nitrogen + ! from m2 ground to m2 leaf; dividing by sum_nscaler to + ! convert total leaf N to leaf N at canopy top + lnc(p) = leafn(p) / (tlai(p) * sum_nscaler) + else + lnc(p) = 0.0_r8 + end if + + end if + lnc(p) = min(lnc(p),10._r8) + + ! reduce_dayl_factor .eqv. .false. + if (reduce_dayl_factor .eqv. .true.) then + if (dayl_factor(p) > 0.25_r8) then + ! dayl_factor(p) = 1.0_r8 + end if + end if + + + ! Default + if (vcmax_opt == 0) then + ! vcmax25 at canopy top, as in CN but using lnc at top of the canopy + vcmax25top = lnc(p) * flnr(patch%itype(p)) * params_inst%fnr * params_inst%act25 * dayl_factor(p) + if (.not. use_cn) then + vcmax25top = vcmax25top * fnitr(patch%itype(p)) + else + if ( CNAllocate_Carbon_only() ) vcmax25top = vcmax25top * fnitr(patch%itype(p)) + end if + else if (vcmax_opt == 3) then + vcmax25top = ( i_vcad(patch%itype(p)) + s_vcad(patch%itype(p)) * lnc(p) ) * dayl_factor(p) + else if (vcmax_opt == 4) then + nptreemax = 9 ! is this number correct? check later + if (patch%itype(p) >= nptreemax) then ! if not tree + ! for shrubs and herbs + vcmax25top = lnc(p) * ( i_flnr(patch%itype(p)) + s_flnr(patch%itype(p)) * lnc(p) ) * params_inst%fnr * params_inst%act25 * & + dayl_factor(p) + else + ! if tree + vcmax25top = lnc(p) * ( i_flnr(patch%itype(p)) * exp(s_flnr(patch%itype(p)) * lnc(p)) ) * params_inst%fnr * params_inst%act25 * & + dayl_factor(p) + ! for trees + end if + end if + + ! Parameters derived from vcmax25top. Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + ! used jmax25 = 1.97 vcmax25, from Wullschleger (1993) Journal of Experimental Botany 44:907-920. + + jmax25top = (2.59_r8 - 0.035_r8*min(max((t10(p)-tfrz),11._r8),35._r8)) * vcmax25top + tpu25top = params_inst%tpu25ratio * vcmax25top + kp25top = params_inst%kp25ratio * vcmax25top + luvcmax25top(p) = vcmax25top + lujmax25top(p) = jmax25top + lutpu25top(p)=tpu25top + + ! Nitrogen scaling factor. Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used + ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al (2010) Biogeosciences, 7, 1833-1859 + ! Remove daylength factor from vcmax25 so that kn is based on maximum vcmax25 + ! But not used as defined here if using sun/shade big leaf code. Instead, + ! will use canopy integrated scaling factors from SurfaceAlbedo. + + if (dayl_factor(p) .eq. 0._r8) then + kn(p) = 0._r8 + else + kn(p) = exp(0.00963_r8 * vcmax25top/dayl_factor(p) - 2.43_r8) + end if + + if (use_cn) then + if ( leafresp_method == leafresp_mtd_ryan1991 ) then + ! Leaf maintenance respiration to match the base rate used in CN + ! but with the new temperature functions for C3 and C4 plants. + ! + ! Base rate for maintenance respiration is from: + ! M. Ryan, 1991. Effects of climate change on plant respiration. + ! Ecological Applications, 1(2), 157-167. + ! Original expression is br = 0.0106 molC/(molN h) + ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) + ! + ! Base rate is at 20C. Adjust to 25C using the CN Q10 = 1.5 + ! + ! CN respiration has units: g C / g N [leaf] / s. This needs to be + ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s + ! + ! Then scale this value at the top of the canopy for canopy depth + + lmr25top = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) + lmr25top = lmr25top * lnc(p) / 12.e-06_r8 + + else if ( leafresp_method == leafresp_mtd_atkin2015 ) then + !using new form for respiration base rate from Atkin + !communication. + if ( lnc(p) > 0.0_r8 ) then + lmr25top = params_inst%lmr_intercept_atkin(ivt(p)) + (lnc(p) * 0.2061_r8) - (0.0402_r8 * (t10(p)-tfrz)) + else + lmr25top = 0.0_r8 + end if + end if + + else + ! Leaf maintenance respiration in proportion to vcmax25top + + if (c3flag(p)) then + lmr25top = vcmax25top * leaf_mr_vcm + else + lmr25top = vcmax25top * 0.025_r8 + end if + end if + + ! Loop through canopy layers (above snow). Respiration needs to be + ! calculated every timestep. Others are calculated only if daytime + + laican = 0._r8 + do iv = 1, nrad(p) + + ! Cumulative lai at middle of layer + + if (iv == 1) then + laican = 0.5_r8 * tlai_z(p,iv) + else + laican = laican + 0.5_r8 * (tlai_z(p,iv-1)+tlai_z(p,iv)) + end if + + ! Scale for leaf nitrogen profile. If multi-layer code, use explicit + ! profile. If sun/shade big leaf code, use canopy integrated factor. + + if (nlevcan == 1) then + nscaler_sun = vcmaxcint_sun(p) + nscaler_sha = vcmaxcint_sha(p) + else if (nlevcan > 1) then + nscaler_sun = exp(-kn(p) * laican) + nscaler_sha = exp(-kn(p) * laican) + end if + + ! Maintenance respiration + + lmr25_sun = lmr25top * nscaler_sun + lmr25_sha = lmr25top * nscaler_sha + + if(use_luna.and.c3flag(p).and.crop(patch%itype(p))== 0)then + if(.not.use_cn)then ! If CN is on, use leaf N to predict respiration (above). Otherwise, use Vcmax term from LUNA. RF + lmr25_sun = leaf_mr_vcm * photosyns_inst%vcmx25_z_patch(p,iv) + lmr25_sha = leaf_mr_vcm * photosyns_inst%vcmx25_z_patch(p,iv) + endif + endif + + if (c3flag(p)) then + lmr_z_sun(p,iv) = lmr25_sun * ft(t_veg(p), params_inst%lmrha) * fth(t_veg(p), params_inst%lmrhd, & + params_inst%lmrse, lmrc) + lmr_z_sha(p,iv) = lmr25_sha * ft(t_veg(p), params_inst%lmrha) * fth(t_veg(p), params_inst%lmrhd, & + params_inst%lmrse, lmrc) + else + lmr_z_sun(p,iv) = lmr25_sun * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + lmr_z_sun(p,iv) = lmr_z_sun(p,iv) / (1._r8 + exp( 1.3_r8*(t_veg(p)-(tfrz+55._r8)) )) + lmr_z_sha(p,iv) = lmr25_sha * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + lmr_z_sha(p,iv) = lmr_z_sha(p,iv) / (1._r8 + exp( 1.3_r8*(t_veg(p)-(tfrz+55._r8)) )) + end if + + ! Reduce lmr w/ low lai + lmr_z_sun(p,iv) = lmr_z_sun(p,iv)*min((0.2_r8*exp(3.218_r8*tlai_z(p,iv))),1._r8) + lmr_z_sha(p,iv) = lmr_z_sha(p,iv)*min((0.2_r8*exp(3.218_r8*tlai_z(p,iv))),1._r8) + + if (par_z_sun(p,iv) <= 0._r8) then ! night time + + vcmax_z(p,sun,iv) = 0._r8 + jmax_z(p,sun,iv) = 0._r8 + tpu_z(p,sun,iv) = 0._r8 + kp_z(p,sun,iv) = 0._r8 + + vcmax_z(p,sha,iv) = 0._r8 + jmax_z(p,sha,iv) = 0._r8 + tpu_z(p,sha,iv) = 0._r8 + kp_z(p,sha,iv) = 0._r8 + + if ( use_c13 ) then + alphapsn_sun(p) = 1._r8 + alphapsn_sha(p) = 1._r8 + end if + + else ! day time + + if(use_luna.and.c3flag(p).and.crop(patch%itype(p))== 0)then + vcmax25_sun = photosyns_inst%vcmx25_z_patch(p,iv) + vcmax25_sha = photosyns_inst%vcmx25_z_patch(p,iv) + jmax25_sun = photosyns_inst%jmx25_z_patch(p,iv) + jmax25_sha = photosyns_inst%jmx25_z_patch(p,iv) + tpu25_sun = params_inst%tpu25ratio * vcmax25_sun + tpu25_sha = params_inst%tpu25ratio * vcmax25_sha + if(surfalb_inst%vcmaxcintsun_patch(p).gt.0._r8.and.nlevcan==1) then + vcmax25_sha = vcmax25_sun * surfalb_inst%vcmaxcintsha_patch(p)/surfalb_inst%vcmaxcintsun_patch(p) + jmax25_sha = jmax25_sun * surfalb_inst%vcmaxcintsha_patch(p)/surfalb_inst%vcmaxcintsun_patch(p) + tpu25_sha = tpu25_sun * surfalb_inst%vcmaxcintsha_patch(p)/surfalb_inst%vcmaxcintsun_patch(p) + end if + else + vcmax25_sun = vcmax25top * nscaler_sun + jmax25_sun = jmax25top * nscaler_sun + tpu25_sun = tpu25top * nscaler_sun + vcmax25_sha = vcmax25top * nscaler_sha + jmax25_sha = jmax25top * nscaler_sha + tpu25_sha = tpu25top * nscaler_sha + endif + kp25_sun = kp25top * nscaler_sun + kp25_sha = kp25top * nscaler_sha + + ! Adjust for temperature + + vcmaxse = 668.39_r8 - 1.07_r8 * min(max((t10(p)-tfrz),11._r8),35._r8) + jmaxse = 659.70_r8 - 0.75_r8 * min(max((t10(p)-tfrz),11._r8),35._r8) + tpuse = vcmaxse + vcmaxc = fth25 (params_inst%vcmaxhd, vcmaxse) + jmaxc = fth25 (params_inst%jmaxhd, jmaxse) + tpuc = fth25 (params_inst%tpuhd, tpuse) + vcmax_z(p,sun,iv) = vcmax25_sun * ft(t_veg(p), params_inst%vcmaxha) * fth(t_veg(p), & + params_inst%vcmaxhd, vcmaxse, vcmaxc) + jmax_z(p,sun,iv) = jmax25_sun * ft(t_veg(p), params_inst%jmaxha) * fth(t_veg(p), & + params_inst%jmaxhd, jmaxse, jmaxc) + tpu_z(p,sun,iv) = tpu25_sun * ft(t_veg(p), params_inst%tpuha) * fth(t_veg(p), & + params_inst%tpuhd, tpuse, tpuc) + vcmax_z(p,sha,iv) = vcmax25_sha * ft(t_veg(p), params_inst%vcmaxha) * fth(t_veg(p), & + params_inst%vcmaxhd, vcmaxse, vcmaxc) + jmax_z(p,sha,iv) = jmax25_sha * ft(t_veg(p), params_inst%jmaxha) * fth(t_veg(p), & + params_inst%jmaxhd, jmaxse, jmaxc) + tpu_z(p,sha,iv) = tpu25_sha * ft(t_veg(p), params_inst%tpuha) * fth(t_veg(p), & + params_inst%tpuhd, tpuse, tpuc) + + if (.not. c3flag(p)) then + vcmax_z(p,sun,iv) = vcmax25_sun * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + vcmax_z(p,sun,iv) = vcmax_z(p,sun,iv) / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-t_veg(p)) )) + vcmax_z(p,sun,iv) = vcmax_z(p,sun,iv) / (1._r8 + exp( 0.3_r8*(t_veg(p)-(tfrz+40._r8)) )) + vcmax_z(p,sha,iv) = vcmax25_sha * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + vcmax_z(p,sha,iv) = vcmax_z(p,sha,iv) / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-t_veg(p)) )) + vcmax_z(p,sha,iv) = vcmax_z(p,sha,iv) / (1._r8 + exp( 0.3_r8*(t_veg(p)-(tfrz+40._r8)) )) + end if + + kp_z(p,sun,iv) = kp25_sun * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + kp_z(p,sha,iv) = kp25_sha * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) + + end if + + ! Change to add in light inhibition of respiration. 0.67 from Lloyd et al. 2010, & Metcalfe et al. 2012 + ! Also pers. comm from Peter Reich (Nov 2015). Might potentially be updated pending findings of Atkin et al. (in prep) + ! review of light inhibition database. + if ( light_inhibit .and. par_z_sun(p,1) > 0._r8) then ! are the lights on? + lmr_z_sun(p,iv) = lmr_z_sun(p,iv) * 0.67_r8 ! inhibit respiration accordingly. + end if + if ( light_inhibit .and. par_z_sha(p,1) > 0._r8) then ! are the lights on? + lmr_z_sha(p,iv) = lmr_z_sha(p,iv) * 0.67_r8 ! inhibit respiration accordingly. + end if + + end do ! canopy layer loop + end do ! patch loop + + !==============================================================================! + ! Leaf-level photosynthesis and stomatal conductance + !==============================================================================! + + rsmax0 = 2.e4_r8 + + do f = 1, fn + p = filterp(f) + c = patch%column(p) + g = patch%gridcell(p) + + ! Leaf boundary layer conductance, umol/m**2/s + + cf = forc_pbot(c)/(rgas*1.e-3_r8*tgcm(p))*1.e06_r8 + gb = 1._r8/rb(p) + gb_mol(p) = gb * cf + + ! Loop through canopy layers (above snow). Only do calculations if daytime + + do iv = 1, nrad(p) + + if (par_z_sun(p,iv) <= 0._r8) then ! night time + + !zqz temporary signal for night time + vegwp(p,sun)=1._r8 + + if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + gsminsun = bbb(p) + gsminsha = bbb(p) + else if ( stomatalcond_mtd == stomatalcond_mtd_medlyn2011 )then + gsminsun = medlynintercept(patch%itype(p)) + gsminsha = medlynintercept(patch%itype(p)) + else + gsminsun = nan + gsminsha = nan + end if + call calcstress(p,c,vegwp(p,:),bsun(p),bsha(p),gb_mol(p),gsminsun, gsminsha, & + qsatl(p),qaf(p), atm2lnd_inst,canopystate_inst,waterdiagnosticbulk_inst, & + soilstate_inst,temperature_inst, waterfluxbulk_inst) + + ac(p,sun,iv) = 0._r8 + aj(p,sun,iv) = 0._r8 + ap(p,sun,iv) = 0._r8 + ag(p,sun,iv) = 0._r8 + if(crop(patch%itype(p))== 0 .or. .not. modifyphoto_and_lmr_forcrop) then + an_sun(p,iv) = ag(p,sun,iv) - bsun(p) * lmr_z_sun(p,iv) + else + an_sun(p,iv) = ag(p,sun,iv) - lmr_z_sun(p,iv) + endif + psn_z_sun(p,iv) = 0._r8 + psn_wc_z_sun(p,iv) = 0._r8 + psn_wj_z_sun(p,iv) = 0._r8 + psn_wp_z_sun(p,iv) = 0._r8 + rs_z_sun(p,iv) = min(rsmax0, 1._r8/(max( bsun(p)*gsminsun, 1._r8 )) * cf) + ci_z_sun(p,iv) = 0._r8 + rh_leaf_sun(p) = 0._r8 + + ac(p,sha,iv) = 0._r8 + aj(p,sha,iv) = 0._r8 + ap(p,sha,iv) = 0._r8 + ag(p,sha,iv) = 0._r8 + if(crop(patch%itype(p))== 0 .or. .not. modifyphoto_and_lmr_forcrop) then + an_sha(p,iv) = ag(p,sha,iv) - bsha(p) * lmr_z_sha(p,iv) + else + an_sha(p,iv) = ag(p,sha,iv) - lmr_z_sha(p,iv) + endif + psn_z_sha(p,iv) = 0._r8 + psn_wc_z_sha(p,iv) = 0._r8 + psn_wj_z_sha(p,iv) = 0._r8 + psn_wp_z_sha(p,iv) = 0._r8 + rs_z_sha(p,iv) = min(rsmax0, 1._r8/(max( bsha(p)*gsminsha, 1._r8 )) * cf) + ci_z_sha(p,iv) = 0._r8 + rh_leaf_sha(p) = 0._r8 +! MS added & based on the code from LJE, XY & BMR------------- + sif_z_sun(p,iv) = 0._r8 + sif_z_sha(p,iv) = 0._r8 + an_z_sun(p,iv) = 0._r8 + an_z_sha(p,iv) = 0._r8 + fs_z_sun(p,iv) = 0._r8 + fs_z_sha(p,iv) = 0._r8 + ps_z_sun(p,iv) = 0._r8 + ps_z_sha(p,iv) = 0._r8 + xsat_z_sun(p,iv)= 0._r8 + xsat_z_sha(p,iv)= 0._r8 + + sifsun(p) = 0._r8 + sifsha(p) = 0._r8 + anetsun(p) = 0._r8 + anetsha(p) = 0._r8 + fyieldsun(p) = 0._r8 ! All yields and light saturation go to zero at night + fyieldsha(p) = 0._r8 ! All yields and light saturation go to zero at night + pyieldsun(p) = 0._r8 + pyieldsha(p) = 0._r8 + xsatsun(p) = 0._r8 + xsatsha(p) = 0._r8 + + par_sun(p) = 0._r8 + par_sha(p) = 0._r8 +! MS ends-------------------------------------------------------------- + else ! day time + + !now the constraint is no longer needed, Jinyun Tang + ceair = min( eair(p), esat_tv(p) ) + if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + rh_can = ceair / esat_tv(p) + else if ( stomatalcond_mtd == stomatalcond_mtd_medlyn2011 )then + ! Put some constraints on RH in the canopy when Medlyn stomatal conductance is being used + rh_can = max((esat_tv(p) - ceair), 50._r8) * 0.001_r8 + end if + + ! Electron transport rate for C3 plants. Convert par from W/m2 to + ! umol photons/m**2/s using the factor 4.6 + + ! sun + qabs = 0.5_r8 * (1._r8 - params_inst%fnps) * par_z_sun(p,iv) * 4.6_r8 + aquad = params_inst%theta_psii + bquad = -(qabs + jmax_z(p,sun,iv)) + cquad = qabs * jmax_z(p,sun,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + je_sun = min(r1,r2) + + ! sha + qabs = 0.5_r8 * (1._r8 - params_inst%fnps) * par_z_sha(p,iv) * 4.6_r8 + aquad = params_inst%theta_psii + bquad = -(qabs + jmax_z(p,sha,iv)) + cquad = qabs * jmax_z(p,sha,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + je_sha = min(r1,r2) + + ! Iterative loop for ci beginning with initial guess + + if (c3flag(p)) then + ci_z_sun(p,iv) = 0.7_r8 * cair(p) + ci_z_sha(p,iv) = 0.7_r8 * cair(p) + else + ci_z_sun(p,iv) = 0.4_r8 * cair(p) + ci_z_sha(p,iv) = 0.4_r8 * cair(p) + end if + + !find ci and stomatal conductance + call hybrid_PHS(ci_z_sun(p,iv), ci_z_sha(p,iv), p, iv, c, gb_mol(p), bsun(p),bsha(p), je_sun, & + je_sha, cair(p), oair(p), lmr_z_sun(p,iv), lmr_z_sha(p,iv), & + par_z_sun(p,iv), par_z_sha(p,iv), rh_can, gs_mol_sun(p,iv), gs_mol_sha(p,iv), & + qsatl(p), qaf(p), iter1, iter2, atm2lnd_inst, photosyns_inst, & + canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, temperature_inst, waterfluxbulk_inst) + if ( stomatalcond_mtd == stomatalcond_mtd_medlyn2011 )then + gsminsun = medlynintercept(patch%itype(p)) + gsminsha = medlynintercept(patch%itype(p)) + gs_slope_sun = medlynslope(patch%itype(p)) + gs_slope_sha = medlynslope(patch%itype(p)) + else if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + gsminsun = bbb(p) + gsminsha = bbb(p) + gs_slope_sun = mbb(p) + gs_slope_sha = mbb(p) + end if + + ! End of ci iteration. Check for an < 0, in which case gs_mol = bbb + + if (an_sun(p,iv) < 0._r8) gs_mol_sun(p,iv) = max( bsun(p)*gsminsun, 1._r8 ) + if (an_sha(p,iv) < 0._r8) gs_mol_sha(p,iv) = max( bsha(p)*gsminsha, 1._r8 ) + ! Use time period 1 hour before and 1 hour after local noon inclusive (11AM-1PM) + if ( is_near_local_noon( grc%londeg(g), deltasec=3600 ) )then + gs_mol_sun_ln(p,iv) = gs_mol_sun(p,iv) + gs_mol_sha_ln(p,iv) = gs_mol_sha(p,iv) + else + gs_mol_sun_ln(p,iv) = spval + gs_mol_sha_ln(p,iv) = spval + end if + + ! Final estimates for cs and ci (needed for early exit of ci iteration when an < 0) + + cs_sun = cair(p) - 1.4_r8/gb_mol(p) * an_sun(p,iv) * forc_pbot(c) + cs_sun = max(cs_sun,1.e-06_r8) + ci_z_sun(p,iv) = cair(p) - an_sun(p,iv) * forc_pbot(c) * & + (1.4_r8*gs_mol_sun(p,iv)+1.6_r8*gb_mol(p)) / & + (gb_mol(p)*gs_mol_sun(p,iv)) + + ! Trap for values of ci_z_sun less than 1.e-06. This is needed for + ! Megan (which can crash with negative values) + ci_z_sun(p,iv) = max( ci_z_sun(p,iv), 1.e-06_r8 ) + + cs_sha = cair(p) - 1.4_r8/gb_mol(p) * an_sha(p,iv) * forc_pbot(c) + cs_sha = max(cs_sha,1.e-06_r8) + ci_z_sha(p,iv) = cair(p) - an_sha(p,iv) * forc_pbot(c) * & + (1.4_r8*gs_mol_sha(p,iv)+1.6_r8*gb_mol(p)) / & + (gb_mol(p)*gs_mol_sha(p,iv)) + + ! Trap for values of ci_z_sha less than 1.e-06. This is needed for + ! Megan (which can crash with negative values) + ci_z_sha(p,iv) = max( ci_z_sha(p,iv), 1.e-06_r8 ) + + ! Convert gs_mol (umol H2O/m**2/s) to gs (m/s) and then to rs (s/m) + + gs = gs_mol_sun(p,iv) / cf + rs_z_sun(p,iv) = min(1._r8/gs, rsmax0) + rs_z_sun(p,iv) = rs_z_sun(p,iv) / o3coefg_sun(p) + gs = gs_mol_sha(p,iv) / cf + rs_z_sha(p,iv) = min(1._r8/gs, rsmax0) + rs_z_sha(p,iv) = rs_z_sha(p,iv) / o3coefg_sha(p) + + ! Photosynthesis. Save rate-limiting photosynthesis + + psn_z_sun(p,iv) = ag(p,sun,iv) + psn_z_sun(p,iv) = psn_z_sun(p,iv) * o3coefv_sun(p) + + psn_wc_z_sun(p,iv) = 0._r8 + psn_wj_z_sun(p,iv) = 0._r8 + psn_wp_z_sun(p,iv) = 0._r8 + + an_z_sun(p,iv) = ag(p,sun,iv)-lmr_z_sun(p,iv) ! MS included + + if (ac(p,sun,iv) <= aj(p,sun,iv) .and. ac(p,sun,iv) <= ap(p,sun,iv)) then + psn_wc_z_sun(p,iv) = psn_z_sun(p,iv) + else if (aj(p,sun,iv) < ac(p,sun,iv) .and. aj(p,sun,iv) <= ap(p,sun,iv)) then + psn_wj_z_sun(p,iv) = psn_z_sun(p,iv) + else if (ap(p,sun,iv) < ac(p,sun,iv) .and. ap(p,sun,iv) < aj(p,sun,iv)) then + psn_wp_z_sun(p,iv) = psn_z_sun(p,iv) + end if +! MS added into CLM5 and based on the code from LJE, XY & BMR -------------------- + + po0 = 1._r8 - params_inst%fnps ! Defining dark adapted max photochemical yield + + if(c3flag(p)) then + + ! ! Original potential Ja without nitrogen downscaling + + co2(p) = forc_pco2(g) + ja_sun = max(psn_z_sun(p,iv)*(ci_z_sun(p,iv)+2._r8*cp(p))/(ci_z_sun(p,iv)-cp(p)), 0._r8) ! Lee et al. (2015) (umol electrons m-2 s-1) + + xsat_z_sun(p,iv) = ja_sun/qabs + ps_z_sun(p,iv) = xsat_z_sun(p,iv)*po0 + else + ps_z_sun(p,iv) = psn_z_sun(p,iv)/aj(p,sun,iv)*po0 + end if + + ps_z_sun(p,iv) = max(ps_z_sun(p,iv),0._r8) + + if (psn_z_sun(p,iv) <= 0._r8) xsat_z_sun(p,iv)=0._r8 + + call fluorescence(ps_z_sun(p,iv),po0,fs_z_sun(p,iv)) + + fs_z_sun(p,iv) = max(fs_z_sun(p,iv),0._r8) + + sif_z_sun(p,iv) = fs_z_sun(p,iv) * par_z_sun(p,iv) ! (W m-2) = (photon absorbed photon emitted of PAR)*(W m-2) + ! (W m-2) = (W W-1)*(W m-2) equivalent expression for fluorescence yield + psn_z_sha(p,iv) = ag(p,sha,iv) + psn_z_sha(p,iv) = psn_z_sha(p,iv) * o3coefv_sha(p) + + psn_wc_z_sha(p,iv) = 0._r8 + psn_wj_z_sha(p,iv) = 0._r8 + psn_wp_z_sha(p,iv) = 0._r8 + + an_z_sha(p,iv) = ag(p,sha,iv)-lmr_z_sha(p,iv) ! MS included + + if (ac(p,sha,iv) <= aj(p,sha,iv) .and. ac(p,sha,iv) <= ap(p,sha,iv)) then + psn_wc_z_sha(p,iv) = psn_z_sha(p,iv) + else if (aj(p,sha,iv) < ac(p,sha,iv) .and. aj(p,sha,iv) <= ap(p,sha,iv)) then + psn_wj_z_sha(p,iv) = psn_z_sha(p,iv) + else if (ap(p,sha,iv) < ac(p,sha,iv) .and. ap(p,sha,iv) < aj(p,sha,iv)) then + psn_wp_z_sha(p,iv) = psn_z_sha(p,iv) + end if +! MS added into CLM5 and based on the code from LJE, XY & BMR -------------------- + + po0 = 1._r8 - params_inst%fnps ! Defining dark adapted max photochemical yield + + if(c3flag(p)) then + ! ! Original potential Ja without nitrogen downscaling + + co2(p) = forc_pco2(g) + ja_sha = max(psn_z_sha(p,iv)*(ci_z_sha(p,iv)+2._r8*cp(p))/(ci_z_sha(p,iv)-cp(p)), 0._r8) + + xsat_z_sha(p,iv) = ja_sha/qabs + ps_z_sha(p,iv) = xsat_z_sha(p,iv)*po0 + else + ps_z_sha(p,iv) = psn_z_sha(p,iv)/aj(p,sha,iv) * po0 + end if + + ps_z_sha(p,iv) = max(ps_z_sha(p,iv),0._r8) ! MS added this line to make sure ps_z_sun is no larger than 1. + + if (psn_z_sha(p,iv) <= 0._r8) xsat_z_sha(p,iv)=0._r8 + + call fluorescence(ps_z_sha(p,iv),po0,fs_z_sha(p,iv)) + + fs_z_sha(p,iv) = max(fs_z_sha(p,iv),0._r8) + + sif_z_sha(p,iv) = fs_z_sha(p,iv) * par_z_sha(p,iv) +!-----MS ends -------------------------------------------------------------------- + ! Make sure iterative solution is correct + + if (gs_mol_sun(p,iv) < 0._r8 .or. gs_mol_sha(p,iv) < 0._r8) then + write (iulog,*)'Negative stomatal conductance:' + write (iulog,*)'p,iv,gs_mol_sun,gs_mol_sha= ',p,iv,gs_mol_sun(p,iv),gs_mol_sha(p,iv) + call endrun(decomp_index=p, clmlevel=namep, msg=errmsg(sourcefile, __LINE__)) + end if + + ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b + + hs = (gb_mol(p)*ceair + gs_mol_sun(p,iv)*esat_tv(p)) / ((gb_mol(p)+gs_mol_sun(p,iv))*esat_tv(p)) + rh_leaf_sun(p) = hs + gs_mol_err = gs_slope_sun*max(an_sun(p,iv), 0._r8)*hs/cs_sun*forc_pbot(c) + max( bsun(p)*gsminsun, 1._r8 ) + + if (abs(gs_mol_sun(p,iv)-gs_mol_err) > 1.e-01_r8 .and. (stomatalcond_mtd == stomatalcond_mtd_bb1987) ) then + write (iulog,*) 'Ball-Berry error check - sunlit stomatal conductance error:' + write (iulog,*) gs_mol_sun(p,iv), gs_mol_err + end if + + hs = (gb_mol(p)*ceair + gs_mol_sha(p,iv)*esat_tv(p)) / ((gb_mol(p)+gs_mol_sha(p,iv))*esat_tv(p)) + rh_leaf_sha(p) = hs + gs_mol_err = gs_slope_sha*max(an_sha(p,iv), 0._r8)*hs/cs_sha*forc_pbot(c) + max( bsha(p)*gsminsha, 1._r8) + + if (abs(gs_mol_sha(p,iv)-gs_mol_err) > 1.e-01_r8 .and. (stomatalcond_mtd == stomatalcond_mtd_bb1987) ) then + write (iulog,*) 'Ball-Berry error check - shaded stomatal conductance error:' + write (iulog,*) gs_mol_sha(p,iv), gs_mol_err + end if + + end if ! night or day if branch + end do ! canopy layer loop + end do ! patch loop + + !==============================================================================! + ! Canopy photosynthesis and stomatal conductance + !==============================================================================! + + ! Sum canopy layer fluxes and then derive effective leaf-level fluxes (per + ! unit leaf area), which are used in other parts of the model. Here, laican + ! sums to either laisun or laisha. + + do f = 1, fn + p = filterp(f) + + psncan_sun = 0._r8 + psncan_wc_sun = 0._r8 + psncan_wj_sun = 0._r8 + psncan_wp_sun = 0._r8 + lmrcan_sun = 0._r8 + gscan_sun = 0._r8 + laican_sun = 0._r8 +! MS added + sifcan_sun = 0._r8 + ancan_sun = 0._r8 + fyieldcan_sun = 0._r8 + pyieldcan_sun = 0._r8 + xsatcan_sun = 0._r8 + parcan_sun = 0._r8 +! MS ends + do iv = 1, nrad(p) + psncan_sun = psncan_sun + psn_z_sun(p,iv) * lai_z_sun(p,iv) + psncan_wc_sun = psncan_wc_sun + psn_wc_z_sun(p,iv) * lai_z_sun(p,iv) + psncan_wj_sun = psncan_wj_sun + psn_wj_z_sun(p,iv) * lai_z_sun(p,iv) + psncan_wp_sun = psncan_wp_sun + psn_wp_z_sun(p,iv) * lai_z_sun(p,iv) + if(crop(patch%itype(p))== 0 .and. modifyphoto_and_lmr_forcrop) then + lmrcan_sun = lmrcan_sun + lmr_z_sun(p,iv) * lai_z_sun(p,iv) * bsun(p) + else + lmrcan_sun = lmrcan_sun + lmr_z_sun(p,iv) * lai_z_sun(p,iv) + endif + gscan_sun = gscan_sun + lai_z_sun(p,iv) / (rb(p)+rs_z_sun(p,iv)) + laican_sun = laican_sun + lai_z_sun(p,iv) +! MS added the code from LJE, XY & BMR--------------------------- + sifcan_sun = sifcan_sun + sif_z_sun(p,iv) * lai_z_sun(p,iv) + ancan_sun = ancan_sun + an_z_sun(p,iv) * lai_z_sun(p,iv) + fyieldcan_sun = fyieldcan_sun + fs_z_sun(p,iv) * lai_z_sun(p,iv) + pyieldcan_sun = pyieldcan_sun + ps_z_sun(p,iv) * lai_z_sun(p,iv) + xsatcan_sun = xsatcan_sun + xsat_z_sun(p,iv)* lai_z_sun(p,iv) + parcan_sun = parcan_sun + par_z_sun(p,iv) * lai_z_sun(p,iv) +! MS ends-------------------------------------------------------- + end do + if (laican_sun > 0._r8) then + psn_sun(p) = psncan_sun / laican_sun + psn_wc_sun(p) = psncan_wc_sun / laican_sun + psn_wj_sun(p) = psncan_wj_sun / laican_sun + psn_wp_sun(p) = psncan_wp_sun / laican_sun + lmr_sun(p) = lmrcan_sun / laican_sun + rs_sun(p) = laican_sun / gscan_sun - rb(p) +! MS added + sifsun(p) = sifcan_sun / laican_sun + anetsun(p) = ancan_sun / laican_sun + fyieldsun(p)= fyieldcan_sun / laican_sun + pyieldsun(p)= pyieldcan_sun / laican_sun + xsatsun(p) = xsatcan_sun / laican_sun + par_sun(p) = parcan_sun / laican_sun +! MS ends + else + psn_sun(p) = 0._r8 + psn_wc_sun(p) = 0._r8 + psn_wj_sun(p) = 0._r8 + psn_wp_sun(p) = 0._r8 + lmr_sun(p) = 0._r8 + rs_sun(p) = 0._r8 +! MS added the code from LJE, XY & BMR------------- + sifsun(p) = 0._r8 + anetsun(p) = 0._r8 ! BMR 8/6/15 + fyieldsun(p) = 0._r8 + pyieldsun(p) = 0._r8 + xsatsun(p) = 0._r8 + par_sun(p) = 0._r8 +! MS ends------------------------------------------ + end if + psncan_sha = 0._r8 + psncan_wc_sha = 0._r8 + psncan_wj_sha = 0._r8 + psncan_wp_sha = 0._r8 + lmrcan_sha = 0._r8 + gscan_sha = 0._r8 + laican_sha = 0._r8 +! MS added + sifcan_sha = 0._r8 + ancan_sha = 0._r8 + fyieldcan_sha = 0._r8 + pyieldcan_sha = 0._r8 + xsatcan_sha = 0._r8 + parcan_sha = 0._r8 +! MS ends + do iv = 1, nrad(p) + psncan_sha = psncan_sha + psn_z_sha(p,iv) * lai_z_sha(p,iv) + psncan_wc_sha = psncan_wc_sha + psn_wc_z_sha(p,iv) * lai_z_sha(p,iv) + psncan_wj_sha = psncan_wj_sha + psn_wj_z_sha(p,iv) * lai_z_sha(p,iv) + psncan_wp_sha = psncan_wp_sha + psn_wp_z_sha(p,iv) * lai_z_sha(p,iv) + if(crop(patch%itype(p))== 0 .and. modifyphoto_and_lmr_forcrop) then + lmrcan_sha = lmrcan_sha + lmr_z_sha(p,iv) * lai_z_sha(p,iv) * bsha(p) + else + lmrcan_sha = lmrcan_sha + lmr_z_sha(p,iv) * lai_z_sha(p,iv) + endif + gscan_sha = gscan_sha + lai_z_sha(p,iv) / (rb(p)+rs_z_sha(p,iv)) + laican_sha = laican_sha + lai_z_sha(p,iv) + +! MS added the code from LJE, XY & BMR--------------------------- + sifcan_sha = sifcan_sha + sif_z_sha(p,iv) * lai_z_sha(p,iv) + ancan_sha = ancan_sha + an_z_sha(p,iv) * lai_z_sha(p,iv) + fyieldcan_sha = fyieldcan_sha + fs_z_sha(p,iv) * lai_z_sha(p,iv) + pyieldcan_sha = pyieldcan_sha + ps_z_sha(p,iv) * lai_z_sha(p,iv) + xsatcan_sha = xsatcan_sha + xsat_z_sha(p,iv)* lai_z_sha(p,iv) + parcan_sha = parcan_sha + par_z_sha(p,iv) * lai_z_sha(p,iv) +! MS ends-------------------------------------------------------- + end do + if (laican_sha > 0._r8) then + psn_sha(p) = psncan_sha / laican_sha + psn_wc_sha(p) = psncan_wc_sha / laican_sha + psn_wj_sha(p) = psncan_wj_sha / laican_sha + psn_wp_sha(p) = psncan_wp_sha / laican_sha + lmr_sha(p) = lmrcan_sha / laican_sha + rs_sha(p) = laican_sha / gscan_sha - rb(p) +! MS added + sifsha(p) = sifcan_sha / laican_sha + anetsha(p) = ancan_sha / laican_sha + fyieldsha(p)= fyieldcan_sha / laican_sha + pyieldsha(p)= pyieldcan_sha / laican_sha + xsatsha(p) = xsatcan_sha / laican_sha + par_sha(p) = parcan_sha / laican_sha +! MS ends + else + psn_sha(p) = 0._r8 + psn_wc_sha(p) = 0._r8 + psn_wj_sha(p) = 0._r8 + psn_wp_sha(p) = 0._r8 + lmr_sha(p) = 0._r8 + rs_sha(p) = 0._r8 +! MS added the code from LJE, XY & BMR------------- + sifsha(p) = 0._r8 + anetsha(p) = 0._r8 ! BMR 8/6/15 + fyieldsha(p) = 0._r8 + pyieldsha(p) = 0._r8 + xsatsha(p) = 0._r8 + par_sha(p) = 0._r8 +! MS ends------------------------------------------ + end if + + if ( laican_sha+laican_sun > 0._r8 ) then + btran(p) = bsun(p) * (laican_sun / (laican_sun + laican_sha)) + & + bsha(p) * (laican_sha / (laican_sun + laican_sha)) + else + ! In this case, bsun and bsha should have the same value and btran + ! can be set to either bsun or bsha. + btran(p) = bsun(p) + end if + + end do + + end associate + + end subroutine PhotosynthesisHydraulicStress + !------------------------------------------------------------------------------ + + !-------------------------------------------------------------------------------- + subroutine hybrid_PHS(x0sun, x0sha, p, iv, c, gb_mol, bsun, bsha, jesun, jesha, & + cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + gs_mol_sun, gs_mol_sha, qsatl, qaf, iter1, iter2, atm2lnd_inst, photosyns_inst, & + canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, temperature_inst, waterfluxbulk_inst) + ! + !! DESCRIPTION: + !use a hybrid solver to find the root of the ci_func equation for sunlit and shaded leaves + ! f(x) = x- h(x) + !we want to find x, s.t. f(x) = 0. + !outside loop iterates for bsun/bsha, which are functions of stomatal conductance + !the hybrid approach combines the strength of the newton secant approach (find the solution domain) + !and the bisection approach implemented with the Brent's method to guarantee convergence. + ! + !! REVISION HISTORY: + ! + ! + !!USES: + ! + !! ARGUMENTS: + implicit none + real(r8), intent(inout) :: x0sun,x0sha ! initial guess and final value of the solution for cisun/cisha + integer , intent(in) :: p ! pft index + integer , intent(in) :: iv ! radiation canopy layer index + integer , intent(in) :: c ! column index + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(out) :: bsun ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8), intent(out) :: bsha ! shaded canopy transpiration wetness factor (0 to 1) + real(r8), intent(in) :: jesun ! sunlit leaf electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: jesha ! shaded leaf electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: cair ! Atmospheric CO2 partial pressure (Pa) + real(r8), intent(in) :: oair ! Atmospheric O2 partial pressure (Pa) + real(r8), intent(in) :: lmr_z_sun ! sunlit canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), intent(in) :: lmr_z_sha ! shaded canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), intent(in) :: par_z_sun ! par absorbed per unit lai for sunlit canopy layer (w/m**2) + real(r8), intent(in) :: par_z_sha ! par absorbed per unit lai for shaded canopy layer (w/m**2) + real(r8), intent(in) :: rh_can ! canopy air relative humidity + real(r8), intent(out) :: gs_mol_sun ! sunlit leaf stomatal conductance (umol H2O/m**2/s) + real(r8), intent(out) :: gs_mol_sha ! shaded leaf stomatal conductance (umol H2O/m**2/s) + real(r8), intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8), intent(in) :: qaf ! humidity of canopy air [kg/kg] + integer, intent(out) :: iter1 ! number of iterations used to find appropriate bsun/bsha + integer, intent(out) :: iter2 ! number of iterations used to find cisun/cisha + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(waterdiagnosticbulk_type) , intent(inout) :: waterdiagnosticbulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + ! + !! LOCAL VARIABLES + real(r8) :: x(nvegwcs) ! working copy of vegwp(p,:) + real(r8) :: gs0sun ! unstressed sunlit stomatal conductance + real(r8) :: gs0sha ! unstressed shaded stomatal conductance + logical :: havegs ! signals direction of calculation gs->qflx or qflx->gs + real(r8) :: soilflux ! total soil column transpiration [mm/s] + real(r8) :: x1sun ! second guess for cisun + real(r8) :: f0sun ! error of cifunc(x0sun) + real(r8) :: f1sun ! error of cifunc(x1sun) + real(r8) :: xsun ! open variable for brent to return cisun solution + real(r8) :: dxsun ! delta cisun from iter_i to iter_i+1 + real(r8) :: x1sha ! second guess for cisha + real(r8) :: f0sha ! error of cifunc(x0sha) + real(r8) :: f1sha ! error of cifunc(x1sha) + real(r8) :: xsha ! open variable for brent to return cisha solution + real(r8) :: dxsha ! delta cisha from iter_i to iter_i+1 + real(r8) :: b0sun ! bsun from previous iter + real(r8) :: b0sha ! bsha from previous iter + real(r8) :: dbsun ! delta(bsun) from iter_i to iter_i+1 + real(r8) :: dbsha ! delta(bsun) from iter_i to iter_i+1 + logical :: bflag ! signals to call calcstress to recalc bsun/bsha (or not) + real(r8) :: tolsun ! error tolerance for cisun solution [Pa] + real(r8) :: tolsha ! error tolerance for cisun solution [Pa] + real(r8) :: minf ! storage spot for best cisun/cisha solution + real(r8) :: minxsun ! cisun associated with minf + real(r8) :: minxsha ! cisha associated with minf + real(r8), parameter :: toldb = 1.e-2_r8 ! tolerance for satisfactory bsun/bsha solution + real(r8), parameter :: eps = 1.e-2_r8 ! relative accuracy + real(r8), parameter :: eps1= 1.e-4_r8 ! absolute accuracy threshold for fsun/fsha + integer , parameter :: itmax = 3 ! maximum number of iterations zqz (increase later) + !------------------------------------------------------------------------------ + + associate( & + qflx_tran_veg => waterfluxbulk_inst%qflx_tran_veg_patch , & ! Input: [real(r8) (:) ] vegetation transpiration (mm H2O/s) (+ = to atm) + vegwp => canopystate_inst%vegwp_patch & ! Input/Output: [real(r8) (:,:) ] vegetation water matric potential (mm) + ) + + + x1sun = x0sun + x1sha = x0sha + bflag = .false. + b0sun = -1._r8 + b0sha = -1._r8 + gs0sun = 0._r8 ! Initialize to zero as good form, not used on first itteration below because of bflag + gs0sha = 0._r8 ! Initialize to zero as good form, not used on first itteration below because of bflag + bsun = 1._r8 + bsha = 1._r8 + iter1 = 0 + + do !outer loop updates bsun/bsha and makes two ci_func calls for interpolation + x=vegwp(p,:) + iter1=iter1+1 + iter2=0 + x0sun=max(0.1_r8,x1sun) !need to make sure x0 .neq. x1 + x1sun=0.99_r8*x1sun + x0sha=max(0.1_r8,x1sha) + x1sha=0.99_r8*x1sha + tolsun = abs(x1sun) * eps + tolsha = abs(x1sha) * eps + + ! this ci_func_PHS call updates bsun/bsha (except on first iter) + call ci_func_PHS(x,x0sun, x0sha, f0sun, f0sha, p, iv, c, bsun, bsha, bflag, gb_mol, gs0sun, gs0sha,& + gs_mol_sun, gs_mol_sha, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + qsatl, qaf, atm2lnd_inst, photosyns_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + + ! update bsun/bsha convergence vars + dbsun=b0sun-bsun + dbsha=b0sha-bsha + b0sun=bsun + b0sha=bsha + bflag=.false. + + ! this ci_func_PHS call creates second point for ci interpolation + call ci_func_PHS(x,x1sun, x1sha, f1sun, f1sha, p, iv, c, bsun, bsha, bflag, gb_mol, gs0sun, gs0sha,& + gs_mol_sun, gs_mol_sha, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + qsatl, qaf, atm2lnd_inst, photosyns_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + + do !inner loop finds ci + if ( (abs(f0sun) < eps1) .and. (abs(f0sha) < eps1) ) then + x1sun=x0sun + x1sha=x0sha + exit + endif + if ( (abs(f1sun) < eps1) .and. (abs(f1sha) < eps1) ) then + exit + endif + iter2=iter2+1 + + if ( (f1sun - f0sun) == 0._r8) then + !makes next x1sun the midpt between current x1 & x0 + dxsun = 0.5_r8*(x1sun+x0sun)-x1sun + else + dxsun=-f1sun*(x1sun-x0sun)/(f1sun-f0sun) + end if + if ( (f1sha - f0sha) == 0._r8) then + dxsha = 0.5_r8*(x1sha+x0sha)-x1sha + else + dxsha=-f1sha*(x1sha-x0sha)/(f1sha-f0sha) + end if + x0sun=x1sun + x1sun=x1sun+dxsun + x0sha=x1sha + x1sha=x1sha+dxsha + + call ci_func_PHS(x,x1sun, x1sha, f1sun, f1sha, p, iv, c, bsun, bsha, bflag, gb_mol, gs0sun, gs0sha,& + gs_mol_sun, gs_mol_sha, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + qsatl, qaf, atm2lnd_inst, photosyns_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + + if ( (abs(dxsun) < tolsun ) .and. (abs(dxsha) itmax) then + x1sun=minxsun + x1sha=minxsha + call ci_func_PHS(x,x1sun, x1sha, f1sun, f1sha, p, iv, c, bsun, bsha, bflag, gb_mol, gs0sun, gs0sha,& + gs_mol_sun, gs_mol_sha, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + qsatl, qaf, atm2lnd_inst, photosyns_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + exit + endif + + enddo + + !update unstressed stomatal conductance + if (bsun>0.01_r8) then + gs0sun=gs_mol_sun/bsun + endif + if (bsha>0.01_r8) then + gs0sha=gs_mol_sha/bsha + endif + + bflag=.true. + + if ( (abs(dbsun) < toldb) .and. (abs(dbsha) < toldb) ) then + exit + endif + + if (iter1 > itmax) then + exit + endif + + enddo + x0sun=x1sun + x0sha=x1sha + + !set vegwp for the final gs_mol solution + call getvegwp(p, c, x, gb_mol, gs_mol_sun, gs_mol_sha, qsatl, qaf, soilflux, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, temperature_inst) + vegwp(p,:)=x + if (soilflux<0._r8) soilflux = 0._r8 + qflx_tran_veg(p) = soilflux + + end associate + + end subroutine hybrid_PHS + !-------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------ + subroutine brent_PHS(xsun, x1sun, x2sun, f1sun, f2sun, xsha, x1sha, x2sha, f1sha, f2sha, & + tol, ip, iv, ic, gb_mol, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha,& + rh_can, gs_mol_sun, gs_mol_sha, bsun, bsha, qsatl, qaf, atm2lnd_inst, photosyns_inst, & + canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, temperature_inst, waterfluxbulk_inst) + !------------------------------------------------------------------------------ + implicit none + ! + !!DESCRIPTION: + !Use Brent's method to find the root of a single variable function ci_func, which is known to exist between x1 and x2. + !The found root will be updated until its accuracy is tol. Performed for cisun and cisha. + ! + !!REVISION HISTORY: + ! + !!ARGUMENTS: + real(r8), intent(out) :: xsun ! independent variable of the single value function ci_func(x) + real(r8), intent(in) :: x1sun, x2sun ! minimum and maximum of the variable domain to search for the solution ci_func(x1) = f1, ci_func(x2)=f2 + real(r8), intent(in) :: f1sun, f2sun ! minimum and maximum of the variable domain to search for the solution ci_func(x1) = f1, ci_func(x2)=f2 + real(r8), intent(out) :: xsha ! independent variable of the single value function ci_func(x) + real(r8), intent(in) :: x1sha, x2sha ! minimum and maximum of the variable domain to search for the solution ci_func(x1) = f1, ci_func(x2)=f2 + real(r8), intent(in) :: f1sha, f2sha ! minimum and maximum of the variable domain to search for the solution ci_func(x1) = f1, ci_func(x2)=f2 + real(r8), intent(in) :: tol ! the error tolerance + integer , intent(in) :: ip, iv, ic ! pft, c3/c4, and column index + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(in) :: jesun,jesha ! electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: cair ! Atmospheric CO2 partial pressure (Pa) + real(r8), intent(in) :: oair ! Atmospheric O2 partial pressure (Pa) + real(r8), intent(in) :: lmr_z_sun, lmr_z_sha ! canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), intent(in) :: par_z_sun, par_z_sha ! par absorbed per unit lai for canopy layer (w/m**2) + real(r8), intent(in) :: rh_can ! inside canopy relative humidity + real(r8), intent(out) :: gs_mol_sun ! sunlit leaf stomatal conductance (umol H2O/m**2/s) + real(r8), intent(out) :: gs_mol_sha ! shaded leaf stomatal conductance (umol H2O/m**2/s) + real(r8), intent(inout) :: bsun ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8), intent(inout) :: bsha ! shaded canopy transpiration wetness factor (0 to 1) + real(r8), intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8), intent(in) :: qaf ! humidity of canopy air [kg/kg] + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(waterdiagnosticbulk_type) , intent(inout) :: waterdiagnosticbulk_inst + type(waterfluxbulk_type) , intent(inout) :: waterfluxbulk_inst + type(soilstate_type) , intent(inout) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + !------------------------------------------------------------------------------ + ! !LOCAL VARIABLES: + real(r8) :: gs0sun ! sunlit leaf stomatal conductance (umol H2O/m**2/s) + real(r8) :: gs0sha ! shaded leaf stomatal conductance (umol H2O/m**2/s) + integer :: phase ! sun==1, sha==2 + integer , parameter :: nphs = 2 ! number of phases for sun/shade + integer , parameter :: itmax = 20 ! maximum number of iterations + real(r8), parameter :: eps = 1.e-4_r8 ! relative error tolerance + integer :: iter ! + real(r8) :: a(nphs),b(nphs),c(nphs),d(nphs),e(nphs),fa(nphs),fb(nphs),fc(nphs) + real(r8) :: p(nphs),q(nphs),r(nphs),s(nphs),tol1(nphs),xm(nphs) + real(r8) :: x(nvegwcs) !dummy variable passed to cifunc + logical , parameter :: bflag = .false. !indicates the cifunc should not call calcstress + !------------------------------------------------------------------------------ + + a(:)=(/x1sun,x1sha/) + b(:)=(/x2sun,x2sha/) + fa(:)=(/f1sun,f1sha/) + fb(:)=(/f2sun,f2sha/) + + do phase=1, nphs + if ( (fa(phase) > 0._r8 .and. fb(phase) > 0._r8) .or. (fa(phase) < 0._r8 .and. fb(phase) < 0._r8) ) then + write(iulog,*) 'root must be bracketed for brent' + call endrun(msg=errmsg(sourcefile, __LINE__)) + endif + enddo + + c=b + fc=fb + iter = 0 + do + if( iter == itmax ) exit + iter=iter+1 + + do phase=1, nphs + if( (fb(phase) > 0._r8 .and. fc(phase) > 0._r8) .or. (fb(phase) < 0._r8 .and. fc(phase) < 0._r8)) then + c(phase)=a(phase) !Rename a, b, c and adjust bounding interval d. + fc(phase)=fa(phase) + d(phase)=b(phase)-a(phase) + e(phase)=d(phase) + endif + if( abs(fc(phase)) < abs(fb(phase)) ) then + a(phase)=b(phase) + b(phase)=c(phase) + c(phase)=a(phase) + fa(phase)=fb(phase) + fb(phase)=fc(phase) + fc(phase)=fa(phase) + endif + enddo + tol1=2._r8*eps*abs(b)+0.5_r8*tol !Convergence check. + xm=0.5_r8*(c-b) + + if( abs(xm(sun)) <= tol1(sun) .or. fb(sun) == 0._r8 ) then + if( abs(xm(sha)) <= tol1(sha) .or. fb(sha) == 0._r8 ) then + xsun=b(sun) + xsha=b(sha) + return + endif + endif + + do phase=1, nphs + if( abs(e(phase)) >= tol1(phase) .and. abs(fa(phase)) > abs(fb(phase)) ) then + s(phase)=fb(phase)/fa(phase) !Attempt inverse quadratic interpolation. + if(a(phase) == c(phase)) then + p(phase)=2._r8*xm(phase)*s(phase) + q(phase)=1._r8-s(phase) + else + q(phase)=fa(phase)/fc(phase) + r(phase)=fb(phase)/fc(phase) + p(phase)=s(phase)*(2._r8*xm(phase)*q(phase)*(q(phase)-r(phase))-(b(phase)-a(phase))*(r(phase)-1._r8)) + q(phase)=(q(phase)-1._r8)*(r(phase)-1._r8)*(s(phase)-1._r8) + endif + if( p(phase) > 0._r8 ) q(phase)=-q(phase) !Check whether in bounds. + p(phase)=abs(p(phase)) + if( 2._r8*p(phase) < min(3._r8*xm(phase)*q(phase)-abs(tol1(phase)*q(phase)),abs(e(phase)*q(phase))) ) then + e(phase)=d(phase) !Accept interpolation. + d(phase)=p(phase)/q(phase) + else + d(phase)=xm(phase) !Interpolation failed, use bisection. + e(phase)=d(phase) + endif + else !Bounds decreasing too slowly, use bisection. + d(phase)=xm(phase) + e(phase)=d(phase) + endif + a(phase)=b(phase) !Move last best guess to a. + fa(phase)=fb(phase) + if( abs(d(phase)) > tol1(phase) ) then !Evaluate new trial root. + b(phase)=b(phase)+d(phase) + else + b(phase)=b(phase)+sign(tol1(phase),xm(phase)) + endif + enddo + + gs0sun = gs_mol_sun + gs0sha = gs_mol_sha + call ci_func_PHS(x,b(sun), b(sha), fb(sun), fb(sha), ip, iv, ic, bsun, bsha, bflag, gb_mol, gs0sun, gs0sha, & + gs_mol_sun, gs_mol_sha, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + qsatl, qaf, atm2lnd_inst, photosyns_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + + if( (fb(sun) == 0._r8) .and. (fb(sha) == 0._r8) ) exit + enddo + if( iter == itmax) write(iulog,*) 'brent exceeding maximum iterations', b, fb + xsun=b(sun) + xsha=b(sha) + + return + + end subroutine brent_PHS + !-------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------ + subroutine ci_func_PHS(x,cisun, cisha, fvalsun, fvalsha, p, iv, c, bsun, bsha, bflag, gb_mol, gs0sun, gs0sha,& + gs_mol_sun, gs_mol_sha, jesun, jesha, cair, oair, lmr_z_sun, lmr_z_sha, par_z_sun, par_z_sha, rh_can, & + qsatl, qaf, atm2lnd_inst, photosyns_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + !------------------------------------------------------------------------------ + ! + ! !DESCRIPTION: + ! evaluate the function + ! f(ci)=ci - (ca - (1.37rb+1.65rs))*patm*an for sunlit and shaded leaves + ! + ! !REVISION HISTORY: + ! + ! + ! !USES: + use clm_varpar , only : nlevsoi + implicit none + ! + ! !ARGUMENTS: + real(r8) , intent(inout) :: x(nvegwcs) ! working copy of vegwp(p,:) + real(r8) , intent(in) :: cisun,cisha ! intracellular leaf CO2 (Pa) + real(r8) , intent(out) :: fvalsun,fvalsha ! return function of the value f(ci) + integer , intent(in) :: p,c,iv ! pft, column, and radiation indexes + real(r8) , intent(inout) :: bsun ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8) , intent(inout) :: bsha ! shaded canopy transpiration wetness factor (0 to 1) + logical , intent(in) :: bflag ! signals to call calcstress to recalc bsun/bsha (or not) + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: gs0sun,gs0sha ! local gs_mol copies + real(r8) , intent(inout) :: gs_mol_sun,gs_mol_sha !leaf stomatal conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: jesun, jesha ! electron transport rate (umol electrons/m**2/s) + real(r8) , intent(in) :: cair ! Atmospheric CO2 partial pressure (Pa) + real(r8) , intent(in) :: oair ! Atmospheric O2 partial pressure (Pa) + real(r8) , intent(in) :: lmr_z_sun, lmr_z_sha ! canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8) , intent(in) :: par_z_sun, par_z_sha ! par absorbed per unit lai for canopy layer (w/m**2) + real(r8) , intent(in) :: rh_can ! canopy air relative humidity + real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(photosyns_type) , intent(inout) :: photosyns_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(waterfluxbulk_type) , intent(in) :: waterfluxbulk_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + + ! !LOCAL VARIABLES: + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + real(r8) :: cs_sun,cs_sha ! CO2 partial pressure at leaf surface (Pa) + real(r8) :: aquad, bquad, cquad ! terms for quadratic equations + real(r8) :: r1, r2 ! roots of quadratic equation + real(r8) :: term ! intermediate in Medlyn stomatal model + ! + !------------------------------------------------------------------------------ + + associate( & + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + c3flag => photosyns_inst%c3flag_patch , & ! Input: [logical (:) ] true if C3 and false if C4 + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + medlynslope=> pftcon%medlynslope , & ! Input: [real(r8) (:) ] Slope for Medlyn stomatal conductance model method + medlynintercept=> pftcon%medlynintercept , & ! Input: [real(r8) (:) ] Intercept for Medlyn stomatal conductance model method + stomatalcond_mtd=> photosyns_inst%stomatalcond_mtd , & ! Input: [integer ] method type to use for stomatal conductance.GC.fnlprmsn15_r22845 + ac => photosyns_inst%ac_phs_patch , & ! Output: [real(r8) (:,:,:) ] Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + aj => photosyns_inst%aj_phs_patch , & ! Output: [real(r8) (:,:,:) ] RuBP-limited gross photosynthesis (umol CO2/m**2/s) + ap => photosyns_inst%ap_phs_patch , & ! Output: [real(r8) (:,:,:) ] product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) + ag => photosyns_inst%ag_phs_patch , & ! Output: [real(r8) (:,:,:) ] co-limited gross leaf photosynthesis (umol CO2/m**2/s) + vcmax_z => photosyns_inst%vcmax_z_phs_patch , & ! Input: [real(r8) (:,:,:) ] maximum rate of carboxylation (umol co2/m**2/s) + cp => photosyns_inst%cp_patch , & ! Output: [real(r8) (:) ] CO2 compensation point (Pa) + kc => photosyns_inst%kc_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for CO2 (Pa) + ko => photosyns_inst%ko_patch , & ! Output: [real(r8) (:) ] Michaelis-Menten constant for O2 (Pa) + qe => photosyns_inst%qe_patch , & ! Output: [real(r8) (:) ] quantum efficiency, used only for C4 (mol CO2 / mol photons) + tpu_z => photosyns_inst%tpu_z_phs_patch , & ! Output: [real(r8) (:,:,:) ] triose phosphate utilization rate (umol CO2/m**2/s) + kp_z => photosyns_inst%kp_z_phs_patch , & ! Output: [real(r8) (:,:,:) ] initial slope of CO2 response curve (C4 plants) + bbb => photosyns_inst%bbb_patch , & ! Output: [real(r8) (:) ] Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + mbb => photosyns_inst%mbb_patch , & ! Output: [real(r8) (:) ] Ball-Berry slope of conductance-photosynthesis relationship + an_sun => photosyns_inst%an_sun_patch , & ! Output: [real(r8) (:,:) ] net sunlit leaf photosynthesis (umol CO2/m**2/s) + an_sha => photosyns_inst%an_sha_patch & ! Output: [real(r8) (:,:) ] net shaded leaf photosynthesis (umol CO2/m**2/s) + ) + + !------------------------------------------------------------------------------ + + if (bflag) then !zqz what if bsun==0 ... doesn't break... but follow up + + call calcstress(p,c,x,bsun,bsha,gb_mol,gs0sun,gs0sha,qsatl,qaf, & + atm2lnd_inst,canopystate_inst,waterdiagnosticbulk_inst,soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + endif + + if (c3flag(p)) then + ! C3: Rubisco-limited photosynthesis + ac(p,sun,iv) = bsun * vcmax_z(p,sun,iv) * max(cisun-cp(p), 0._r8) / (cisun+kc(p)*(1._r8+oair/ko(p))) + ac(p,sha,iv) = bsha * vcmax_z(p,sha,iv) * max(cisha-cp(p), 0._r8) / (cisha+kc(p)*(1._r8+oair/ko(p))) + + ! C3: RuBP-limited photosynthesis + aj(p,sun,iv) = jesun * max(cisun-cp(p), 0._r8) / (4._r8*cisun+8._r8*cp(p)) + aj(p,sha,iv) = jesha * max(cisha-cp(p), 0._r8) / (4._r8*cisha+8._r8*cp(p)) + + ! C3: Product-limited photosynthesis + ap(p,sun,iv) = 3._r8 * tpu_z(p,sun,iv) + ap(p,sha,iv) = 3._r8 * tpu_z(p,sha,iv) + + else + ! C4: Rubisco-limited photosynthesis + ac(p,sun,iv) = bsun * vcmax_z(p,sun,iv) + ac(p,sha,iv) = bsha * vcmax_z(p,sha,iv) + + ! C4: RuBP-limited photosynthesis + aj(p,sun,iv) = qe(p) * par_z_sun * 4.6_r8 + aj(p,sha,iv) = qe(p) * par_z_sha * 4.6_r8 + + ! C4: PEP carboxylase-limited (CO2-limited) + ap(p,sun,iv) = kp_z(p,sun,iv) * max(cisun, 0._r8) / forc_pbot(c) + ap(p,sha,iv) = kp_z(p,sha,iv) * max(cisha, 0._r8) / forc_pbot(c) + + end if + + ! Gross photosynthesis. First co-limit ac and aj. Then co-limit ap + + ! Sunlit + aquad = params_inst%theta_cj(ivt(p)) + bquad = -(ac(p,sun,iv) + aj(p,sun,iv)) + cquad = ac(p,sun,iv) * aj(p,sun,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = params_inst%theta_ip + bquad = -(ai + ap(p,sun,iv)) + cquad = ai * ap(p,sun,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + ag(p,sun,iv) = max(0._r8,min(r1,r2)) + + ! Shaded + aquad = params_inst%theta_cj(ivt(p)) + bquad = -(ac(p,sha,iv) + aj(p,sha,iv)) + cquad = ac(p,sha,iv) * aj(p,sha,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = params_inst%theta_ip + bquad = -(ai + ap(p,sha,iv)) + cquad = ai * ap(p,sha,iv) + call quadratic (aquad, bquad, cquad, r1, r2) + ag(p,sha,iv) = max(0._r8,min(r1,r2)) + + ! Net photosynthesis. Exit iteration if an < 0 + an_sun(p,iv) = ag(p,sun,iv) - bsun * lmr_z_sun + an_sha(p,iv) = ag(p,sha,iv) - bsha * lmr_z_sha + + if (an_sun(p,iv) < 0._r8) then + if ( stomatalcond_mtd == stomatalcond_mtd_medlyn2011 )then + gs_mol_sun = medlynintercept(patch%itype(p)) + else if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + gs_mol_sun = bbb(p) + else + gs_mol_sun = nan + end if + gs_mol_sun = max( bsun*gs_mol_sun, 1._r8) + fvalsun = 0._r8 ! really tho? zqz + endif + if (an_sha(p,iv) < 0._r8) then + if ( stomatalcond_mtd == stomatalcond_mtd_medlyn2011 )then + gs_mol_sha = medlynintercept(patch%itype(p)) + else if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + gs_mol_sha = bbb(p) + else + gs_mol_sha = nan + end if + gs_mol_sha = max( bsha*gs_mol_sha, 1._r8) + fvalsha = 0._r8 + endif + if ((an_sun(p,iv) < 0._r8) .AND. (an_sha(p,iv) < 0._r8)) then + return + endif + + ! Quadratic gs_mol calculation with an known. Valid for an >= 0. + ! With an <= 0, then gs_mol = bbb + + ! Sunlit + cs_sun = cair - 1.4_r8/gb_mol * an_sun(p,iv) * forc_pbot(c) + cs_sun = max(cs_sun,10.e-06_r8) + + if ( stomatalcond_mtd == stomatalcond_mtd_medlyn2011 )then + term = 1.6_r8 * an_sun(p,iv) / (cs_sun / forc_pbot(c) * 1.e06_r8) + aquad = 1.0_r8 + bquad = -(2.0 * (medlynintercept(patch%itype(p))*1.e-06_r8 + term) + (medlynslope(patch%itype(p)) * term)**2 / & + (gb_mol*1.e-06_r8 * rh_can)) + cquad = medlynintercept(patch%itype(p))*medlynintercept(patch%itype(p))*1.e-12_r8 + & + (2.0*medlynintercept(patch%itype(p))*1.e-06_r8 + term * & + (1.0 - medlynslope(patch%itype(p))* medlynslope(patch%itype(p)) / rh_can)) * term + + call quadratic (aquad, bquad, cquad, r1, r2) + gs_mol_sun = max(r1,r2) * 1.e06_r8 + + ! Shaded + cs_sha = cair - 1.4_r8/gb_mol * an_sha(p,iv) * forc_pbot(c) + cs_sha = max(cs_sha,10.e-06_r8) + + term = 1.6_r8 * an_sha(p,iv) / (cs_sha / forc_pbot(c) * 1.e06_r8) + aquad = 1.0_r8 + bquad = -(2.0 * (medlynintercept(patch%itype(p))*1.e-06_r8 + term) + (medlynslope(patch%itype(p)) * term)**2 / & + (gb_mol*1.e-06_r8 * rh_can)) + cquad = medlynintercept(patch%itype(p))*medlynintercept(patch%itype(p))*1.e-12_r8 + & + (2.0*medlynintercept(patch%itype(p))*1.e-06_r8 + term * (1.0 - medlynslope(patch%itype(p))* & + medlynslope(patch%itype(p)) / rh_can)) * term + + call quadratic (aquad, bquad, cquad, r1, r2) + gs_mol_sha = max(r1,r2)* 1.e06_r8 + else if ( stomatalcond_mtd == stomatalcond_mtd_bb1987 )then + aquad = cs_sun + bquad = cs_sun*(gb_mol - max(bsun*bbb(p),1._r8)) - mbb(p)*an_sun(p,iv)*forc_pbot(c) + cquad = -gb_mol*(cs_sun*max(bsun*bbb(p),1._r8) + mbb(p)*an_sun(p,iv)*forc_pbot(c)*rh_can) + call quadratic (aquad, bquad, cquad, r1, r2) + gs_mol_sun = max(r1,r2) + + ! Shaded + cs_sha = cair - 1.4_r8/gb_mol * an_sha(p,iv) * forc_pbot(c) + cs_sha = max(cs_sha,10.e-06_r8) + + aquad = cs_sha + bquad = cs_sha*(gb_mol - max(bsha*bbb(p),1._r8)) - mbb(p)*an_sha(p,iv)*forc_pbot(c) + cquad = -gb_mol*(cs_sha*max(bsha*bbb(p),1._r8) + mbb(p)*an_sha(p,iv)*forc_pbot(c)*rh_can) + call quadratic (aquad, bquad, cquad, r1, r2) + gs_mol_sha = max(r1,r2) + end if + + ! Derive new estimate for cisun,cisha + if (an_sun(p,iv) >= 0._r8) then + if (gs_mol_sun > 0._r8) then + fvalsun =cisun - cair + an_sun(p,iv) * forc_pbot(c) * (1.4_r8*gs_mol_sun+1.6_r8*gb_mol) / (gb_mol*gs_mol_sun) + else + fvalsun =cisun - cair + endif + endif + if (an_sha(p,iv) >= 0._r8) then + if (gs_mol_sha > 0._r8) then + fvalsha =cisha - cair + an_sha(p,iv) * forc_pbot(c) * (1.4_r8*gs_mol_sha+1.6_r8*gb_mol) / (gb_mol*gs_mol_sha) + else + fvalsha =cisha - cair + endif + endif + end associate + end subroutine ci_func_PHS + !-------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------ + subroutine calcstress(p,c,x,bsun,bsha,gb_mol,gs_mol_sun,gs_mol_sha,qsatl,qaf, & + atm2lnd_inst,canopystate_inst,waterdiagnosticbulk_inst,soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + ! + ! DESCRIPTIONS + ! compute the transpiration stress using a plant hydraulics approach + ! calls spacF, spacA, and getvegwp + ! + ! USES + use clm_varpar , only : nlevsoi + use clm_varcon , only : rgas + !! + ! !ARGUMENTS: + integer , intent(in) :: p ! pft index + integer , intent(in) :: c ! column index + real(r8) , intent(inout) :: x(nvegwcs) ! working copy of vegwp(p,:) + real(r8) , intent(out) :: bsun ! sunlit canopy transpiration wetness factor (0 to 1) + real(r8) , intent(out) :: bsha ! shaded sunlit canopy transpiration wetness factor (0 to 1) + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: gs_mol_sun ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: gs_mol_sha ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterfluxbulk_type) , intent(in) :: waterfluxbulk_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: wtl ! heat conductance for leaf [m/s] + real(r8) :: A(nvegwcs,nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=A*f + real(r8) :: f(nvegwcs) ! flux divergence (mm/s) + real(r8) :: dx(nvegwcs) ! change in vegwp from one iter to the next [mm] + real(r8) :: efpot ! potential latent energy flux [kg/m2/s] + real(r8) :: rppdry_sun ! fraction of potential evaporation through transp - sunlit [-] + real(r8) :: rppdry_sha ! fraction of potential evaporation through transp - shaded [-] + real(r8) :: qflx_sun ! [kg/m2/s] + real(r8) :: qflx_sha ! [kg/m2/s] + real(r8) :: gs0sun,gs0sha ! local gs_mol copies + real(r8) :: qsun,qsha ! attenuated transpiration fluxes + integer :: j ! index + real(r8) :: cf ! s m**2/umol -> s/m + integer :: iter ! newton's method iteration number + logical :: flag ! signal that matrix was not invertible + logical :: night ! signal to store vegwp within this routine, b/c it is night-time and full suite won't be called + integer, parameter :: itmax=50 ! exit newton's method if iters>itmax + real(r8), parameter :: tolf=1.e-6,toldx=1.e-9 !tolerances for a satisfactory solution + logical :: havegs ! signals direction of calculation gs->qflx or qflx->gs + real(r8) :: soilflux ! total soil column transpiration [mm/s] + real(r8), parameter :: tol_lai=.001_r8 ! minimum lai where transpiration is calc'd + !------------------------------------------------------------------------------ + + associate( & + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit leaf area + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded leaf area + elai => canopystate_inst%elai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index with burying by snow + esai => canopystate_inst%esai_patch , & ! Input: [real(r8) (:) ] one-sided stem area index with burying by snow + tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] patch canopy one-sided stem area index, no burying by snow + fdry => waterdiagnosticbulk_inst%fdry_patch , & ! Input: [real(r8) (:) ] fraction of foliage that is green and dry [-] + forc_rho => atm2lnd_inst%forc_rho_downscaled_col , & ! Input: [real(r8) (:) ] density (kg/m**3) + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + tgcm => temperature_inst%thm_patch , & ! Input: [real(r8) (:) ] air temperature at agcm reference height (kelvin) + bsw => soilstate_inst%bsw_col , & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" + qflx_tran_veg => waterfluxbulk_inst%qflx_tran_veg_patch , & ! Input: [real(r8) (:) ] vegetation transpiration (mm H2O/s) (+ = to atm) + sucsat => soilstate_inst%sucsat_col & ! Input: [real(r8) (:,:) ] minimum soil suction (mm) + ) + + !temporary flag for night time vegwp(sun)>0 + if (x(sun)>0._r8) then + night=.TRUE. + x(sun)=x(sha) + else + night=.FALSE. + endif + + !copy to avoid rewriting gs_mol_sun + gs0sun=gs_mol_sun + gs0sha=gs_mol_sha + + !compute transpiration demand + havegs=.true. + call getqflx(p,c,gb_mol,gs0sun,gs0sha,qflx_sun,qflx_sha,qsatl,qaf,havegs, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, temperature_inst) + + if ((laisun(p)>tol_lai .or. laisha(p)>tol_lai).and.& + (qflx_sun>0._r8 .or. qflx_sha>0._r8))then + + !newton's method solves for matching fluxes through the spac + iter=0 + do + + iter=iter+1 + + call spacF(p,c,x,f,qflx_sun,qflx_sha, & + atm2lnd_inst,canopystate_inst,soilstate_inst,temperature_inst,waterfluxbulk_inst) + + if ( sqrt(sum(f*f)) < tolf*(qflx_sun+qflx_sha) ) then !fluxes balanced -> exit + flag = .false. + exit + end if + if ( iter>itmax ) then !exceeds max iters -> exit + flag = .false. + exit + end if + + call spacA(p,c,x,A,qflx_sun,qflx_sha,flag, & + atm2lnd_inst,canopystate_inst,soilstate_inst,temperature_inst,waterfluxbulk_inst) + + if (flag) then + ! cannot invert the matrix, solve for x algebraically assuming no flux + exit + end if + + if (laisun(p)>tol_lai.and.laisha(p)>tol_lai)then + dx = matmul(A,f) + else + !reduces to 3x3 system + !in this case, dx is not always [sun,sha,xyl,root] + !sun and sha flip depending on which is lai==0 + dx(sun)=0._r8 + dx(sha:root)=matmul(A(sha:root,sha:root),f(sha:root)) + endif + + + if ( maxval(abs(dx)) > 50000._r8) then + dx = 50000._r8 * dx / maxval(abs(dx)) !rescale step to max of 50000 + end if + + + if (laisun(p)>tol_lai.and.laisha(p)>tol_lai)then + x=x+dx + elseif (laisha(p)>tol_lai) then + x=x+dx + x(sun)=x(xyl) ! psi_sun = psi_xyl because laisun==0 + else + x(xyl:root)=x(xyl:root)+dx(xyl:root) + x(sun)=x(sun)+dx(sha) ! implementation ugly bit, chose to flip dx(sun) and dx(sha) for laisha==0 case + x(sha)=x(xyl) ! psi_sha = psi_xyl because laisha==0 + + endif + + + if ( sqrt(sum(dx*dx)) < toldx) then + !step in vegwp small -> exit + exit + end if + + ! this is a catch to force spac gradient to atmosphere + if ( x(xyl) > x(root) ) x(xyl) = x(root) + if ( x(sun) > x(xyl) ) x(sun) = x(xyl) + if ( x(sha) > x(xyl) ) x(sha) = x(xyl) + + end do + + else + ! both qflxsun and qflxsha==0 + flag=.true. + end if + + if (flag) then + ! solve algebraically + call getvegwp(p, c, x, gb_mol, gs0sun, gs0sha, qsatl, qaf, soilflux, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, temperature_inst) + bsun = plc(x(sun),p,c,sun,veg) + bsha = plc(x(sha),p,c,sha,veg) + else + ! compute attenuated flux + qsun=qflx_sun*plc(x(sun),p,c,sun,veg) + qsha=qflx_sha*plc(x(sha),p,c,sha,veg) + + ! retrieve stressed stomatal conductance + havegs=.FALSE. + call getqflx(p,c,gb_mol,gs0sun,gs0sha,qsun,qsha,qsatl,qaf,havegs, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, temperature_inst) + + ! compute water stress + ! .. generally -> B= gs_stressed / gs_unstressed + ! .. when gs=0 -> B= plc( x ) + if (qflx_sun>0._r8) then + bsun = gs0sun/gs_mol_sun + else + bsun = plc(x(sun),p,c,sun,veg) + endif + if (qflx_sha>0._r8) then + bsha = gs0sha/gs_mol_sha + else + bsha = plc(x(sha),p,c,sha,veg) + endif + endif + if ( bsun < 0.01_r8 ) bsun = 0._r8 + if ( bsha < 0.01_r8 ) bsha = 0._r8 + + !zqz is this the best place to do this? + ! was looking like qflx_tran_veg/vegwp was not being set at night time + ! set vegwp for the final gs_mol solution + if (night) then + gs0sun=bsun*gs_mol_sun + gs0sha=bsha*gs_mol_sha + call getvegwp(p, c, x, gb_mol, gs0sun, gs0sha, qsatl, qaf, soilflux, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, soilstate_inst, temperature_inst) + if (soilflux<0._r8) soilflux = 0._r8 + qflx_tran_veg(p) = soilflux + endif + + + end associate + + end subroutine calcstress + + !------------------------------------------------------------------------------ + + !------------------------------------------------------------------------------ + subroutine spacA(p,c,x,invA,qflx_sun,qflx_sha,flag, & + atm2lnd_inst,canopystate_inst,soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + + ! + ! DESCRIPTION + ! Returns invA, the inverse matrix relating delta(vegwp) to f + ! d(vegwp)=invA*f + ! evaluated at vegwp(p) + ! + ! The methodology is currently hardcoded for linear algebra assuming the + ! number of vegetation segments is four. Thus the matrix A and it's inverse + ! invA are both 4x4 matrices. A more general method could be done using for + ! example a LINPACK linear algebra solver. + ! + ! USES + use clm_varpar , only : nlevsoi + use clm_varcon , only : rgas + ! + ! !ARGUMENTS: + integer , intent(in) :: p ! pft index + integer , intent(in) :: c ! column index + real(r8) , intent(in) :: x(nvegwcs) ! working copy of veg water potential for patch p [mm H2O] + real(r8) , intent(out) :: invA(nvegwcs,nvegwcs) ! matrix relating d(vegwp) and f: d(vegwp)=invA*f + real(r8) , intent(in) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8) , intent(in) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + logical , intent(out) :: flag ! tells calling function that the matrix is not invertible + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterfluxbulk_type) , intent(in) :: waterfluxbulk_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: wtl ! heat conductance for leaf [m/s] + real(r8) :: fsto1 ! sunlit transpiration reduction function [-] + real(r8) :: fsto2 ! shaded transpiration reduction function [-] + real(r8) :: fx ! fraction of maximum conductance, xylem-to-leaf [-] + real(r8) :: fr ! fraction of maximum conductance, root-to-xylem [-] + real(r8) :: dfsto1 ! 1st derivative of fsto1 w.r.t. change in vegwp + real(r8) :: dfsto2 ! 1st derivative of fsto2 w.r.t. change in vegwp + real(r8) :: dfx ! 1st derivative of fx w.r.t. change in vegwp + real(r8) :: dfr ! 1st derivative of fr w.r.t. change in vegwp + real(r8) :: A(nvegwcs,nvegwcs) ! matrix relating vegwp to flux divergence f=A*d(vegwp) + real(r8) :: leading ! inverse of determiniant + real(r8) :: determ ! determinant of matrix + real(r8) :: grav1 ! gravitational potential surface to canopy top (mm H2O) + real(r8) :: invfactor ! + real(r8), parameter :: tol_lai=.001_r8 ! minimum lai where transpiration is calc'd + integer :: j ! index + !------------------------------------------------------------------------------ +#ifndef NDEBUG + ! Only execute this code if DEBUG=TRUE + if ( nvegwcs /= 4 )then + call endrun(msg='Error:: this function is hardcoded for 4x4 matrices with nvegwcs==4'//errMsg(__FILE__, __LINE__)) + end if +#endif + + associate( & + k_soil_root => soilstate_inst%k_soil_root_patch , & ! Input: [real(r8) (:,:) ] soil-root interface conductance (mm/s) + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit leaf area + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded leaf area + htop => canopystate_inst%htop_patch , & ! Input: [real(r8) (:) ] patch canopy top (m) + tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] patch canopy one-sided stem area index, no burying by snow + ivt => patch%itype & ! Input: [integer (:) ] patch vegetation type + ) + + ! initialize all elements to zero + A = 0._r8 + invA = 0._r8 + + grav1 = htop(p)*1000._r8 + + !compute conductance attentuation for each segment + fsto1= plc(x(sun),p,c,sun,veg) + fsto2= plc(x(sha),p,c,sha,veg) + fx= plc(x(xyl),p,c,xyl,veg) + fr= plc(x(root),p,c,root,veg) + + !compute 1st deriv of conductance attenuation for each segment + dfsto1= d1plc(x(sun),p,c,sun,veg) + dfsto2= d1plc(x(sha),p,c,sha,veg) + dfx= d1plc(x(xyl),p,c,xyl,veg) + dfr= d1plc(x(root),p,c,root,veg) + + !A - f=A*d(vegwp) + A(1,1)= - laisun(p) * params_inst%kmax(ivt(p),sun) * fx& + - qflx_sun * dfsto1 + A(1,3)= laisun(p) * params_inst%kmax(ivt(p),sun) * dfx * (x(xyl)-x(sun))& + + laisun(p) * params_inst%kmax(ivt(p),sun) * fx + A(2,2)= - laisha(p) * params_inst%kmax(ivt(p),sha) * fx& + - qflx_sha * dfsto2 + A(2,3)= laisha(p) * params_inst%kmax(ivt(p),sha) * dfx * (x(xyl)-x(sha))& + + laisha(p) * params_inst%kmax(ivt(p),sha) * fx + A(3,1)= laisun(p) * params_inst%kmax(ivt(p),sun) * fx + A(3,2)= laisha(p) * params_inst%kmax(ivt(p),sha) * fx + A(3,3)= - laisun(p) * params_inst%kmax(ivt(p),sun) * dfx * (x(xyl)-x(sun))& + - laisun(p) * params_inst%kmax(ivt(p),sun) * fx& + - laisha(p) * params_inst%kmax(ivt(p),sha) * dfx * (x(xyl)-x(sha))& + - laisha(p) * params_inst%kmax(ivt(p),sha) * fx& + - tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * fr + A(3,4)= tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * dfr * (x(root)-x(xyl)-grav1)& + + tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * fr + A(4,3)= tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * fr + A(4,4)= - tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * fr& + - tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * dfr * (x(root)-x(xyl)-grav1)& + - sum(k_soil_root(p,1:nlevsoi)) + + invfactor=1._r8 + A=invfactor*A + + !matrix inversion + if (laisun(p)>tol_lai .and. laisha(p)>tol_lai) then + ! general case + + determ=A(4,4)*A(2,2)*A(3,3)*A(1,1) - A(4,4)*A(2,2)*A(3,1)*A(1,3)& + - A(4,4)*A(3,2)*A(2,3)*A(1,1) - A(4,3)*A(1,1)*A(2,2)*A(3,4) + if ( abs(determ) <= 1.e-50_r8 ) then + flag = .true. !tells calling function that the matrix is not invertible + return + else + flag = .false. + end if + + leading = 1._r8/determ + + !algebraic inversion of the matrix + invA(1,1)=leading*A(4,4)*A(2,2)*A(3,3) - leading*A(4,4)*A(3,2)*A(2,3) - leading*A(4,3)*A(2,2)*A(3,4) + invA(2,1)=leading*A(2,3)*A(4,4)*A(3,1) + invA(3,1)=-leading*A(4,4)*A(2,2)*A(3,1) + invA(4,1)=leading*A(4,3)*A(2,2)*A(3,1) + invA(1,2)=leading*A(1,3)*A(4,4)*A(3,2) + invA(2,2)=leading*A(4,4)*A(3,3)*A(1,1)-leading*A(4,4)*A(3,1)*A(1,3)-leading*A(4,3)*A(1,1)*A(3,4) + invA(3,2)=-leading*A(1,1)*A(4,4)*A(3,2) + invA(4,2)=leading*A(4,3)*A(1,1)*A(3,2) + invA(1,3)=-leading*A(1,3)*A(2,2)*A(4,4) + invA(2,3)=-leading*A(2,3)*A(1,1)*A(4,4) + invA(3,3)=leading*A(2,2)*A(1,1)*A(4,4) + invA(4,3)=-leading*A(4,3)*A(1,1)*A(2,2) + invA(1,4)=leading*A(1,3)*A(3,4)*A(2,2) + invA(2,4)=leading*A(2,3)*A(3,4)*A(1,1) + invA(3,4)=-leading*A(3,4)*A(1,1)*A(2,2) + invA(4,4)=leading*A(2,2)*A(3,3)*A(1,1)-leading*A(2,2)*A(3,1)*A(1,3)-leading*A(3,2)*A(2,3)*A(1,1) + invA=invfactor*invA !undo inversion scaling + else + ! if laisun or laisha ==0 invert the corresponding 3x3 matrix + ! if both are zero, this routine is not called + if (laisha(p)<=tol_lai) then + ! shift nonzero matrix values so that both 3x3 cases can be inverted with the same code + A(2,2)=A(1,1) + A(3,2)=A(3,1) + A(2,3)=A(1,3) + endif + determ=A(2,2)*A(3,3)*A(4,4)-A(3,4)*A(2,2)*A(4,3)-A(2,3)*A(3,2)*A(4,4) + if ( abs(determ) <= 1.e-50_r8 ) then + flag = .true. !tells calling function that the matrix is not invertible + return + else + flag = .false. + end if + + !algebraic inversion of the 3x3 matrix stored in A(2:4,2:4) + invA(2,2)=A(3,3)*A(4,4)-A(3,4)*A(4,3) + invA(2,3)=-A(2,3)*A(4,4) + invA(2,4)=A(3,4)*A(2,3) + invA(3,2)=-A(3,2)*A(4,4) + invA(3,3)=A(2,2)*A(4,4) + invA(3,4)=-A(3,4)*A(2,2) + invA(4,2)=A(3,2)*A(4,3) + invA(4,3)=-A(2,2)*A(4,3) + invA(4,4)=A(2,2)*A(3,3)-A(2,3)*A(3,2) + invA=1._r8/determ*invA + + endif + + end associate + + end subroutine spacA + + !-------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------ + subroutine spacF(p,c,x,f,qflx_sun,qflx_sha, & + atm2lnd_inst,canopystate_inst,soilstate_inst, & + temperature_inst, waterfluxbulk_inst) + ! + ! DESCRIPTION + ! Returns f, the flux divergence across each vegetation segment + ! calculated for vegwp(p,:) as passed in via x + ! + ! USES + use clm_varpar , only : nlevsoi + use clm_varcon , only : rgas + use ColumnType , only : col + ! + ! !ARGUMENTS: + integer , intent(in) :: p ! pft index + integer , intent(in) :: c ! column index + real(r8) , intent(in) :: x(nvegwcs) ! working copy of veg water potential for patch p [mm H2O] + real(r8) , intent(out) :: f(nvegwcs) ! water flux divergence [mm/s] + real(r8) , intent(in) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8) , intent(in) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(soilstate_type) , intent(in) :: soilstate_inst + type(temperature_type) , intent(in) :: temperature_inst + type(waterfluxbulk_type) , intent(in) :: waterfluxbulk_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: wtl ! heat conductance for leaf [m/s] + real(r8) :: fsto1 ! sunlit transpiration reduction function [-] + real(r8) :: fsto2 ! shaded transpiration reduction function [-] + real(r8) :: fx ! fraction of maximum conductance, xylem-to-leaf [-] + real(r8) :: fr ! fraction of maximum conductance, root-to-xylem [-] + real(r8) :: grav1 ! gravitational potential surface to canopy top (mm H2O) + real(r8) :: grav2(nlevsoi) ! soil layer gravitational potential relative to surface (mm H2O) + real(r8) :: temp ! used to copy f(sun) to f(sha) for special case + real(r8), parameter :: tol_lai=.001_r8 ! needs to be the same as in calcstress and spacA (poor form, refactor)< + integer :: j ! index + !------------------------------------------------------------------------------ + + associate( & + k_soil_root => soilstate_inst%k_soil_root_patch , & ! Input: [real(r8) (:,:) ] soil-root interface conductance (mm/s) + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit leaf area + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded leaf area + htop => canopystate_inst%htop_patch , & ! Input: [real(r8) (:) ] patch canopy top (m) + tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] patch canopy one-sided stem area index, no burying by snow + smp => soilstate_inst%smp_l_col , & ! Input: [real(r8) (:,:) ] soil matrix potential [mm] + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + z => col%z & ! Input: [real(r8) (:,:) ] layer node depth (m) + ) + + grav1 = htop(p) * 1000._r8 + grav2(1:nlevsoi) = z(c,1:nlevsoi) * 1000._r8 + + fsto1= plc(x(sun),p,c,sun,veg) + fsto2= plc(x(sha),p,c,sha,veg) + fx= plc(x(xyl),p,c,xyl,veg) + fr= plc(x(root),p,c,root,veg) + + !compute flux divergence across each plant segment + f(sun)= qflx_sun * fsto1 - laisun(p) * params_inst%kmax(ivt(p),sun) * fx * (x(xyl)-x(sun)) + f(sha)= qflx_sha * fsto2 - laisha(p) * params_inst%kmax(ivt(p),sha) * fx * (x(xyl)-x(sha)) + f(xyl)= laisun(p) * params_inst%kmax(ivt(p),sun) * fx * (x(xyl)-x(sun))& + + laisha(p) * params_inst%kmax(ivt(p),sha) * fx * (x(xyl)-x(sha)) & + - tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * fr * (x(root)-x(xyl)-grav1) + f(root)= tsai(p) * params_inst%kmax(ivt(p),xyl) / htop(p) * fr * (x(root)-x(xyl)-grav1) & + + sum( k_soil_root(p,1:nlevsoi) * (x(root)+grav2(1:nlevsoi)) ) & + - sum( k_soil_root(p,1:nlevsoi) * smp(c,1:nlevsoi) ) + + if (laisha(p)qflx or qflx->gs + !---------------------------------------------------------------------- + associate( & + k_soil_root => soilstate_inst%k_soil_root_patch , & ! Input: [real(r8) (:,:) ] soil-root interface conductance (mm/s) + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit leaf area + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded leaf area + htop => canopystate_inst%htop_patch , & ! Input: [real(r8) (:) ] patch canopy top (m) + tsai => canopystate_inst%tsai_patch , & ! Input: [real(r8) (:) ] patch canopy one-sided stem area index, no burying by snow + smp => soilstate_inst%smp_l_col , & ! Input: [real(r8) (:,:) ] soil matrix potential [mm] + rootfr => soilstate_inst%rootfr_patch , & ! Input: [real(r8) (:,:) ] fraction of roots in each soil layer + bsw => soilstate_inst%bsw_col , & ! Input: [real(r8) (:,:) ] Clapp and Hornberger "b" + ivt => patch%itype , & ! Input: [integer (:) ] patch vegetation type + hk_l => soilstate_inst%hk_l_col , & ! Input: [real(r8) (:,:) ] hydraulic conductivity (mm/s) + hksat => soilstate_inst%hksat_col , & ! Input: [real(r8) (:,:) ] hydraulic conductivity at saturation (mm H2O /s) + sucsat => soilstate_inst%sucsat_col , & ! Input: [real(r8) (:,:) ] minimum soil suction (mm) + z => col%z & ! Input: [real(r8) (:,:) ] layer node depth (m) + ) + + grav1 = 1000._r8 *htop(p) + grav2(1:nlevsoi) = 1000._r8 * z(c,1:nlevsoi) + + !compute transpiration demand + havegs=.true. + call getqflx(p,c,gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf,havegs, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, temperature_inst) + + !calculate root water potential + if ( abs(sum(k_soil_root(p,1:nlevsoi))) == 0._r8 ) then + x(root) = sum(smp(c,1:nlevsoi) - grav2)/nlevsoi + else + x(root) = (sum(k_soil_root(p,1:nlevsoi)*(smp(c,1:nlevsoi)-grav2))-qflx_sun-qflx_sha) & + /sum(k_soil_root(p,1:nlevsoi)) + endif + + !calculate xylem water potential + fr = plc(x(root),p,c,root,veg) + if ( (tsai(p) > 0._r8) .and. (fr > 0._r8) ) then + x(xyl) = x(root) - grav1 - (qflx_sun+qflx_sha)/(fr*params_inst%kmax(ivt(p),root)/htop(p)*tsai(p))!removed htop conversion + else + x(xyl) = x(root) - grav1 + endif + + !calculate sun/sha leaf water potential + fx = plc(x(xyl),p,c,xyl,veg) + if ( (laisha(p) > 0._r8) .and. (fx > 0._r8) ) then + x(sha) = x(xyl) - (qflx_sha/(fx*params_inst%kmax(ivt(p),xyl)*laisha(p))) + else + x(sha) = x(xyl) + endif + if ( (laisun(p) > 0._r8) .and. (fx > 0._r8) ) then + x(sun) = x(xyl) - (qflx_sun/(fx*params_inst%kmax(ivt(p),xyl)*laisun(p))) + else + x(sun) = x(xyl) + endif + + !calculate soil flux + soilflux = 0._r8 + do j = 1,nlevsoi + soilflux = soilflux + k_soil_root(p,j)*(smp(c,j)-x(root)-grav2(j)) + enddo + + end associate + + end subroutine getvegwp + + !-------------------------------------------------------------------------------- + subroutine getqflx(p,c,gb_mol,gs_mol_sun,gs_mol_sha,qflx_sun,qflx_sha,qsatl,qaf,havegs, & + atm2lnd_inst, canopystate_inst, waterdiagnosticbulk_inst, temperature_inst) + ! !DESCRIPTION: + ! calculate sunlit and shaded transpiration using gb_MOL and gs_MOL + ! !USES: + ! + use clm_varcon , only : rgas + implicit none + ! + ! !ARGUMENTS: + integer , intent(in) :: p ! pft index + integer , intent(in) :: c ! column index + real(r8) , intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) , intent(inout) :: gs_mol_sun ! Ball-Berry leaf conductance (umol H2O/m**2/s) + real(r8) , intent(inout) :: gs_mol_sha ! Ball-Berry leaf conductance (umol H2O/m**2/s) + real(r8) , intent(inout) :: qflx_sun ! Sunlit leaf transpiration [kg/m2/s] + real(r8) , intent(inout) :: qflx_sha ! Shaded leaf transpiration [kg/m2/s] + real(r8) , intent(in) :: qsatl ! leaf specific humidity [kg/kg] + real(r8) , intent(in) :: qaf ! humidity of canopy air [kg/kg] + logical , intent(in) :: havegs ! signals direction of calculation gs->qflx or qflx->gs + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(canopystate_type) , intent(in) :: canopystate_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(temperature_type) , intent(in) :: temperature_inst + ! + ! !LOCAL VARIABLES: + real(r8) :: wtl ! heat conductance for leaf [m/s] + real(r8) :: efpot ! potential latent energy flux [kg/m2/s] + real(r8) :: rppdry_sun ! fraction of potential evaporation through transp - sunlit [-] + real(r8) :: rppdry_sha ! fraction of potential evaporation through transp - shaded [-] + real(r8) :: cf ! s m**2/umol -> s/m + !---------------------------------------------------------------------- + + associate( & + laisun => canopystate_inst%laisun_patch , & ! Input: [real(r8) (:) ] sunlit leaf area + laisha => canopystate_inst%laisha_patch , & ! Input: [real(r8) (:) ] shaded leaf area + elai => canopystate_inst%elai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index with burying by snow + esai => canopystate_inst%esai_patch , & ! Input: [real(r8) (:) ] one-sided stem area index with burying by snow + fdry => waterdiagnosticbulk_inst%fdry_patch , & ! Input: [real(r8) (:) ] fraction of foliage that is green and dry [-] + forc_rho => atm2lnd_inst%forc_rho_downscaled_col , & ! Input: [real(r8) (:) ] density (kg/m**3) + forc_pbot => atm2lnd_inst%forc_pbot_downscaled_col , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + tgcm => temperature_inst%thm_patch & ! Input: [real(r8) (:) ] air temperature at agcm reference height (kelvin) + ) + + + cf = forc_pbot(c)/(rgas*1.e-3_r8*tgcm(p))*1.e6_r8 ! gb->gbmol conversion factor + wtl = (elai(p)+esai(p))*gb_mol + efpot = forc_rho(c)*wtl*(qsatl-qaf) + if (havegs) then + + if ( (efpot > 0._r8) .and. (elai(p) > 0._r8) ) then + if ( gs_mol_sun > 0._r8 ) then + rppdry_sun = fdry(p)/gb_mol*(laisun(p)/(1._r8/gb_mol+1._r8/gs_mol_sun))/elai(p) + qflx_sun = efpot*rppdry_sun/cf + else + qflx_sun = 0._r8 + end if + if ( gs_mol_sha > 0._r8 ) then + rppdry_sha = fdry(p)/gb_mol*(laisha(p)/(1._r8/gb_mol+1._r8/gs_mol_sha))/elai(p) + qflx_sha = efpot*rppdry_sha/cf + else + qflx_sha = 0._r8 + end if + else + qflx_sun = 0._r8 + qflx_sha = 0._r8 + end if + + else + if (qflx_sun > 0._r8) then + gs_mol_sun=gb_mol*qflx_sun*cf*elai(p)/(efpot*fdry(p)*laisun(p)-qflx_sun*cf*elai(p)) + else + gs_mol_sun=0._r8 + endif + if (qflx_sha > 0._r8) then + gs_mol_sha=gb_mol*qflx_sha*cf*elai(p)/(efpot*fdry(p)*laisha(p)-qflx_sha*cf*elai(p)) + else + gs_mol_sha=0._r8 + endif + + endif + + end associate + + end subroutine getqflx + + !-------------------------------------------------------------------------------- + function plc(x,p,c,level,plc_method) + ! !DESCRIPTION + ! Return value of vulnerability curve at x + ! + ! !ARGUMENTS + real(r8) , intent(in) :: x ! water potential input + integer , intent(in) :: p ! index for pft + integer , intent(in) :: c ! index for column + integer , intent(in) :: level ! veg segment lvl (1:nvegwcs) + integer , intent(in) :: plc_method ! + real(r8) :: plc ! attenuated conductance [0:1] 0=no flow + ! + ! !PARAMETERS + integer , parameter :: vegetation_weibull=0 ! case number + !------------------------------------------------------------------------------ + associate( & + ivt => patch%itype & ! Input: [integer (:) ] patch vegetation type + ) + + select case (plc_method) + !possible to add other methods later + case (vegetation_weibull) + plc=2._r8**(-(x/params_inst%psi50(ivt(p),level))**params_inst%ck(ivt(p),level)) + if ( plc < 0.005_r8) plc = 0._r8 + case default + print *,'must choose plc method' + end select + + end associate + + end function plc + !-------------------------------------------------------------------------------- + + !-------------------------------------------------------------------------------- + function d1plc(x,p,c,level,plc_method) + ! !DESCRIPTION + ! Return 1st derivative of vulnerability curve at x + ! + ! !ARGUMENTS + real(r8) , intent(in) :: x ! water potential input + integer , intent(in) :: p ! index for pft + integer , intent(in) :: c ! index for column + integer , intent(in) :: level ! veg segment lvl (1:nvegwcs) + integer , intent(in) :: plc_method ! 0 for vegetation, 1 for soil + real(r8) :: d1plc ! first deriv of plc curve at x + ! + ! !PARAMETERS + integer , parameter :: vegetation_weibull=0 ! case number + !------------------------------------------------------------------------------ + associate( & + ivt => patch%itype & ! Input: [integer (:) ] patch vegetation type + ) + + select case (plc_method) + !possible to add other methods later + case (vegetation_weibull) + d1plc= -params_inst%ck(ivt(p),level) * log(2._r8) * (2._r8**(-(x/params_inst%psi50(ivt(p),level)) & + **params_inst%ck(ivt(p),level))) & + * ((x/params_inst%psi50(ivt(p),level))**params_inst%ck(ivt(p),level)) / x + case default + print *,'must choose plc method' + end select + + end associate + + end function d1plc + +end module PhotosynthesisMod diff --git a/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/biogeophys/SurfaceRadiationMod.F90 b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/biogeophys/SurfaceRadiationMod.F90 new file mode 100644 index 0000000000..8be4ffe546 --- /dev/null +++ b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/biogeophys/SurfaceRadiationMod.F90 @@ -0,0 +1,1041 @@ + +! DART note: this file started life as release-cesm2.2.01 : +! /glade/work/thoar/CESM/my_cesm_sandbox/components/clm/src/biogeophys/SurfaceRadiationMod.F90 +! +! This sourcemod allows the 'PARVEG' variable to be added to the +! history file. 'PARVEG' is the 'absorbed par by vegetation', as opposed to +! 'PARVEGLN', which is the 'absorbed par by vegetation at local noon' + +module SurfaceRadiationMod + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! Calculate solar fluxes absorbed by vegetation and ground surface + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_log_mod , only : errMsg => shr_log_errMsg + use clm_varctl , only : use_snicar_frc, use_fates + use decompMod , only : bounds_type + use clm_varcon , only : namec + use atm2lndType , only : atm2lnd_type + use WaterDiagnosticBulkType , only : waterdiagnosticbulk_type + use CanopyStateType , only : canopystate_type + use SurfaceAlbedoType , only : surfalb_type + use SolarAbsorbedType , only : solarabs_type + use GridcellType , only : grc + use LandunitType , only : lun + use ColumnType , only : col + use PatchType , only : patch + use landunit_varcon , only : istdlak + + ! !PRIVATE TYPES: + implicit none + private + + logical, parameter :: local_debug = .false. ! for debugging this module + + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: SurfaceRadiation ! Solar fluxes absorbed by veg and ground surface + public :: CanopySunShadeFracs ! Sun/Shade fractions and some area indices computations + + ! + ! !PRIVATE DATA: + type, public :: surfrad_type + real(r8), pointer, private :: sfc_frc_aer_patch (:) ! patch surface forcing of snow with all aerosols (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_bc_patch (:) ! patch surface forcing of snow with BC (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_oc_patch (:) ! patch surface forcing of snow with OC (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_dst_patch (:) ! patch surface forcing of snow with dust (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_aer_sno_patch (:) ! patch surface forcing of snow with all aerosols, averaged only when snow is present (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_bc_sno_patch (:) ! patch surface forcing of snow with BC, averaged only when snow is present (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_oc_sno_patch (:) ! patch surface forcing of snow with OC, averaged only when snow is present (patch) [W/m2] + real(r8), pointer, private :: sfc_frc_dst_sno_patch (:) ! patch surface forcing of snow with dust, averaged only when snow is present (patch) [W/m2] + + real(r8), pointer, private :: parveg_ln_patch (:) ! patch absorbed par by vegetation at local noon (W/m**2) + real(r8), pointer, private :: parveg_patch (:) ! patch absorbed par by vegetation (W/m**2) + + real(r8), pointer, private :: fsr_sno_vd_patch (:) ! patch reflected direct beam vis solar radiation from snow (W/m**2) + real(r8), pointer, private :: fsr_sno_nd_patch (:) ! patch reflected direct beam NIR solar radiation from snow (W/m**2) + real(r8), pointer, private :: fsr_sno_vi_patch (:) ! patch reflected diffuse vis solar radiation from snow (W/m**2) + real(r8), pointer, private :: fsr_sno_ni_patch (:) ! patch reflected diffuse NIR solar radiation from snow (W/m**2) + + real(r8), pointer, private :: fsr_vis_d_patch (:) ! patch reflected direct beam vis solar radiation (W/m**2) + real(r8), pointer, private :: fsr_vis_i_patch (:) ! patch reflected diffuse vis solar radiation (W/m**2) + real(r8), pointer, private :: fsr_vis_d_ln_patch (:) ! patch reflected direct beam vis solar radiation at local noon (W/m**2) + ! diagnostic fluxes: + real(r8), pointer, private :: fsrSF_vis_d_patch (:) ! snow-free patch reflected direct beam vis solar radiation (W/m**2) + real(r8), pointer, private :: fsrSF_vis_i_patch (:) ! snow-free patch reflected diffuse vis solar radiation (W/m**2) + real(r8), pointer, private :: fsrSF_vis_d_ln_patch (:) ! snow-free patch reflected direct beam vis solar radiation at local noon (W/m**2) + real(r8), pointer, private :: ssre_fsr_vis_d_patch (:) ! snow radiative effect + real(r8), pointer, private :: ssre_fsr_vis_i_patch (:) ! snow radiative effect + real(r8), pointer, private :: ssre_fsr_vis_d_ln_patch(:)! snow radiative effect + real(r8), pointer, private :: fsds_sno_vd_patch (:) ! patch incident visible, direct radiation on snow (for history files) [W/m2] + real(r8), pointer, private :: fsds_sno_nd_patch (:) ! patch incident near-IR, direct radiation on snow (for history files) [W/m2] + real(r8), pointer, private :: fsds_sno_vi_patch (:) ! patch incident visible, diffuse radiation on snow (for history files) [W/m2] + real(r8), pointer, private :: fsds_sno_ni_patch (:) ! patch incident near-IR, diffuse radiation on snow (for history files) [W/m2] + + real(r8), pointer, private :: fsds_vis_d_patch (:) ! patch incident direct beam vis solar radiation (W/m**2) + real(r8), pointer, private :: fsds_vis_i_patch (:) ! patch incident diffuse vis solar radiation (W/m**2) + real(r8), pointer, private :: fsds_vis_d_ln_patch (:) ! patch incident direct beam vis solar radiation at local noon (W/m**2) + real(r8), pointer, private :: fsds_vis_i_ln_patch (:) ! patch incident diffuse beam vis solar radiation at local noon (W/m**2) + + contains + + procedure, public :: Init + procedure, private :: InitAllocate + procedure, private :: InitHistory + procedure, private :: InitCold + + end type surfrad_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !------------------------------------------------------------------------ + subroutine Init(this, bounds) + + class(surfrad_type) :: this + type(bounds_type), intent(in) :: bounds + + call this%InitAllocate(bounds) + call this%InitHistory(bounds) + call this%InitCold(bounds) + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine InitAllocate(this, bounds) + ! + ! !USES: + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS: + class(surfrad_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + + allocate(this%sfc_frc_aer_patch (begp:endp)) ; this%sfc_frc_aer_patch (:) = nan + allocate(this%sfc_frc_bc_patch (begp:endp)) ; this%sfc_frc_bc_patch (:) = nan + allocate(this%sfc_frc_oc_patch (begp:endp)) ; this%sfc_frc_oc_patch (:) = nan + allocate(this%sfc_frc_dst_patch (begp:endp)) ; this%sfc_frc_dst_patch (:) = nan + allocate(this%sfc_frc_aer_sno_patch (begp:endp)) ; this%sfc_frc_aer_sno_patch (:) = nan + allocate(this%sfc_frc_bc_sno_patch (begp:endp)) ; this%sfc_frc_bc_sno_patch (:) = nan + allocate(this%sfc_frc_oc_sno_patch (begp:endp)) ; this%sfc_frc_oc_sno_patch (:) = nan + allocate(this%sfc_frc_dst_sno_patch (begp:endp)) ; this%sfc_frc_dst_sno_patch (:) = nan + + allocate(this%parveg_ln_patch (begp:endp)) ; this%parveg_ln_patch (:) = nan + allocate(this%parveg_patch (begp:endp)) ; this%parveg_patch (:) = nan + + allocate(this%fsr_vis_d_patch (begp:endp)) ; this%fsr_vis_d_patch (:) = nan + allocate(this%fsr_vis_d_ln_patch (begp:endp)) ; this%fsr_vis_d_ln_patch (:) = nan + allocate(this%fsr_vis_i_patch (begp:endp)) ; this%fsr_vis_i_patch (:) = nan + allocate(this%fsrSF_vis_d_patch (begp:endp)) ; this%fsrSF_vis_d_patch (:) = nan + allocate(this%fsrSF_vis_d_ln_patch (begp:endp)) ; this%fsrSF_vis_d_ln_patch (:) = nan + allocate(this%fsrSF_vis_i_patch (begp:endp)) ; this%fsrSF_vis_i_patch (:) = nan + allocate(this%ssre_fsr_vis_d_patch (begp:endp)) ; this%ssre_fsr_vis_d_patch (:) = nan + allocate(this%ssre_fsr_vis_d_ln_patch(begp:endp)) ; this%ssre_fsr_vis_d_ln_patch(:) = nan + allocate(this%ssre_fsr_vis_i_patch (begp:endp)) ; this%ssre_fsr_vis_i_patch (:) = nan + allocate(this%fsr_sno_vd_patch (begp:endp)) ; this%fsr_sno_vd_patch (:) = nan + allocate(this%fsr_sno_nd_patch (begp:endp)) ; this%fsr_sno_nd_patch (:) = nan + allocate(this%fsr_sno_vi_patch (begp:endp)) ; this%fsr_sno_vi_patch (:) = nan + allocate(this%fsr_sno_ni_patch (begp:endp)) ; this%fsr_sno_ni_patch (:) = nan + + allocate(this%fsds_vis_d_patch (begp:endp)) ; this%fsds_vis_d_patch (:) = nan + allocate(this%fsds_vis_i_patch (begp:endp)) ; this%fsds_vis_i_patch (:) = nan + allocate(this%fsds_vis_d_ln_patch (begp:endp)) ; this%fsds_vis_d_ln_patch (:) = nan + allocate(this%fsds_vis_i_ln_patch (begp:endp)) ; this%fsds_vis_i_ln_patch (:) = nan + allocate(this%fsds_sno_vd_patch (begp:endp)) ; this%fsds_sno_vd_patch (:) = nan + allocate(this%fsds_sno_nd_patch (begp:endp)) ; this%fsds_sno_nd_patch (:) = nan + allocate(this%fsds_sno_vi_patch (begp:endp)) ; this%fsds_sno_vi_patch (:) = nan + allocate(this%fsds_sno_ni_patch (begp:endp)) ; this%fsds_sno_ni_patch (:) = nan + + end subroutine InitAllocate + + !----------------------------------------------------------------------- + subroutine InitHistory(this, bounds) + ! + ! History fields initialization + ! + ! !USES: + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + use clm_varcon , only : spval + use histFileMod , only : hist_addfld1d, hist_addfld2d + use clm_varctl , only : use_SSRE + ! + ! !ARGUMENTS: + class(surfrad_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: begp, endp + integer :: begc, endc + real(r8), pointer :: data2dptr(:,:) ! temp. pointers for slicing larger arrays + !--------------------------------------------------------------------- + + begp = bounds%begp; endp = bounds%endp + begc = bounds%begc; endc = bounds%endc + + if (use_snicar_frc) then + this%sfc_frc_aer_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOAERFRCL', units='W/m^2', & + avgflag='A', long_name='surface forcing of all aerosols in snow (land) ', & + ptr_patch=this%sfc_frc_aer_patch, set_urb=spval) + + this%sfc_frc_aer_sno_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOAERFRC2L', units='W/m^2', & + avgflag='A', long_name='surface forcing of all aerosols in snow, averaged only when snow is present (land)', & + ptr_patch=this%sfc_frc_aer_sno_patch, set_urb=spval) + + this%sfc_frc_bc_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOBCFRCL', units='W/m^2', & + avgflag='A', long_name='surface forcing of BC in snow (land) ', & + ptr_patch=this%sfc_frc_bc_patch, set_urb=spval) + + this%sfc_frc_bc_sno_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOBCFRC2L', units='W/m^2', & + avgflag='A', long_name='surface forcing of BC in snow, averaged only when snow is present (land)', & + ptr_patch=this%sfc_frc_bc_sno_patch, set_urb=spval) + + this%sfc_frc_oc_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOOCFRCL', units='W/m^2', & + avgflag='A', long_name='surface forcing of OC in snow (land) ', & + ptr_patch=this%sfc_frc_oc_patch, set_urb=spval) + + this%sfc_frc_oc_sno_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOOCFRC2L', units='W/m^2', & + avgflag='A', long_name='surface forcing of OC in snow, averaged only when snow is present (land)', & + ptr_patch=this%sfc_frc_oc_sno_patch, set_urb=spval) + + this%sfc_frc_dst_patch(begp:endp) = spval + call hist_addfld1d (fname='SNODSTFRCL', units='W/m^2', & + avgflag='A', long_name='surface forcing of dust in snow (land) ', & + ptr_patch=this%sfc_frc_dst_patch, set_urb=spval) + + this%sfc_frc_dst_sno_patch(begp:endp) = spval + call hist_addfld1d (fname='SNODSTFRC2L', units='W/m^2', & + avgflag='A', long_name='surface forcing of dust in snow, averaged only when snow is present (land)', & + ptr_patch=this%sfc_frc_dst_sno_patch, set_urb=spval) + end if + + this%fsds_vis_d_patch(begp:endp) = spval + call hist_addfld1d (fname='FSDSVD', units='W/m^2', & + avgflag='A', long_name='direct vis incident solar radiation', & + ptr_patch=this%fsds_vis_d_patch) + + this%fsds_vis_i_patch(begp:endp) = spval + call hist_addfld1d (fname='FSDSVI', units='W/m^2', & + avgflag='A', long_name='diffuse vis incident solar radiation', & + ptr_patch=this%fsds_vis_i_patch) + + this%fsr_vis_d_patch(begp:endp) = spval + call hist_addfld1d (fname='FSRVD', units='W/m^2', & + avgflag='A', long_name='direct vis reflected solar radiation', & + ptr_patch=this%fsr_vis_d_patch, c2l_scale_type='urbanf') + this%fsr_vis_i_patch(begp:endp) = spval + call hist_addfld1d (fname='FSRVI', units='W/m^2', & + avgflag='A', long_name='diffuse vis reflected solar radiation', & + ptr_patch=this%fsr_vis_i_patch, c2l_scale_type='urbanf') + ! diagnostic fluxes + if (use_SSRE) then + this%fsrSF_vis_d_patch(begp:endp) = spval + call hist_addfld1d (fname='FSRSFVD', units='W/m^2', & + avgflag='A', long_name='direct vis reflected solar radiation', & + ptr_patch=this%fsrSF_vis_d_patch, c2l_scale_type='urbanf') + this%fsrSF_vis_i_patch(begp:endp) = spval + call hist_addfld1d (fname='FSRSFVI', units='W/m^2', & + avgflag='A', long_name='diffuse vis reflected solar radiation', & + ptr_patch=this%fsrSF_vis_i_patch, c2l_scale_type='urbanf') + + this%ssre_fsr_vis_d_patch(begp:endp) = spval + call hist_addfld1d (fname='SSRE_FSRVD', units='W/m^2', & + avgflag='A', long_name='surface snow radiatve effect on direct vis reflected solar radiation', & + ptr_patch=this%ssre_fsr_vis_d_patch, c2l_scale_type='urbanf') + this%ssre_fsr_vis_i_patch(begp:endp) = spval + call hist_addfld1d (fname='SSRE_FSRVI', units='W/m^2', & + avgflag='A', long_name='surface snow radiatve effect on diffuse vis reflected solar radiation', & + ptr_patch=this%ssre_fsr_vis_i_patch, c2l_scale_type='urbanf') + end if + this%fsds_vis_d_ln_patch(begp:endp) = spval + call hist_addfld1d (fname='FSDSVDLN', units='W/m^2', & + avgflag='A', long_name='direct vis incident solar radiation at local noon', & + ptr_patch=this%fsds_vis_d_ln_patch) + + this%fsds_vis_i_ln_patch(begp:endp) = spval + call hist_addfld1d (fname='FSDSVILN', units='W/m^2', & + avgflag='A', long_name='diffuse vis incident solar radiation at local noon', & + ptr_patch=this%fsds_vis_i_ln_patch) + + this%parveg_ln_patch(begp:endp) = spval + call hist_addfld1d (fname='PARVEGLN', units='W/m^2', & + avgflag='A', long_name='absorbed par by vegetation at local noon', & + ptr_patch=this%parveg_ln_patch) + + this%parveg_patch(begp:endp) = spval + call hist_addfld1d (fname='PARVEG', units='W/m^2', & + avgflag='A', long_name='absorbed par by vegetation', & + ptr_patch=this%parveg_patch) + + this%fsr_vis_d_ln_patch(begp:endp) = spval + call hist_addfld1d (fname='FSRVDLN', units='W/m^2', & + avgflag='A', long_name='direct vis reflected solar radiation at local noon', & + ptr_patch=this%fsr_vis_d_ln_patch, c2l_scale_type='urbanf') + ! diagnostic flux + if (use_SSRE) then + this%fsrSF_vis_d_ln_patch(begp:endp) = spval + call hist_addfld1d (fname='FSRSFVDLN', units='W/m^2', & + avgflag='A', long_name='direct vis reflected solar radiation at local noon', & + ptr_patch=this%fsrSF_vis_d_ln_patch, c2l_scale_type='urbanf') + this%ssre_fsr_vis_d_ln_patch(begp:endp) = spval + call hist_addfld1d (fname='SSRE_FSRVDLN', units='W/m^2', & + avgflag='A', long_name='surface snow radiatve effect on direct vis reflected solar radiation at local noon', & + ptr_patch=this%ssre_fsr_vis_d_ln_patch, c2l_scale_type='urbanf') + end if + this%fsds_sno_vd_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOFSDSVD', units='W/m^2', & + avgflag='A', long_name='direct vis incident solar radiation on snow', & + ptr_patch=this%fsds_sno_vd_patch, default='inactive') + + this%fsds_sno_nd_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOFSDSND', units='W/m^2', & + avgflag='A', long_name='direct nir incident solar radiation on snow', & + ptr_patch=this%fsds_sno_nd_patch, default='inactive') + + this%fsds_sno_vi_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOFSDSVI', units='W/m^2', & + avgflag='A', long_name='diffuse vis incident solar radiation on snow', & + ptr_patch=this%fsds_sno_vi_patch, default='inactive') + + this%fsds_sno_ni_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOFSDSNI', units='W/m^2', & + avgflag='A', long_name='diffuse nir incident solar radiation on snow', & + ptr_patch=this%fsds_sno_ni_patch, default='inactive') + + this%fsr_sno_vd_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOFSRVD', units='W/m^2', & + avgflag='A', long_name='direct vis reflected solar radiation from snow', & + ptr_patch=this%fsr_sno_vd_patch) + + this%fsr_sno_nd_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOFSRND', units='W/m^2', & + avgflag='A', long_name='direct nir reflected solar radiation from snow', & + ptr_patch=this%fsr_sno_nd_patch) + + this%fsr_sno_vi_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOFSRVI', units='W/m^2', & + avgflag='A', long_name='diffuse vis reflected solar radiation from snow', & + ptr_patch=this%fsr_sno_vi_patch) + + this%fsr_sno_ni_patch(begp:endp) = spval + call hist_addfld1d (fname='SNOFSRNI', units='W/m^2', & + avgflag='A', long_name='diffuse nir reflected solar radiation from snow', & + ptr_patch=this%fsr_sno_ni_patch) + + + end subroutine InitHistory + + !------------------------------------------------------------------------ + subroutine InitCold(this, bounds) + ! + ! !USES: + ! + ! !ARGUMENTS: + class(surfrad_type) :: this + type(bounds_type), intent(in) :: bounds + ! + ! !LOCAL VARIABLES: + integer :: p,l + !----------------------------------------------------------------------- + + ! nothing for now + + end subroutine InitCold + + + subroutine CanopySunShadeFracs(filter_nourbanp, num_nourbanp, & + atm2lnd_inst, surfalb_inst, & + canopystate_inst, solarabs_inst) + + ! ------------------------------------------------------------------------------------ + ! This subroutine calculates and returns patch vectors of + ! + ! 1) absorbed PAR for sunlit leaves in canopy layer + ! 2) absorbed PAR for shaded leaves in canopy layer + ! 3) sunlit leaf area + ! 4) shaded leaf area + ! 5) sunlit leaf area for canopy layer + ! 6) shaded leaf area for canopy layer + ! 7) sunlit fraction of canopy + ! + ! This routine has a counterpart when the fates model is turned on. + ! CLMEDInterf_CanopySunShadeFracs() + ! If changes are applied to this routine, please take a moment to review that + ! subroutine as well and consider if any new information related to these types of + ! variables also needs to be augmented in that routine as well. + ! ------------------------------------------------------------------------------------ + + + implicit none + + ! Arguments (in) + + integer, intent(in),dimension(:) :: filter_nourbanp ! patch filter for non-urban points + integer, intent(in) :: num_nourbanp ! size of the nonurban filter + type(atm2lnd_type), intent(in) :: atm2lnd_inst + type(surfalb_type), intent(in) :: surfalb_inst + + ! Arguments (inout) + type(canopystate_type), intent(inout) :: canopystate_inst + type(solarabs_type), intent(inout) :: solarabs_inst + + ! local variables + integer :: fp ! non-urban filter patch index + integer :: p ! patch index + integer :: g ! gridcell index + integer :: iv ! canopy layer index + integer,parameter :: ipar = 1 ! The band index for PAR + + associate( tlai_z => surfalb_inst%tlai_z_patch, & ! tlai increment for canopy layer + fsun_z => surfalb_inst%fsun_z_patch, & ! sunlit fraction of canopy layer + elai => canopystate_inst%elai_patch, & ! one-sided leaf area index + forc_solad => atm2lnd_inst%forc_solad_grc, & ! direct beam radiation (W/m**2) + forc_solai => atm2lnd_inst%forc_solai_grc, & ! diffuse radiation (W/m**2) + fabd_sun_z => surfalb_inst%fabd_sun_z_patch, & ! absorbed sunlit leaf direct PAR + fabd_sha_z => surfalb_inst%fabd_sha_z_patch, & ! absorbed shaded leaf direct PAR + fabi_sun_z => surfalb_inst%fabi_sun_z_patch, & ! absorbed sunlit leaf diffuse PAR + fabi_sha_z => surfalb_inst%fabi_sha_z_patch, & ! absorbed shaded leaf diffuse PAR + nrad => surfalb_inst%nrad_patch, & ! number of canopy layers + parsun_z => solarabs_inst%parsun_z_patch, & ! absorbed PAR for sunlit leaves + parsha_z => solarabs_inst%parsha_z_patch, & ! absorbed PAR for shaded leaves + laisun => canopystate_inst%laisun_patch, & ! sunlit leaf area + laisha => canopystate_inst%laisha_patch, & ! shaded leaf area + laisun_z => canopystate_inst%laisun_z_patch, & ! sunlit leaf area for canopy layer + laisha_z => canopystate_inst%laisha_z_patch, & ! shaded leaf area for canopy layer + fsun => canopystate_inst%fsun_patch) ! sunlit fraction of canopy + + do fp = 1,num_nourbanp + + p = filter_nourbanp(fp) + + do iv = 1, nrad(p) + parsun_z(p,iv) = 0._r8 + parsha_z(p,iv) = 0._r8 + laisun_z(p,iv) = 0._r8 + laisha_z(p,iv) = 0._r8 + end do + + ! Loop over patches to calculate laisun_z and laisha_z for each layer. + ! Derive canopy laisun, laisha, and fsun from layer sums. + ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from + ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. + + laisun(p) = 0._r8 + laisha(p) = 0._r8 + do iv = 1, nrad(p) + laisun_z(p,iv) = tlai_z(p,iv) * fsun_z(p,iv) + laisha_z(p,iv) = tlai_z(p,iv) * (1._r8 - fsun_z(p,iv)) + laisun(p) = laisun(p) + laisun_z(p,iv) + laisha(p) = laisha(p) + laisha_z(p,iv) + end do + if (elai(p) > 0._r8) then + fsun(p) = laisun(p) / elai(p) + else + fsun(p) = 0._r8 + end if + + ! Absorbed PAR profile through canopy + ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo + ! are canopy integrated so that layer values equal big leaf values. + + g = patch%gridcell(p) + + do iv = 1, nrad(p) + parsun_z(p,iv) = forc_solad(g,ipar)*fabd_sun_z(p,iv) + forc_solai(g,ipar)*fabi_sun_z(p,iv) + parsha_z(p,iv) = forc_solad(g,ipar)*fabd_sha_z(p,iv) + forc_solai(g,ipar)*fabi_sha_z(p,iv) + end do + + end do ! end of fp = 1,num_nourbanp loop + end associate + return + end subroutine CanopySunShadeFracs + + !------------------------------------------------------------------------------ + subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & + num_urbanp, filter_urbanp, num_urbanc, filter_urbanc, & + atm2lnd_inst, waterdiagnosticbulk_inst, canopystate_inst, & + surfalb_inst, solarabs_inst, surfrad_inst) + ! + ! !DESCRIPTION: + ! Solar fluxes absorbed by vegetation and ground surface + ! Note possible problem when land is on different grid than atmosphere. + ! Land may have sun above the horizon (coszen > 0) but atmosphere may + ! have sun below the horizon (forc_solad = 0 and forc_solai = 0). This is okay + ! because all fluxes (absorbed, reflected, transmitted) are multiplied + ! by the incoming flux and all will equal zero. + ! Atmosphere may have sun above horizon (forc_solad > 0 and forc_solai > 0) but + ! land may have sun below horizon. This is okay because fabd, fabi, + ! ftdd, ftid, and ftii all equal zero so that sabv=sabg=fsa=0. Also, + ! albd and albi equal one so that fsr=forc_solad+forc_solai. In other words, all + ! the radiation is reflected. NDVI should equal zero in this case. + ! However, the way the code is currently implemented this is only true + ! if (forc_solad+forc_solai)|vis = (forc_solad+forc_solai)|nir. + ! Output variables are parsun,parsha,sabv,sabg,fsa,fsr,ndvi + ! + ! !USES: + use clm_varpar , only : numrad, nlevsno + use clm_varcon , only : spval + use landunit_varcon , only : istsoil, istcrop + use clm_varctl , only : use_subgrid_fluxes, use_snicar_frc, iulog, use_SSRE + use clm_time_manager , only : get_step_size_real, is_near_local_noon + use SnowSnicarMod , only : DO_SNO_OC + use abortutils , only : endrun + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_nourbanp ! number of patches in non-urban points in patch filter + integer , intent(in) :: filter_nourbanp(:) ! patch filter for non-urban points + integer , intent(in) :: num_urbanp ! number of patches in non-urban points in patch filter + integer , intent(in) :: filter_urbanp(:) ! patch filter for non-urban points + integer , intent(in) :: num_urbanc ! number of urban columns in clump + integer , intent(in) :: filter_urbanc(:) ! urban column filter + type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(waterdiagnosticbulk_type) , intent(in) :: waterdiagnosticbulk_inst + type(surfalb_type) , intent(in) :: surfalb_inst + type(canopystate_type) , intent(inout) :: canopystate_inst + type(solarabs_type) , intent(inout) :: solarabs_inst + type(surfrad_type) , intent(inout) :: surfrad_inst + ! + ! !LOCAL VARIABLES: + integer , parameter :: nband = numrad ! number of solar radiation waveband classes + real(r8), parameter :: mpe = 1.e-06_r8 ! prevents overflow for division by zero + integer :: fp ! non-urban filter patch index + integer :: p ! patch index + integer :: c ! column index + integer :: l ! landunit index + integer :: g ! grid cell index + integer :: ib ! waveband number (1=vis, 2=nir) + integer :: iv ! canopy layer + real(r8) :: absrad ! absorbed solar radiation (W/m**2) + integer :: i ! layer index [idx] + real(r8) :: rnir ! reflected solar radiation [nir] (W/m**2) + real(r8) :: rvis ! reflected solar radiation [vis] (W/m**2) + real(r8) :: rnirSF ! snow-free reflected solar radiation [nir] (W/m**2) + real(r8) :: rvisSF ! snow-free reflected solar radiation [vis] (W/m**2) + real(r8) :: trd(bounds%begp:bounds%endp,numrad) ! transmitted solar radiation: direct (W/m**2) + real(r8) :: tri(bounds%begp:bounds%endp,numrad) ! transmitted solar radiation: diffuse (W/m**2) + real(r8) :: cad(bounds%begp:bounds%endp,numrad) ! direct beam absorbed by canopy (W/m**2) + real(r8) :: cai(bounds%begp:bounds%endp,numrad) ! diffuse radiation absorbed by canopy (W/m**2) + real(r8) :: dtime ! land model time step (sec) + real(r8) :: sabg_snl_sum ! temporary, absorbed energy in all active snow layers [W/m2] + real(r8) :: absrad_pur ! temp: absorbed solar radiation by pure snow [W/m2] + real(r8) :: absrad_bc ! temp: absorbed solar radiation without BC [W/m2] + real(r8) :: absrad_oc ! temp: absorbed solar radiation without OC [W/m2] + real(r8) :: absrad_dst ! temp: absorbed solar radiation without dust [W/m2] + real(r8) :: sabg_pur(bounds%begp:bounds%endp) ! solar radiation absorbed by ground with pure snow [W/m2] + real(r8) :: sabg_bc(bounds%begp:bounds%endp) ! solar radiation absorbed by ground without BC [W/m2] + real(r8) :: sabg_oc(bounds%begp:bounds%endp) ! solar radiation absorbed by ground without OC [W/m2] + real(r8) :: sabg_dst(bounds%begp:bounds%endp) ! solar radiation absorbed by ground without dust [W/m2] + real(r8) :: parveg(bounds%begp:bounds%endp) ! absorbed par by vegetation (W/m**2) + ! + !------------------------------------------------------------------------------ + + associate( & + snl => col%snl , & ! Input: [integer (:) ] negative number of snow layers [nbr] + + forc_solad => atm2lnd_inst%forc_solad_grc , & ! Input: [real(r8) (:,:) ] direct beam radiation (W/m**2) + forc_solai => atm2lnd_inst%forc_solai_grc , & ! Input: [real(r8) (:,:) ] diffuse radiation (W/m**2) + + snow_depth => waterdiagnosticbulk_inst%snow_depth_col , & ! Input: [real(r8) (:) ] snow height (m) + frac_sno => waterdiagnosticbulk_inst%frac_sno_col , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) + + nrad => surfalb_inst%nrad_patch , & ! Input: [integer (:) ] number of canopy layers, above snow for radiative transfer + coszen => surfalb_inst%coszen_col , & ! Input: [real(r8) (:) ] column cosine of solar zenith angle + albgrd => surfalb_inst%albgrd_col , & ! Input: [real(r8) (:,:) ] ground albedo (direct) + albgri => surfalb_inst%albgri_col , & ! Input: [real(r8) (:,:) ] ground albedo (diffuse) + albsod => surfalb_inst%albsod_col , & ! Input: [real(r8) (:,:) ] direct-beam soil albedo (col,bnd) [frc] + albgrd_oc => surfalb_inst%albgrd_oc_col , & ! Input: [real(r8) (:,:) ] ground albedo without OC (direct) (col,bnd) + albgri_oc => surfalb_inst%albgri_oc_col , & ! Input: [real(r8) (:,:) ] ground albedo without OC (diffuse) (col,bnd) + albgrd_dst => surfalb_inst%albgrd_dst_col , & ! Input: [real(r8) (:,:) ] ground albedo without dust (direct) (col,bnd) + albgri_dst => surfalb_inst%albgri_dst_col , & ! Input: [real(r8) (:,:) ] ground albedo without dust (diffuse) (col,bnd) + albsnd_hst => surfalb_inst%albsnd_hst_col , & ! Input: [real(r8) (:,:) ] snow albedo, direct, for history files (col,bnd) [frc] + albsni_hst => surfalb_inst%albsni_hst_col , & ! Input: [real(r8) (:,:) ] snow ground albedo, diffuse, for history files (col,bnd + flx_absdv => surfalb_inst%flx_absdv_col , & ! Input: [real(r8) (:,:) ] direct flux absorption factor (col,lyr): VIS [frc] + flx_absdn => surfalb_inst%flx_absdn_col , & ! Input: [real(r8) (:,:) ] direct flux absorption factor (col,lyr): NIR [frc] + flx_absiv => surfalb_inst%flx_absiv_col , & ! Input: [real(r8) (:,:) ] diffuse flux absorption factor (col,lyr): VIS [frc] + flx_absin => surfalb_inst%flx_absin_col , & ! Input: [real(r8) (:,:) ] diffuse flux absorption factor (col,lyr): NIR [frc] + albsoi => surfalb_inst%albsoi_col , & ! Input: [real(r8) (:,:) ] diffuse soil albedo (col,bnd) [frc] + albd => surfalb_inst%albd_patch , & ! Input: [real(r8) (:,:) ] surface albedo (direct) + albi => surfalb_inst%albi_patch , & ! Input: [real(r8) (:,:) ] surface albedo (diffuse) + albdSF => surfalb_inst%albdSF_patch , & ! Input: [real(r8) (:,:) ] snow-free surface albedo (direct) + albiSF => surfalb_inst%albiSF_patch , & ! Input: [real(r8) (:,:) ] snow-free surface albedo (diffuse) + fabd => surfalb_inst%fabd_patch , & ! Input: [real(r8) (:,:) ] flux absorbed by canopy per unit direct flux + fabd_sun => surfalb_inst%fabd_sun_patch , & ! Input: [real(r8) (:,:) ] flux absorbed by sunlit canopy per unit direct flux + fabd_sha => surfalb_inst%fabd_sha_patch , & ! Input: [real(r8) (:,:) ] flux absorbed by shaded canopy per unit direct flux + fabi => surfalb_inst%fabi_patch , & ! Input: [real(r8) (:,:) ] flux absorbed by canopy per unit diffuse flux + fabi_sun => surfalb_inst%fabi_sun_patch , & ! Input: [real(r8) (:,:) ] flux absorbed by sunlit canopy per unit diffuse flux + fabi_sha => surfalb_inst%fabi_sha_patch , & ! Input: [real(r8) (:,:) ] flux absorbed by shaded canopy per unit diffuse flux + ftdd => surfalb_inst%ftdd_patch , & ! Input: [real(r8) (:,:) ] down direct flux below canopy per unit direct flux + ftid => surfalb_inst%ftid_patch , & ! Input: [real(r8) (:,:) ] down diffuse flux below canopy per unit direct flux + ftii => surfalb_inst%ftii_patch , & ! Input: [real(r8) (:,:) ] down diffuse flux below canopy per unit diffuse flux + fabd_sun_z => surfalb_inst%fabd_sun_z_patch , & ! Input: [real(r8) (:,:) ] absorbed sunlit leaf direct PAR (per unit lai+sai) for each canopy layer + fabd_sha_z => surfalb_inst%fabd_sha_z_patch , & ! Input: [real(r8) (:,:) ] absorbed shaded leaf direct PAR (per unit lai+sai) for each canopy layer + fabi_sun_z => surfalb_inst%fabi_sun_z_patch , & ! Input: [real(r8) (:,:) ] absorbed sunlit leaf diffuse PAR (per unit lai+sai) for each canopy layer + fabi_sha_z => surfalb_inst%fabi_sha_z_patch , & ! Input: [real(r8) (:,:) ] absorbed shaded leaf diffuse PAR (per unit lai+sai) for each canopy layer + albgrd_pur => surfalb_inst%albgrd_pur_col , & ! Input: [real(r8) (:,:) ] pure snow ground albedo (direct) + albgri_pur => surfalb_inst%albgri_pur_col , & ! Input: [real(r8) (:,:) ] pure snow ground albedo (diffuse) + albgrd_bc => surfalb_inst%albgrd_bc_col , & ! Input: [real(r8) (:,:) ] ground albedo without BC (direct) (col,bnd) + albgri_bc => surfalb_inst%albgri_bc_col , & ! Input: [real(r8) (:,:) ] ground albedo without BC (diffuse) (col,bnd) + tlai => canopystate_inst%tlai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index + elai => canopystate_inst%elai_patch , & ! Input: [real(r8) (:) ] one-sided leaf area index with burying by snow + esai => canopystate_inst%esai_patch , & ! Input: [real(r8) (:) ] one-sided stem area index with burying by snow + fsun => canopystate_inst%fsun_patch , & ! Output: [real(r8) (:) ] sunlit fraction of canopy + fsa => solarabs_inst%fsa_patch , & ! Output: [real(r8) (:) ] solar radiation absorbed (total) (W/m**2) + fsr => solarabs_inst%fsr_patch , & ! Output: [real(r8) (:) ] solar radiation reflected (W/m**2) + fsrSF => solarabs_inst%fsrSF_patch , & ! Output: [real(r8) (:) ] diagnostic snow-free solar radiation reflected (W/m**2) + ssre_fsr => solarabs_inst%ssre_fsr_patch , & ! Output: [real(r8) (:) ] diagnostic snow-free solar radiation reflected (W/m**2) + sabv => solarabs_inst%sabv_patch , & ! Output: [real(r8) (:) ] solar radiation absorbed by vegetation (W/m**2) + sabg => solarabs_inst%sabg_patch , & ! Output: [real(r8) (:) ] solar radiation absorbed by ground (W/m**2) + sabg_pen => solarabs_inst%sabg_pen_patch , & ! Output: [real(r8) (:) ] solar (rural) radiation penetrating top soisno layer (W/m**2) + sabg_soil => solarabs_inst%sabg_soil_patch , & ! Output: [real(r8) (:) ] solar radiation absorbed by soil (W/m**2) + sabg_snow => solarabs_inst%sabg_snow_patch , & ! Output: [real(r8) (:) ] solar radiation absorbed by snow (W/m**2) + sabg_lyr => solarabs_inst%sabg_lyr_patch , & ! Output: [real(r8) (:,:) ] absorbed radiative flux (patch,lyr) [W/m2] + fsr_nir_d => solarabs_inst%fsr_nir_d_patch , & ! Output: [real(r8) (:) ] reflected direct beam nir solar radiation (W/m**2) + fsr_nir_i => solarabs_inst%fsr_nir_i_patch , & ! Output: [real(r8) (:) ] reflected diffuse nir solar radiation (W/m**2) + fsr_nir_d_ln => solarabs_inst%fsr_nir_d_ln_patch , & ! Output: [real(r8) (:) ] reflected direct beam nir solar rad at local noon (W/m**2) + fsds_nir_d => solarabs_inst%fsds_nir_d_patch , & ! Output: [real(r8) (:) ] incident direct beam nir solar radiation (W/m**2) + fsds_nir_d_ln => solarabs_inst%fsds_nir_d_ln_patch , & ! Output: [real(r8) (:) ] incident direct beam nir solar rad at local noon (W/m**2) + fsds_nir_i => solarabs_inst%fsds_nir_i_patch , & ! Output: [real(r8) (:) ] incident diffuse nir solar radiation (W/m**2) + fsrSF_nir_d => solarabs_inst%fsrSF_nir_d_patch , & ! Output: [real(r8) (:) ] snow-free reflected direct beam nir solar radiation (W/m**2) + fsrSF_nir_i => solarabs_inst%fsrSF_nir_i_patch , & ! Output: [real(r8) (:) ] snow-free reflected diffuse nir solar radiation (W/m**2) + fsrSF_nir_d_ln => solarabs_inst%fsrSF_nir_d_ln_patch, & ! Output: [real(r8) (:) ] snow-free reflected direct beam nir solar rad at local noon (W/m**2) + ssre_fsr_nir_d => solarabs_inst%ssre_fsr_nir_d_patch, & ! Output: [real(r8) (:) ] snow-free reflected direct beam nir solar radiation (W/m**2) + ssre_fsr_nir_i => solarabs_inst%ssre_fsr_nir_i_patch, & ! Output: [real(r8) (:) ] snow-free reflected diffuse nir solar radiation (W/m**2) + ssre_fsr_nir_d_ln=> solarabs_inst%ssre_fsr_nir_d_ln_patch,&!Output: [real(r8) (:) ] snow-free reflected direct beam nir solar rad at local noon (W/m**2) + fsa_r => solarabs_inst%fsa_r_patch , & ! Output: [real(r8) (:) ] rural solar radiation absorbed (total) (W/m**2) + sub_surf_abs_SW => solarabs_inst%sub_surf_abs_SW_patch,& ! Output: [real(r8) (:) ] fraction of solar radiation absorbed below first snow layer (W/M**2) + + parveg_ln => surfrad_inst%parveg_ln_patch , & ! Output: [real(r8) (:) ] absorbed par by vegetation at local noon (W/m**2) + parveg => surfrad_inst%parveg_patch , & ! Output: [real(r8) (:) ] absorbed par by vegetation (W/m**2) + fsr_vis_d => surfrad_inst%fsr_vis_d_patch , & ! Output: [real(r8) (:) ] reflected direct beam vis solar radiation (W/m**2) + fsr_vis_i => surfrad_inst%fsr_vis_i_patch , & ! Output: [real(r8) (:) ] reflected diffuse vis solar radiation (W/m**2) + fsrSF_vis_d => surfrad_inst%fsrSF_vis_d_patch , & ! Output: [real(r8) (:) ] snow-free reflected direct beam vis solar radiation (W/m**2) + fsrSF_vis_i => surfrad_inst%fsrSF_vis_i_patch , & ! Output: [real(r8) (:) ] snow-free reflected diffuse vis solar radiation (W/m**2) + ssre_fsr_vis_d => surfrad_inst%ssre_fsr_vis_d_patch , & ! Output: [real(r8) (:) ] snow-free reflected direct beam vis solar radiation (W/m**2) + ssre_fsr_vis_i => surfrad_inst%ssre_fsr_vis_i_patch , & ! Output: [real(r8) (:) ] snow-free reflected diffuse vis solar radiation (W/m**2) + fsds_vis_i_ln => surfrad_inst%fsds_vis_i_ln_patch , & ! Output: [real(r8) (:) ] incident diffuse beam vis solar rad at local noon (W/m**2) + fsr_vis_d_ln => surfrad_inst%fsr_vis_d_ln_patch , & ! Output: [real(r8) (:) ] reflected direct beam vis solar rad at local noon (W/m**2) + fsrSF_vis_d_ln => surfrad_inst%fsrSF_vis_d_ln_patch , & ! Output: [real(r8) (:) ] snow-free reflected direct beam vis solar rad at local noon (W/m**2) + fsds_vis_d => surfrad_inst%fsds_vis_d_patch , & ! Output: [real(r8) (:) ] incident direct beam vis solar radiation (W/m**2) + fsds_vis_i => surfrad_inst%fsds_vis_i_patch , & ! Output: [real(r8) (:) ] incident diffuse vis solar radiation (W/m**2) + fsds_vis_d_ln => surfrad_inst%fsds_vis_d_ln_patch , & ! Output: [real(r8) (:) ] incident direct beam vis solar rad at local noon (W/m**2) + sfc_frc_aer => surfrad_inst%sfc_frc_aer_patch , & ! Output: [real(r8) (:) ] surface forcing of snow with all aerosols (patch) [W/m2] + sfc_frc_aer_sno => surfrad_inst%sfc_frc_aer_sno_patch, & ! Output: [real(r8) (:) ] surface forcing of snow with all aerosols, averaged only when snow is present (patch) [W/m2] + sfc_frc_bc => surfrad_inst%sfc_frc_bc_patch , & ! Output: [real(r8) (:) ] surface forcing of snow with BC (patch) [W/m2] + sfc_frc_bc_sno => surfrad_inst%sfc_frc_bc_sno_patch , & ! Output: [real(r8) (:) ] surface forcing of snow with BC, averaged only when snow is present (patch) [W/m2] + sfc_frc_oc => surfrad_inst%sfc_frc_oc_patch , & ! Output: [real(r8) (:) ] surface forcing of snow with OC (patch) [W/m2] + sfc_frc_oc_sno => surfrad_inst%sfc_frc_oc_sno_patch , & ! Output: [real(r8) (:) ] surface forcing of snow with OC, averaged only when snow is present (patch) [W/m2] + sfc_frc_dst => surfrad_inst%sfc_frc_dst_patch , & ! Output: [real(r8) (:) ] surface forcing of snow with dust (patch) [W/m2] + sfc_frc_dst_sno => surfrad_inst%sfc_frc_dst_sno_patch, & ! Output: [real(r8) (:) ] surface forcing of snow with dust, averaged only when snow is present (patch) [W/m2] + fsr_sno_vd => surfrad_inst%fsr_sno_vd_patch , & ! Output: [real(r8) (:) ] reflected visible, direct radiation from snow (for history files) (patch) [W/m2] + fsr_sno_nd => surfrad_inst%fsr_sno_nd_patch , & ! Output: [real(r8) (:) ] reflected near-IR, direct radiation from snow (for history files) (patch) [W/m2] + fsr_sno_vi => surfrad_inst%fsr_sno_vi_patch , & ! Output: [real(r8) (:) ] reflected visible, diffuse radiation from snow (for history files) (patch) [W/m2] + fsr_sno_ni => surfrad_inst%fsr_sno_ni_patch , & ! Output: [real(r8) (:) ] reflected near-IR, diffuse radiation from snow (for history files) (patch) [W/m2] + fsds_sno_vd => surfrad_inst%fsds_sno_vd_patch , & ! Output: [real(r8) (:) ] incident visible, direct radiation on snow (for history files) (patch) [W/m2] + fsds_sno_nd => surfrad_inst%fsds_sno_nd_patch , & ! Output: [real(r8) (:) ] incident near-IR, direct radiation on snow (for history files) (patch) [W/m2] + fsds_sno_vi => surfrad_inst%fsds_sno_vi_patch , & ! Output: [real(r8) (:) ] incident visible, diffuse radiation on snow (for history files) (patch) [W/m2] + fsds_sno_ni => surfrad_inst%fsds_sno_ni_patch , & ! Output: [real(r8) (:) ] incident near-IR, diffuse radiation on snow (for history files) (patch) [W/m2] + frac_sno_eff => waterdiagnosticbulk_inst%frac_sno_eff_col & !Input: + + ) + + ! Determine seconds off current time step + dtime = get_step_size_real() + + ! Initialize fluxes + + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + l = patch%landunit(p) + g = patch%gridcell(p) + + sabg_soil(p) = 0._r8 + sabg_snow(p) = 0._r8 + sabg(p) = 0._r8 + sabv(p) = 0._r8 + fsa(p) = 0._r8 + if (lun%itype(l)==istsoil .or. lun%itype(l)==istcrop) then + fsa_r(p) = 0._r8 + end if + sabg_lyr(p,:) = 0._r8 + sabg_pur(p) = 0._r8 + sabg_bc(p) = 0._r8 + sabg_oc(p) = 0._r8 + sabg_dst(p) = 0._r8 + + end do + + ! zero-out fsun for the urban patches + ! the non-urban patches were set prior to this call + ! and split into fates and non-fates specific functions + do fp = 1,num_urbanp + p = filter_urbanp(fp) + fsun(p) = 0._r8 + end do + + ! Loop over nband wavebands + do ib = 1, nband + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + c = patch%column(p) + l = patch%landunit(p) + g = patch%gridcell(p) + + ! Absorbed by canopy + + cad(p,ib) = forc_solad(g,ib)*fabd(p,ib) + cai(p,ib) = forc_solai(g,ib)*fabi(p,ib) + sabv(p) = sabv(p) + cad(p,ib) + cai(p,ib) + fsa(p) = fsa(p) + cad(p,ib) + cai(p,ib) + if (ib == 1) then + parveg(p) = cad(p,ib) + cai(p,ib) + end if + if (lun%itype(l)==istsoil .or. lun%itype(l)==istcrop) then + fsa_r(p) = fsa_r(p) + cad(p,ib) + cai(p,ib) + end if + + ! Transmitted = solar fluxes incident on ground + + trd(p,ib) = forc_solad(g,ib)*ftdd(p,ib) + tri(p,ib) = forc_solad(g,ib)*ftid(p,ib) + forc_solai(g,ib)*ftii(p,ib) + ! Solar radiation absorbed by ground surface + ! calculate absorbed solar by soil/snow separately + absrad = trd(p,ib)*(1._r8-albsod(c,ib)) + tri(p,ib)*(1._r8-albsoi(c,ib)) + sabg_soil(p) = sabg_soil(p) + absrad + absrad = trd(p,ib)*(1._r8-albsnd_hst(c,ib)) + tri(p,ib)*(1._r8-albsni_hst(c,ib)) + sabg_snow(p) = sabg_snow(p) + absrad + absrad = trd(p,ib)*(1._r8-albgrd(c,ib)) + tri(p,ib)*(1._r8-albgri(c,ib)) + sabg(p) = sabg(p) + absrad + fsa(p) = fsa(p) + absrad + if (lun%itype(l)==istsoil .or. lun%itype(l)==istcrop) then + fsa_r(p) = fsa_r(p) + absrad + end if + if (snl(c) == 0) then + sabg_snow(p) = sabg(p) + sabg_soil(p) = sabg(p) + endif + ! if no subgrid fluxes, make sure to set both components equal to weighted average + if (.not. use_subgrid_fluxes .or. lun%itype(l) == istdlak) then + sabg_snow(p) = sabg(p) + sabg_soil(p) = sabg(p) + endif + + if (use_snicar_frc) then + ! Solar radiation absorbed by ground surface without BC + absrad_bc = trd(p,ib)*(1._r8-albgrd_bc(c,ib)) + tri(p,ib)*(1._r8-albgri_bc(c,ib)) + sabg_bc(p) = sabg_bc(p) + absrad_bc + + ! Solar radiation absorbed by ground surface without OC + absrad_oc = trd(p,ib)*(1._r8-albgrd_oc(c,ib)) + tri(p,ib)*(1._r8-albgri_oc(c,ib)) + sabg_oc(p) = sabg_oc(p) + absrad_oc + + ! Solar radiation absorbed by ground surface without dust + absrad_dst = trd(p,ib)*(1._r8-albgrd_dst(c,ib)) + tri(p,ib)*(1._r8-albgri_dst(c,ib)) + sabg_dst(p) = sabg_dst(p) + absrad_dst + + ! Solar radiation absorbed by ground surface without any aerosols + absrad_pur = trd(p,ib)*(1._r8-albgrd_pur(c,ib)) + tri(p,ib)*(1._r8-albgri_pur(c,ib)) + sabg_pur(p) = sabg_pur(p) + absrad_pur + end if + + end do ! end of patch loop + end do ! end nbands loop + + ! compute absorbed flux in each snow layer and top soil layer, + ! based on flux factors computed in the radiative transfer portion of SNICAR. + + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + c = patch%column(p) + l = patch%landunit(p) + sabg_snl_sum = 0._r8 + + sub_surf_abs_SW(p) = 0._r8 + + ! CASE1: No snow layers: all energy is absorbed in top soil layer + if (snl(c) == 0) then + sabg_lyr(p,:) = 0._r8 + sabg_lyr(p,1) = sabg(p) + sabg_snl_sum = sabg_lyr(p,1) + + ! CASE 2: Snow layers present: absorbed radiation is scaled according to + ! flux factors computed by SNICAR + else + do i = -nlevsno+1,1,1 + sabg_lyr(p,i) = flx_absdv(c,i)*trd(p,1) + flx_absdn(c,i)*trd(p,2) + & + flx_absiv(c,i)*tri(p,1) + flx_absin(c,i)*tri(p,2) + ! summed radiation in active snow layers: + if (i >= snl(c)+1) then + sabg_snl_sum = sabg_snl_sum + sabg_lyr(p,i) + endif + if (i > snl(c)+1) then ! if snow layer is below surface snow layer + !accumulate subsurface flux as a diagnostic for history file + sub_surf_abs_SW(p) = sub_surf_abs_SW(p) + sabg_lyr(p,i) + endif + enddo + + ! Divide absorbed by total, to get fraction absorbed in subsurface + if (sabg_snl_sum /= 0._r8) then + sub_surf_abs_SW(p) = sub_surf_abs_SW(p)/sabg_snl_sum + else + sub_surf_abs_SW(p) = 0._r8 + endif + + ! Error handling: The situation below can occur when solar radiation is + ! NOT computed every timestep. + ! When the number of snow layers has changed in between computations of the + ! absorbed solar energy in each layer, we must redistribute the absorbed energy + ! to avoid physically unrealistic conditions. The assumptions made below are + ! somewhat arbitrary, but this situation does not arise very frequently. + ! This error handling is implemented to accomodate any value of the + ! radiation frequency. + ! change condition to match sabg_snow isntead of sabg + if (abs(sabg_snl_sum-sabg_snow(p)) > 0.00001_r8) then + if (snl(c) == 0) then + sabg_lyr(p,-nlevsno+1:0) = 0._r8 + sabg_lyr(p,1) = sabg(p) + elseif (snl(c) == -1) then + sabg_lyr(p,-nlevsno+1:-1) = 0._r8 + sabg_lyr(p,0) = sabg_snow(p)*0.6_r8 + sabg_lyr(p,1) = sabg_snow(p)*0.4_r8 + else + sabg_lyr(p,:) = 0._r8 + sabg_lyr(p,snl(c)+1) = sabg_snow(p)*0.75_r8 + sabg_lyr(p,snl(c)+2) = sabg_snow(p)*0.25_r8 + endif + endif + + ! If shallow snow depth, all solar radiation absorbed in top or top two snow layers + ! to prevent unrealistic timestep soil warming + if (.not. use_subgrid_fluxes .or. lun%itype(l) == istdlak) then + if (snow_depth(c) < 0.10_r8) then + if (snl(c) == 0) then + sabg_lyr(p,-nlevsno+1:0) = 0._r8 + sabg_lyr(p,1) = sabg(p) + elseif (snl(c) == -1) then + sabg_lyr(p,-nlevsno+1:-1) = 0._r8 + sabg_lyr(p,0) = sabg(p) + sabg_lyr(p,1) = 0._r8 + else + sabg_lyr(p,:) = 0._r8 + sabg_lyr(p,snl(c)+1) = sabg(p)*0.75_r8 + sabg_lyr(p,snl(c)+2) = sabg(p)*0.25_r8 + endif + endif + endif + endif + + ! This situation should not happen: + if (abs(sum(sabg_lyr(p,:))-sabg_snow(p)) > 0.00001_r8) then + write(iulog,*)"SNICAR ERROR: Absorbed ground radiation not equal to summed snow layer radiation" + write(iulog,*)"Diff = ",sum(sabg_lyr(p,:))-sabg_snow(p) + write(iulog,*)"sabg_snow(p)= ",sabg_snow(p) + write(iulog,*)"sabg_sum(p) = ",sum(sabg_lyr(p,:)) + write(iulog,*)"snl(c) = ",snl(c) + write(iulog,*)"flx_absdv1 = ",trd(p,1)*(1.-albgrd(c,1)) + write(iulog,*)"flx_absdv2 = ",sum(flx_absdv(c,:))*trd(p,1) + write(iulog,*)"flx_absiv1 = ",tri(p,1)*(1.-albgri(c,1)) + write(iulog,*)"flx_absiv2 = ",sum(flx_absiv(c,:))*tri(p,1) + write(iulog,*)"flx_absdn1 = ",trd(p,2)*(1.-albgrd(c,2)) + write(iulog,*)"flx_absdn2 = ",sum(flx_absdn(c,:))*trd(p,2) + write(iulog,*)"flx_absin1 = ",tri(p,2)*(1.-albgri(c,2)) + write(iulog,*)"flx_absin2 = ",sum(flx_absin(c,:))*tri(p,2) + write(iulog,*)"albgrd_nir = ",albgrd(c,2) + write(iulog,*)"coszen = ",coszen(c) + call endrun(decomp_index=c, clmlevel=namec, msg=errmsg(sourcefile, __LINE__)) + endif + + ! Diagnostic: shortwave penetrating ground (e.g. top layer) + if (lun%itype(l) == istsoil .or. lun%itype(l) == istcrop) then + sabg_pen(p) = sabg(p) - sabg_lyr(p, snl(c)+1) + end if + + if (use_snicar_frc) then + + ! BC aerosol forcing (patch-level): + sfc_frc_bc(p) = sabg(p) - sabg_bc(p) + + ! OC aerosol forcing (patch-level): + if (DO_SNO_OC) then + sfc_frc_oc(p) = sabg(p) - sabg_oc(p) + else + sfc_frc_oc(p) = 0._r8 + endif + + ! dust aerosol forcing (patch-level): + sfc_frc_dst(p) = sabg(p) - sabg_dst(p) + + ! all-aerosol forcing (patch-level): + sfc_frc_aer(p) = sabg(p) - sabg_pur(p) + + ! forcings averaged only over snow: + if (frac_sno(c) > 0._r8) then + sfc_frc_bc_sno(p) = sfc_frc_bc(p)/frac_sno(c) + sfc_frc_oc_sno(p) = sfc_frc_oc(p)/frac_sno(c) + sfc_frc_dst_sno(p) = sfc_frc_dst(p)/frac_sno(c) + sfc_frc_aer_sno(p) = sfc_frc_aer(p)/frac_sno(c) + else + sfc_frc_bc_sno(p) = spval + sfc_frc_oc_sno(p) = spval + sfc_frc_dst_sno(p) = spval + sfc_frc_aer_sno(p) = spval + endif + end if + enddo + + ! Radiation diagnostics + + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + g = patch%gridcell(p) + + ! NDVI and reflected solar radiation + + rvis = albd(p,1)*forc_solad(g,1) + albi(p,1)*forc_solai(g,1) + rnir = albd(p,2)*forc_solad(g,2) + albi(p,2)*forc_solai(g,2) + fsr(p) = rvis + rnir + if (use_SSRE) then + rvisSF = albdSF(p,1)*forc_solad(g,1) + albiSF(p,1)*forc_solai(g,1) + rnirSF = albdSF(p,2)*forc_solad(g,2) + albiSF(p,2)*forc_solai(g,2) + fsrSF(p) = rvisSF + rnirSF + ssre_fsr(p) = fsr(p)-fsrSF(p) + end if + fsds_vis_d(p) = forc_solad(g,1) + fsds_nir_d(p) = forc_solad(g,2) + fsds_vis_i(p) = forc_solai(g,1) + fsds_nir_i(p) = forc_solai(g,2) + fsr_vis_d(p) = albd(p,1)*forc_solad(g,1) + fsr_nir_d(p) = albd(p,2)*forc_solad(g,2) + fsr_vis_i(p) = albi(p,1)*forc_solai(g,1) + fsr_nir_i(p) = albi(p,2)*forc_solai(g,2) + if (use_SSRE) then + fsrSF_vis_d(p) = albdSF(p,1)*forc_solad(g,1) + fsrSF_nir_d(p) = albdSF(p,2)*forc_solad(g,2) + fsrSF_vis_i(p) = albiSF(p,1)*forc_solai(g,1) + fsrSF_nir_i(p) = albiSF(p,2)*forc_solai(g,2) + + ssre_fsr_vis_d(p) = fsrSF_vis_d(p)-fsr_vis_d(p) + ssre_fsr_nir_d(p) = fsrSF_nir_d(p)-fsr_nir_d(p) + ssre_fsr_vis_i(p) = fsrSF_vis_i(p)-fsr_vis_i(p) + ssre_fsr_nir_i(p) = fsrSF_nir_i(p)-fsr_nir_i(p) + end if + if ( is_near_local_noon( grc%londeg(g), deltasec=nint(dtime)/2 ) )then + fsds_vis_d_ln(p) = forc_solad(g,1) + fsds_nir_d_ln(p) = forc_solad(g,2) + fsr_vis_d_ln(p) = albd(p,1)*forc_solad(g,1) + fsr_nir_d_ln(p) = albd(p,2)*forc_solad(g,2) + fsds_vis_i_ln(p) = forc_solai(g,1) + parveg_ln(p) = parveg(p) + else + fsds_vis_d_ln(p) = spval + fsds_nir_d_ln(p) = spval + fsr_vis_d_ln(p) = spval + fsr_nir_d_ln(p) = spval + fsds_vis_i_ln(p) = spval + parveg_ln(p) = spval + end if + if (use_SSRE) then + if ( is_near_local_noon( grc%londeg(g), deltasec=nint(dtime)/2 ) )then + fsrSF_vis_d_ln(p) = albdSF(p,1)*forc_solad(g,1) + fsrSF_nir_d_ln(p) = albdSF(p,2)*forc_solad(g,2) + else + fsrSF_vis_d_ln(p) = spval + fsrSF_nir_d_ln(p) = spval + end if + end if + ! diagnostic variables (downwelling and absorbed radiation partitioning) for history files + ! (OPTIONAL) + c = patch%column(p) + if (snl(c) < 0) then + fsds_sno_vd(p) = forc_solad(g,1) + fsds_sno_nd(p) = forc_solad(g,2) + fsds_sno_vi(p) = forc_solai(g,1) + fsds_sno_ni(p) = forc_solai(g,2) + + fsr_sno_vd(p) = fsds_vis_d(p)*albsnd_hst(c,1) + fsr_sno_nd(p) = fsds_nir_d(p)*albsnd_hst(c,2) + fsr_sno_vi(p) = fsds_vis_i(p)*albsni_hst(c,1) + fsr_sno_ni(p) = fsds_nir_i(p)*albsni_hst(c,2) + else + fsds_sno_vd(p) = spval + fsds_sno_nd(p) = spval + fsds_sno_vi(p) = spval + fsds_sno_ni(p) = spval + + fsr_sno_vd(p) = spval + fsr_sno_nd(p) = spval + fsr_sno_vi(p) = spval + fsr_sno_ni(p) = spval + endif + end do + + ! TODO: urban snow-free albedos: + do fp = 1,num_urbanp + p = filter_urbanp(fp) + g = patch%gridcell(p) + + if(elai(p)==0.0_r8.and.fabd(p,1)>0._r8)then + if ( local_debug ) write(iulog,*) 'absorption without LAI',elai(p),tlai(p),fabd(p,1),p + endif + + ! Solar incident + + fsds_vis_d(p) = forc_solad(g,1) + fsds_nir_d(p) = forc_solad(g,2) + fsds_vis_i(p) = forc_solai(g,1) + fsds_nir_i(p) = forc_solai(g,2) + + ! Determine local noon incident solar + if ( is_near_local_noon( grc%londeg(g), deltasec=nint(dtime)/2 ) )then + fsds_vis_d_ln(p) = forc_solad(g,1) + fsds_nir_d_ln(p) = forc_solad(g,2) + fsds_vis_i_ln(p) = forc_solai(g,1) + parveg_ln(p) = 0._r8 + else + fsds_vis_d_ln(p) = spval + fsds_nir_d_ln(p) = spval + fsds_vis_i_ln(p) = spval + parveg_ln(p) = spval + endif + + ! Solar reflected + ! per unit ground area (roof, road) and per unit wall area (sunwall, shadewall) + + fsr_vis_d(p) = albd(p,1) * forc_solad(g,1) + fsr_nir_d(p) = albd(p,2) * forc_solad(g,2) + fsr_vis_i(p) = albi(p,1) * forc_solai(g,1) + fsr_nir_i(p) = albi(p,2) * forc_solai(g,2) + + ! Determine local noon reflected solar + if ( is_near_local_noon( grc%londeg(g), deltasec=nint(dtime)/2 ) )then + fsr_vis_d_ln(p) = fsr_vis_d(p) + fsr_nir_d_ln(p) = fsr_nir_d(p) + else + fsr_vis_d_ln(p) = spval + fsr_nir_d_ln(p) = spval + endif + fsr(p) = fsr_vis_d(p) + fsr_nir_d(p) + fsr_vis_i(p) + fsr_nir_i(p) + end do + + end associate + + end subroutine SurfaceRadiation + +end module SurfaceRadiationMod diff --git a/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/cpl/lnd_import_export.F90 b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/cpl/lnd_import_export.F90 new file mode 100644 index 0000000000..2223657afa --- /dev/null +++ b/models/clm/DART_SourceMods/cesm2_2_0/SourceMods/src.clm/cpl/lnd_import_export.F90 @@ -0,0 +1,466 @@ + +! DART note: this file started life as release-cesm2.2.01 : +! /glade/work/thoar/CESM/my_cesm_sandbox/components/clm/src/cpl/mct/lnd_import_export.F90 +! +! Its only purpose is to change any unphysical downward negative fluxes from the forcing files. +! Some of the preprocessed fluxes in DS199.1 have numerical artifacts that leave them slightly negative. +! These should have been replaced on the RDA, but may exist for users who are using old files. + +module lnd_import_export + + use shr_kind_mod , only: r8 => shr_kind_r8, cl=>shr_kind_cl + use abortutils , only: endrun + use decompmod , only: bounds_type + use lnd2atmType , only: lnd2atm_type + use lnd2glcMod , only: lnd2glc_type + use atm2lndType , only: atm2lnd_type + use glc2lndMod , only: glc2lnd_type + use Waterlnd2atmBulkType , only: waterlnd2atmbulk_type + use Wateratm2lndBulkType , only: wateratm2lndbulk_type + use clm_cpl_indices + ! + implicit none + !=============================================================================== + +contains + + !=============================================================================== + subroutine lnd_import( bounds, x2l, glc_present, atm2lnd_inst, glc2lnd_inst, wateratm2lndbulk_inst) + + !--------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Convert the input data from the coupler to the land model + ! + ! !USES: + use seq_flds_mod , only: seq_flds_x2l_fields + use clm_varctl , only: co2_type, co2_ppmv, iulog, use_c13 + use clm_varctl , only: ndep_from_cpl + use clm_varcon , only: rair, o2_molar_const, c13ratio + use shr_const_mod , only: SHR_CONST_TKFRZ + use shr_string_mod , only: shr_string_listGetName + use domainMod , only: ldomain + use shr_infnan_mod , only : isnan => shr_infnan_isnan + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds ! bounds + real(r8) , intent(in) :: x2l(:,:) ! driver import state to land model + logical , intent(in) :: glc_present ! .true. => running with a non-stub GLC model + type(atm2lnd_type) , intent(inout) :: atm2lnd_inst ! clm internal input data type + type(glc2lnd_type) , intent(inout) :: glc2lnd_inst ! clm internal input data type + type(wateratm2lndbulk_type), intent(inout) :: wateratm2lndbulk_inst ! clm internal input data type + ! + ! !LOCAL VARIABLES: + integer :: g,i,k,nstep,ier ! indices, number of steps, and error code + real(r8) :: forc_rainc ! rainxy Atm flux mm/s + real(r8) :: e ! vapor pressure (Pa) + real(r8) :: qsat ! saturation specific humidity (kg/kg) + real(r8) :: forc_t ! atmospheric temperature (Kelvin) + real(r8) :: forc_q ! atmospheric specific humidity (kg/kg) + real(r8) :: forc_pbot ! atmospheric pressure (Pa) + real(r8) :: forc_rainl ! rainxy Atm flux mm/s + real(r8) :: forc_snowc ! snowfxy Atm flux mm/s + real(r8) :: forc_snowl ! snowfxl Atm flux mm/s + real(r8) :: co2_ppmv_diag ! temporary + real(r8) :: co2_ppmv_prog ! temporary + real(r8) :: co2_ppmv_val ! temporary + integer :: co2_type_idx ! integer flag for co2_type options + real(r8) :: esatw ! saturation vapor pressure over water (Pa) + real(r8) :: esati ! saturation vapor pressure over ice (Pa) + real(r8) :: a0,a1,a2,a3,a4,a5,a6 ! coefficients for esat over water + real(r8) :: b0,b1,b2,b3,b4,b5,b6 ! coefficients for esat over ice + real(r8) :: tdc, t ! Kelvins to Celcius function and its input + character(len=32) :: fname ! name of field that is NaN + character(len=32), parameter :: sub = 'lnd_import' + + ! Constants to compute vapor pressure + parameter (a0=6.107799961_r8 , a1=4.436518521e-01_r8, & + a2=1.428945805e-02_r8, a3=2.650648471e-04_r8, & + a4=3.031240396e-06_r8, a5=2.034080948e-08_r8, & + a6=6.136820929e-11_r8) + + parameter (b0=6.109177956_r8 , b1=5.034698970e-01_r8, & + b2=1.886013408e-02_r8, b3=4.176223716e-04_r8, & + b4=5.824720280e-06_r8, b5=4.838803174e-08_r8, & + b6=1.838826904e-10_r8) + ! + ! function declarations + ! + tdc(t) = min( 50._r8, max(-50._r8,(t-SHR_CONST_TKFRZ)) ) + esatw(t) = 100._r8*(a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+t*a6)))))) + esati(t) = 100._r8*(b0+t*(b1+t*(b2+t*(b3+t*(b4+t*(b5+t*b6)))))) + !--------------------------------------------------------------------------- + + co2_type_idx = 0 + if (co2_type == 'prognostic') then + co2_type_idx = 1 + else if (co2_type == 'diagnostic') then + co2_type_idx = 2 + end if + if (co2_type == 'prognostic' .and. index_x2l_Sa_co2prog == 0) then + call endrun( sub//' ERROR: must have nonzero index_x2l_Sa_co2prog for co2_type equal to prognostic' ) + else if (co2_type == 'diagnostic' .and. index_x2l_Sa_co2diag == 0) then + call endrun( sub//' ERROR: must have nonzero index_x2l_Sa_co2diag for co2_type equal to diagnostic' ) + end if + + ! Note that the precipitation fluxes received from the coupler + ! are in units of kg/s/m^2. To convert these precipitation rates + ! in units of mm/sec, one must divide by 1000 kg/m^3 and multiply + ! by 1000 mm/m resulting in an overall factor of unity. + ! Below the units are therefore given in mm/s. + + + do g = bounds%begg,bounds%endg + i = 1 + (g - bounds%begg) + + ! Determine flooding input, sign convention is positive downward and + ! hierarchy is atm/glc/lnd/rof/ice/ocn. so water sent from rof to land is negative, + ! change the sign to indicate addition of water to system. + + wateratm2lndbulk_inst%forc_flood_grc(g) = -x2l(index_x2l_Flrr_flood,i) + + wateratm2lndbulk_inst%volr_grc(g) = x2l(index_x2l_Flrr_volr,i) * (ldomain%area(g) * 1.e6_r8) + wateratm2lndbulk_inst%volrmch_grc(g)= x2l(index_x2l_Flrr_volrmch,i) * (ldomain%area(g) * 1.e6_r8) + + ! Determine required receive fields + + atm2lnd_inst%forc_hgt_grc(g) = x2l(index_x2l_Sa_z,i) ! zgcmxy Atm state m + atm2lnd_inst%forc_topo_grc(g) = x2l(index_x2l_Sa_topo,i) ! Atm surface height (m) + atm2lnd_inst%forc_u_grc(g) = x2l(index_x2l_Sa_u,i) ! forc_uxy Atm state m/s + atm2lnd_inst%forc_v_grc(g) = x2l(index_x2l_Sa_v,i) ! forc_vxy Atm state m/s + atm2lnd_inst%forc_solad_grc(g,2) = x2l(index_x2l_Faxa_swndr,i) ! forc_sollxy Atm flux W/m^2 + atm2lnd_inst%forc_solad_grc(g,1) = x2l(index_x2l_Faxa_swvdr,i) ! forc_solsxy Atm flux W/m^2 + atm2lnd_inst%forc_solai_grc(g,2) = x2l(index_x2l_Faxa_swndf,i) ! forc_solldxy Atm flux W/m^2 + atm2lnd_inst%forc_solai_grc(g,1) = x2l(index_x2l_Faxa_swvdf,i) ! forc_solsdxy Atm flux W/m^2 + + atm2lnd_inst%forc_th_not_downscaled_grc(g) = x2l(index_x2l_Sa_ptem,i) ! forc_thxy Atm state K + wateratm2lndbulk_inst%forc_q_not_downscaled_grc(g) = x2l(index_x2l_Sa_shum,i) ! forc_qxy Atm state kg/kg + atm2lnd_inst%forc_pbot_not_downscaled_grc(g) = x2l(index_x2l_Sa_pbot,i) ! ptcmxy Atm state Pa + atm2lnd_inst%forc_t_not_downscaled_grc(g) = x2l(index_x2l_Sa_tbot,i) ! forc_txy Atm state K + atm2lnd_inst%forc_lwrad_not_downscaled_grc(g) = x2l(index_x2l_Faxa_lwdn,i) ! flwdsxy Atm flux W/m^2 + + forc_rainc = x2l(index_x2l_Faxa_rainc,i) ! mm/s + forc_rainl = x2l(index_x2l_Faxa_rainl,i) ! mm/s + forc_snowc = x2l(index_x2l_Faxa_snowc,i) ! mm/s + forc_snowl = x2l(index_x2l_Faxa_snowl,i) ! mm/s + + ! atmosphere coupling, for prognostic/prescribed aerosols + atm2lnd_inst%forc_aer_grc(g,1) = x2l(index_x2l_Faxa_bcphidry,i) + atm2lnd_inst%forc_aer_grc(g,2) = x2l(index_x2l_Faxa_bcphodry,i) + atm2lnd_inst%forc_aer_grc(g,3) = x2l(index_x2l_Faxa_bcphiwet,i) + atm2lnd_inst%forc_aer_grc(g,4) = x2l(index_x2l_Faxa_ocphidry,i) + atm2lnd_inst%forc_aer_grc(g,5) = x2l(index_x2l_Faxa_ocphodry,i) + atm2lnd_inst%forc_aer_grc(g,6) = x2l(index_x2l_Faxa_ocphiwet,i) + atm2lnd_inst%forc_aer_grc(g,7) = x2l(index_x2l_Faxa_dstwet1,i) + atm2lnd_inst%forc_aer_grc(g,8) = x2l(index_x2l_Faxa_dstdry1,i) + atm2lnd_inst%forc_aer_grc(g,9) = x2l(index_x2l_Faxa_dstwet2,i) + atm2lnd_inst%forc_aer_grc(g,10) = x2l(index_x2l_Faxa_dstdry2,i) + atm2lnd_inst%forc_aer_grc(g,11) = x2l(index_x2l_Faxa_dstwet3,i) + atm2lnd_inst%forc_aer_grc(g,12) = x2l(index_x2l_Faxa_dstdry3,i) + atm2lnd_inst%forc_aer_grc(g,13) = x2l(index_x2l_Faxa_dstwet4,i) + atm2lnd_inst%forc_aer_grc(g,14) = x2l(index_x2l_Faxa_dstdry4,i) + + ! Determine optional receive fields + + if (index_x2l_Sa_co2prog /= 0) then + co2_ppmv_prog = x2l(index_x2l_Sa_co2prog,i) ! co2 atm state prognostic + else + co2_ppmv_prog = co2_ppmv + end if + + if (index_x2l_Sa_co2diag /= 0) then + co2_ppmv_diag = x2l(index_x2l_Sa_co2diag,i) ! co2 atm state diagnostic + else + co2_ppmv_diag = co2_ppmv + end if + + if (index_x2l_Sa_methane /= 0) then + atm2lnd_inst%forc_pch4_grc(g) = x2l(index_x2l_Sa_methane,i) + endif + + ! Determine derived quantities for required fields + + forc_t = atm2lnd_inst%forc_t_not_downscaled_grc(g) + forc_q = wateratm2lndbulk_inst%forc_q_not_downscaled_grc(g) + forc_pbot = atm2lnd_inst%forc_pbot_not_downscaled_grc(g) + + atm2lnd_inst%forc_hgt_u_grc(g) = atm2lnd_inst%forc_hgt_grc(g) !observational height of wind [m] + atm2lnd_inst%forc_hgt_t_grc(g) = atm2lnd_inst%forc_hgt_grc(g) !observational height of temperature [m] + atm2lnd_inst%forc_hgt_q_grc(g) = atm2lnd_inst%forc_hgt_grc(g) !observational height of humidity [m] + atm2lnd_inst%forc_vp_grc(g) = forc_q * forc_pbot / (0.622_r8 + 0.378_r8 * forc_q) + atm2lnd_inst%forc_rho_not_downscaled_grc(g) = & + (forc_pbot - 0.378_r8 * atm2lnd_inst%forc_vp_grc(g)) / (rair * forc_t) + atm2lnd_inst%forc_po2_grc(g) = o2_molar_const * forc_pbot + atm2lnd_inst%forc_wind_grc(g) = sqrt(atm2lnd_inst%forc_u_grc(g)**2 + atm2lnd_inst%forc_v_grc(g)**2) + atm2lnd_inst%forc_solar_grc(g) = atm2lnd_inst%forc_solad_grc(g,1) + atm2lnd_inst%forc_solai_grc(g,1) + & + atm2lnd_inst%forc_solad_grc(g,2) + atm2lnd_inst%forc_solai_grc(g,2) + + wateratm2lndbulk_inst%forc_rain_not_downscaled_grc(g) = forc_rainc + forc_rainl + wateratm2lndbulk_inst%forc_snow_not_downscaled_grc(g) = forc_snowc + forc_snowl + + if (forc_t > SHR_CONST_TKFRZ) then + e = esatw(tdc(forc_t)) + else + e = esati(tdc(forc_t)) + end if + qsat = 0.622_r8*e / (forc_pbot - 0.378_r8*e) + + !modify specific humidity if precip occurs + if(1==2) then + if((forc_rainc+forc_rainl) > 0._r8) then + forc_q = 0.95_r8*qsat + ! forc_q = qsat + wateratm2lndbulk_inst%forc_q_not_downscaled_grc(g) = forc_q + endif + endif + + wateratm2lndbulk_inst%forc_rh_grc(g) = 100.0_r8*(forc_q / qsat) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! AMF 11/30/17 Remove ENDRUN for negative values, and replace with 1.0_r8 +! TJH 1/31/18 Some of the preprocessed fluxes have numerical artifacts that leave them slightly negative + + ! Check that solar, specific-humidity and LW downward aren't negative + if ( atm2lnd_inst%forc_lwrad_not_downscaled_grc(g) <= 0.0_r8 )then + write(iulog,*) 'WARNING: Longwave down =',atm2lnd_inst%forc_lwrad_not_downscaled_grc(g) ,' gridcell index = ', g + atm2lnd_inst%forc_lwrad_not_downscaled_grc(g) = tiny(1.0_r8) + end if + if (atm2lnd_inst%forc_solad_grc(g,1) < 0.0_r8) then + write(iulog,*) 'WARNING: Indirect solar =', atm2lnd_inst%forc_solad_grc(g,1),' gridcell index = ', g + atm2lnd_inst%forc_solad_grc(g,1) = 1.0_r8 + end if + if (atm2lnd_inst%forc_solad_grc(g,2) < 0.0_r8) then + write(iulog,*) 'WARNING: Diffuse solar =', atm2lnd_inst%forc_solad_grc(g,2),' gridcell index = ', g + atm2lnd_inst%forc_solad_grc(g,2) = 1.0_r8 + end if + if (atm2lnd_inst%forc_solai_grc(g,1) < 0.0_r8) then + write(iulog,*) 'WARNING: Indirect, vis solar =', atm2lnd_inst%forc_solai_grc(g,1),' gridcell index = ', g + atm2lnd_inst%forc_solai_grc(g,1) = 1.0_r8 + end if + if (atm2lnd_inst%forc_solai_grc(g,2) < 0.0_r8) then + write(iulog,*) 'WARNING: Indirect, near IR solar =', atm2lnd_inst%forc_solai_grc(g,2),' gridcell index = ', g + atm2lnd_inst%forc_solai_grc(g,2) = 1.0_r8 + end if + if (atm2lnd_inst%forc_solad_grc(g,1) < 0.0_r8 ) then + write(iulog,*) 'WARNING: Direct, vis solar =', atm2lnd_inst%forc_solad_grc(g,1),' gridcell index = ', g + atm2lnd_inst%forc_solad_grc(g,1) = 1.0_r8 + end if + if (atm2lnd_inst%forc_solad_grc(g,2) < 0.0_r8 ) then + write(iulog,*) 'WARNING: Direct, near IR solar =', atm2lnd_inst%forc_solad_grc(g,2),' gridcell index = ', g + atm2lnd_inst%forc_solad_grc(g,2) = 1.0_r8 + end if + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if ( wateratm2lndbulk_inst%forc_q_not_downscaled_grc(g) < 0.0_r8 )then + call endrun( sub//' ERROR: Bottom layer specific humidty sent from the atmosphere model is less than zero' ) + end if + + ! Check if any input from the coupler is NaN + if ( any(isnan(x2l(:,i))) )then + write(iulog,*) '# of NaNs = ', count(isnan(x2l(:,i))) + write(iulog,*) 'Which are NaNs = ', isnan(x2l(:,i)) + do k = 1, size(x2l(:,i)) + if ( isnan(x2l(k,i)) )then + call shr_string_listGetName( seq_flds_x2l_fields, k, fname ) + write(iulog,*) trim(fname) + end if + end do + write(iulog,*) 'gridcell index = ', g + call endrun( sub//' ERROR: One or more of the input from the atmosphere model are NaN '// & + '(Not a Number from a bad floating point calculation)' ) + end if + + ! Make sure relative humidity is properly bounded + ! wateratm2lndbulk_inst%forc_rh_grc(g) = min( 100.0_r8, wateratm2lndbulk_inst%forc_rh_grc(g) ) + ! wateratm2lndbulk_inst%forc_rh_grc(g) = max( 0.0_r8, wateratm2lndbulk_inst%forc_rh_grc(g) ) + + ! Determine derived quantities for optional fields + ! Note that the following does unit conversions from ppmv to partial pressures (Pa) + ! Note that forc_pbot is in Pa + + if (co2_type_idx == 1) then + co2_ppmv_val = co2_ppmv_prog + else if (co2_type_idx == 2) then + co2_ppmv_val = co2_ppmv_diag + else + co2_ppmv_val = co2_ppmv + end if + if ( (co2_ppmv_val < 10.0_r8) .or. (co2_ppmv_val > 15000.0_r8) )then + call endrun( sub//' ERROR: CO2 is outside of an expected range' ) + end if + atm2lnd_inst%forc_pco2_grc(g) = co2_ppmv_val * 1.e-6_r8 * forc_pbot + if (use_c13) then + atm2lnd_inst%forc_pc13o2_grc(g) = co2_ppmv_val * c13ratio * 1.e-6_r8 * forc_pbot + end if + + if (ndep_from_cpl) then + ! The coupler is sending ndep in units if kgN/m2/s - and clm uses units of gN/m2/sec - so the + ! following conversion needs to happen + atm2lnd_inst%forc_ndep_grc(g) = (x2l(index_x2l_Faxa_nhx, i) + x2l(index_x2l_faxa_noy, i))*1000._r8 + end if + + end do + + call glc2lnd_inst%set_glc2lnd_fields_mct( & + bounds = bounds, & + glc_present = glc_present, & + ! NOTE(wjs, 2017-12-13) the x2l argument doesn't have the typical bounds + ! subsetting (bounds%begg:bounds%endg). This mirrors the lack of these bounds in + ! the call to lnd_import from lnd_run_mct. This is okay as long as this code is + ! outside a clump loop. + x2l = x2l, & + index_x2l_Sg_ice_covered = index_x2l_Sg_ice_covered, & + index_x2l_Sg_topo = index_x2l_Sg_topo, & + index_x2l_Flgg_hflx = index_x2l_Flgg_hflx, & + index_x2l_Sg_icemask = index_x2l_Sg_icemask, & + index_x2l_Sg_icemask_coupled_fluxes = index_x2l_Sg_icemask_coupled_fluxes) + + end subroutine lnd_import + + !=============================================================================== + + subroutine lnd_export( bounds, waterlnd2atmbulk_inst, lnd2atm_inst, lnd2glc_inst, l2x) + + !--------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Convert the data to be sent from the clm model to the coupler + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use seq_flds_mod , only : seq_flds_l2x_fields + use clm_varctl , only : iulog + use clm_time_manager , only : get_nstep + use seq_drydep_mod , only : n_drydep + use shr_megan_mod , only : shr_megan_mechcomps_n + use shr_fire_emis_mod , only : shr_fire_emis_mechcomps_n + use domainMod , only : ldomain + use shr_string_mod , only : shr_string_listGetName + use shr_infnan_mod , only : isnan => shr_infnan_isnan + ! + ! !ARGUMENTS: + implicit none + type(bounds_type) , intent(in) :: bounds ! bounds + type(lnd2atm_type), intent(inout) :: lnd2atm_inst ! clm land to atmosphere exchange data type + type(lnd2glc_type), intent(inout) :: lnd2glc_inst ! clm land to atmosphere exchange data type + type(waterlnd2atmbulk_type), intent(in) :: waterlnd2atmbulk_inst + real(r8) , intent(out) :: l2x(:,:)! land to coupler export state on land grid + ! + ! !LOCAL VARIABLES: + integer :: g,i,k ! indices + integer :: ier ! error status + integer :: nstep ! time step index + integer :: dtime ! time step + integer :: num ! counter + character(len=32) :: fname ! name of field that is NaN + character(len=32), parameter :: sub = 'lnd_export' + !--------------------------------------------------------------------------- + + ! cesm sign convention is that fluxes are positive downward + + l2x(:,:) = 0.0_r8 + + do g = bounds%begg,bounds%endg + i = 1 + (g-bounds%begg) + l2x(index_l2x_Sl_t,i) = lnd2atm_inst%t_rad_grc(g) + l2x(index_l2x_Sl_snowh,i) = waterlnd2atmbulk_inst%h2osno_grc(g) + l2x(index_l2x_Sl_avsdr,i) = lnd2atm_inst%albd_grc(g,1) + l2x(index_l2x_Sl_anidr,i) = lnd2atm_inst%albd_grc(g,2) + l2x(index_l2x_Sl_avsdf,i) = lnd2atm_inst%albi_grc(g,1) + l2x(index_l2x_Sl_anidf,i) = lnd2atm_inst%albi_grc(g,2) + l2x(index_l2x_Sl_tref,i) = lnd2atm_inst%t_ref2m_grc(g) + l2x(index_l2x_Sl_qref,i) = waterlnd2atmbulk_inst%q_ref2m_grc(g) + l2x(index_l2x_Sl_u10,i) = lnd2atm_inst%u_ref10m_grc(g) + l2x(index_l2x_Fall_taux,i) = -lnd2atm_inst%taux_grc(g) + l2x(index_l2x_Fall_tauy,i) = -lnd2atm_inst%tauy_grc(g) + l2x(index_l2x_Fall_lat,i) = -lnd2atm_inst%eflx_lh_tot_grc(g) + l2x(index_l2x_Fall_sen,i) = -lnd2atm_inst%eflx_sh_tot_grc(g) + l2x(index_l2x_Fall_lwup,i) = -lnd2atm_inst%eflx_lwrad_out_grc(g) + l2x(index_l2x_Fall_evap,i) = -waterlnd2atmbulk_inst%qflx_evap_tot_grc(g) + l2x(index_l2x_Fall_swnet,i) = lnd2atm_inst%fsa_grc(g) + if (index_l2x_Fall_fco2_lnd /= 0) then + l2x(index_l2x_Fall_fco2_lnd,i) = -lnd2atm_inst%net_carbon_exchange_grc(g) + end if + + ! Additional fields for DUST, PROGSSLT, dry-deposition and VOC + ! These are now standard fields, but the check on the index makes sure the driver handles them + if (index_l2x_Sl_ram1 /= 0 ) l2x(index_l2x_Sl_ram1,i) = lnd2atm_inst%ram1_grc(g) + if (index_l2x_Sl_fv /= 0 ) l2x(index_l2x_Sl_fv,i) = lnd2atm_inst%fv_grc(g) + if (index_l2x_Sl_soilw /= 0 ) l2x(index_l2x_Sl_soilw,i) = waterlnd2atmbulk_inst%h2osoi_vol_grc(g,1) + if (index_l2x_Fall_flxdst1 /= 0 ) l2x(index_l2x_Fall_flxdst1,i)= -lnd2atm_inst%flxdst_grc(g,1) + if (index_l2x_Fall_flxdst2 /= 0 ) l2x(index_l2x_Fall_flxdst2,i)= -lnd2atm_inst%flxdst_grc(g,2) + if (index_l2x_Fall_flxdst3 /= 0 ) l2x(index_l2x_Fall_flxdst3,i)= -lnd2atm_inst%flxdst_grc(g,3) + if (index_l2x_Fall_flxdst4 /= 0 ) l2x(index_l2x_Fall_flxdst4,i)= -lnd2atm_inst%flxdst_grc(g,4) + + + ! for dry dep velocities + if (index_l2x_Sl_ddvel /= 0 ) then + l2x(index_l2x_Sl_ddvel:index_l2x_Sl_ddvel+n_drydep-1,i) = & + lnd2atm_inst%ddvel_grc(g,:n_drydep) + end if + + ! for MEGAN VOC emis fluxes + if (index_l2x_Fall_flxvoc /= 0 ) then + l2x(index_l2x_Fall_flxvoc:index_l2x_Fall_flxvoc+shr_megan_mechcomps_n-1,i) = & + -lnd2atm_inst%flxvoc_grc(g,:shr_megan_mechcomps_n) + end if + + + ! for fire emis fluxes + if (index_l2x_Fall_flxfire /= 0 ) then + l2x(index_l2x_Fall_flxfire:index_l2x_Fall_flxfire+shr_fire_emis_mechcomps_n-1,i) = & + -lnd2atm_inst%fireflx_grc(g,:shr_fire_emis_mechcomps_n) + l2x(index_l2x_Sl_ztopfire,i) = lnd2atm_inst%fireztop_grc(g) + end if + + if (index_l2x_Fall_methane /= 0) then + l2x(index_l2x_Fall_methane,i) = -lnd2atm_inst%ch4_surf_flux_tot_grc(g) + endif + + ! sign convention is positive downward with + ! hierarchy of atm/glc/lnd/rof/ice/ocn. + ! I.e. water sent from land to rof is positive + + l2x(index_l2x_Flrl_rofsur,i) = waterlnd2atmbulk_inst%qflx_rofliq_qsur_grc(g) + + ! subsurface runoff is the sum of qflx_drain and qflx_perched_drain + l2x(index_l2x_Flrl_rofsub,i) = waterlnd2atmbulk_inst%qflx_rofliq_qsub_grc(g) & + + waterlnd2atmbulk_inst%qflx_rofliq_drain_perched_grc(g) + + ! qgwl sent individually to coupler + l2x(index_l2x_Flrl_rofgwl,i) = waterlnd2atmbulk_inst%qflx_rofliq_qgwl_grc(g) + + ! ice sent individually to coupler + l2x(index_l2x_Flrl_rofi,i) = waterlnd2atmbulk_inst%qflx_rofice_grc(g) + + ! irrigation flux to be removed from main channel storage (negative) + l2x(index_l2x_Flrl_irrig,i) = - waterlnd2atmbulk_inst%qirrig_grc(g) + + ! glc coupling + ! We could avoid setting these fields if glc_present is .false., if that would + ! help with performance. (The downside would be that we wouldn't have these fields + ! available for diagnostic purposes or to force a later T compset with dlnd.) + do num = 0,glc_nec + l2x(index_l2x_Sl_tsrf(num),i) = lnd2glc_inst%tsrf_grc(g,num) + l2x(index_l2x_Sl_topo(num),i) = lnd2glc_inst%topo_grc(g,num) + l2x(index_l2x_Flgl_qice(num),i) = lnd2glc_inst%qice_grc(g,num) + end do + + ! Check if any output sent to the coupler is NaN + if ( any(isnan(l2x(:,i))) )then + write(iulog,*) '# of NaNs = ', count(isnan(l2x(:,i))) + write(iulog,*) 'Which are NaNs = ', isnan(l2x(:,i)) + do k = 1, size(l2x(:,i)) + if ( isnan(l2x(k,i)) )then + call shr_string_listGetName( seq_flds_l2x_fields, k, fname ) + write(iulog,*) trim(fname) + end if + end do + write(iulog,*) 'gridcell index = ', g + call endrun( sub//' ERROR: One or more of the output from CLM to the coupler are NaN ' ) + end if + + end do + + end subroutine lnd_export + +end module lnd_import_export diff --git a/models/clm/readme.rst b/models/clm/readme.rst index 6c9fa0ab9a..c7914da266 100644 --- a/models/clm/readme.rst +++ b/models/clm/readme.rst @@ -9,7 +9,7 @@ Overview This is the DART interface to the `CESM2 Community Land Model. `__ -Specifically, CESM **release-cesm2.2.0** using CLM **release-cesm2.2.01** +Specifically, CESM **release-cesm2.2.0** using CTSM **release-cesm2.2.03** This document is most useful if the user has a prior understanding of running CESM and also running CLM-DART. For this reason **we strongly recommend the following @@ -41,7 +41,7 @@ changes to the CLM source code that are useful in a data assimilation context. CLM is a rapidly-moving target and DART is developed and maintained by a small group of people. Consequently, we have focused on supporting *released* versions of CLM. This documentation and scripting were tested using the CESM -tag **release-cesm2.2.0** and CLM tag **release-cesm2.2.01** following the download +tag **release-cesm2.2.0** and CTSM tag **release-cesm2.2.03** following the download instructions from https://github.com/ESCOMP/CESM . CLM-DART has been used to assimilate snow data, soil moisture, leaf area index, @@ -65,10 +65,10 @@ SourceMods ~~~~~~~~~~ While we strive to keep DART requirements out of the model code, there are a few -SourceMods needed to run DART for CLM from within CESM. Appropriate SourceMods -for each CESM version are available as tar files at -http://www.image.ucar.edu/pub/DART/CESM -They will create a directory with the appropriate SourceMods structure. +SourceMods needed to run DART for CLM from within CESM. +DART SourceMods for different versions of CESM are available as +part of the DART package at ${dartroot}/models/clm/DART_SourceMods/ +where dartroot is the location of your DART installation. It is up to you to either use them 'as is' or put them under version control in your CESM source code installation. The DART scripting allows you to specify a directory containing the SourceMods - and then copies those SourceMods to diff --git a/models/clm/shell_scripts/cesm2_2/CLM5_setup_assimilation b/models/clm/shell_scripts/cesm2_2/CLM5_setup_assimilation index 07bd145777..a41fef271f 100755 --- a/models/clm/shell_scripts/cesm2_2/CLM5_setup_assimilation +++ b/models/clm/shell_scripts/cesm2_2/CLM5_setup_assimilation @@ -42,15 +42,17 @@ endif # job settings: # # run_queue, run_time, st_archive_queue, st_archive_time may be changed at any time +# Derecho only has one 'main' queue, priority can be regular/economy/premium -setenv run_queue regular -setenv run_time 00:30:00 +setenv run_queue main +setenv run_priority premium +setenv run_time 01:00:00 # the short-term archiver is turned off (initially?) to let you explore the # run directory setenv short_term_archiver off -setenv st_archive_queue share +setenv st_archive_queue main setenv st_archive_time 06:00:00 # ============================================================================== @@ -179,7 +181,6 @@ endif # By computing task counts like we do below, we guarantee each instance uses # a whole number of nodes which is the recommended configuration. # CIME interprets a negative task count as representing the number of nodes. -# On Cheyenne (at least) using multiple threads is not recommended. @ nthreads = ${number_of_threads} @@ -204,6 +205,7 @@ endif ./xmlchange ROOTPE_ESP=0,NTHRDS_ESP=$nthreads,NTASKS_ESP=$esp_tasks ./xmlchange --subgroup case.run --id JOB_QUEUE --val ${run_queue} +./xmlchange JOB_PRIORITY=${run_priority} ./xmlchange --subgroup case.run --id JOB_WALLCLOCK_TIME --val ${run_time} echo "setting up the case ... " @@ -230,12 +232,20 @@ endif ./xmlchange INFO_DBUG=0 # ============================================================================== -# Use the stream template that has all CAM reanalysis years available. - +# If the experiment only spans one year, copy a stream template for a single year +# otherwise, use 'all' the years. + +if (${stream_year_first} == ${stream_year_last}) then + set STREAMFILE_SOLAR = datm.streams.txt.CPLHISTForcing.Solar_single_year + set STREAMFILE_STATE1HR = datm.streams.txt.CPLHISTForcing.State1hr_single_year + set STREAMFILE_STATE3HR = datm.streams.txt.CPLHISTForcing.State3hr_single_year + set STREAMFILE_NONSOLARFLUX = datm.streams.txt.CPLHISTForcing.nonSolarFlux_single_year +else set STREAMFILE_SOLAR = datm.streams.txt.CPLHISTForcing.Solar_complete set STREAMFILE_STATE1HR = datm.streams.txt.CPLHISTForcing.State1hr_complete set STREAMFILE_STATE3HR = datm.streams.txt.CPLHISTForcing.State3hr_complete set STREAMFILE_NONSOLARFLUX = datm.streams.txt.CPLHISTForcing.nonSolarFlux_complete +endif # ============================================================================== # Modify namelist templates for each instance. @@ -259,7 +269,7 @@ while ( $inst <= $num_instances ) set FILE2 = datm.streams.txt.CPLHISTForcing.State1hr_${inst_string} set FILE3 = datm.streams.txt.CPLHISTForcing.State3hr_${inst_string} set FILE4 = datm.streams.txt.CPLHISTForcing.nonSolarFlux_${inst_string} - set DOMAINFILE = '/glade/p/cesmdata/cseg/inputdata/share/domains/domain.lnd.fv0.9x1.25_gx1v7.151020.nc' + set DOMAINFILE = '/glade/campaign/cesm/cesmdata/cseg/inputdata/share/domains/domain.lnd.fv0.9x1.25_gx1v7.151020.nc' echo "domainfile = '${DOMAINFILE}'" >> ${fname} echo "streams = '$FILE1 $stream_year_align $stream_year_first $stream_year_last'," >> ${fname} @@ -635,13 +645,16 @@ if ( ${use_SourceMods} == TRUE ) then else echo "ERROR - DART_params.csh use_SourceMods = ${use_SourceMods}" echo "ERROR - but there are no SourceMods in ${SourceModDir}" - echo " See discussion in DART_params.csh for information on" - echo " where to get a tar file of SourceMods for DART." exit 7 endif endif -${BUILD_WRAPPER} ./case.build || exit 9 +# Derecho should be able to handle the CESM build step through a login node +# If your platform has restrictions on computational load consider submitting +# as a batch job (e.q. qsub) + + +./case.build || exit 9 # ============================================================================== # What to do next diff --git a/models/clm/shell_scripts/cesm2_2/DART_params.csh b/models/clm/shell_scripts/cesm2_2/DART_params.csh index c36aab3ace..54feff81af 100755 --- a/models/clm/shell_scripts/cesm2_2/DART_params.csh +++ b/models/clm/shell_scripts/cesm2_2/DART_params.csh @@ -41,9 +41,9 @@ else endif # ============================================================================== -# SourceMods for different versions of CESM are available at -# http://www.image.ucar.edu/pub/DART/CESM. Download the tar file that matches -# your CESM version and install the sourcefiles. +# DART SourceMods for different versions of CESM are available as +# part of the DART package at ${dartroot}/models/clm/DART_SourceMods/ +# where dartroot is the location of your DART installation # # SourceMods may be handled in one of two ways. If you have your own GIT clone of # the repository, you may simply commit your changes to your GIT repo and @@ -74,9 +74,10 @@ endif # Normally, only 'PARVEGLN' is output. # # biogeophys/CanopyFluxesMod.F90,PhotosynthesisMod.F90 calculate SIF - +# +setenv dartroot /glade/work/${USER}/DART setenv use_SourceMods TRUE -setenv SourceModDir ~/SourceMods_release-cesm2.2.01/SourceMods +setenv SourceModDir ${dartroot}/DART_SourceMods/cesm2_2_0/SourceMods # ============================================================================== # Directories: @@ -98,27 +99,25 @@ setenv SourceModDir ~/SourceMods_release-cesm2.2.01/SourceMods # not be on a scratch partition unless the long-term archiver is # invoked to move these files to permanent storage. -setenv cesmdata /glade/p/cesmdata/cseg/inputdata +setenv cesmdata /glade/campaign/cesm/cesmdata/cseg/inputdata setenv cesmroot /glade/work/${USER}/CESM/${cesmtag} setenv caseroot /glade/work/${USER}/cases/${cesmtag}/${CASE} -setenv cime_output_root /glade/scratch/${USER}/${cesmtag}/${CASE} +setenv cime_output_root /glade/derecho/scratch/${USER}/${cesmtag}/${CASE} setenv rundir ${cime_output_root}/run setenv exeroot ${cime_output_root}/bld setenv archdir ${cime_output_root}/archive # ============================================================================== # Set the variables needed for the DART configuration. -# dartroot Location of the root of _your_ DART installation # baseobsdir Part of the directory name containing the observation sequence # files to be used in the assimilation. The observations are presumed # to be stored in sub-directories with names built from the year and # month. 'baseobsdir' will be inserted into the appropriate scripts. # ============================================================================== -setenv dartroot /glade/work/${USER}/git/DART_public -setenv baseobsdir /glade/p/cisl/dares/Observations/land -setenv pmo_input_baseobsdir /glade/p/cisl/dares/Observations/land/pmo/input -setenv pmo_output_baseobsdir /glade/p/cisl/dares/Observations/land/pmo/output +setenv baseobsdir /glade/campaign/cisl/dares/glade-p-dares-Oct2023/Observations/land +setenv pmo_input_baseobsdir /glade/campaign/cisl/dares/glade-p-dares-Oct2023/Observations/land/pmo/input +setenv pmo_output_baseobsdir /glade/campaign/cisl/dares/glade-p-dares-Oct2023/Observations/land/pmo/output # ============================================================================== # configure settings: @@ -142,7 +141,7 @@ setenv reftod 00000 setenv refdate ${refyear}-${refmon}-${refday} setenv reftimestamp ${refyear}-${refmon}-${refday}-${reftod} -setenv stagedir /glade/p/cisl/dares/RDA_strawman/CESM_ensembles/CLM/CLM5BGC-Crop/ctsm_${reftimestamp} +setenv stagedir /glade/campaign/cisl/dares/glade-p-dares-Oct2023/RDA_strawman/CESM_ensembles/CLM/CLM5BGC-Crop/ctsm_${reftimestamp} # In a hybrid configuration, you can set the startdate to whatever you want. # It does not have to match the reference (although changing the month/day seems bad). @@ -190,18 +189,13 @@ setenv resubmit 0 setenv stream_year_align 2011 setenv stream_year_first 2011 -setenv stream_year_last 2019 +setenv stream_year_last 2020 # ============================================================================== # machine-specific commands: setenv project P86850054 -setenv machine cheyenne - -# The CESM compile step takes enough resource that Cheyenne requires a wrapper -# If your platform does not have this restriction, set BUILD_WRAPPER to '' -# setenv BUILD_WRAPPER '' -setenv BUILD_WRAPPER "qcmd -q share -l select=1 -A $project --" +setenv machine derecho setenv nodes_per_instance 2 setenv number_of_threads 1 diff --git a/models/clm/shell_scripts/cesm2_2/assimilate.csh b/models/clm/shell_scripts/cesm2_2/assimilate.csh index 7bd93aa75a..e5863303a1 100755 --- a/models/clm/shell_scripts/cesm2_2/assimilate.csh +++ b/models/clm/shell_scripts/cesm2_2/assimilate.csh @@ -45,7 +45,7 @@ setenv DATA_ASSIMILATION_CYCLES `./xmlquery DATA_ASSIMILATION_CYCLES --value` setenv TASKS_PER_NODE `./xmlquery MAX_TASKS_PER_NODE --value` # Most of this syntax can be determined from CASEROOT ./preview_run -setenv MPI_RUN_COMMAND "mpiexec_mpt -np $TOTALPES omplace -tm open64" +setenv MPI_RUN_COMMAND "mpiexec -n $TOTALPES" cd ${RUNDIR} diff --git a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.Solar_complete b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.Solar_complete index ef4e9d80b7..49d21c5121 100644 --- a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.Solar_complete +++ b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.Solar_complete @@ -4,22 +4,22 @@ Two CAM-DART Ensemble Reanalysis efforts have been completed and provide DATM forcing files particularly appropriate for CESM experiments. - NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 + NSF NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 Spans 1998_01-2010_12 at 1.875x2.5 degrees resolution every 6 hours a2x6h_Faxa_swndr long_name = "Direct near-infrared incident solar radiation" ; a2x6h_Faxa_swvdr long_name = "Direct visible incident solar radiation" ; a2x6h_Faxa_swndf long_name = "Diffuse near-infrared incident solar radiation" ; a2x6h_Faxa_swvdf long_name = "Diffuse visible incident solar radiation" ; - NCAR RDA ds345.0 | DOI: 10.5065/JG1E-8525 + NSF NCAR RDA ds345.0 | DOI: 10.5065/JG1E-8525 Spans 2010_07-2019_12 at 0.9x1.25 degree resolution a2x1hi_Faxa_swndr long_name = "Direct near-infrared incident solar radiation" ; a2x1hi_Faxa_swvdr long_name = "Direct visible incident solar radiation" ; a2x1hi_Faxa_swndf long_name = "Diffuse near-infrared incident solar radiation" ; a2x1hi_Faxa_swvdf long_name = "Diffuse visible incident solar radiation" ; - The RDA collections are on spinning disk at NCAR: - /glade/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc + The NSF NCAR RDA collections are located: + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc @@ -39,7 +39,7 @@ doma_mask mask - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x1hi.2011.nc @@ -53,7 +53,7 @@ a2x1hi_Faxa_swvdf swvdf - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST 1800 @@ -68,6 +68,7 @@ f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x1hi.2017.nc f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x1hi.2018.nc f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x1hi.2019.nc + f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x1hi.2020.nc diff --git a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.Solar_single_year b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.Solar_single_year index 7f00a786a3..a295b392d3 100644 --- a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.Solar_single_year +++ b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.Solar_single_year @@ -4,22 +4,22 @@ Two CAM-DART Ensemble Reanalysis efforts have been completed and provide DATM forcing files particularly appropriate for CESM experiments. - NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 + NSF NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 Spans 1998_01-2010_12 at 1.875x2.5 degrees resolution every 6 hours a2x6h_Faxa_swndr long_name = "Direct near-infrared incident solar radiation" ; a2x6h_Faxa_swvdr long_name = "Direct visible incident solar radiation" ; a2x6h_Faxa_swndf long_name = "Diffuse near-infrared incident solar radiation" ; a2x6h_Faxa_swvdf long_name = "Diffuse visible incident solar radiation" ; - NCAR RDA ds345.0 | DOI: 10.5065/JG1E-8525 + NSF NCAR RDA ds345.0 | DOI: 10.5065/JG1E-8525 Spans 2010_07-2019_12 at 0.9x1.25 degree resolution a2x1hi_Faxa_swndr long_name = "Direct near-infrared incident solar radiation" ; a2x1hi_Faxa_swvdr long_name = "Direct visible incident solar radiation" ; a2x1hi_Faxa_swndf long_name = "Diffuse near-infrared incident solar radiation" ; a2x1hi_Faxa_swvdf long_name = "Diffuse visible incident solar radiation" ; - The RDA collections are on spinning disk at NCAR: - /glade/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc + The NSF NCAR RDA collections are located: + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc @@ -39,7 +39,7 @@ doma_mask mask - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x1hi.RUNYEAR.nc @@ -53,7 +53,7 @@ a2x1hi_Faxa_swvdf swvdf - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST 1800 diff --git a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State1hr_complete b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State1hr_complete index 322a04671e..ddf2f29f0e 100644 --- a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State1hr_complete +++ b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State1hr_complete @@ -4,18 +4,18 @@ Two CAM-DART Ensemble Reanalysis efforts have been completed and provide DATM forcing files particularly appropriate for CESM experiments. - NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 + NSF NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 Spans 1998_01-2010_12 at 1.875x2.5 degrees resolution every 6 hours a2x6h_Sa_u long_name = "Zonal wind at the lowest model level" ; a2x6h_Sa_v long_name = "Meridional wind at the lowest model level" ; - NCAR RDA ds345.0 | DOI: 10.5065/JG1E-8525 + NSF NCAR RDA ds345.0 | DOI: 10.5065/JG1E-8525 Spans 2010_07-2019_12 at 0.9x1.25 degree resolution every hour a2x1h_Sa_u long_name = "Zonal wind at the lowest model level" ; a2x1h_Sa_v long_name = "Meridional wind at the lowest model level" ; - The RDA collections are on spinning disk at NCAR: - /glade/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc + The NSF NCAR RDA collections are located: + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc @@ -35,7 +35,7 @@ doma_mask mask - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x1h.2011.nc @@ -47,7 +47,7 @@ a2x1h_Sa_v v - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST linear @@ -65,6 +65,7 @@ f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x1h.2017.nc f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x1h.2018.nc f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x1h.2019.nc + f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x1h.2020.nc diff --git a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State1hr_single_year b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State1hr_single_year index e3d8ccbf9c..a1e6821a42 100644 --- a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State1hr_single_year +++ b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State1hr_single_year @@ -4,18 +4,18 @@ Two CAM-DART Ensemble Reanalysis efforts have been completed and provide DATM forcing files particularly appropriate for CESM experiments. - NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 + NSF NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 Spans 1998_01-2010_12 at 1.875x2.5 degrees resolution every 6 hours a2x6h_Sa_u long_name = "Zonal wind at the lowest model level" ; a2x6h_Sa_v long_name = "Meridional wind at the lowest model level" ; - NCAR RDA ds345.0 | DOI: 10.5065/JG1E-8525 + NSF NCAR RDA ds345.0 | DOI: 10.5065/JG1E-8525 Spans 2010_07-2019_12 at 0.9x1.25 degree resolution every hour a2x1h_Sa_u long_name = "Zonal wind at the lowest model level" ; a2x1h_Sa_v long_name = "Meridional wind at the lowest model level" ; - The RDA collections are on spinning disk at NCAR: - /glade/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc + The NSF NCAR RDA collections are located: + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc @@ -35,7 +35,7 @@ doma_mask mask - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x1h.RUNYEAR.nc @@ -47,7 +47,7 @@ a2x1h_Sa_v v - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST linear diff --git a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State3hr_complete b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State3hr_complete index ec20800948..5d5adc4a94 100644 --- a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State3hr_complete +++ b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State3hr_complete @@ -4,7 +4,7 @@ Two CAM-DART Ensemble Reanalysis efforts have been completed and provide DATM forcing files particularly appropriate for CESM experiments. - NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 + NSF NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 Spans 1998_01-2010_12 at 1.875x2.5 degrees resolution every 6 hours a2x6h_Sa_z long_name = "Height at the lowest model level" ; a2x6h_Sa_tbot long_name = "Temperature at the lowest model level" ; @@ -15,7 +15,7 @@ a2x6h_Sa_dens long_name = "Density at the lowest model level" ; a2x6h_Sa_pslv long_name = "Sea level pressure" ; - NCAR RDA ds345.0 + NSF NCAR RDA ds345.0 Spans 2010_07-2019_12 at 0.9x1.25 degree resolution every 3 hours a2x3h_Sa_z long_name = "Height at the lowest model level" ; a2x3h_Sa_tbot long_name = "Temperature at the lowest model level" ; @@ -26,8 +26,8 @@ a2x3h_Sa_dens long_name = "Density at the lowest model level" ; a2x3h_Sa_pslv long_name = "Sea level pressure" ; - The RDA collections are on spinning disk at NCAR: - /glade/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc + The NSF NCAR RDA collections are located: + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc @@ -47,7 +47,7 @@ doma_mask mask - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x3h.2011.nc @@ -65,7 +65,7 @@ a2x3h_Sa_pslv pslv - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST linear @@ -83,6 +83,7 @@ f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x3h.2017.nc f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x3h.2018.nc f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x3h.2019.nc + f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x3h.2020.nc diff --git a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State3hr_single_year b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State3hr_single_year index 50f43ed08b..77e6c48090 100644 --- a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State3hr_single_year +++ b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.State3hr_single_year @@ -4,7 +4,7 @@ Two CAM-DART Ensemble Reanalysis efforts have been completed and provide DATM forcing files particularly appropriate for CESM experiments. - NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 + NSF NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 Spans 1998_01-2010_12 at 1.875x2.5 degrees resolution every 6 hours a2x6h_Sa_z long_name = "Height at the lowest model level" ; a2x6h_Sa_tbot long_name = "Temperature at the lowest model level" ; @@ -15,7 +15,7 @@ a2x6h_Sa_dens long_name = "Density at the lowest model level" ; a2x6h_Sa_pslv long_name = "Sea level pressure" ; - NCAR RDA ds345.0 + NSF NCAR RDA ds345.0 Spans 2010_07-2019_12 at 0.9x1.25 degree resolution every 3 hours a2x3h_Sa_z long_name = "Height at the lowest model level" ; a2x3h_Sa_tbot long_name = "Temperature at the lowest model level" ; @@ -26,8 +26,8 @@ a2x3h_Sa_dens long_name = "Density at the lowest model level" ; a2x3h_Sa_pslv long_name = "Sea level pressure" ; - The RDA collections are on spinning disk at NCAR: - /glade/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc + The NSF NCAR RDA collections are located: + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc @@ -47,7 +47,7 @@ doma_mask mask - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x3h.RUNYEAR.nc @@ -65,7 +65,7 @@ a2x3h_Sa_pslv pslv - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST linear diff --git a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.nonSolarFlux_complete b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.nonSolarFlux_complete index dfa9c2a7e4..f1639d7623 100644 --- a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.nonSolarFlux_complete +++ b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.nonSolarFlux_complete @@ -4,7 +4,7 @@ Two CAM-DART Ensemble Reanalysis efforts have been completed and provide DATM forcing files particularly appropriate for CESM experiments. - NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 + NSF NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 Spans 1998_01-2010_12 at 1.875x2.5 degrees resolution every 6 hours a2x6h_Faxa_rainc long_name = "Convective precipitation rate" ; a2x6h_Faxa_rainl long_name = "Large-scale (stable) precipitation rate" ; @@ -12,7 +12,7 @@ a2x6h_Faxa_snowl long_name = "Large-scale (stable) snow rate (water equivalent)" ; a2x6h_Faxa_lwdn long_name = "Downward longwave heat flux" ; - NCAR RDA ds345.0 | DOI: 10.5065/JG1E-8525 + NSF NCAR RDA ds345.0 | DOI: 10.5065/JG1E-8525 Spans 2010_07-2019_12 at 0.9x1.25 degree resolution a2x3h_Faxa_rainc long_name = "Convective precipitation rate" ; a2x3h_Faxa_rainl long_name = "Large-scale (stable) precipitation rate" ; @@ -20,8 +20,8 @@ a2x3h_Faxa_snowl long_name = "Large-scale (stable) snow rate (water equivalent)" ; a2x3h_Faxa_lwdn long_name = "Downward longwave heat flux" ; - The RDA collections are on spinning disk at NCAR: - /glade/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc + The NSF NCAR RDA collections are located: + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc @@ -41,7 +41,7 @@ doma_mask mask - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x3h.2011.nc @@ -56,7 +56,7 @@ a2x3h_Faxa_lwdn lwdn - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST 1800 @@ -71,6 +71,7 @@ f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x3h.2017.nc f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x3h.2018.nc f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x3h.2019.nc + f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x3h.2020.nc diff --git a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.nonSolarFlux_single_year b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.nonSolarFlux_single_year index 96fda03eda..69fc479604 100644 --- a/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.nonSolarFlux_single_year +++ b/models/clm/shell_scripts/cesm2_2/datm.streams.txt.CPLHISTForcing.nonSolarFlux_single_year @@ -4,7 +4,7 @@ Two CAM-DART Ensemble Reanalysis efforts have been completed and provide DATM forcing files particularly appropriate for CESM experiments. - NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 + NSF NCAR RDA ds199.1 | DOI: 10.5065/38ED-RZ08 Spans 1998_01-2010_12 at 1.875x2.5 degrees resolution every 6 hours a2x6h_Faxa_rainc long_name = "Convective precipitation rate" ; a2x6h_Faxa_rainl long_name = "Large-scale (stable) precipitation rate" ; @@ -12,7 +12,7 @@ a2x6h_Faxa_snowl long_name = "Large-scale (stable) snow rate (water equivalent)" ; a2x6h_Faxa_lwdn long_name = "Downward longwave heat flux" ; - NCAR RDA ds345.0 | DOI: 10.5065/JG1E-8525 + NSF NCAR RDA ds345.0 | DOI: 10.5065/JG1E-8525 Spans 2010_07-2019_12 at 0.9x1.25 degree resolution a2x3h_Faxa_rainc long_name = "Convective precipitation rate" ; a2x3h_Faxa_rainl long_name = "Large-scale (stable) precipitation rate" ; @@ -20,8 +20,8 @@ a2x3h_Faxa_snowl long_name = "Large-scale (stable) snow rate (water equivalent)" ; a2x3h_Faxa_lwdn long_name = "Downward longwave heat flux" ; - The RDA collections are on spinning disk at NCAR: - /glade/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc + The NSF NCAR RDA collections are located: + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/----/{CASENAME}.cpl_----.ha2x*.YYYY.nc @@ -41,7 +41,7 @@ doma_mask mask - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x3h.RUNYEAR.nc @@ -56,7 +56,7 @@ a2x3h_Faxa_lwdn lwdn - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST 1800 diff --git a/models/clm/tutorial/README.rst b/models/clm/tutorial/README.rst index 08d6c4570e..1de8491135 100644 --- a/models/clm/tutorial/README.rst +++ b/models/clm/tutorial/README.rst @@ -14,10 +14,12 @@ with the concepts of CLM5-DART in order to design an assimilation for their own research interests. This tutorial was assembled to be compatible with CLM5.0.34 as part -of CESM (release-cesm2.2.01) and the latest release on the ``main`` branch of the +of CESM (release-cesm2.2.01) or CTSM (release-cesm2.2.03) and the latest release on the ``main`` branch of the the `DART repository. `__ Other combinations of CLM and DART (prior to DART version 9.13.0) may not be compatible -with this tutorial. +with this tutorial. Currently, only the CTSM (release-cesm2.2.03) is fully compatible with Derecho. +If you are using other tags you may need to modify the external scripting to be compatible +with Derecho. It is not recommended to use this tutorial without prior experience @@ -115,7 +117,7 @@ custom initial conditions and observation sequence files for your own work. .. Important :: We have provided tutorial instructions for the NSF NCAR - supercomputer Cheyenne, however, if using your own machine you will need to + supercomputer Derecho, however, if using your own machine you will need to customize the setup scripts in order to properly compile DART (see Step 4: Compiling DART). These system-specific setup steps may take a good deal of effort, especially if you are unfamiliar with details such as compilers, MPI, @@ -126,7 +128,7 @@ custom initial conditions and observation sequence files for your own work. Other required files to run the tutorial include the meteorology (Step 5), reference case (Step 6), and observation files (Step 7). These are all readily available - if you are using Cheyenne. If you are using your own machine you need + if you are using Derecho. If you are using your own machine you need use the following links to download these files directly: 1. `CAM6 Reanalysis Meteorology `__, @@ -148,17 +150,18 @@ consisting of both NSF NCAR and university scientists and researchers. In contrast, DART is maintained by a relatively small group that supports numerous earth system models (20+) including CLM. Therefore the DART team focuses on only supporting official released versions of CLM. This documentation -and scripting was tested using the CESM tag ``release-cesm2.2.0`` following +and scripting was tested using the CESM tag ``release-cesm2.2.0`` and +``release-cesm2.2.03`` following the download instructions `here `__. Although the DART code may work with more recent versions of CESM (CLM) we recommend -checking out ``release-cesm2.2.0``. +checking out ``release-cesm2.2.03`` which is compatible with both DART and Derecho :: - git clone https://github.com/escomp/cesm.git cesm_dart + git clone https://github.com/ESCOMP/CTSM.git cesm_dart cd cesm_dart - git checkout release-cesm2.2.0 + git checkout release-cesm2.2.03 ./manage_externals/checkout_externals @@ -171,14 +174,8 @@ balance checks in CLM5 for the time step immediately after the assimilation update step. These sourcecode modifications are brought in through the SourceMod mechanism in CLM where modifications overwrite the template sourcecode during the compilation step. The SourceMods -are located as tar files `here. `__ -For this tutorial retrieve the most recent tar file ``DART_SourceMods_cesm2_2_0_2021_07_02.tar`` -and untar it on your local machine as: +are included within the DART package which is downloaded in Step 2. -:: - - wget https://www.image.ucar.edu/pub/DART/CESM/DART_SourceMods_cesm2_2_0_2021_07_02.tar - tar -xvf DART_SourceMods_cesm2_2_0_2021_07_02.tar For more information on the SourceMods see the main :doc:`CLM-DART documentation. <../readme>` @@ -186,7 +183,7 @@ SourceMods see the main :doc:`CLM-DART documentation. <../readme>` Compiling CLM5 -------------- -Compiling CLM5 on the NSF NCAR machine Cheyenne is straightforward because the +Compiling CLM5 on the NSF NCAR machine Derecho is straightforward because the run and build environment settings are already defined within the ``config_machines.xml`` file located within the CESM installation: ``/cime/config/cesm/machines``. If you are using your own machine please follow the porting instructions located @@ -208,8 +205,6 @@ DART repository on the `main branch `__. cd DART - - Step 3: Navigating DART Scripts ------------------------------- @@ -270,20 +265,20 @@ Step 4: Compiling DART Similar to CLM, it is necessary to compile the DART code before an assimilation can be performed. The DART code includes a variety of build template scripts that provide the appropriate compiler and library settings depending upon your system environment. -This is an example of the default system environment for Cheyenne (e.g. ``module list``), +This is an example of the system environment for Derecho (e.g. ``module list``), which was used to perform this tutorial: :: Currently Loaded Modules: - 1) ncarenv/1.3 2) intel/19.0.5 3) ncarcompilers/0.5.0 4) mpt/2.22 5) netcdf/4.7.4 + 1) ncarenv/23.06 (S) 2) intel/19.0.5 3) ncarcompilers/1.0.0 4) hdf5/1.12.2 5) netcdf/4.9.2 Please note in this example we used the ``intel`` fortran compiler with ``netcdf`` libraries to support the netcdf file format and the ``mpt`` libraries to support the ``mpi`` tasks. Below are instructions on how to modify the DART template script ``mkmf_template`` -to properly compile DART on Cheyenne: +to properly compile DART on Derecho: :: @@ -379,9 +374,9 @@ and 2011-2020 `ds345.0 `__. For this tutorial we will use the January 2011 CAM6 reanalysis (ds345.0) only. To make sure the scripts can locate the weather data first make sure the ``DART_params.csh`` variable ``dartroot`` is set to the path of your -DART installation. For example, if you have a Cheyenne account and you +DART installation. For example, if you have a Derecho account and you followed the DART cloning instructions in Step 2 above your ``dartroot`` -variable will be: ``//DART``. Make sure you update +variable will be: ``//DART``. Make sure you update the default ``dartroot`` as shown below. :: @@ -427,7 +422,7 @@ and ``State3hr``. doma_mask mask - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST f.e21.FHIST_BGC.f09_025.CAM6assim.011.cpl_NINST.ha2x3h.RUNYEAR.nc @@ -445,7 +440,7 @@ and ``State3hr``. a2x3h_Faxa_lwdn lwdn - /glade/collections/rda/data/ds345.0/cpl_unzipped/NINST + /glade/campaign/collections/rda/data/ds345.0/cpl_unzipped/NINST 1800 @@ -539,7 +534,7 @@ ensemble spinup (at time 1-1-2011) are used as the initial conditions for the as setenv reftod 00000 ... ... - setenv stagedir /glade/p/cisl/dares/RDA_strawman/CESM_ensembles/CLM/CLM5BGC-Crop/ctsm_${reftimestamp} + setenv stagedir /glade/campaign/cisl/dares/glade-p-dares-Oct2023/RDA_strawman/CESM_ensembles/CLM/CLM5BGC-Crop/ctsm_${reftimestamp} ... ... setenv start_year 2011 @@ -576,11 +571,11 @@ assimilation through an observation sequence file whose format is described First confirm that the ``baseobsdir`` variable within ``DART_params.csh`` is pointed to the directory where the observation sequence files are -located. In Cheyenne they are located in the directory as: +located. In Derecho they are located in the directory as: :: - setenv baseobsdir /glade/p/cisl/dares/Observations/land + setenv baseobsdir /glade/campaign/cisl/dares/glade-p-dares-Oct2023/Observations/land In this tutorial we have several observation types that are to be assimilated, including ``SOIL_TEMPERATURE``, ``MODIS_SNOWCOVER_FRAC``, @@ -1201,21 +1196,21 @@ environment, especially ``cesmroot``, ``caseroot``, ``cime_output_root``, :: - setenv cesmdata /glade/p/cesmdata/cseg/inputdata + setenv cesmdata /glade/campaign/cesmdata/cseg/inputdata setenv cesmroot /glade/work/${USER}/CESM/${cesmtag} setenv caseroot /glade/work/${USER}/cases/${cesmtag}/${CASE} - setenv cime_output_root /glade/scratch/${USER}/${cesmtag}/${CASE} + setenv cime_output_root /glade/derecho/scratch/${USER}/${cesmtag}/${CASE} setenv rundir ${cime_output_root}/run setenv exeroot ${cime_output_root}/bld setenv archdir ${cime_output_root}/archive .. .. - setenv dartroot /glade/work/${USER}/git/DART_public - setenv baseobsdir /glade/p/cisl/dares/Observations/land + setenv dartroot /glade/work/${USER}/DART + setenv baseobsdir /glade/campaign/cisl/dares/glade-p-dares-Oct2023/Observations/land .. .. setenv project - setenv machine cheyenne + setenv machine derecho @@ -1235,9 +1230,6 @@ It takes approximately 7-10 minutes for the script to create the assimilation ca which includes compiling the CESM executable. The script is submitted to a login node where it performs low-intensive tasks including the execution of ``case_setup``, and ``preview_namelist`` and stages the appropriate files in the ``rundir``. -However, compiling CESM is more resource intensive, thus the ``case_build`` command is -automatically submitted using ``qcmd`` which starts a non-interactive job on a single -batch node in the Cheyenne "regular" queue for a default time of 1 hour. .. Caution:: @@ -1321,7 +1313,7 @@ the assimilation run: > cd > ./case.submit -Check the status of the job on Cheyenne using PBS commands to determine if job +Check the status of the job on Derecho using PBS commands to determine if job is queued (Q), running (R) or completed. :: @@ -1365,7 +1357,7 @@ of the file with ``case.run success`` at the end: 2022-01-14 14:21:11: case.submit starting --------------------------------------------------- - 2022-01-14 14:21:18: case.submit success case.run:2465146.chadmin1.ib0.cheyenne.ucar.edu + 2022-01-14 14:21:18: case.submit success case.run:2684631.desched1 --------------------------------------------------- 2022-01-14 14:21:28: case.run starting --------------------------------------------------- @@ -1388,16 +1380,16 @@ will look like this: 2022-01-14 14:24:58: model execution starting --------------------------------------------------- 2022-01-14 14:25:08: model execution error - ERROR: Command: 'mpiexec_mpt -p "%g:" -np 360 omplace -tm open64 - /glade/scratch/bmraczka/cesm2.2.0/clm5_SWE0_MissingVal/bld/cesm.exe + ERROR: Command: 'mpiexec -p "%g:" + /glade/derecho/scratch/bmraczka/ctsm_cesm2.2.03/clm5_assim_e5/bld/cesm.exe >> cesm.log.$LID 2>&1 ' failed with error '' from dir - '/glade/scratch/bmraczka/cesm2.2.0/clm5_SWE0_MissingVal/run' + '/glade/derecho/scratch/bmraczka/ctsm_cesm2.2.03/clm5_assim_e5/run' --------------------------------------------------- 2022-01-14 14:25:08: case.run error - ERROR: RUN FAIL: Command 'mpiexec_mpt -p "%g:" -np 360 omplace -tm open64 - /glade/scratch/bmraczka/cesm2.2.0/clm5_SWE0_MissingVal/bld/cesm.exe >> + ERROR: RUN FAIL: Command 'mpiexec -p "%g:" + /glade/derecho/scratch/bmraczka/ctsm_cesm2.2.03/clm5_assim_e5/bld/cesm.exe >> cesm.log.$LID 2>&1 ' failed See log file for details: - /glade/scratch/bmraczka/cesm2.2.0/clm5_SWE0_MissingVal/run/cesm.log.2465146.chadmin1.ib0.cheyenne.ucar.edu.220114-142457 + /glade/derecho/scratch/bmraczka/ctsm_cesm2.2.03/clm5_assim_e5/run/cesm.log.2684631.desched1.231222-142931 If the case ran successfully proceed to the next step in the tutorial, **but if the case did not run successfully** locate the log file details which describe @@ -1647,7 +1639,7 @@ and the ``obsname`` variable are customizable. .. Tip:: - When remotley logged into Cheyenne there is a time delay when the Matlab figures are rendering, + When remotely logged into Derecho there is a time delay when the Matlab figures are rendering, and also when interacting with the figures. For the purposes of this tutorial this delay is minimal. However, to improve responsiveness for your own research you may find it convenient to port your diagnostic files (e.g. obs_diag_output.nc) and run the Matlab diagnostics