From 27bd39be2bd6f84fef7c865f3af45d334a89b303 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 22 Jan 2015 15:55:45 -0700 Subject: [PATCH 0001/1724] Created a new module for output of land ice statistics The new module is called li_statistics, in file mpas_li_statistics.F. It is based on the glide_diagnostics module in CISM. At time intervals specified by the user, various global statistics are written to the standard output log file. These statistics include the total ice area, volume and internal energy, along with the max/min values of various state variables (thickness, temperature, velocity) and the cells/edges/levels where these max/mins reside. In addition, the user can write diagnostic output for a single grid cell specified in the config file. This output includes cell thickness, bed topography, SMB, etc., along with vertical profiles of temperature and normal velocity at each sigma level. To support these diagnostics, I modified the broadcast routines and added some new minloc/maxloc subroutines in ../framework/mpas_dmpar.F. Since these changes are in the framework, I included them in a previous commit of branch framework/dmpar_bcast_maxloc. This statistics branch was checked out from that framework branch. In the Registry I added several config variables: config_ice_specific_heat (used in energy diagnostics) config_seconds_per_year (used for unit conversions in diagnostics) config_stats_interval (time interval for writing statistics, in number of timesteps; the default is 0, in which case no stats are written) config_write_stats_on_startup (if true, write stats on startup) In addition, I added two 2D state variables to the Registry: surfaceTemperature = upper ice surface temperature basalTemperature = lower ice surface temperature Previously the temperature was defined only at layer midpoints, in the tracer array. Note that the surface and basal temperatures are not tracers (they are not advected and are not associated with any internal energy). This treatment is different from CISM, in which surface and basal temperature are part of the 3D temperature array. I modified subroutine mpas_core_run to call subroutine li_compute_statistics at startup (if desired) and at the designated timestep interval. I also modified the Makefile to build the new statistics module. I verified that statistics are written out at the desired interval in the desired text format, which is similar to that of CISM log files and hopefully is easy to read. I also verified that the answers are the same (within roundoff) for 1, 2 or 4 processors on a Mac. This confirms that the various global reductions are working as intended. --- src/core_landice/Makefile | 6 + src/core_landice/Registry.xml | 34 +- src/core_landice/mpas_li_mpas_core.F | 67 +-- src/core_landice/mpas_li_statistics.F | 826 ++++++++++++++++++++++++++ 4 files changed, 882 insertions(+), 51 deletions(-) create mode 100644 src/core_landice/mpas_li_statistics.F diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index 5ba19beaae..bead875257 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -6,6 +6,7 @@ OBJS = mpas_li_mpas_core.o \ mpas_li_diagnostic_vars.o \ mpas_li_tendency.o \ mpas_li_setup.o \ + mpas_li_statistics.o \ mpas_li_velocity.o \ mpas_li_sia.o \ mpas_li_mask.o @@ -22,6 +23,7 @@ mpas_li_mpas_core.o: mpas_li_time_integration.o \ mpas_li_setup.o \ mpas_li_velocity.o \ mpas_li_diagnostic_vars.o \ + mpas_li_statistics.o \ mpas_li_mask.o mpas_li_setup.o: @@ -44,8 +46,12 @@ mpas_li_velocity.o: mpas_li_sia.o \ mpas_li_sia.o: mpas_li_mask.o \ mpas_li_setup.o +mpas_li_statistics.o: mpas_li_mask.o \ + mpas_li_setup.o + mpas_li_mask.o: mpas_li_setup.o + clean: $(RM) *.o *.mod *.f90 libdycore.a $(RM) Registry_processed.xml diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index b9d37b3304..0ce33ba6f7 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -69,6 +69,10 @@ + + - + /> + + + @@ -528,6 +545,7 @@ + diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index 87f313b948..3627f40b4f 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -161,6 +161,7 @@ subroutine mpas_core_init(domain, stream_manager, startTimeStamp) ! check for errors and exit + call mpas_dmpar_max_int(domain % dminfo, err, globalErr) ! Find out if any blocks got an error if (globalErr > 0) then call mpas_dmpar_global_abort("An error has occurred in mpas_core_init. Aborting...") @@ -191,6 +192,7 @@ subroutine mpas_core_run(domain, stream_manager) use mpas_timer use li_diagnostic_vars use li_setup + use li_statistics use mpas_io_streams, only: MPAS_STREAM_LATEST_BEFORE implicit none @@ -223,7 +225,8 @@ subroutine mpas_core_run(domain, stream_manager) integer :: itimestep type (block_type), pointer :: block type (mpas_pool_type), pointer :: statePool - logical, pointer :: config_do_restart, config_write_output_on_startup + integer, pointer :: config_stats_interval !< interval (number of timesteps) for writing stats + logical, pointer :: config_do_restart, config_write_output_on_startup, config_write_stats_on_startup character(len=StrKIND), pointer :: config_restart_timestamp_name type (MPAS_Time_Type) :: currTime @@ -242,6 +245,8 @@ subroutine mpas_core_run(domain, stream_manager) call mpas_pool_get_config(liConfigs, 'config_do_restart', config_do_restart) call mpas_pool_get_config(liConfigs, 'config_write_output_on_startup', config_write_output_on_startup) call mpas_pool_get_config(liConfigs, 'config_restart_timestamp_name', config_restart_timestamp_name) + call mpas_pool_get_config(liConfigs, 'config_write_stats_on_startup', config_write_stats_on_startup) + call mpas_pool_get_config(liConfigs, 'config_stats_interval', config_stats_interval) call mpas_timer_start("land ice core run") currTime = mpas_get_clock_time(clock, MPAS_NOW, err_tmp) @@ -275,14 +280,15 @@ subroutine mpas_core_run(domain, stream_manager) call mpas_timer_stop("initial state calculation") - ! === ! === Write Initial Output ! === call mpas_timer_start("write output") + if (config_write_output_on_startup) then call mpas_stream_mgr_write(stream_manager, 'output', forceWriteNow=.true., ierr=err_tmp) endif + call mpas_timer_stop("write output") ! === error check and exit @@ -291,7 +297,12 @@ subroutine mpas_core_run(domain, stream_manager) call mpas_dmpar_global_abort("An error has occurred in mpas_core_run before time-stepping. Aborting...") endif - + if (config_write_stats_on_startup) then + call mpas_timer_start("compute_statistics") + call li_compute_statistics(domain, 1, 0) ! timelevel = 1, itimestep = 0 + ! (itimestep is initialized below) + call mpas_timer_stop("compute_statistics") + endif ! During integration, time level 1 stores the model state at the beginning of the ! time step, and time level 2 stores the state advanced dt in time by timestep(...) @@ -323,7 +334,6 @@ subroutine mpas_core_run(domain, stream_manager) !write(6,*) ' dt (s) = ', dtSeconds - ! === ! === Perform Timestep ! === @@ -332,6 +342,15 @@ subroutine mpas_core_run(domain, stream_manager) call landice_timestep(domain, itimestep, dtSeconds, timeStamp, err_tmp) err = ior(err,err_tmp) + ! Write statistics at designated interval + if (config_stats_interval > 0) then + if (mod(itimestep, config_stats_interval) == 0) then + call mpas_timer_start("compute_statistics") + call li_compute_statistics(domain, 2, itimestep) + call mpas_timer_stop("compute_statistics") + end if + end if + ! Move time level 2 fields back into time level 1 for next time step block => domain % blocklist do while(associated(block)) @@ -339,8 +358,8 @@ subroutine mpas_core_run(domain, stream_manager) call mpas_pool_shift_time_levels(statePool) block => block % next end do - call mpas_timer_stop("time integration") + call mpas_timer_stop("time integration") ! === ! === Read time-varying inputs, if present (i.e., forcing) @@ -692,7 +711,6 @@ subroutine landice_timestep(domain, itimestep, dt, timeStamp, err) use mpas_grid_types use li_time_integration use mpas_timer -!!! use li_global_diagnostics implicit none @@ -727,56 +745,19 @@ subroutine landice_timestep(domain, itimestep, dt, timeStamp, err) type (block_type), pointer :: block_ptr integer :: err_tmp - err = 0 err_tmp = 0 - call li_timestep(domain, dt, timeStamp, err_tmp) err = ior(err,err_tmp) -!!! if (config_stats_interval .gt. 0) then -!!! if(mod(itimestep, config_stats_interval) == 0) then -!!! block_ptr => domain % blocklist -!!! if(associated(block_ptr % next)) then -!!! write(0,*) 'Error: computeGlobalDiagnostics assumes ',& -!!! 'that there is only one block per processor.' -!!! end if -!!! -!!! call mpas_timer_start("global_diagnostics") -!!! call li_compute_global_diagnostics(domain % dminfo, & -!!! block_ptr % state % time_levs(2) % state, block_ptr % mesh, & -!!! itimestep, dt) -!!! call mpas_timer_stop("global_diagnostics") -!!! end if -!!! end if - - !TODO: replace the above code block with this if we desire to convert config_stats_interval to use alarms - !if (mpas_is_alarm_ringing(clock, statsAlarmID, ierr=ierr)) then - ! call mpas_reset_clock_alarm(clock, statsAlarmID, ierr=ierr) - - ! block_ptr => domain % blocklist - ! if(associated(block_ptr % next)) then - ! write(0,*) 'Error: computeGlobalDiagnostics assumes ',& - ! 'that there is only one block per processor.' - ! end if - - ! call mpas_timer_start("global_diagnostics") - ! call sw_compute_global_diagnostics(domain % dminfo, & - ! block_ptr % state % time_levs(2) % state, block_ptr % mesh, & - ! timeStamp, dt) - ! call mpas_timer_stop("global_diagnostics") - !end if - ! === error check if (err > 0) then write (0,*) "An error has occurred in mpas_timestep." endif - end subroutine landice_timestep - !*********************************************************************** ! diff --git a/src/core_landice/mpas_li_statistics.F b/src/core_landice/mpas_li_statistics.F new file mode 100644 index 0000000000..c2cc77eade --- /dev/null +++ b/src/core_landice/mpas_li_statistics.F @@ -0,0 +1,826 @@ + +! Copyright (c) 2015, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! li_statistics +! +!> \MPAS land ice global and local statistics +!> \author William Lipscomb +!> \date 22 January 2015 +!> \details +!> This module contains routines for computing glocal and local +!> statistics and other diagnostic info. +!> It is based on a similar module in CISM. +! +!----------------------------------------------------------------------- + +module li_statistics + + use mpas_grid_types + use mpas_configure + use mpas_constants + use mpas_dmpar + use mpas_timer + use li_setup + use li_mask + + implicit none + private + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: li_compute_statistics + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + contains + +!*********************************************************************** +! +! routine li_compute_statistics +! +!> \brief Computes global and local statistics +!> \author William Lipscomb +!> \date 22 January 2015 +!> \details +!> This routine computes global statistics for the full domain, along with +!> local statistics and diagnostic info for a user-specified grid cell. +!> +!----------------------------------------------------------------------- + + subroutine li_compute_statistics(domain, timeLevel, timeIndex) + + ! dminfo is the domain info needed for global communication + ! state contains the state variables needed to compute global diagnostics + ! grid contains the meta data about the grid + ! timeIndex is the current time step counter + + implicit none + + ! Input/output arguments + type (domain_type), intent(inout) :: domain !< Input/Output: domain information + integer, intent(in) :: timeLevel + integer, intent(in) :: timeIndex + + ! Local variables + + type (block_type), pointer :: block + type (dm_info), pointer :: dminfo + + ! pools + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: diagnosticsPool + + ! mesh dimensions + integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve + + ! mesh arrays + integer, dimension(:), pointer :: indexToCellID, indexToEdgeID + integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell + real (kind=RKIND), dimension(:), pointer :: areaCell + real (kind=RKIND), dimension(:), pointer :: layerCenterSigma + real (kind=RKIND), dimension(:), pointer :: bedTopography, sfcMassBal + + ! state variables + character (len=StrKIND), pointer :: xtime + integer, dimension(:), pointer :: cellMask + real (kind=RKIND), dimension(:), pointer :: upperSurface + real (kind=RKIND), dimension(:), pointer :: surfaceTemperature, basalTemperature + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, normalVelocity + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + + ! config variables + real (kind=RKIND), pointer :: scyr ! seconds per year + real (kind=RKIND), pointer :: rhoi ! ice density (kg/m^3) + real (kind=RKIND), pointer :: shci ! specific heat capacity of ice (J/deg/kg) + integer, pointer :: statsCellID ! global ID of cell for which we write stats/diagnostics + + ! masks + integer, dimension(:), allocatable :: iceCellMask, iceEdgeMask + + ! work variables and arrays + real (kind=RKIND) :: localSum, localMin, localMax, localVertSumMin, localVertSumMax + integer :: localMinlocElement, localMinlocLevel + integer :: localMaxlocElement, localMaxlocLevel + integer :: localVertSumMinlocElement, localVertSumMaxlocElement + real (kind=RKIND), dimension(:), allocatable :: workArray1D + real (kind=RKIND), dimension(:,:), allocatable :: workArray + + ! sums and max/mins on local block + real (kind=RKIND) :: iceAreaSum, iceVolumeSum, iceEnergySum + real (kind=RKIND) :: thicknessMax, thicknessMin + real (kind=RKIND) :: temperatureMax, temperatureMin + real (kind=RKIND) :: velocityMax, basalVelocityMax + + ! cells, edges and levels where max/min values are located (cell/edge indices are global) + integer :: thicknessMinlocCell, thicknessMaxlocCell + integer :: temperatureMinlocCell, temperatureMinlocLevel + integer :: temperatureMaxlocCell, temperatureMaxlocLevel + integer :: velocityMaxlocEdge, velocityMaxlocLevel + integer :: basalVelocityMaxlocEdge + + ! global sums and max/mins + real (kind=RKIND) :: globalIceAreaSum, globalIceVolumeSum, globalIceEnergySum + real (kind=RKIND) :: globalThicknessMax, globalThicknessMin, globalThicknessMean + real (kind=RKIND) :: globalTemperatureMax, globalTemperatureMin, globalTemperatureMean + real (kind=RKIND) :: globalVelocityMax, globalBasalVelocityMax + + ! diagnostic info for user-specified grid cell + integer :: diagnosticCell, diagnosticBlockID, diagnosticProcID + real (kind=RKIND) :: diagnosticUpperSurface, diagnosticThickness, diagnosticBedTopography + real (kind=RKIND) :: diagnosticSfcMassBal, diagnosticSurfaceTemperature, diagnosticBasalTemperature + real (kind=RKIND), dimension(:), allocatable :: diagnosticSpeed, diagnosticTemperature + + integer :: iCell, iCell1, iCell2, iEdge, iTracer, kLevel + integer :: proc + + block => domain % blocklist + dminfo => domain % dminfo + + ! initialize info for diagnostic grid cell + ! These values will be overwritten on the processor owning this grid cell + diagnosticCell = 0 + diagnosticBlockID = 0 + diagnosticProcID = 0 + diagnosticUpperSurface = 0.0_RKIND + diagnosticThickness = 0.0_RKIND + diagnosticBedTopography = 0.0_RKIND + diagnosticSfcMassBal = 0.0_RKIND + diagnosticSurfaceTemperature = 0.0_RKIND + diagnosticBasalTemperature = 0.0_RKIND + + do while (associated(block)) + + ! pools + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + + ! mesh dimensions + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + ! mesh arrays + call mpas_pool_get_array(meshPool, 'indexToCellID', indexToCellID) + call mpas_pool_get_array(meshPool, 'indexToEdgeID', indexToEdgeID) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) + !TODO - Make bedTopography and sfcMassBal state variables? + call mpas_pool_get_array(meshPool, 'bedTopography', bedTopography) + call mpas_pool_get_array(meshPool, 'sfcMassBal', sfcMassBal) + + ! state variables + call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) + call mpas_pool_get_array(statePool, 'upperSurface', upperSurface, timeLevel) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_array(statePool, 'surfaceTemperature', surfaceTemperature, timeLevel) + call mpas_pool_get_array(statePool, 'basalTemperature', basalTemperature, timeLevel) + !Note: xtime only has one time level, but stating it explicitly here to avoid confusion + call mpas_pool_get_array(statePool, 'xtime', xtime, timeLevel=1) + + ! config settings + call mpas_pool_get_config(liConfigs, 'config_ice_density', rhoi) + call mpas_pool_get_config(liConfigs, 'config_ice_specific_heat', shci) + call mpas_pool_get_config(liConfigs, 'config_seconds_per_year', scyr) + call mpas_pool_get_config(liConfigs, 'config_stats_cell_ID', statsCellID) + + ! compute ice cell mask (= 1 for cells where ice is present, else = 0) + ! Note: Global sums are taken only over cells with mask = 1 + + allocate(iceCellMask(nCellsSolve)) + do iCell = 1, nCellsSolve + if (li_mask_is_ice(cellMask(iCell))) then + iceCellMask(iCell) = 1 + else + iceCellMask(iCell) = 0 + endif + enddo + + ! compute ice edge mask (= 1 for edges of cells where ice is present, else = 0) + allocate(iceEdgeMask(nEdgesSolve)) + do iEdge = 1, nEdgesSolve + iCell1 = cellsOnEdge(1,iEdge) + iCell2 = cellsOnEdge(2,iEdge) + if (li_mask_is_ice(cellMask(iCell1)) .or. li_mask_is_ice(cellMask(iCell2))) then + iceEdgeMask(iEdge) = 1 + else + iceEdgeMask(iEdge) = 0 + endif + enddo + + ! Compute statistics on local block + + ! max and min ice thickness + ! optional maxloc/minloc arguments give the local cell IDs where max/mins are located + + call li_compute_field_local_stats(dminfo, & + nVertLevels, nCellsSolve, & + layerThickness, iceCellMask, & + localSum, & + localMin, localMax, & + localVertSumMin, localVertSumMax, & + localVertSumMinlocElement = localVertSumMinlocElement, & + localVertSumMaxlocElement = localVertSumMaxlocElement) + + thicknessMin = localVertSumMin + thicknessMax = localVertSumMax + + ! global cell index for max/min values + thicknessMinlocCell = indexToCellID(localVertSumMinlocElement) + thicknessMaxlocCell = indexToCellID(localVertSumMaxlocElement) + + ! work array whose vertical sum = 1 everywhere + + if (.not. allocated(workArray)) allocate(workArray(nVertLevels,nCellsSolve)) + workArray(1,:) = 1.0_RKIND + workArray(2:nVertLevels,:) = 0.0_RKIND + + ! total ice area + call li_compute_field_area_weighted_local_stats & + (dminfo, & + nVertLevels, nCellsSolve, & + areaCell(1:nCellsSolve), & + workArray, iceCellMask, & + localSum, & + localMin, localMax, & + localVertSumMin, localVertSumMax) + + iceAreaSum = localSum + + ! work array with a value of 1 in each layer + workArray(:,:) = 1.0_RKIND + + ! total ice volume + call li_compute_field_volume_weighted_local_stats & + (dminfo, & + nVertLevels, nCellsSolve, & + areaCell(1:nCellsSolve), & + layerThickness(:,1:nCellsSolve), & + workArray, iceCellMask, & + localSum, & + localMin, localMax, & + localVertSumMin, localVertSumMax) + + iceVolumeSum = localSum + + ! max and min temperature + ! optional maxloc/minloc arguments give the local cell IDs where max/mins are located + + iTracer = 1 ! assume temperature is the first tracer array + + call li_compute_field_local_stats(dminfo, & + nVertLevels, nCellsSolve, & + tracers(iTracer,:,1:nCellsSolve), & + iceCellMask, & + localSum, & + localMin, localMax, & + localVertSumMin, localVertSumMax, & + localMinlocElement, localMinlocLevel, & + localMaxlocElement, localMaxlocLevel) + + temperatureMax = localMax + temperatureMin = localMin + + ! global cell and level indices for max/min values + temperatureMinlocCell = indexToCellID(localMinlocElement) + temperatureMinlocLevel = localMinlocLevel + temperatureMaxlocCell = indexToCellID(localMaxlocElement) + temperatureMaxlocLevel = localMaxlocLevel + + ! total ice energy (relative to 0 deg C) + !TODO - Compute ice energy differently if using the enthalpy scheme + + call li_compute_field_volume_weighted_local_stats & + (dminfo, & + nVertLevels, nCellsSolve, & + areaCell(1:nCellsSolve), & + layerThickness(:,1:nCellsSolve), & + tracers(iTracer,:,1:nCellsSolve), & + iceCellMask, & + localSum, & + localMin, localMax, & + localVertSumMin, localVertSumMax) + + iceEnergySum = localSum * rhoi * shci + + ! normal velocity at cell edges; find the maximum magnitude + !TODO - If velocity is defined at layer interfaces, then nVertLevels -> nVertLevels + 1 + + call li_compute_field_local_stats(dminfo, & + nVertLevels, nEdgesSolve, & + normalVelocity(:,1:nEdgesSolve), & + iceEdgeMask, & + localSum, & + localMin, localMax, & + localVertSumMin, localVertSumMax, & + localMinlocElement, localMinlocLevel, & + localMaxlocElement, localMaxlocLevel) + + velocityMax = max(localMax, -localMin) + + ! global edge and level indices for max value + if (localMax > abs(localMin)) then + velocityMaxlocEdge = indexToEdgeID(localMaxlocElement) + velocityMaxlocLevel = localMaxlocLevel + else + velocityMaxlocEdge = indexToEdgeId(localMinlocElement) + velocityMaxlocLevel = localMinlocLevel + endif + + ! basal velocity at cell edges; find the maximum magnitude + ! Note: If velocity is located at layer midpoints, this is actually the + ! velocity in the lowest layer + + call li_compute_field_local_stats(dminfo, & + 1, nEdgesSolve, & + normalVelocity(nVertLevels,1:nEdgesSolve), & + iceEdgeMask, & + localSum, & + localMin, localMax, & + localVertSumMin, localVertSumMax, & + localMinlocElement, localMinlocLevel,& + localMaxlocElement, localMaxlocLevel) + + basalVelocityMax = max(localMax, -localMin) + + ! global edge and level indices for max value + if (localMax > abs(localMin)) then + basalVelocityMaxlocEdge = indexToEdgeID(localMaxlocElement) + else + basalVelocityMaxlocEdge = indexToEdgeID(localMinlocElement) + endif + + ! allocate and initialize some diagnostic arrays if not done already + !TODO - If velocity is defined at layer interfaces, then nVertLevels -> nVertLevels + 1 + if (.not. allocated(diagnosticTemperature)) then + allocate(diagnosticTemperature(nVertLevels)) + diagnosticTemperature(:) = 0.0_RKIND + endif + + if (.not. allocated(diagnosticSpeed)) then + allocate(diagnosticSpeed(nVertLevels)) + diagnosticSpeed(:) = 0.0_RKIND + endif + + ! Determine whether the user-specified diagnostic cell is on this block + ! If so, then set some diagnostics to be broadcast later to the head processor + + do iCell = 1, nCellsSolve + if (indexToCellId(iCell) == statsCellID) then ! this is the diagnostic cell + diagnosticCell = iCell + diagnosticBlockID = block % localBlockID + diagnosticProcID = dminfo % my_proc_id + diagnosticUpperSurface = upperSurface(iCell) + diagnosticThickness = sum(layerThickness(:,iCell)) + diagnosticBedTopography = bedTopography(iCell) + diagnosticSfcMassBal = sfcMassBal(iCell) * scyr / 1000.0_RKIND ! convert from kg/m^2/s to m/yr + diagnosticSurfaceTemperature = surfaceTemperature(iCell) + diagnosticBasalTemperature = basalTemperature(iCell) + iEdge = edgesOnCell(1,iCell) ! arbitrarily choose edge #1 for velocity diagnostics + diagnosticSpeed(:) = normalVelocity(:,iEdge) * scyr ! convert from m/s to m/yr + diagnosticTemperature(:) = tracers(1,:,iCell) ! assume temperature is tracer #1 + endif + enddo + + block => block % next + end do ! block loop + + ! Compute global statistics + ! TODO: Reduce the number of global reductions in this subroutine? + ! This could be done by packing quantities into arrays. + + ! global sums + call mpas_dmpar_sum_real(dminfo, iceAreaSum, globalIceAreaSum) + call mpas_dmpar_sum_real(dminfo, iceVolumeSum, globalIceVolumeSum) + call mpas_dmpar_sum_real(dminfo, iceEnergySum, globalIceEnergySum) + + ! global means + !TODO - Replace temperature mean with enthalpy mean if using enthalpy scheme + + if (globalIceAreaSum > 0.0_RKIND) then + globalThicknessMean = globalIceVolumeSum / globalIceAreaSum + else + globalThicknessMean = 0.0_RKIND + endif + + if (globalIceVolumeSum > 0.0_RKIND) then + globalTemperatureMean = globalIceEnergySum / (globalIceVolumeSum * rhoi * shci) + else + globalTemperatureMean = 0.0_RKIND + endif + + ! global max/mins of state variables + ! First determine the global max/min and the proc on which it resides + ! Then broadcast the global max/min and its cell/edge/level location to all processors + + call mpas_dmpar_minloc_real(dminfo, thicknessMin, globalThicknessMin, proc) + call mpas_dmpar_bcast_real (dminfo, globalThicknessMin, proc) + call mpas_dmpar_bcast_int (dminfo, thicknessMinlocCell, proc) + + call mpas_dmpar_maxloc_real(dminfo, thicknessMax, globalThicknessMax, proc) + call mpas_dmpar_bcast_real (dminfo, globalThicknessMax, proc) + call mpas_dmpar_bcast_int (dminfo, thicknessMaxlocCell, proc) + + call mpas_dmpar_minloc_real(dminfo, temperatureMin, globalTemperatureMin, proc) + call mpas_dmpar_bcast_real (dminfo, globalTemperatureMin, proc) + call mpas_dmpar_bcast_int (dminfo, temperatureMinlocCell, proc) + call mpas_dmpar_bcast_int (dminfo, temperatureMinlocLevel, proc) + + call mpas_dmpar_maxloc_real(dminfo, temperatureMax, globalTemperatureMax, proc) + call mpas_dmpar_bcast_real (dminfo, globalTemperatureMax, proc) + call mpas_dmpar_bcast_int (dminfo, temperatureMaxlocCell, proc) + call mpas_dmpar_bcast_int (dminfo, temperatureMaxlocLevel, proc) + + call mpas_dmpar_maxloc_real(dminfo, velocityMax, globalVelocityMax, proc) + call mpas_dmpar_bcast_real (dminfo, globalVelocityMax, proc) + call mpas_dmpar_bcast_int (dminfo, velocityMaxlocEdge, proc) + call mpas_dmpar_bcast_int (dminfo, velocityMaxlocLevel, proc) + + call mpas_dmpar_maxloc_real(dminfo, basalVelocityMax, globalBasalVelocityMax, proc) + call mpas_dmpar_bcast_real (dminfo, globalBasalVelocityMax, proc) + call mpas_dmpar_bcast_int (dminfo, basalVelocityMaxlocEdge, proc) + + ! global reductions for user-specified diagnostic cell + ! Note: These reductions are done with global sums rather than broadcasts. + ! Global sums will work provided that the quantity of interest + ! has nonzero values on only a single processor. + + call mpas_dmpar_sum_int (dminfo, diagnosticCell, diagnosticCell) + call mpas_dmpar_sum_int (dminfo, diagnosticBlockID, diagnosticBlockID) + call mpas_dmpar_sum_int (dminfo, diagnosticProcID, diagnosticProcID) + + call mpas_dmpar_sum_real (dminfo, diagnosticUpperSurface, diagnosticUpperSurface) + call mpas_dmpar_sum_real (dminfo, diagnosticThickness, diagnosticThickness) + call mpas_dmpar_sum_real (dminfo, diagnosticBedTopography, diagnosticBedTopography) + call mpas_dmpar_sum_real (dminfo, diagnosticSfcMassBal, diagnosticSfcMassBal) + call mpas_dmpar_sum_real (dminfo, diagnosticSurfaceTemperature, diagnosticSurfaceTemperature) + call mpas_dmpar_sum_real (dminfo, diagnosticBasalTemperature, diagnosticBasalTemperature) + + !TODO - Change to nVertLevels + 1 if velocity lives on layer interfaces + allocate (workArray1d(nVertLevels)) + call mpas_dmpar_sum_real_array(dminfo, nVertLevels, diagnosticSpeed, workArray1d) + diagnosticSpeed(:) = workArray1D(:) + + call mpas_dmpar_sum_real_array(dminfo, nVertLevels, diagnosticTemperature, workArray1D) + diagnosticTemperature(:) = workArray1D(:) + + ! Write global and local stats to the log file + !TODO - Change stdout (6) to another fileunit? + + if (dminfo % my_proc_id == IO_NODE) then + write(6,*) ' ' + write(6,'(a60)') '------------------------------------------------------------' + write(6,*) ' ' + write(6,'(a25,a20)') 'Global statistics: time =', trim(xtime) + write(6,'(a25,i8)') ' timestep =', timeIndex + write(6,*) ' ' + write(6,'(a32,e24.16)') 'Total ice area (km^2) ', & + globalIceAreaSum*1.0d-6 ! convert from m^2 to km^2 + write(6,'(a32,e24.16)') 'Total ice volume (km^3) ', & + globalIceVolumeSum*1.0d-9 ! convert from m^3 to km^3 + write(6,'(a32,e24.16)') 'Total ice energy (J) ', & + globalIceEnergySum + write(6,'(a32,f24.16,i8)') 'Max thickness (m), cell ', & + globalThicknessMax, thicknessMaxlocCell + write(6,'(a32,f24.16,i8)') 'Min thickness (m), cell ', & + globalThicknessMin, thicknessMinlocCell + write(6,'(a32,f24.16)') 'Mean thickness (m) ', & + globalthicknessMean + write(6,'(a32,f24.16,i8,i4)') 'Max temperature (C), cell, level', & + globalTemperatureMax, temperatureMaxlocCell, temperatureMaxlocLevel + write(6,'(a32,f24.16,i8,i4)') 'Min temperature (C), cell, level', & + globalTemperatureMin, temperatureMinlocCell, temperatureMinlocLevel + write(6,'(a32,f24.16)') 'Mean temperature (C) ', & + globalTemperatureMean + write(6,'(a32,f24.16,i8,i4)') 'Max velocity (m/yr), edge, level', & + globalVelocityMax * scyr, velocityMaxlocEdge, velocityMaxlocLevel + write(6,'(a32,f24.16,i8,i4)') 'Max basal velo (m/yr), edge ', & + globalBasalVelocityMax * scyr, basalVelocityMaxlocEdge + write(6,*) ' ' + write(6,'(a30,i6)') 'Column diagnostics: cell ID = ', statsCellID + write(6,'(a30,3i6)') 'Local cell ID, block, proc = ', diagnosticCell, diagnosticBlockID, diagnosticProcID + write(6,*) ' ' + write(6,'(a25,f24.16)') 'Upper surface (m) ', diagnosticUpperSurface + write(6,'(a25,f24.16)') 'Thickness (m) ', diagnosticThickness + write(6,'(a25,f24.16)') 'Bed topography (m) ', diagnosticBedTopography + write(6,'(a25,f24.16)') 'Sfc mass balance (m/yr) ', diagnosticSfcMassBal + write(6,*) ' ' + write(6,'(a55)') 'Sigma Ice speed (m/yr) Ice temperature (C)' + write(6,'(f6.4, a25, f24.16)') 0.0_RKIND, '------', diagnosticSurfaceTemperature + do kLevel = 1, nVertLevels + write(6,'(f6.4, f25.16, f24.16)') & + layerCenterSigma(kLevel), diagnosticSpeed(kLevel), diagnosticTemperature(kLevel) + end do + write(6,'(f6.4, a25, f24.16)') 1.0_RKIND, '------', diagnosticBasalTemperature + write(6,*) ' ' + endif ! my_proc_id = IO_NODE + + ! clean up + deallocate(workArray) + deallocate(workArray1d) + deallocate(diagnosticSpeed) + deallocate(diagnosticTemperature) + + end subroutine li_compute_statistics + +!*********************************************************************** +! +! routine li_compute_field_local_stats +! +!> \brief Computes statistics for a field on a single block +!> \author William Lipscomb +!> \date 22 January 2015 +!> \details +!> This routine computes statistics (sum, max/min, vertical sum max/min) +!> for a real array on a single block. +! +!----------------------------------------------------------------------- + + subroutine li_compute_field_local_stats(dminfo, & + nVertLevels, nElements, & + field, mask, & + localSum, & + localMin, localMax, & + localVertSumMin, localVertSumMax, & + localMinlocElement, localMinlocLevel, & + localMaxlocElement, localMaxlocLevel, & + localVertSumMinlocElement, & + localVertSumMaxlocElement) + + ! Compute field statistics without area or volume weighting + + implicit none + + ! Input/output arguments + type (dm_info), intent(in) :: dminfo + integer, intent(in) :: nVertLevels, nElements + + real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: & + field ! input field for which statistics are computed + + integer, dimension(nElements), intent(in) :: & + mask ! = 0 or 1; compute stats only over region where mask = 1 + + real (kind=RKIND), intent(out) :: localSum, localMin, localMax + real (kind=RKIND), intent(out) :: localVertSumMin, localVertSumMax + + integer, intent(out), optional :: localMinlocElement, localMinlocLevel + integer, intent(out), optional :: localMaxlocElement, localMaxlocLevel + integer, intent(out), optional :: localVertSumMinlocElement + integer, intent(out), optional :: localVertSumMaxlocElement + + ! Local variables + integer :: i, k + + localSum = 0.0_RKIND + do i = 1, nElements + localSum = localSum + real(mask(i),RKIND) * sum(field(:,i)) + end do + + if (present(localMinlocElement) .and. present(localMinlocLevel)) then + localMin = 1.0e34 + localMinlocElement = 0 + localMinlocLevel = 0 + do i = 1, nElements + do k = 1, nVertLevels + if (field(k,i) < localMin) then + localMin = field(k,i) + localMinlocElement = i + localMinlocLevel = k + endif + enddo + enddo + else + localMin = minval(field) + endif + + if (present(localMaxlocElement) .and. present(localMaxlocLevel)) then + localMax = -1.0e34 + localMaxlocElement = 0 + localMaxlocLevel = 0 + do i = 1, nElements + do k = 1, nVertLevels + if (field(k,i) > localMax) then + localMax = field(k,i) + localMaxlocElement = i + localMaxlocLevel = k + endif + enddo + enddo + else + localMax = maxval(field) + endif + + if (present(localVertSumMinlocElement)) then + localVertSumMin = 1.0e34 + localVertSumMinlocElement = 0 + do i = 1, nElements + if (sum(field(:,i)) < localVertSumMin) then + localVertSumMin = sum(field(:,i)) + localVertSumMinlocElement = i + endif + enddo + else + localVertSumMin = minval(sum(field,1)) + endif + + if (present(localVertSumMaxlocElement)) then + localVertSumMax = -1.0e34 + localVertSumMaxlocElement = 0 + do i = 1, nElements + if (sum(field(:,i)) > localVertSumMax) then + localVertSumMax = sum(field(:,i)) + localVertSumMaxlocElement = i + endif + enddo + else + localVertSumMax = maxval(sum(field,1)) + endif + + end subroutine li_compute_field_local_stats + +!*********************************************************************** +! +! routine li_compute_field_area_weighted_local_stats +! +!> \brief Computes area-weighted statistics for a field on a single block +!> \author William Lipscomb +!> \date 22 January 2015 +!> \details +!> This routine computes statistics (sum, max/min, vertical sum max/min) +!> for a real array on a single block. The sum is weighted by the input +!> field 'areas' (typically the grid cell area). +! +!----------------------------------------------------------------------- + + subroutine li_compute_field_area_weighted_local_stats(dminfo, & + nVertLevels, nElements, & + areas, & + field, mask, & + localSum, & + localMin, localMax, & + localVertSumMin, localVertSumMax) + + ! Compute field statistics weighted by area + + implicit none + + ! Input/output arguments + type (dm_info), intent(in) :: dminfo + integer, intent(in) :: nVertLevels, nElements + + real (kind=RKIND), dimension(nElements), intent(in) :: & + areas ! grid cell areas + + real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: & + field ! input field for which statistics are computed + + integer, dimension(nElements), intent(in) :: & + mask ! = 0 or 1; compute stats only over region where mask = 1 + + real (kind=RKIND), intent(out) :: localSum, localMin, localMax + real (kind=RKIND), intent(out) :: localVertSumMin, localVertSumMax + + ! Local variables + integer :: i + + localSum = 0.0_RKIND + do i = 1, nElements + localSum = localSum + real(mask(i),RKIND) * areas(i) * sum(field(:,i)) + end do + + localMin = minval(field) + localMax = maxval(field) + + localVertSumMin = minval(sum(field,1)) + localVertSumMax = maxval(sum(field,1)) + + end subroutine li_compute_field_area_weighted_local_stats + +!*********************************************************************** +! +! routine li_compute_field_volume_weighted_local_stats +! +!> \brief Computes volume-weighted statistics for a field on a single block +!> \author William Lipscomb +!> \date 22 January 2015 +!> \details +!> This routine computes statistics (sum, max/min, vertical sum max/min) +!> for a real array on a single block. The sum is weighted by the product +!> of the input fields 'areas' (typically the grid cell area) and 'layerThickness'. +! +!----------------------------------------------------------------------- + + subroutine li_compute_field_volume_weighted_local_stats(dminfo, & + nVertLevels, nElements, & + areas, layerThickness, & + field, mask, & + localSum, & + localMin, localMax, & + localVertSumMin, localVertSumMax) + + implicit none + + ! Input/output arguments + type (dm_info), intent(in) :: dminfo + integer, intent(in) :: nVertLevels, nElements + + real (kind=RKIND), dimension(nElements), intent(in) :: & + areas ! element areas + + real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: & + layerThickness ! ice thickness in each layer + + real (kind=RKIND), dimension(nVertLevels, nElements), intent(in) :: & + field ! input field for which statistics are computed + + integer, dimension(nElements), intent(in) :: & + mask ! = 0 or 1; compute stats only over region where mask = 1 + + real (kind=RKIND), intent(out) :: localSum, localMin, localMax + real (kind=RKIND), intent(out) :: localVertSumMin, localVertSumMax + + ! Local variables + integer :: i + + localSum = 0.0_RKIND + do i = 1, nElements + localSum = localSum + real(mask(i),RKIND) * areas(i) * sum(layerThickness(:,i)*field(:,i)) + end do + + localMin = minval(field) + localMax = maxval(field) + + localVertSumMin = minval(sum(layerThickness*field,1)) + localVertSumMax = maxval(sum(layerThickness*field,1)) + + end subroutine li_compute_field_volume_weighted_local_stats + +! The remaining code is from an older module by Matt Hoffman. +! Keeping it here for reference. +!===================================================================================== + +! ! 6. Write out your global stat to the file +! if (dminfo % my_proc_id == IO_NODE) then +! fileID = land_ice_get_free_unit() +! +! if (config_write_initial_stats .and. (timeIndex == 0)) then +! open(fileID, file='GlobalIntegrals.txt',STATUS='unknown') +! elseif ( .not.(config_write_initial_stats) .and. (timeIndex/config_stats_interval == 1) ) then +! open(fileID, file='GlobalIntegrals.txt',STATUS='unknown') +! else +! open(fileID, file='GlobalIntegrals.txt',POSITION='append') +! endif +!! write(fileID,'(1i0, 100es24.16)') timeIndex, timeIndex*dt, globalFluidThickness, globalPotentialVorticity, globalPotentialEnstrophy, & +!! globalEnergy, globalCoriolisEnergyTendency, globalKineticEnergyTendency+globalPotentialEnergyTendency, & +!! globalKineticEnergy, globalPotentialEnergy +! +! endif + +! integer function land_ice_get_free_unit() +! implicit none + +! integer :: index +! logical :: isOpened + +! land_ice_get_free_unit = 0 +! do index = 1,99 +! if((index /= 5) .and. (index /= 6)) then +! inquire(unit = index, opened = isOpened) +! if( .not. isOpened) then +! land_ice_get_free_unit = index +! return +! end if +! end if +! end do +! end function land_ice_get_free_unit + + end module li_statistics From a6b74cdc793f1d031c659afc8503a562c2854c3c Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 15 Jan 2015 16:33:30 -0700 Subject: [PATCH 0002/1724] LI: Use cell->vertex interp operator for upperSurface This commits makes use of the recently added operator mpas_cells_to_points_using_baryweights for interpolating upperSurface to upperSurfaceVertex. The old method I had implemented gave garbage values for obtuse triangles, but this method does not. It requires setting up the interpolation weights on init with mpas_calculate_barycentric_weights_for_points. The old method is retained as an alternative (since the new method does not work across periodic edges). The method can be controlled with the config_upperSurfaceVertex_method namelist option. The new method is the default. --- src/core_landice/Registry.xml | 18 +++++++ src/core_landice/mpas_li_diagnostic_vars.F | 56 ++++++++++++++-------- src/core_landice/mpas_li_mpas_core.F | 34 ++++++++++++- 3 files changed, 86 insertions(+), 22 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index b9d37b3304..c12037cfc4 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -47,6 +47,10 @@ description="Selection of the method for solving ice velocity." possible_values="'sia'" /> + @@ -510,6 +514,12 @@ description="Coefficients to reconstruct velocity vectors at cells centers." /> + + @@ -534,6 +544,14 @@ + + + + + diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index bca3832160..8fb7daf792 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -268,6 +268,8 @@ end subroutine li_calculate_diagnostic_vars !----------------------------------------------------------------------- subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ + use mpas_geometry_utils, only: mpas_cells_to_points_using_baryweights + !----------------------------------------------------------------- ! ! input variables @@ -303,11 +305,13 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ real (kind=RKIND), dimension(:), pointer :: thickness, upperSurface, & lowerSurface, bedTopography, upperSurfaceVertex integer, dimension(:), pointer :: cellMask - real (kind=RKIND), dimension(:,:), pointer :: layerThickness + integer, dimension(:,:), pointer :: baryCellsOnVertex + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, baryWeightsOnVertex real (kind=RKIND), dimension(:,:,:), pointer :: tracers type (field1DInteger), pointer :: cellMaskField, edgeMaskField, vertexMaskField - integer, pointer :: nCells + integer, pointer :: nCells, nVertices real (kind=RKIND), pointer :: config_sea_level, config_ice_density, config_ocean_density + character (len=StrKIND), pointer :: config_velocity_solver, config_upperSurfaceVertex_method real (kind=RKIND) :: thisThk integer :: iCell, iLevel integer :: err_tmp @@ -361,10 +365,12 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) call mpas_pool_get_config(liConfigs, 'config_sea_level', config_sea_level) call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) call mpas_pool_get_config(liConfigs, 'config_ocean_density', config_ocean_density) + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) @@ -374,6 +380,8 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel=timeLevel) call mpas_pool_get_array(meshPool, 'bedTopography', bedTopography) + call mpas_pool_get_array(meshPool, 'baryCellsOnVertex', baryCellsOnVertex) + call mpas_pool_get_array(meshPool, 'baryWeightsOnVertex', baryWeightsOnVertex) ! Lower surface is based on floatation for floating ice. For grounded ice (and non-ice areas) it is the bed. where ( li_mask_is_floating_ice(cellMask) ) @@ -391,8 +399,23 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! Upper surface is the lower surface plus the thickness upperSurface(:) = lowerSurface(:) + thickness(:) - call cells_to_vertices_2dfield(meshPool, upperSurface, upperSurfaceVertex) ! (Needed only for SIA solver) - ! Note: the outer halo may be wrong, but that's ok as long as numhalos>1 because the velocity on the 0-halo will still be correct. + + ! Upper surface on vertices only needed for SIA solver + if (trim(config_velocity_solver) == 'sia') then + call mpas_pool_get_config(liConfigs, 'config_upperSurfaceVertex_method', config_upperSurfaceVertex_method) + select case (trim(config_upperSurfaceVertex_method)) + case ('barycentric') + call mpas_cells_to_points_using_baryweights(meshPool, baryCellsOnVertex(:, 1:nVertices), & + baryWeightsOnVertex(:, 1:nVertices), upperSurface, upperSurfaceVertex(1:nVertices), err_tmp) + err = ior(err, err_tmp) + case ('barycentric_kiteareas') + call cells_to_vertices_2dfield_using_kiteAreas(meshPool, upperSurface, upperSurfaceVertex) + case default + write (stdErrUnit,*) 'Error: Invalid value for config_upperSurface_method.' + err = 1 + end select + ! Note: the outer halo may be wrong, but that's ok as long as numhalos>1 because the velocity on the 0-halo will still be correct. + endif ! Do vertical remapping of layerThickness and tracers call vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers, err) @@ -818,48 +841,41 @@ subroutine vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers end subroutine vertical_remap - !*********************************************************************** ! -! subroutine cells_to_vertices_2dfield +! subroutine cells_to_vertices_2dfield_using_kiteAreas ! !> \brief Converts a 2d scalar field from cells to vertices !> \author Matt Hoffman !> \date 21 May 2012 -!> \details +!> \details !> This routine converts a 2d scalar field from cells to vertices. +!> It will give garbage values on obtuse triangles! But it does work +!> on periodic meshes. +!> TODO: It would be more efficient to calculate the weights once on init and then only +!> perform the interp. in this routine. !----------------------------------------------------------------------- - subroutine cells_to_vertices_2dfield(meshPool, fieldCells, fieldVertices) + subroutine cells_to_vertices_2dfield_using_kiteAreas(meshPool, fieldCells, fieldVertices) !----------------------------------------------------------------- - ! ! input variables - ! !----------------------------------------------------------------- - type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information real (kind=RKIND), dimension(:), intent(in) :: & fieldCells !< Input: field on cells !----------------------------------------------------------------- - ! ! input/output variables - ! !----------------------------------------------------------------- !----------------------------------------------------------------- - ! ! output variables - ! !----------------------------------------------------------------- - real (kind=RKIND), dimension(:), intent(out) :: & fieldVertices !< Input: field on vertices !----------------------------------------------------------------- - ! ! local variables - ! !----------------------------------------------------------------- real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex integer, dimension(:,:), pointer :: cellsOnVertex @@ -886,12 +902,12 @@ subroutine cells_to_vertices_2dfield(meshPool, fieldCells, fieldVertices) if (iCell2 /= icell) baryweight = baryweight + 0.5 * kiteAreasOnVertex(iCell2, iVertex) enddo fVertexAccum = fVertexAccum + baryweight * fieldCells(cellIndex) ! add the contribution from this cell's kite - weightAccum = weightAccum + kiteAreasOnVertex(iCell, iVertex) ! This doesn't match areaTriangle for some weird vertices + weightAccum = weightAccum + kiteAreasOnVertex(iCell, iVertex) ! This doesn't match areaTriangle for obtuse triangles!!! enddo fieldVertices(iVertex) = fVertexAccum / weightAccum ! I assume this should never be 0... enddo - end subroutine cells_to_vertices_2dfield + end subroutine cells_to_vertices_2dfield_using_kiteAreas end module li_diagnostic_vars diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index 87f313b948..7840e69e2b 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -579,6 +579,7 @@ end subroutine mpas_core_get_mesh_stream subroutine landice_init_block(block, startTimeStamp, dminfo) use mpas_grid_types + use mpas_geometry_utils, only: mpas_calculate_barycentric_weights_for_points use mpas_rbf_interpolation use mpas_vector_reconstruction use li_setup @@ -615,11 +616,17 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) !----------------------------------------------------------------- type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: scratchPool character (len=StrKIND), pointer :: xtime type (MPAS_Time_Type) :: currTime integer :: err, err_tmp - integer :: iCell, iLevel, i - + integer :: iCell, iLevel, i, iVertex + integer, pointer :: nVertices + character (len=StrKIND), pointer :: config_velocity_solver + integer, dimension(:,:), pointer :: baryCellsOnVertex + real (kind=RKIND), dimension(:,:), pointer :: baryWeightsOnVertex + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + type (field1dInteger), pointer :: vertexIndicesField err = 0 err_tmp = 0 @@ -627,6 +634,16 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! Get pool stuff call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_array(meshPool, 'baryCellsOnVertex', baryCellsOnVertex) + call mpas_pool_get_array(meshPool, 'baryWeightsOnVertex', baryWeightsOnVertex) + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + call mpas_pool_get_field(scratchPool, 'vertexIndices', vertexIndicesField) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + ! === ! === Call init routines === @@ -636,6 +653,19 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) call li_setup_sign_and_index_fields(meshPool) + ! The SIA solver needs to setup these weights for calculating upperSurfaceVertex + if (trim(config_velocity_solver) == 'sia') then + call mpas_allocate_scratch_field(vertexIndicesField, .true.) + do iVertex = 1, nVertices + vertexIndicesField % array(iVertex) = iVertex + enddo + call mpas_calculate_barycentric_weights_for_points(meshPool, & + xVertex(1:nVertices), yVertex(1:nVertices), zVertex(1:nVertices), & + vertexIndicesField % array(1:nVertices), & + baryCellsOnVertex(:, 1:nVertices), baryWeightsOnVertex(:, 1:nVertices), err_tmp) + err = ior(err, err_tmp) + call mpas_deallocate_scratch_field(vertexIndicesField, .true.) + endif ! This was needed to init FCT once. !!! ! Init for FCT tracer advection From bfd31881c6198ccdb5d3bb87f315c93d1352d1be Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 23 Dec 2014 09:38:43 -0700 Subject: [PATCH 0003/1724] LI: Add SIA package, add tangent slope method from normal slope Added "config_sia_tangent_slope_calculation" option for "Selection of the method for calculating the tangent component of surface slope at edges needed by the SIA velocity solver. 'from_vertex_barycentric' interpolates upperSurface values from cell centers to vertices using the barycentric interpolation routine in operators (mpas_cells_to_points_using_baryweights) and then calculates the slope between vertices. It works for obtuse triangles, but will not work correctly across the edges of periodic meshes. 'from_vertex_barycentric_kiteareas' interpolates upperSurface values from cell centers to vertices using barycentric interpolation based on kiterea values and then calculates the slope between vertices. It will work across the edges of periodic meshes, but will not work correctly for obtuse triangles. 'from_normal_slope' uses the vector operator mpas_tangential_vector_1d to calculate the tangent slopes from the normal slopes on the edges of the adjacent cells. It will work for any mesh configuration, but is the least accurate method." This option replaces the option from the last commit "config_upperSurfaceVertex_method" which provided two ways to calculate the tangent slope component. Additionally: * Created a package called SIAvelocity that includes the variables upperSurfaceVertex, normalSlopeEdge, tangentSlopeEdge, slopeEdge * Moved the slope calculation to diagnostic_solve_before_velocity() instead of in the SIA velocity solve itself. --- src/core_landice/Registry.xml | 32 +++++-- src/core_landice/mpas_li_diagnostic_vars.F | 98 +++++++++++++++++----- src/core_landice/mpas_li_mpas_core.F | 14 +++- src/core_landice/mpas_li_sia.F | 17 ++-- 4 files changed, 119 insertions(+), 42 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index c12037cfc4..b744494de9 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -47,9 +47,12 @@ description="Selection of the method for solving ice velocity." possible_values="'sia'" /> - @@ -319,6 +322,13 @@ + + + + + + + @@ -349,9 +359,6 @@ - @@ -380,6 +387,19 @@ + + + + + diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index 8fb7daf792..2ca6e3c583 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -269,6 +269,7 @@ end subroutine li_calculate_diagnostic_vars subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ use mpas_geometry_utils, only: mpas_cells_to_points_using_baryweights + use mpas_vector_operations, only: mpas_tangential_vector_1d !----------------------------------------------------------------- ! @@ -303,17 +304,19 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: statePool real (kind=RKIND), dimension(:), pointer :: thickness, upperSurface, & - lowerSurface, bedTopography, upperSurfaceVertex - integer, dimension(:), pointer :: cellMask + lowerSurface, bedTopography, upperSurfaceVertex, slopeEdge, & + normalSlopeEdge, tangentSlopeEdge, dcEdge, dvEdge + integer, dimension(:), pointer :: cellMask, edgeMask + integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge integer, dimension(:,:), pointer :: baryCellsOnVertex real (kind=RKIND), dimension(:,:), pointer :: layerThickness, baryWeightsOnVertex real (kind=RKIND), dimension(:,:,:), pointer :: tracers type (field1DInteger), pointer :: cellMaskField, edgeMaskField, vertexMaskField - integer, pointer :: nCells, nVertices + integer, pointer :: nCells, nVertices, nEdges real (kind=RKIND), pointer :: config_sea_level, config_ice_density, config_ocean_density - character (len=StrKIND), pointer :: config_velocity_solver, config_upperSurfaceVertex_method + character (len=StrKIND), pointer :: config_velocity_solver, config_sia_tangent_slope_calculation real (kind=RKIND) :: thisThk - integer :: iCell, iLevel + integer :: iCell, iLevel, iEdge, cell1, cell2 integer :: err_tmp @@ -375,13 +378,10 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'upperSurface', upperSurface, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'upperSurfaceVertex', upperSurfaceVertex, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'lowerSurface', lowerSurface, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel=timeLevel) call mpas_pool_get_array(meshPool, 'bedTopography', bedTopography) - call mpas_pool_get_array(meshPool, 'baryCellsOnVertex', baryCellsOnVertex) - call mpas_pool_get_array(meshPool, 'baryWeightsOnVertex', baryWeightsOnVertex) ! Lower surface is based on floatation for floating ice. For grounded ice (and non-ice areas) it is the bed. where ( li_mask_is_floating_ice(cellMask) ) @@ -400,22 +400,76 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! Upper surface is the lower surface plus the thickness upperSurface(:) = lowerSurface(:) + thickness(:) - ! Upper surface on vertices only needed for SIA solver - if (trim(config_velocity_solver) == 'sia') then - call mpas_pool_get_config(liConfigs, 'config_upperSurfaceVertex_method', config_upperSurfaceVertex_method) - select case (trim(config_upperSurfaceVertex_method)) - case ('barycentric') + + ! Calculate SIA-related variables, if needed + if(trim(config_velocity_solver) == 'sia') then + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + call mpas_pool_get_config(liConfigs, 'config_sia_tangent_slope_calculation', config_sia_tangent_slope_calculation) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + + call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'slopeEdge', slopeEdge, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'normalSlopeEdge', normalSlopeEdge, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'tangentSlopeEdge', tangentSlopeEdge, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'upperSurfaceVertex', upperSurfaceVertex, timeLevel=timeLevel) + call mpas_pool_get_array(meshPool, 'baryCellsOnVertex', baryCellsOnVertex) + call mpas_pool_get_array(meshPool, 'baryWeightsOnVertex', baryWeightsOnVertex) + + + ! Calculate normal slope + do iEdge = 1, nEdges + ! Only calculate slope for edges that have ice on at least one side. + if ( li_mask_is_dynamic_ice(edgeMask(iEdge)) ) then + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + ! Calculate slope at edge + normalSlopeEdge(iEdge) = (upperSurface(cell1) - upperSurface(cell2) ) / dcEdge(iEdge) + else + normalSlopeEdge(iEdge) = 0.0_RKIND + endif + end do ! edges + + ! Calculate upperSurfaceVertex if needed + select case (trim(config_sia_tangent_slope_calculation)) + case ('from_vertex_barycentric') call mpas_cells_to_points_using_baryweights(meshPool, baryCellsOnVertex(:, 1:nVertices), & baryWeightsOnVertex(:, 1:nVertices), upperSurface, upperSurfaceVertex(1:nVertices), err_tmp) err = ior(err, err_tmp) - case ('barycentric_kiteareas') - call cells_to_vertices_2dfield_using_kiteAreas(meshPool, upperSurface, upperSurfaceVertex) + case ('from_vertex_barycentric_kiteareas') + call cells_to_vertices_1dfield_using_kiteAreas(meshPool, upperSurface, upperSurfaceVertex) + end select + + ! Calculate tangent slope + select case (trim(config_sia_tangent_slope_calculation)) + case ('from_vertex_barycentric', 'from_vertex_barycentric_kiteareas') + do iEdge = 1, nEdges + ! Only calculate slope for edges that have ice on at least one side. + if ( li_mask_is_dynamic_ice(edgeMask(iEdge)) ) then + tangentSlopeEdge(iEdge) = ( upperSurfaceVertex(verticesOnEdge(1,iEdge)) - & + upperSurfaceVertex(verticesOnEdge(2,iEdge)) ) / dvEdge(iEdge) + else + tangentSlopeEdge(iEdge) = 0.0_RKIND + endif + end do ! edges + case ('from_normal_slope') + call mpas_tangential_vector_1d(normalSlopeEdge, meshPool, & + includeHalo=.true., tangentialVector=tangentSlopeEdge) case default - write (stdErrUnit,*) 'Error: Invalid value for config_upperSurface_method.' + write (stdErrUnit,*) 'Error: Invalid value for config_sia_tangent_slope_calculation.' err = 1 end select + + ! Now calculate the slope magnitude + slopeEdge = sqrt(normalSlopeEdge**2 + tangentSlopeEdge**2) + ! Note: the outer halo may be wrong, but that's ok as long as numhalos>1 because the velocity on the 0-halo will still be correct. - endif + + end if ! SIA variables + ! Do vertical remapping of layerThickness and tracers call vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers, err) @@ -843,19 +897,19 @@ end subroutine vertical_remap !*********************************************************************** ! -! subroutine cells_to_vertices_2dfield_using_kiteAreas +! subroutine cells_to_vertices_1dfield_using_kiteAreas ! -!> \brief Converts a 2d scalar field from cells to vertices +!> \brief Converts a 1d scalar field from cells to vertices !> \author Matt Hoffman !> \date 21 May 2012 !> \details -!> This routine converts a 2d scalar field from cells to vertices. +!> This routine converts a 1d scalar field from cells to vertices. !> It will give garbage values on obtuse triangles! But it does work !> on periodic meshes. !> TODO: It would be more efficient to calculate the weights once on init and then only !> perform the interp. in this routine. !----------------------------------------------------------------------- - subroutine cells_to_vertices_2dfield_using_kiteAreas(meshPool, fieldCells, fieldVertices) + subroutine cells_to_vertices_1dfield_using_kiteAreas(meshPool, fieldCells, fieldVertices) !----------------------------------------------------------------- ! input variables !----------------------------------------------------------------- @@ -907,7 +961,7 @@ subroutine cells_to_vertices_2dfield_using_kiteAreas(meshPool, fieldCells, field fieldVertices(iVertex) = fVertexAccum / weightAccum ! I assume this should never be 0... enddo - end subroutine cells_to_vertices_2dfield_using_kiteAreas + end subroutine cells_to_vertices_1dfield_using_kiteAreas end module li_diagnostic_vars diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index 7840e69e2b..d04f69ad91 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -480,9 +480,17 @@ subroutine mpas_core_setup_packages(configPool, packagePool, ierr) type (mpas_pool_type), intent(in) :: configPool type (mpas_pool_type), intent(in) :: packagePool integer, intent(out) :: ierr + ! Locals + character (len=StrKIND), pointer :: config_velocity_solver + logical, pointer :: SIAvelocityActive ierr = 0 + call mpas_pool_get_config(configPool, 'config_velocity_solver', config_velocity_solver) + call mpas_pool_get_package(packagePool, 'SIAvelocityActive', SIAvelocityActive) + + if(trim(config_velocity_solver) == 'sia') SIAvelocityActive = .true. + end subroutine mpas_core_setup_packages @@ -622,7 +630,7 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) integer :: err, err_tmp integer :: iCell, iLevel, i, iVertex integer, pointer :: nVertices - character (len=StrKIND), pointer :: config_velocity_solver + character (len=StrKIND), pointer :: config_sia_tangent_slope_calculation integer, dimension(:,:), pointer :: baryCellsOnVertex real (kind=RKIND), dimension(:,:), pointer :: baryWeightsOnVertex real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex @@ -640,7 +648,7 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) call mpas_pool_get_array(meshPool, 'xVertex', xVertex) call mpas_pool_get_array(meshPool, 'yVertex', yVertex) call mpas_pool_get_array(meshPool, 'zVertex', zVertex) - call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + call mpas_pool_get_config(liConfigs, 'config_sia_tangent_slope_calculation', config_sia_tangent_slope_calculation) call mpas_pool_get_field(scratchPool, 'vertexIndices', vertexIndicesField) call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) @@ -654,7 +662,7 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) call li_setup_sign_and_index_fields(meshPool) ! The SIA solver needs to setup these weights for calculating upperSurfaceVertex - if (trim(config_velocity_solver) == 'sia') then + if (trim(config_sia_tangent_slope_calculation) == 'from_vertex_barycentric') then call mpas_allocate_scratch_field(vertexIndicesField, .true.) do iVertex = 1, nVertices vertexIndicesField % array(iVertex) = iVertex diff --git a/src/core_landice/mpas_li_sia.F b/src/core_landice/mpas_li_sia.F index efb1934b44..46d3d8f676 100644 --- a/src/core_landice/mpas_li_sia.F +++ b/src/core_landice/mpas_li_sia.F @@ -211,14 +211,14 @@ subroutine li_sia_solve(meshPool, statePool, timeLevel, err) ! !----------------------------------------------------------------- - real (kind=RKIND), dimension(:), pointer :: thickness, layerCenterSigma, dcEdge, dvEdge, upperSurface, upperSurfaceVertex + real (kind=RKIND), dimension(:), pointer :: thickness, layerCenterSigma, dcEdge, dvEdge + real (kind=RKIND), dimension(:), pointer :: slopeEdge, normalSlopeEdge real (kind=RKIND), dimension(:,:), pointer :: normalVelocity integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge integer, dimension(:), pointer :: edgeMask integer, pointer :: nVertLevels, nEdges, nVertices, vertexDegree integer :: iLevel, iEdge, iCell, iVertex, cell1, cell2, cellIndex - real (kind=RKIND) :: basalVelocity, slopeOnEdge, & - normalSlopeOnEdge, tangentSlopeOnEdge, & + real (kind=RKIND) :: basalVelocity, & layerCenterHeightOnEdge, thicknessEdge, hVertexAccum real (kind=RKIND), pointer :: rhoi ! ice density real (kind=RKIND), pointer :: ratefactor ! flow law parameter, A @@ -241,8 +241,8 @@ subroutine li_sia_solve(meshPool, statePool, timeLevel, err) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'upperSurface', upperSurface, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'upperSurfaceVertex', upperSurfaceVertex, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'slopeEdge', slopeEdge, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'normalSlopeEdge', normalSlopeEdge, timeLevel=timeLevel) ! Get parameters specified in the namelist @@ -260,11 +260,6 @@ subroutine li_sia_solve(meshPool, statePool, timeLevel, err) if ( li_mask_is_dynamic_ice(edgeMask(iEdge)) ) then cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - ! Calculate slope at edge - ! This could/should be calculated externally to this subroutine - normalSlopeOnEdge = (upperSurface(cell1) - upperSurface(cell2) ) / dcEdge(iEdge) - tangentSlopeOnEdge = ( upperSurfaceVertex(verticesOnEdge(1,iEdge)) - upperSurfaceVertex(verticesOnEdge(2,iEdge)) ) / dvEdge(iEdge) - slopeOnEdge = (normalSlopeOnEdge**2 + tangentSlopeOnEdge**2)**0.5 ! Calculate thickness on edge - 2nd order thicknessEdge = (thickness(cell1) + thickness(cell2) ) * 0.5_RKIND ! Loop over layers @@ -273,7 +268,7 @@ subroutine li_sia_solve(meshPool, statePool, timeLevel, err) layerCenterHeightOnEdge = thicknessEdge * (1.0_RKIND - layerCenterSigma(iLevel) ) ! Calculate SIA velocity normalVelocity(iLevel,iEdge) = basalVelocity + & - 0.5_RKIND * ratefactor * (rhoi * gravity)**n * slopeOnEdge**(n-1) * normalSlopeOnEdge * & + 0.5_RKIND * ratefactor * (rhoi * gravity)**n * slopeEdge(iEdge)**(n-1) * normalSlopeEdge(iEdge) * & (thicknessEdge**(n+1) - (thicknessEdge - layerCenterHeightOnEdge)**(n+1)) end do ! Levels else From a82191455a93bbeb1e32328b95eb1beafd99288e Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Sat, 7 Feb 2015 20:34:00 -0700 Subject: [PATCH 0004/1724] LI: move init of baryweights for SIA slope calc from mpas_core to sia module Since initializing the barycentric weights for interpolating from upperSurface to upperSurfaceVertex is only needed by the SIA core, I've moved this procedure from the mpas_li_mpas_core.F module to the mpas_li_sia.F module. --- src/core_landice/mpas_li_mpas_core.F | 33 ------------------------ src/core_landice/mpas_li_sia.F | 38 ++++++++++++++++++++++++++++ 2 files changed, 38 insertions(+), 33 deletions(-) diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index d04f69ad91..5281183d6b 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -587,7 +587,6 @@ end subroutine mpas_core_get_mesh_stream subroutine landice_init_block(block, startTimeStamp, dminfo) use mpas_grid_types - use mpas_geometry_utils, only: mpas_calculate_barycentric_weights_for_points use mpas_rbf_interpolation use mpas_vector_reconstruction use li_setup @@ -624,17 +623,9 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) !----------------------------------------------------------------- type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: statePool - type (mpas_pool_type), pointer :: scratchPool character (len=StrKIND), pointer :: xtime type (MPAS_Time_Type) :: currTime integer :: err, err_tmp - integer :: iCell, iLevel, i, iVertex - integer, pointer :: nVertices - character (len=StrKIND), pointer :: config_sia_tangent_slope_calculation - integer, dimension(:,:), pointer :: baryCellsOnVertex - real (kind=RKIND), dimension(:,:), pointer :: baryWeightsOnVertex - real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex - type (field1dInteger), pointer :: vertexIndicesField err = 0 err_tmp = 0 @@ -642,16 +633,6 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! Get pool stuff call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) - call mpas_pool_get_array(meshPool, 'baryCellsOnVertex', baryCellsOnVertex) - call mpas_pool_get_array(meshPool, 'baryWeightsOnVertex', baryWeightsOnVertex) - call mpas_pool_get_array(meshPool, 'xVertex', xVertex) - call mpas_pool_get_array(meshPool, 'yVertex', yVertex) - call mpas_pool_get_array(meshPool, 'zVertex', zVertex) - call mpas_pool_get_config(liConfigs, 'config_sia_tangent_slope_calculation', config_sia_tangent_slope_calculation) - call mpas_pool_get_field(scratchPool, 'vertexIndices', vertexIndicesField) - call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) - ! === ! === Call init routines === @@ -661,20 +642,6 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) call li_setup_sign_and_index_fields(meshPool) - ! The SIA solver needs to setup these weights for calculating upperSurfaceVertex - if (trim(config_sia_tangent_slope_calculation) == 'from_vertex_barycentric') then - call mpas_allocate_scratch_field(vertexIndicesField, .true.) - do iVertex = 1, nVertices - vertexIndicesField % array(iVertex) = iVertex - enddo - call mpas_calculate_barycentric_weights_for_points(meshPool, & - xVertex(1:nVertices), yVertex(1:nVertices), zVertex(1:nVertices), & - vertexIndicesField % array(1:nVertices), & - baryCellsOnVertex(:, 1:nVertices), baryWeightsOnVertex(:, 1:nVertices), err_tmp) - err = ior(err, err_tmp) - call mpas_deallocate_scratch_field(vertexIndicesField, .true.) - endif - ! This was needed to init FCT once. !!! ! Init for FCT tracer advection !!! mesh % maxLevelCell % array = mesh % nVertLevels ! Needed for FCT tracer advection diff --git a/src/core_landice/mpas_li_sia.F b/src/core_landice/mpas_li_sia.F index 46d3d8f676..082c8a2700 100644 --- a/src/core_landice/mpas_li_sia.F +++ b/src/core_landice/mpas_li_sia.F @@ -124,6 +124,8 @@ end subroutine li_sia_init subroutine li_sia_block_init(block, err) + use mpas_geometry_utils, only: mpas_calculate_barycentric_weights_for_points + !----------------------------------------------------------------- ! ! input variables @@ -151,9 +153,45 @@ subroutine li_sia_block_init(block, err) ! local variables ! !----------------------------------------------------------------- + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: scratchPool + integer :: iCell, iLevel, i, iVertex, err_tmp + integer, pointer :: nVertices + character (len=StrKIND), pointer :: config_sia_tangent_slope_calculation + integer, dimension(:,:), pointer :: baryCellsOnVertex + real (kind=RKIND), dimension(:,:), pointer :: baryWeightsOnVertex + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + type (field1dInteger), pointer :: vertexIndicesField ! No block init needed. err = 0 + err_tmp = 0 + + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_array(meshPool, 'baryCellsOnVertex', baryCellsOnVertex) + call mpas_pool_get_array(meshPool, 'baryWeightsOnVertex', baryWeightsOnVertex) + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + call mpas_pool_get_config(liConfigs, 'config_sia_tangent_slope_calculation', config_sia_tangent_slope_calculation) + call mpas_pool_get_field(scratchPool, 'vertexIndices', vertexIndicesField) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + + ! The SIA solver may need to setup these weights for calculating upperSurfaceVertex + if (trim(config_sia_tangent_slope_calculation) == 'from_vertex_barycentric') then + call mpas_allocate_scratch_field(vertexIndicesField, .true.) + do iVertex = 1, nVertices + vertexIndicesField % array(iVertex) = iVertex + enddo + call mpas_calculate_barycentric_weights_for_points(meshPool, & + xVertex(1:nVertices), yVertex(1:nVertices), zVertex(1:nVertices), & + vertexIndicesField % array(1:nVertices), & + baryCellsOnVertex(:, 1:nVertices), baryWeightsOnVertex(:, 1:nVertices), err_tmp) + err = ior(err, err_tmp) + call mpas_deallocate_scratch_field(vertexIndicesField, .true.) + endif + !-------------------------------------------------------------------- end subroutine li_sia_block_init From 021f3f2d7f946bf25bec0709cc16aa644e9c521e Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 13 Feb 2015 12:45:23 -0700 Subject: [PATCH 0005/1724] Minor edits in response to Matt Hoffman's code review * Changed C to K for temperature units * Added a config parameter for Kelvin/Celsius conversion * Replaced scyr with a local parameter (instead of a config file parameter) * Added some scratch fields in the Registry * Replaced locally allocated horizontal arrays with scratch arrays in li_statistics module * Added code to do reductions (sums, maxs, mins) over multiple blocks per processor * Fetched temperature index from a pool instead of hard-coding to 1 * Replaced '6' with 'stdoutUnit' * Cleaned up a few comments --- src/core_landice/Registry.xml | 34 ++- src/core_landice/mpas_li_statistics.F | 349 +++++++++++++++----------- 2 files changed, 225 insertions(+), 158 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 0ce33ba6f7..74c667cc25 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -69,7 +69,7 @@ - @@ -81,14 +81,14 @@ description="ocean density to use for calculating floatation" possible_values="Any positive real value" /> + - - - - @@ -545,12 +545,26 @@ - + + + + + + diff --git a/src/core_landice/mpas_li_statistics.F b/src/core_landice/mpas_li_statistics.F index c2cc77eade..f95dc46b6e 100644 --- a/src/core_landice/mpas_li_statistics.F +++ b/src/core_landice/mpas_li_statistics.F @@ -70,19 +70,15 @@ module li_statistics !> !----------------------------------------------------------------------- - subroutine li_compute_statistics(domain, timeLevel, timeIndex) - - ! dminfo is the domain info needed for global communication - ! state contains the state variables needed to compute global diagnostics - ! grid contains the meta data about the grid - ! timeIndex is the current time step counter + subroutine li_compute_statistics(domain, timeLevel, itimestep) implicit none ! Input/output arguments - type (domain_type), intent(inout) :: domain !< Input/Output: domain information - integer, intent(in) :: timeLevel - integer, intent(in) :: timeIndex + type (domain_type), intent(inout) :: domain !< Input/Output: domain object + integer, intent(in) :: timeLevel !< Input: time level used by pools for variables with multiple time levels + ! (typically '2' when this subroutine is called at the end of a time step) + integer, intent(in) :: itimestep !< Input: current time step counter ! Local variables @@ -92,6 +88,7 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) ! pools type (mpas_pool_type), pointer :: statePool type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: scratchPool type (mpas_pool_type), pointer :: diagnosticsPool ! mesh dimensions @@ -107,29 +104,40 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) ! state variables character (len=StrKIND), pointer :: xtime integer, dimension(:), pointer :: cellMask + integer, dimension(:), pointer :: edgeMask real (kind=RKIND), dimension(:), pointer :: upperSurface real (kind=RKIND), dimension(:), pointer :: surfaceTemperature, basalTemperature real (kind=RKIND), dimension(:,:), pointer :: layerThickness, normalVelocity real (kind=RKIND), dimension(:,:,:), pointer :: tracers + ! scratch variables + type (field1dInteger), pointer :: iceCellMaskField + integer, dimension(:), pointer :: iceCellMask + + type (field1dInteger), pointer :: iceEdgeMaskField + integer, dimension(:), pointer :: iceEdgeMask + + type (field2dReal), pointer :: workLevelCellField + real (kind=RKIND), dimension(:,:), pointer :: workLevelCell + ! config variables - real (kind=RKIND), pointer :: scyr ! seconds per year real (kind=RKIND), pointer :: rhoi ! ice density (kg/m^3) real (kind=RKIND), pointer :: shci ! specific heat capacity of ice (J/deg/kg) + real (kind=RKIND), pointer :: KtoC ! 273.15; factor for converting Kelvin to Celsius integer, pointer :: statsCellID ! global ID of cell for which we write stats/diagnostics - ! masks - integer, dimension(:), allocatable :: iceCellMask, iceEdgeMask + ! other pointers + integer, pointer :: indexTemperature ! work variables and arrays - real (kind=RKIND) :: localSum, localMin, localMax, localVertSumMin, localVertSumMax + real (kind=RKIND) :: localSum, localMin, localMax, localVertSumMin, localVertSumMax + real (kind=RKIND) :: localAbsoluteMax integer :: localMinlocElement, localMinlocLevel integer :: localMaxlocElement, localMaxlocLevel integer :: localVertSumMinlocElement, localVertSumMaxlocElement - real (kind=RKIND), dimension(:), allocatable :: workArray1D - real (kind=RKIND), dimension(:,:), allocatable :: workArray + real (kind=RKIND), dimension(:), allocatable :: workLevel - ! sums and max/mins on local block + ! sums and max/mins on local processor real (kind=RKIND) :: iceAreaSum, iceVolumeSum, iceEnergySum real (kind=RKIND) :: thicknessMax, thicknessMin real (kind=RKIND) :: temperatureMax, temperatureMin @@ -154,12 +162,36 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) real (kind=RKIND) :: diagnosticSfcMassBal, diagnosticSurfaceTemperature, diagnosticBasalTemperature real (kind=RKIND), dimension(:), allocatable :: diagnosticSpeed, diagnosticTemperature - integer :: iCell, iCell1, iCell2, iEdge, iTracer, kLevel + integer :: iCell, iCell1, iCell2, iEdge, kLevel integer :: proc + ! local parameters + real (kind=RKIND), parameter :: scyr = 31536000.0_RKIND ! seconds per 365-day year + block => domain % blocklist dminfo => domain % dminfo + ! initialize statistics for this processor + ! If we have > 1 block/proc, these are summed or reduced over the block + + iceAreaSum = 0.0_RKIND + iceVolumeSum = 0.0_RKIND + iceEnergySum = 0.0_RKIND + thicknessMax = -huge(0.0_RKIND) + thicknessMin = huge(0.0_RKIND) + temperatureMax = -huge(0.0_RKIND) + temperatureMin = huge(0.0_RKIND) + velocityMax = -huge(0.0_RKIND) + basalVelocityMax = -huge(0.0_RKIND) + + thicknessMinlocCell = 0 + thicknessMaxlocCell = 0 + temperatureMinlocCell = 0 + temperatureMinlocLevel = 0 + velocityMaxlocEdge = 0 + velocityMaxlocLevel = 0 + basalVelocityMaxlocEdge = 0 + ! initialize info for diagnostic grid cell ! These values will be overwritten on the processor owning this grid cell diagnosticCell = 0 @@ -175,8 +207,10 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) do while (associated(block)) ! pools + call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) ! mesh dimensions @@ -191,12 +225,17 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) - !TODO - Make bedTopography and sfcMassBal state variables? call mpas_pool_get_array(meshPool, 'bedTopography', bedTopography) call mpas_pool_get_array(meshPool, 'sfcMassBal', sfcMassBal) + ! scratch fields + call mpas_pool_get_field(scratchPool, 'iceCellMask', iceCellMaskField) + call mpas_pool_get_field(scratchPool, 'iceEdgeMask', iceEdgeMaskField) + call mpas_pool_get_field(scratchPool, 'workLevelCell', workLevelCellField) + ! state variables call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel) + call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) call mpas_pool_get_array(statePool, 'upperSurface', upperSurface, timeLevel) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) @@ -205,36 +244,37 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) call mpas_pool_get_array(statePool, 'basalTemperature', basalTemperature, timeLevel) !Note: xtime only has one time level, but stating it explicitly here to avoid confusion call mpas_pool_get_array(statePool, 'xtime', xtime, timeLevel=1) + call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) ! config settings call mpas_pool_get_config(liConfigs, 'config_ice_density', rhoi) call mpas_pool_get_config(liConfigs, 'config_ice_specific_heat', shci) - call mpas_pool_get_config(liConfigs, 'config_seconds_per_year', scyr) call mpas_pool_get_config(liConfigs, 'config_stats_cell_ID', statsCellID) + call mpas_pool_get_config(liConfigs, 'config_kelvin_to_celsius', KtoC) + + call mpas_allocate_scratch_field(iceCellMaskField, .true.) + iceCellMask => iceCellMaskField % array + call mpas_allocate_scratch_field(iceEdgeMaskField, .true.) + iceEdgeMask => iceEdgeMaskField % array + call mpas_allocate_scratch_field(workLevelCellField, .true.) + workLevelCell => workLevelCellField % array ! compute ice cell mask (= 1 for cells where ice is present, else = 0) ! Note: Global sums are taken only over cells with mask = 1 - allocate(iceCellMask(nCellsSolve)) - do iCell = 1, nCellsSolve - if (li_mask_is_ice(cellMask(iCell))) then - iceCellMask(iCell) = 1 - else - iceCellMask(iCell) = 0 - endif - enddo + where (li_mask_is_ice(cellMask)) + iceCellMask = 1 + elsewhere + iceCellMask = 0 + endwhere ! compute ice edge mask (= 1 for edges of cells where ice is present, else = 0) - allocate(iceEdgeMask(nEdgesSolve)) - do iEdge = 1, nEdgesSolve - iCell1 = cellsOnEdge(1,iEdge) - iCell2 = cellsOnEdge(2,iEdge) - if (li_mask_is_ice(cellMask(iCell1)) .or. li_mask_is_ice(cellMask(iCell2))) then - iceEdgeMask(iEdge) = 1 - else - iceEdgeMask(iEdge) = 0 - endif - enddo + + where (li_mask_is_ice(edgeMask)) + iceEdgeMask = 1 + elsewhere + iceEdgeMask = 0 + endwhere ! Compute statistics on local block @@ -243,40 +283,43 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) call li_compute_field_local_stats(dminfo, & nVertLevels, nCellsSolve, & - layerThickness, iceCellMask, & + layerThickness, & + iceCellMask(1:nCellsSolve), & localSum, & localMin, localMax, & localVertSumMin, localVertSumMax, & localVertSumMinlocElement = localVertSumMinlocElement, & localVertSumMaxlocElement = localVertSumMaxlocElement) - thicknessMin = localVertSumMin - thicknessMax = localVertSumMax + if (localVertSumMin < thicknessMin) then + thicknessMin = localVertSumMin + thicknessMinlocCell = indexToCellID(localVertSumMinlocElement) + endif - ! global cell index for max/min values - thicknessMinlocCell = indexToCellID(localVertSumMinlocElement) - thicknessMaxlocCell = indexToCellID(localVertSumMaxlocElement) + if (localVertSumMax > thicknessMax) then + thicknessMax = localVertSumMax + thicknessMaxlocCell = indexToCellID(localVertSumMaxlocElement) + endif ! work array whose vertical sum = 1 everywhere - - if (.not. allocated(workArray)) allocate(workArray(nVertLevels,nCellsSolve)) - workArray(1,:) = 1.0_RKIND - workArray(2:nVertLevels,:) = 0.0_RKIND + workLevelCell(1,:) = 1.0_RKIND + workLevelCell(2:nVertLevels,:) = 0.0_RKIND ! total ice area call li_compute_field_area_weighted_local_stats & (dminfo, & nVertLevels, nCellsSolve, & areaCell(1:nCellsSolve), & - workArray, iceCellMask, & + workLevelCell(:,1:nCellsSolve), & + iceCellMask(1:nCellsSolve), & localSum, & localMin, localMax, & localVertSumMin, localVertSumMax) - iceAreaSum = localSum + iceAreaSum = iceAreaSum + localSum ! work array with a value of 1 in each layer - workArray(:,:) = 1.0_RKIND + workLevelCell(:,:) = 1.0_RKIND ! total ice volume call li_compute_field_volume_weighted_local_stats & @@ -284,36 +327,38 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) nVertLevels, nCellsSolve, & areaCell(1:nCellsSolve), & layerThickness(:,1:nCellsSolve), & - workArray, iceCellMask, & + workLevelCell(:,1:nCellsSolve), & + iceCellMask(1:nCellsSolve), & localSum, & localMin, localMax, & localVertSumMin, localVertSumMax) - iceVolumeSum = localSum + iceVolumeSum = iceVolumeSum + localSum ! max and min temperature ! optional maxloc/minloc arguments give the local cell IDs where max/mins are located - iTracer = 1 ! assume temperature is the first tracer array - - call li_compute_field_local_stats(dminfo, & - nVertLevels, nCellsSolve, & - tracers(iTracer,:,1:nCellsSolve), & - iceCellMask, & - localSum, & - localMin, localMax, & - localVertSumMin, localVertSumMax, & - localMinlocElement, localMinlocLevel, & + call li_compute_field_local_stats(dminfo, & + nVertLevels, nCellsSolve, & + tracers(indexTemperature,:,1:nCellsSolve), & + iceCellMask(1:nCellsSolve), & + localSum, & + localMin, localMax, & + localVertSumMin, localVertSumMax, & + localMinlocElement, localMinlocLevel, & localMaxlocElement, localMaxlocLevel) - temperatureMax = localMax - temperatureMin = localMin + if (localMin < temperatureMin) then + temperatureMin = localMin + temperatureMinlocCell = indexToCellID(localMinlocElement) + temperatureMinlocLevel = localMinlocLevel + endif - ! global cell and level indices for max/min values - temperatureMinlocCell = indexToCellID(localMinlocElement) - temperatureMinlocLevel = localMinlocLevel - temperatureMaxlocCell = indexToCellID(localMaxlocElement) - temperatureMaxlocLevel = localMaxlocLevel + if (localMax > temperatureMax) then + temperatureMax = localMax + temperatureMaxlocCell = indexToCellID(localMaxlocElement) + temperatureMaxlocLevel = localMaxlocLevel + endif ! total ice energy (relative to 0 deg C) !TODO - Compute ice energy differently if using the enthalpy scheme @@ -323,13 +368,13 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) nVertLevels, nCellsSolve, & areaCell(1:nCellsSolve), & layerThickness(:,1:nCellsSolve), & - tracers(iTracer,:,1:nCellsSolve), & - iceCellMask, & + tracers(indexTemperature,:,1:nCellsSolve), & + iceCellMask(1:nCellsSolve), & localSum, & localMin, localMax, & localVertSumMin, localVertSumMax) - iceEnergySum = localSum * rhoi * shci + iceEnergySum = iceEnergySum + localSum*rhoi*shci ! normal velocity at cell edges; find the maximum magnitude !TODO - If velocity is defined at layer interfaces, then nVertLevels -> nVertLevels + 1 @@ -337,59 +382,63 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) call li_compute_field_local_stats(dminfo, & nVertLevels, nEdgesSolve, & normalVelocity(:,1:nEdgesSolve), & - iceEdgeMask, & + iceEdgeMask(1:nEdgesSolve), & localSum, & localMin, localMax, & localVertSumMin, localVertSumMax, & localMinlocElement, localMinlocLevel, & localMaxlocElement, localMaxlocLevel) - velocityMax = max(localMax, -localMin) + localAbsoluteMax = max(localMax, -localMin) ! take maximum magnitude, independent of sign - ! global edge and level indices for max value - if (localMax > abs(localMin)) then - velocityMaxlocEdge = indexToEdgeID(localMaxlocElement) - velocityMaxlocLevel = localMaxlocLevel - else - velocityMaxlocEdge = indexToEdgeId(localMinlocElement) - velocityMaxlocLevel = localMinlocLevel + if (localAbsoluteMax > velocityMax) then + velocityMax = localAbsoluteMax + if (localMax > abs(localMin)) then + velocityMaxlocEdge = indexToEdgeID(localMaxlocElement) + velocityMaxlocLevel = localMaxlocLevel + else + velocityMaxlocEdge = indexToEdgeId(localMinlocElement) + velocityMaxlocLevel = localMinlocLevel + endif endif ! basal velocity at cell edges; find the maximum magnitude ! Note: If velocity is located at layer midpoints, this is actually the ! velocity in the lowest layer - call li_compute_field_local_stats(dminfo, & - 1, nEdgesSolve, & + call li_compute_field_local_stats(dminfo, & + 1, nEdgesSolve, & normalVelocity(nVertLevels,1:nEdgesSolve), & - iceEdgeMask, & - localSum, & - localMin, localMax, & - localVertSumMin, localVertSumMax, & - localMinlocElement, localMinlocLevel,& + iceEdgeMask(1:nEdgesSolve), & + localSum, & + localMin, localMax, & + localVertSumMin, localVertSumMax, & + localMinlocElement, localMinlocLevel, & localMaxlocElement, localMaxlocLevel) - basalVelocityMax = max(localMax, -localMin) - - ! global edge and level indices for max value - if (localMax > abs(localMin)) then - basalVelocityMaxlocEdge = indexToEdgeID(localMaxlocElement) - else - basalVelocityMaxlocEdge = indexToEdgeID(localMinlocElement) + localAbsoluteMax = max(localMax, -localMin) ! take maximum magnitude, independent of sign + + if (localAbsoluteMax > basalVelocityMax) then + basalVelocityMax = localAbsoluteMax + if (localMax > abs(localMin)) then + basalVelocityMaxlocEdge = indexToEdgeID(localMaxlocElement) + else + basalVelocityMaxlocEdge = indexToEdgeID(localMinlocElement) + endif endif ! allocate and initialize some diagnostic arrays if not done already !TODO - If velocity is defined at layer interfaces, then nVertLevels -> nVertLevels + 1 - if (.not. allocated(diagnosticTemperature)) then - allocate(diagnosticTemperature(nVertLevels)) - diagnosticTemperature(:) = 0.0_RKIND - endif - if (.not. allocated(diagnosticSpeed)) then allocate(diagnosticSpeed(nVertLevels)) diagnosticSpeed(:) = 0.0_RKIND endif + if (.not. allocated(diagnosticTemperature)) then + allocate(diagnosticTemperature(nVertLevels)) + diagnosticTemperature(:) = 0.0_RKIND + endif + ! Determine whether the user-specified diagnostic cell is on this block ! If so, then set some diagnostics to be broadcast later to the head processor @@ -405,13 +454,19 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) diagnosticSurfaceTemperature = surfaceTemperature(iCell) diagnosticBasalTemperature = basalTemperature(iCell) iEdge = edgesOnCell(1,iCell) ! arbitrarily choose edge #1 for velocity diagnostics + ! alternatively, could write out the cell-center velocity diagnosticSpeed(:) = normalVelocity(:,iEdge) * scyr ! convert from m/s to m/yr - diagnosticTemperature(:) = tracers(1,:,iCell) ! assume temperature is tracer #1 + diagnosticTemperature(:) = tracers(indexTemperature,:,iCell) endif enddo + ! clean up + call mpas_deallocate_scratch_field(iceCellMaskField, .true.) + call mpas_deallocate_scratch_field(iceEdgeMaskField, .true.) + call mpas_deallocate_scratch_field(workLevelCellField, .true.) + block => block % next - end do ! block loop + enddo ! block loop ! Compute global statistics ! TODO: Reduce the number of global reductions in this subroutine? @@ -485,70 +540,68 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) call mpas_dmpar_sum_real (dminfo, diagnosticBasalTemperature, diagnosticBasalTemperature) !TODO - Change to nVertLevels + 1 if velocity lives on layer interfaces - allocate (workArray1d(nVertLevels)) - call mpas_dmpar_sum_real_array(dminfo, nVertLevels, diagnosticSpeed, workArray1d) - diagnosticSpeed(:) = workArray1D(:) + allocate (workLevel(nVertLevels)) + call mpas_dmpar_sum_real_array(dminfo, nVertLevels, diagnosticSpeed, workLevel) + diagnosticSpeed(:) = workLevel(:) - call mpas_dmpar_sum_real_array(dminfo, nVertLevels, diagnosticTemperature, workArray1D) - diagnosticTemperature(:) = workArray1D(:) + call mpas_dmpar_sum_real_array(dminfo, nVertLevels, diagnosticTemperature, workLevel) + diagnosticTemperature(:) = workLevel(:) ! Write global and local stats to the log file - !TODO - Change stdout (6) to another fileunit? - + if (dminfo % my_proc_id == IO_NODE) then - write(6,*) ' ' - write(6,'(a60)') '------------------------------------------------------------' - write(6,*) ' ' - write(6,'(a25,a20)') 'Global statistics: time =', trim(xtime) - write(6,'(a25,i8)') ' timestep =', timeIndex - write(6,*) ' ' - write(6,'(a32,e24.16)') 'Total ice area (km^2) ', & + write(stdoutUnit,*) ' ' + write(stdoutUnit,'(a60)') '------------------------------------------------------------' + write(stdoutUnit,*) ' ' + write(stdoutUnit,'(a25,a20)') 'Global statistics: time =', trim(xtime) + write(stdoutUnit,'(a25,i8)') ' timestep =', itimestep + write(stdoutUnit,*) ' ' + write(stdoutUnit,'(a32,e24.16)') 'Total ice area (km^2) ', & globalIceAreaSum*1.0d-6 ! convert from m^2 to km^2 - write(6,'(a32,e24.16)') 'Total ice volume (km^3) ', & + write(stdoutUnit,'(a32,e24.16)') 'Total ice volume (km^3) ', & globalIceVolumeSum*1.0d-9 ! convert from m^3 to km^3 - write(6,'(a32,e24.16)') 'Total ice energy (J) ', & + write(stdoutUnit,'(a32,e24.16)') 'Total ice energy (J) ', & globalIceEnergySum - write(6,'(a32,f24.16,i8)') 'Max thickness (m), cell ', & + write(stdoutUnit,'(a32,f24.16,i8)') 'Max thickness (m), cell ', & globalThicknessMax, thicknessMaxlocCell - write(6,'(a32,f24.16,i8)') 'Min thickness (m), cell ', & + write(stdoutUnit,'(a32,f24.16,i8)') 'Min thickness (m), cell ', & globalThicknessMin, thicknessMinlocCell - write(6,'(a32,f24.16)') 'Mean thickness (m) ', & + write(stdoutUnit,'(a32,f24.16)') 'Mean thickness (m) ', & globalthicknessMean - write(6,'(a32,f24.16,i8,i4)') 'Max temperature (C), cell, level', & - globalTemperatureMax, temperatureMaxlocCell, temperatureMaxlocLevel - write(6,'(a32,f24.16,i8,i4)') 'Min temperature (C), cell, level', & - globalTemperatureMin, temperatureMinlocCell, temperatureMinlocLevel - write(6,'(a32,f24.16)') 'Mean temperature (C) ', & - globalTemperatureMean - write(6,'(a32,f24.16,i8,i4)') 'Max velocity (m/yr), edge, level', & + write(stdoutUnit,'(a32,f24.16,i8,i4)') 'Max temperature (C), cell, level', & + globalTemperatureMax - KtoC, temperatureMaxlocCell, temperatureMaxlocLevel + write(stdoutUnit,'(a32,f24.16,i8,i4)') 'Min temperature (C), cell, level', & + globalTemperatureMin - KtoC , temperatureMinlocCell, temperatureMinlocLevel + write(stdoutUnit,'(a32,f24.16)') 'Mean temperature (C) ', & + globalTemperatureMean - KtoC + write(stdoutUnit,'(a32,f24.16,i8,i4)') 'Max velocity (m/yr), edge, level', & globalVelocityMax * scyr, velocityMaxlocEdge, velocityMaxlocLevel - write(6,'(a32,f24.16,i8,i4)') 'Max basal velo (m/yr), edge ', & + write(stdoutUnit,'(a32,f24.16,i8,i4)') 'Max basal velo (m/yr), edge ', & globalBasalVelocityMax * scyr, basalVelocityMaxlocEdge - write(6,*) ' ' - write(6,'(a30,i6)') 'Column diagnostics: cell ID = ', statsCellID - write(6,'(a30,3i6)') 'Local cell ID, block, proc = ', diagnosticCell, diagnosticBlockID, diagnosticProcID - write(6,*) ' ' - write(6,'(a25,f24.16)') 'Upper surface (m) ', diagnosticUpperSurface - write(6,'(a25,f24.16)') 'Thickness (m) ', diagnosticThickness - write(6,'(a25,f24.16)') 'Bed topography (m) ', diagnosticBedTopography - write(6,'(a25,f24.16)') 'Sfc mass balance (m/yr) ', diagnosticSfcMassBal - write(6,*) ' ' - write(6,'(a55)') 'Sigma Ice speed (m/yr) Ice temperature (C)' - write(6,'(f6.4, a25, f24.16)') 0.0_RKIND, '------', diagnosticSurfaceTemperature + write(stdoutUnit,*) ' ' + write(stdoutUnit,'(a30,i6)') 'Column diagnostics: cell ID = ', statsCellID + write(stdoutUnit,'(a30,3i6)') 'Local cell ID, block, proc = ', diagnosticCell, diagnosticBlockID, diagnosticProcID + write(stdoutUnit,*) ' ' + write(stdoutUnit,'(a25,f24.16)') 'Upper surface (m) ', diagnosticUpperSurface + write(stdoutUnit,'(a25,f24.16)') 'Thickness (m) ', diagnosticThickness + write(stdoutUnit,'(a25,f24.16)') 'Bed topography (m) ', diagnosticBedTopography + write(stdoutUnit,'(a25,f24.16)') 'Sfc mass balance (m/yr) ', diagnosticSfcMassBal + write(stdoutUnit,*) ' ' + write(stdoutUnit,'(a55)') 'Sigma Ice speed (m/yr) Ice temperature (C)' + write(stdoutUnit,'(f6.4, a25, f24.16)') 0.0_RKIND, '------', diagnosticSurfaceTemperature - KtoC do kLevel = 1, nVertLevels - write(6,'(f6.4, f25.16, f24.16)') & - layerCenterSigma(kLevel), diagnosticSpeed(kLevel), diagnosticTemperature(kLevel) + write(stdoutUnit,'(f6.4, f25.16, f24.16)') & + layerCenterSigma(kLevel), diagnosticSpeed(kLevel), diagnosticTemperature(kLevel) - KtoC end do - write(6,'(f6.4, a25, f24.16)') 1.0_RKIND, '------', diagnosticBasalTemperature - write(6,*) ' ' + write(stdoutUnit,'(f6.4, a25, f24.16)') 1.0_RKIND, '------', diagnosticBasalTemperature - KtoC + write(stdoutUnit,*) ' ' endif ! my_proc_id = IO_NODE ! clean up - deallocate(workArray) - deallocate(workArray1d) - deallocate(diagnosticSpeed) + deallocate(workLevel) deallocate(diagnosticTemperature) - + deallocate(diagnosticSpeed) + end subroutine li_compute_statistics !*********************************************************************** From b50eff8f408f5c14530eb346c2108b2dda8f896a Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 17 Feb 2015 20:44:45 -0700 Subject: [PATCH 0006/1724] LI: Create li_constants module, use it in stats module For now it only has cp_ice, latent_heat_ice, triple_point, kelvin_to_celsius --- src/core_landice/Makefile | 4 +- src/core_landice/Registry.xml | 8 ---- src/core_landice/mpas_li_constants.F | 54 +++++++++++++++++++++++++++ src/core_landice/mpas_li_statistics.F | 21 +++++------ 4 files changed, 66 insertions(+), 21 deletions(-) create mode 100644 src/core_landice/mpas_li_constants.F diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index bead875257..02da7d6136 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -47,10 +47,12 @@ mpas_li_sia.o: mpas_li_mask.o \ mpas_li_setup.o mpas_li_statistics.o: mpas_li_mask.o \ - mpas_li_setup.o + mpas_li_setup.o \ + mpas_li_constants.o mpas_li_mask.o: mpas_li_setup.o +mpas_li_constants.o: clean: $(RM) *.o *.mod *.f90 libdycore.a diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 74c667cc25..791b114d5c 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -69,10 +69,6 @@ - - \brief MPAS land ice specific constants +!> \author Matthew Hoffman +!> \date 17 Feb. 2015 +!> \details +!> This module contains constants specific to the land ice model. +! +!----------------------------------------------------------------------- + +module li_constants + + use mpas_grid_types + use mpas_kind_types + +#ifdef MPAS_CESM + use shr_const_mod, only: & + cp_ice => SHR_CONST_CPICE,& + latent_heat_ice => SHR_CONST_LATICE,& + triple_point => SHR_CONST_TKTRIP + implicit none + save + +#else + + implicit none + save + + ! physical constants + real (kind=RKIND), parameter, public :: cp_ice = 2009.0_RKIND !< heat capacity of ice (J/kg/K) + real (kind=RKIND), parameter, public :: latent_heat_ice = 335.0d3 !< Latent heat of melting of ice (J/kg) + real (kind=RKIND), parameter, public :: triple_point = 273.16_RKIND !< Triple point of water (K) + +#endif + + ! conversion factors + real (kind=RKIND), parameter, public :: kelvin_to_celsius = 273.15_RKIND !< factor to convert Kelvin to Celsius + + +!*********************************************************************** + + +!*********************************************************************** + +end module li_constants diff --git a/src/core_landice/mpas_li_statistics.F b/src/core_landice/mpas_li_statistics.F index f95dc46b6e..3578e1188f 100644 --- a/src/core_landice/mpas_li_statistics.F +++ b/src/core_landice/mpas_li_statistics.F @@ -30,6 +30,7 @@ module li_statistics use mpas_timer use li_setup use li_mask + use li_constants implicit none private @@ -122,8 +123,6 @@ subroutine li_compute_statistics(domain, timeLevel, itimestep) ! config variables real (kind=RKIND), pointer :: rhoi ! ice density (kg/m^3) - real (kind=RKIND), pointer :: shci ! specific heat capacity of ice (J/deg/kg) - real (kind=RKIND), pointer :: KtoC ! 273.15; factor for converting Kelvin to Celsius integer, pointer :: statsCellID ! global ID of cell for which we write stats/diagnostics ! other pointers @@ -248,9 +247,7 @@ subroutine li_compute_statistics(domain, timeLevel, itimestep) ! config settings call mpas_pool_get_config(liConfigs, 'config_ice_density', rhoi) - call mpas_pool_get_config(liConfigs, 'config_ice_specific_heat', shci) call mpas_pool_get_config(liConfigs, 'config_stats_cell_ID', statsCellID) - call mpas_pool_get_config(liConfigs, 'config_kelvin_to_celsius', KtoC) call mpas_allocate_scratch_field(iceCellMaskField, .true.) iceCellMask => iceCellMaskField % array @@ -374,7 +371,7 @@ subroutine li_compute_statistics(domain, timeLevel, itimestep) localMin, localMax, & localVertSumMin, localVertSumMax) - iceEnergySum = iceEnergySum + localSum*rhoi*shci + iceEnergySum = iceEnergySum + localSum*rhoi*cp_ice ! normal velocity at cell edges; find the maximum magnitude !TODO - If velocity is defined at layer interfaces, then nVertLevels -> nVertLevels + 1 @@ -487,7 +484,7 @@ subroutine li_compute_statistics(domain, timeLevel, itimestep) endif if (globalIceVolumeSum > 0.0_RKIND) then - globalTemperatureMean = globalIceEnergySum / (globalIceVolumeSum * rhoi * shci) + globalTemperatureMean = globalIceEnergySum / (globalIceVolumeSum * rhoi * cp_ice) else globalTemperatureMean = 0.0_RKIND endif @@ -569,11 +566,11 @@ subroutine li_compute_statistics(domain, timeLevel, itimestep) write(stdoutUnit,'(a32,f24.16)') 'Mean thickness (m) ', & globalthicknessMean write(stdoutUnit,'(a32,f24.16,i8,i4)') 'Max temperature (C), cell, level', & - globalTemperatureMax - KtoC, temperatureMaxlocCell, temperatureMaxlocLevel + globalTemperatureMax - kelvin_to_celsius, temperatureMaxlocCell, temperatureMaxlocLevel write(stdoutUnit,'(a32,f24.16,i8,i4)') 'Min temperature (C), cell, level', & - globalTemperatureMin - KtoC , temperatureMinlocCell, temperatureMinlocLevel + globalTemperatureMin - kelvin_to_celsius , temperatureMinlocCell, temperatureMinlocLevel write(stdoutUnit,'(a32,f24.16)') 'Mean temperature (C) ', & - globalTemperatureMean - KtoC + globalTemperatureMean - kelvin_to_celsius write(stdoutUnit,'(a32,f24.16,i8,i4)') 'Max velocity (m/yr), edge, level', & globalVelocityMax * scyr, velocityMaxlocEdge, velocityMaxlocLevel write(stdoutUnit,'(a32,f24.16,i8,i4)') 'Max basal velo (m/yr), edge ', & @@ -588,12 +585,12 @@ subroutine li_compute_statistics(domain, timeLevel, itimestep) write(stdoutUnit,'(a25,f24.16)') 'Sfc mass balance (m/yr) ', diagnosticSfcMassBal write(stdoutUnit,*) ' ' write(stdoutUnit,'(a55)') 'Sigma Ice speed (m/yr) Ice temperature (C)' - write(stdoutUnit,'(f6.4, a25, f24.16)') 0.0_RKIND, '------', diagnosticSurfaceTemperature - KtoC + write(stdoutUnit,'(f6.4, a25, f24.16)') 0.0_RKIND, '------', diagnosticSurfaceTemperature - kelvin_to_celsius do kLevel = 1, nVertLevels write(stdoutUnit,'(f6.4, f25.16, f24.16)') & - layerCenterSigma(kLevel), diagnosticSpeed(kLevel), diagnosticTemperature(kLevel) - KtoC + layerCenterSigma(kLevel), diagnosticSpeed(kLevel), diagnosticTemperature(kLevel) - kelvin_to_celsius end do - write(stdoutUnit,'(f6.4, a25, f24.16)') 1.0_RKIND, '------', diagnosticBasalTemperature - KtoC + write(stdoutUnit,'(f6.4, a25, f24.16)') 1.0_RKIND, '------', diagnosticBasalTemperature - kelvin_to_celsius write(stdoutUnit,*) ' ' endif ! my_proc_id = IO_NODE From 94cb6459010455f4cdfb6b0c00a6bc4db574564f Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Fri, 16 Jan 2015 15:53:53 -0700 Subject: [PATCH 0007/1724] LI: move velocity fields to layer interfaces Up until now, velocity fields have had nVertLevels as the vertical dimension and were located vertically at the midpoints of layers. This commit moves them to the layer interfaces and uses the dimension nVertInterfaces. The SIA velocity solver and the FO thickness advection scheme have been updated to use this adjustment. For the Halfar test case with SIA, after 200 years, the new discretization results in thickness difference of no more than 0.4 m anywhere in the dome. Halfar error statistics are similar (generally very slightly smaller): Calculating velocity at layer midpoints directly: * RMS error = 7.64967419492 * Minimum error = -11.965715168 * Maximum error = 32.6677930106 * Mean error = 1.48743374354 * Median error = -1.74945246068 * Mean absolute error = 4.21985469326 * Median absolute error = 2.04201722556 Calculating velocity at layer interfaces and then averaging to layer midpoints for advection: * RMS error = 7.45981445537 * Minimum error = -13.23532514 * Maximum error = 31.8648384179 * Mean error = 1.48743374354 * Median error = -1.45224522457 * Mean absolute error = 4.03341684953 * Median absolute error = 1.79193706078 --- src/core_landice/Registry.xml | 16 ++++++++-------- src/core_landice/mpas_li_sia.F | 16 ++++++++-------- src/core_landice/mpas_li_tendency.F | 12 ++++++++---- 3 files changed, 24 insertions(+), 20 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 9abf938121..133811d299 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -33,7 +33,7 @@ - @@ -377,23 +377,23 @@ - - - - - - @@ -561,7 +561,7 @@ - 0.0_RKIND) then - maxAllowableDt = (0.5_RKIND * dcEdge(iEdge)) / abs(normalVelocity(k, iEdge)) ! in years + ! Average native velocities from layer interfaces to layer midpoints for advection + ! TODO This may make more sense to calculate as a 3d field somewhere else so it can also be used for tracer advection, output visualization, etc. + layerNormalVelocity = 0.5_RKIND * (normalVelocity(k, iEdge) + normalVelocity(k+1, iEdge)) + + if (abs(layerNormalVelocity) > 0.0_RKIND) then + maxAllowableDt = (0.5_RKIND * dcEdge(iEdge)) / abs(layerNormalVelocity) ! in years else maxAllowableDt = 1.0e36_RKIND endif @@ -656,7 +660,7 @@ subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknes endif MinOfMaxAllowableDt = min(MinOfMaxAllowableDt, maxAllowableDt) - flux = normalVelocity(k, iEdge) * dvEdge(iEdge) * layerThicknessEdge(k, iEdge) + flux = layerNormalVelocity * dvEdge(iEdge) * layerThicknessEdge(k, iEdge) tend(k, iCell) = tend(k, iCell) + edgeSignOnCell(i, iCell) * flux * invAreaCell end do end do From 9d2dee6cae38da291b17e5718fbdc8060a9b724a Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 29 Jan 2015 20:49:04 -0700 Subject: [PATCH 0008/1724] LI: add surfaceSpeed, basalSpeed arrays These are single layer speed fields that can be calculated for diagnostic output purposes. --- src/core_landice/Registry.xml | 6 ++++ src/core_landice/mpas_li_diagnostic_vars.F | 35 ++++++++++++++++------ 2 files changed, 32 insertions(+), 9 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 133811d299..91eeb477ef 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -400,6 +400,12 @@ + + diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index 2ca6e3c583..7ac1b3f0d2 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -111,14 +111,19 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) type (block_type), pointer :: block type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: statePool + character (len=StrKIND), pointer :: config_velocity_solver type (field2DReal), pointer :: normalVelocityField, layerThicknessEdgeField real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional + real (kind=RKIND), dimension(:), pointer :: surfaceSpeed, basalSpeed + integer, pointer :: nVertInterfaces integer :: err_tmp !!! integer :: blockVertexMaskChanged, procVertexMaskChanged, anyVertexMaskChanged err = 0 + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + ! === ! === Diagnostic solve of variables prior to velocity ! === @@ -201,17 +206,29 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) - - call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_pool_get_dimension(meshPool, 'nVertInterfaces', nVertInterfaces) call mpas_pool_get_array(statePool, 'uReconstructX', uReconstructX, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'uReconstructY', uReconstructY, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'uReconstructZ', uReconstructZ, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'uReconstructZonal', uReconstructZonal, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'uReconstructMeridional', uReconstructMeridional, timeLevel=timeLevel) - - call mpas_reconstruct(meshPool, normalVelocity, & - uReconstructX, uReconstructY, uReconstructZ, & - uReconstructZonal, uReconstructMeridional ) + call mpas_pool_get_array(statePool, 'surfaceSpeed', surfaceSpeed, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'basalSpeed', basalSpeed, timeLevel=timeLevel) + + ! Native SIA dycore needs to have reconstructed velocities calculated. + ! External dycores return their native velocities at cell center locations, + ! but these can optionally be overwritten by reconstructed velocities for testing. + if ( (trim(config_velocity_solver) == 'sia') ) then + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'uReconstructZ', uReconstructZ, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'uReconstructZonal', uReconstructZonal, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'uReconstructMeridional', uReconstructMeridional, timeLevel=timeLevel) + + call mpas_reconstruct(meshPool, normalVelocity, & + uReconstructX, uReconstructY, uReconstructZ, & + uReconstructZonal, uReconstructMeridional ) + endif + + ! Calculate diagnostic speed arrays + surfaceSpeed = sqrt(uReconstructX(1,:)**2 + uReconstructY(1,:)**2) + basalSpeed = sqrt(uReconstructX(nVertInterfaces,:)**2 + uReconstructY(nVertInterfaces,:)**2) block => block % next end do From 43ff5228a466f03174f336757c3a9b4383fc86a1 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Wed, 19 Nov 2014 22:12:31 -0700 Subject: [PATCH 0009/1724] LI: Add external velo solver functionality This commit adds the MPAS code needed to use external dycores with MPAS. This covers the L1L2, FO, and Stokes solvers available in LifeV, Albany, and PHG. This is a merge squash of the old commits 27b5c1 through ba800d in the landice/add_external_dycore_interface branch from the MPAS-Release repo (which may soon be deleted). They needed to be updated for Pools, and it was much easier to do it this way than preserve that old history, most of which was corrections, changing names of things, and minor updates to the API. This commit does *not* include the changes to the build system to include C++ interface code - that will follow in a separate commit. The external dycore wrapper is contained in the new mpas_li_velocity_external.F module. New "velocity_solver" options are now available when compiling with external velocity solver libraries: 'L1L2', 'FO', 'Stokes' Some details about this commit: * Calculation of anyVertexMaskChanged: if the vertex mask does not change between timesteps, then the external solvers do not need to recalculate their mesh information. MPAS now does a check for this considering the following to get the initial time setup correctly: 1) The calculation of anyVertexMaskChanged in diagnostic_solve_before_velocity() has to be saved to the specified timeLevel instead of always getting saved into time level 2 (since the initial solve currently is using time level 1). 2) vertexMask on time level 2 has to be initialized to impossible values so that the first call of diagnostic_solve_before_velocity() will think the mask has changed and therefore set anyVertexMaskChanged=1. * The array_from_exchange_list routine has been created to convert MPAS exchange lists into flat arrays to be used by external C/C++ velocity solvers. It makes use of dmpar functionality to convert an exchage list to a communication list and then converts the communication list to a specified flat array format. External dycores do not support multiple blocks per processor, but this implementation is written to support them where convenient. * External dycores need config_num_halos>=2. * The interface allows lifev to handle spheric geometries * The name of files, subroutines, flags and namelist options in this commit are meant to be generic (i.e., not specific to LifeV, Albany, or PHG). Unlike the earliest implementation of the interface, this commit assumes the API is fairly generic and does not care what code is on the other side of the interface, as long as it works! There is logic in the Makefile and in ifdefs in the code to only allow certain external libraries/solvers to do the things they are currently able to do. This will need to be updated as libraries evolve (e.g., if Albany becomes able to do L1L2 or Stokes solves). Details: * To build with an external library, you must specify on the 'make' line one or more of: ALBANY=true, LIFEV=true, PHG=true * There is logic in the Makefile that defines new variables based on the external library being linked (the flags above): USE_EXTERNAL_L1L2, USE_EXTERNAL_FIRSTORDER, USE_EXTERNAL_STOKES * ifdefs in the Fortran code match these Makefile variable names * subroutines in mpas_li_velocity_external.F have the albany, lifev and phg names avoided where appropriate to have a more general name * namelist options for the velocity solvers have had the library names removed. Valid options are now 'L1L2', 'FO', 'Stokes'. So if you specify 'FO', you will use Albany if you've compiled with Albany or LifeV if you've compiled with LifeV - you don't have to change the namelist option based on which external library you compiled with. * config_always_compute_fem_grid is a debug option that: Always computes finite-element grid information for external dycores rather than only doing so when the ice extent changes I have tested this commit with standalone MPAS/sia and confirmed that the code builds and the dome and EISMINT test cases remain unchanged. The commit also includes the Interface_velocity_solver.* files to actually interface with external dycores so the code will build with external dycores. To allow this, the LI Makefile has been updated: Logic has been added to only build the interface if one of the external dycores has been enabled. The building of the interface C++ code has been done in a general template for C++ code that can be extended to additional C++ files. get_prism_velocity_on_FEdges routine is for non-uniform meshes: The function computes the average normal velocity on the edges/faces of MPAS cells. It relies on the assumptions that 1. the locations of the circumcenters of two triangles sharing an edge are inside the union of the triangles 2. the locations of the cicumcenters should not coincide and should not be inverted (i.e. if triangle 1 precedes triangle 2 on the circumcenters line, then circumcenter 1 should preced circumceter 2). The flux obtained multiplying normal velocity with the area of the face corresponding that edge will be exact for linear-bilinear finte elements on the prisms. The flux will be second order accurate for other finite elements (e.g. linear or quadratic on Tetra). --- .../Interface_velocity_solver.cpp | 1743 +++++++++++++++++ .../Interface_velocity_solver.hpp | 281 +++ src/core_landice/Makefile | 62 +- src/core_landice/Registry.xml | 18 +- src/core_landice/mpas_li_diagnostic_vars.F | 75 +- src/core_landice/mpas_li_mpas_core.F | 10 + src/core_landice/mpas_li_tendency.F | 2 +- src/core_landice/mpas_li_velocity.F | 85 +- src/core_landice/mpas_li_velocity_external.F | 865 ++++++++ 9 files changed, 3054 insertions(+), 87 deletions(-) create mode 100644 src/core_landice/Interface_velocity_solver.cpp create mode 100644 src/core_landice/Interface_velocity_solver.hpp create mode 100644 src/core_landice/mpas_li_velocity_external.F diff --git a/src/core_landice/Interface_velocity_solver.cpp b/src/core_landice/Interface_velocity_solver.cpp new file mode 100644 index 0000000000..1ff12226b5 --- /dev/null +++ b/src/core_landice/Interface_velocity_solver.cpp @@ -0,0 +1,1743 @@ +// =================================================== +//! Includes +// =================================================== + +#include +#include "Interface_velocity_solver.hpp" +//#include +//#include +//#include + +// =================================================== +//! Namespaces +// =================================================== + +//typedef std::list exchangeList_Type; + +// ice_problem pointer + +int Ordering = 0; //ordering ==0 means that the mesh is extruded layerwise, whereas ordering==1 means that the mesh is extruded columnwise. +MPI_Comm comm, reducedComm; +bool isDomainEmpty = true; +bool initialize_velocity = true; +bool first_time_step = true; +int nCells_F, nEdges_F, nVertices_F; +int nCellsSolve_F, nEdgesSolve_F, nVerticesSolve_F; +int nVertices, nEdges, nTriangles, nGlobalVertices, nGlobalEdges, + nGlobalTriangles; +int maxNEdgesOnCell_F; +int const *cellsOnEdge_F, *cellsOnVertex_F, *verticesOnCell_F, + *verticesOnEdge_F, *edgesOnCell_F, *indexToCellID_F, *nEdgesOnCells_F; +std::vector layersRatio, levelsNormalizedThickness; +int nLayers; +double const *xCell_F, *yCell_F, *zCell_F, *xVertex_F, *yVertex_F, *zVertex_F, *areaTriangle_F; +std::vector xCellProjected, yCellProjected, zCellProjected; +const double unit_length = 1000; +const double T0 = 273.15; +const double minThick = 1e-3; //1m +const double minBeta = 1e-5; +//void *phgGrid = 0; +std::vector edgesToReceive, fCellsToReceive, indexToTriangleID, + verticesOnTria, trianglesOnEdge, trianglesPositionsOnEdge, verticesOnEdge; +std::vector indexToVertexID, vertexToFCell, indexToEdgeID, edgeToFEdge, + mask, fVertexToTriangleID, fCellToVertex; +std::vector temperatureOnTetra, velocityOnVertices, velocityOnCells, + elevationData, thicknessData, betaData, smb_F, thicknessOnCells; +std::vector isVertexBoundary, isBoundaryEdge; +; +int numBoundaryEdges; +double radius; + +exchangeList_Type const *sendCellsList_F = 0, *recvCellsList_F = 0; +exchangeList_Type const *sendEdgesList_F = 0, *recvEdgesList_F = 0; +exchangeList_Type const *sendVerticesList_F = 0, *recvVerticesList_F = 0; +exchangeList_Type sendCellsListReversed, recvCellsListReversed, + sendEdgesListReversed, recvEdgesListReversed; + +exchange::exchange(int _procID, int const* vec_first, int const* vec_last, + int fieldDim) : + procID(_procID), vec(vec_first, vec_last), buffer( + fieldDim * (vec_last - vec_first)), doubleBuffer( + fieldDim * (vec_last - vec_first)) { +} + +extern "C" { + +// =================================================== +//! Interface functions +// =================================================== +int velocity_solver_init_mpi(int* fComm) { + // get MPI_Comm from Fortran + comm = MPI_Comm_f2c(*fComm); + + return 0; +} + +void velocity_solver_export_2d_data(double const* lowerSurface_F, + double const* thickness_F, double const* beta_F) { + if (isDomainEmpty) + return; + + import2DFields(lowerSurface_F, thickness_F, beta_F, minThick); + + velocity_solver_export_2d_data__(reducedComm, elevationData, thicknessData, + betaData, indexToVertexID); +} + +void velocity_solver_set_grid_data(int const* _nCells_F, int const* _nEdges_F, + int const* _nVertices_F, int const* _nLevels, int const* _nCellsSolve_F, + int const* _nEdgesSolve_F, int const* _nVerticesSolve_F, + int const* _maxNEdgesOnCell_F, double const* radius_F, + int const* _cellsOnEdge_F, int const* _cellsOnVertex_F, + int const* _verticesOnCell_F, int const* _verticesOnEdge_F, + int const* _edgesOnCell_F, int const* _nEdgesOnCells_F, + int const* _indexToCellID_F, + double const* _xCell_F, double const* _yCell_F, double const* _zCell_F, + double const* _xVertex_F, double const* _yVertex_F, double const* _zVertex_F, + double const* _areaTriangle_F, + int const* sendCellsArray_F, int const* recvCellsArray_F, + int const* sendEdgesArray_F, int const* recvEdgesArray_F, + int const* sendVerticesArray_F, int const* recvVerticesArray_F) { + + nCells_F = *_nCells_F; + nEdges_F = *_nEdges_F; + nVertices_F = *_nVertices_F; + nLayers = *_nLevels-1; + nCellsSolve_F = *_nCellsSolve_F; + nEdgesSolve_F = *_nEdgesSolve_F; + nVerticesSolve_F = *_nVerticesSolve_F; + maxNEdgesOnCell_F = *_maxNEdgesOnCell_F; + radius = *radius_F; + cellsOnEdge_F = _cellsOnEdge_F; + cellsOnVertex_F = _cellsOnVertex_F; + verticesOnCell_F = _verticesOnCell_F; + verticesOnEdge_F = _verticesOnEdge_F; + edgesOnCell_F = _edgesOnCell_F; + nEdgesOnCells_F = _nEdgesOnCells_F; + indexToCellID_F = _indexToCellID_F; + xCell_F = _xCell_F; + yCell_F = _yCell_F; + zCell_F = _zCell_F; + xVertex_F = _xVertex_F; + yVertex_F = _yVertex_F; + zVertex_F = _zVertex_F; + areaTriangle_F = _areaTriangle_F; + mask.resize(nVertices_F); + + thicknessOnCells.resize(nCellsSolve_F); + + sendCellsList_F = new exchangeList_Type(unpackMpiArray(sendCellsArray_F)); + recvCellsList_F = new exchangeList_Type(unpackMpiArray(recvCellsArray_F)); + sendEdgesList_F = new exchangeList_Type(unpackMpiArray(sendEdgesArray_F)); + recvEdgesList_F = new exchangeList_Type(unpackMpiArray(recvEdgesArray_F)); + sendVerticesList_F = new exchangeList_Type( + unpackMpiArray(sendVerticesArray_F)); + recvVerticesList_F = new exchangeList_Type( + unpackMpiArray(recvVerticesArray_F)); + + if (radius > 10) { + xCellProjected.resize(nCells_F); + yCellProjected.resize(nCells_F); + zCellProjected.assign(nCells_F, 0.); + for (int i = 0; i < nCells_F; i++) { + double r = std::sqrt( + xCell_F[i] * xCell_F[i] + yCell_F[i] * yCell_F[i] + + zCell_F[i] * zCell_F[i]); + xCellProjected[i] = radius * std::asin(xCell_F[i] / r); + yCellProjected[i] = radius * std::asin(yCell_F[i] / r); + } + xCell_F = &xCellProjected[0]; + yCell_F = &yCellProjected[0]; + zCell_F = &zCellProjected[0]; + } +} + +void velocity_solver_init_l1l2(double const* levelsRatio_F) { +#ifdef LIFEV + velocityOnVertices.resize(2 * nVertices * (nLayers + 1), 0.); + velocityOnCells.resize(2 * nCells_F * (nLayers + 1), 0.); + + if (isDomainEmpty) + return; + + layersRatio.resize(nLayers); + // !!Indexing of layers is reversed + for (int i = 0; i < nLayers; i++) + layersRatio[i] = levelsRatio_F[nLayers - 1 - i]; + //std::copy(levelsRatio_F, levelsRatio_F+nLayers, layersRatio.begin()); + mapCellsToVertices(velocityOnCells, velocityOnVertices, 2, nLayers, Ordering); + + velocity_solver_init_l1l2__(layersRatio, velocityOnVertices, initialize_velocity); + initialize_velocity = false; +#endif +} + + + + +void velocity_solver_solve_l1l2(double const* lowerSurface_F, + double const* thickness_F, double const* beta_F, + double const* temperature_F, double* u_normal_F, double* xVelocityOnCell, double* yVelocityOnCell) { + +#ifdef LIFEV + + std::fill(u_normal_F, u_normal_F + nEdges_F * (nLayers+1), 0.); + + double localSum(0), sum(0); + + for (int i = 0; i < nCellsSolve_F; i++) { + localSum = std::max(localSum, + std::fabs(thickness_F[i] - thicknessOnCells[i])); + } + + MPI_Allreduce(&localSum, &sum, 1, MPI_DOUBLE, MPI_MAX, comm); + + std::cout << "Thickness change: " << sum << std::endl; + std::copy(thickness_F, thickness_F + nCellsSolve_F, &thicknessOnCells[0]); + + if (!isDomainEmpty) { + std::vector temperatureData(nLayers * nVertices); + + import2DFields(lowerSurface_F, thickness_F, beta_F, minThick); + + for (int index = 0; index < nVertices; index++) { + int iCell = vertexToFCell[index]; + for (int il = 0; il < nLayers; il++) { + temperatureData[index + il * nVertices] = temperature_F[iCell * nLayers + + (nLayers - il - 1)] + T0; + } + } + + + velocity_solver_solve_l1l2__(elevationData, thicknessData, betaData, + temperatureData, indexToVertexID, velocityOnVertices); + } + + + mapVerticesToCells (velocityOnVertices, &velocityOnCells[0], 2, nLayers, Ordering); + + //computing x, yVelocityOnCell + int sizeVelOnCell = nCells_F * (nLayers + 1); + for(int iCell=0; iCell regulThk(thicknessData); + for (int index = 0; index < nVertices; index++) + regulThk[index] = std::max(1e-4, thicknessData[index]); + + std::vector mpasIndexToVertexID(nVertices); + for (int i = 0; i < nVertices; i++) { + mpasIndexToVertexID[i] = indexToCellID_F[vertexToFCell[i]]; + } +#ifdef LIFEV + velocity_solver_export_l1l2_velocity__(layersRatio, elevationData, regulThk, mpasIndexToVertexID, reducedComm); +#endif +} + +void velocity_solver_init_fo(double const *levelsRatio_F) { + + velocityOnVertices.resize(2 * nVertices * (nLayers + 1), 0.); + velocityOnCells.resize(2 * nCells_F * (nLayers + 1), 0.); + + if (isDomainEmpty) + return; + + layersRatio.resize(nLayers); + // !!Indexing of layers is reversed + for (int i = 0; i < nLayers; i++) + layersRatio[i] = levelsRatio_F[nLayers - 1 - i]; + //std::copy(levelsRatio_F, levelsRatio_F+nLayers, layersRatio.begin()); + + mapCellsToVertices(velocityOnCells, velocityOnVertices, 2, nLayers, Ordering); + +#ifdef LIFEV + velocity_solver_init_fo__(layersRatio, velocityOnVertices, indexToVertexID, initialize_velocity); +#endif + // iceProblemPtr->initializeSolverFO(layersRatio, velocityOnVertices, thicknessData, elevationData, indexToVertexID, initialize_velocity); + initialize_velocity = false; +} + +void velocity_solver_solve_fo(double const* lowerSurface_F, + double const* thickness_F, double const* beta_F, + double const* temperature_F, double* u_normal_F, double* xVelocityOnCell, double* yVelocityOnCell) { + + std::fill(u_normal_F, u_normal_F + nEdges_F * (nLayers+1), 0.); + + if (!isDomainEmpty) { + +#ifdef LIFEV + double localSum(0), sum(0); + + for (int i = 0; i < nCellsSolve_F; i++) { + localSum = std::max(localSum, + std::fabs(thickness_F[i] - thicknessOnCells[i])); + } + + MPI_Allreduce(&localSum, &sum, 1, MPI_DOUBLE, MPI_MAX, comm); + + std::cout << "Thickness change: " << sum << std::endl; + std::copy(thickness_F, thickness_F + nCellsSolve_F, &thicknessOnCells[0]); +#endif + + + + import2DFields(lowerSurface_F, thickness_F, beta_F, minThick); + + std::vector regulThk(thicknessData); + for (int index = 0; index < nVertices; index++) + regulThk[index] = std::max(1e-4, thicknessData[index]); + + importP0Temperature(temperature_F); + + velocity_solver_solve_fo__(nLayers, nGlobalVertices, nGlobalTriangles, + Ordering, first_time_step, indexToVertexID, indexToTriangleID, minBeta, + regulThk, levelsNormalizedThickness, elevationData, thicknessData, + betaData, temperatureOnTetra, velocityOnVertices); + + std::vector mpasIndexToVertexID(nVertices); + for (int i = 0; i < nVertices; i++) { + mpasIndexToVertexID[i] = indexToCellID_F[vertexToFCell[i]]; + } + } + + mapVerticesToCells(velocityOnVertices, &velocityOnCells[0], 2, nLayers, + Ordering); + + //computing x, yVelocityOnCell + int sizeVelOnCell = nCells_F * (nLayers + 1); + for(int iCell=0; iCell velOnEdges(nEdges * (nLayers+1)); + for (int i = 0; i < nEdges; i++) { + for (int il = 0; il < nLayers+1; il++) { + velOnEdges[i * (nLayers+1) + il] = u_normal_F[edgeToFEdge[i] * (nLayers+1) + il]; + } + } + + allToAll(u_normal_F, &sendEdgesListReversed, &recvEdgesListReversed, nLayers+1); + + allToAll(u_normal_F, sendEdgesList_F, recvEdgesList_F, nLayers+1); + + first_time_step = false; + + +#ifdef LIFEV + + std::vector edgesProcId(nEdges_F), trianglesProcIds(nVertices_F); + getProcIds(edgesProcId, recvEdgesList_F); + getProcIds(trianglesProcIds, recvVerticesList_F); + + int localSumInt(0), sumInt(0); + + for (int i = 0; i < nEdges; i++) { + for (int il = 0; il < 1; il++) { + if (std::fabs( + velOnEdges[i * (nLayers+1) + il] + - u_normal_F[edgeToFEdge[i] * nLayers + il]) > 1e-9) + // if(edgeToFEdge[i]>nEdgesSolve_F) + { + localSumInt++; + int edge = edgeToFEdge[i]; + int gEdge = indexToEdgeID[i]; + ID fVertex0 = verticesOnEdge_F[2 * edge] - 1; + ID fVertex1 = verticesOnEdge_F[2 * edge + 1] - 1; + ID triaId0 = fVertexToTriangleID[fVertex0]; + ID triaId1 = fVertexToTriangleID[fVertex1]; + ID procTria0 = trianglesProcIds[fVertex0]; + ID procTria1 = trianglesProcIds[fVertex1]; + std::cout << "vs( " << velOnEdges[i * (nLayers+1) + il] << ", " + << u_normal_F[edgeToFEdge[i] * nLayers + il] << ") "; + std::cout << "edge: " << edge << ", gEdge: " << gEdge << ", on proc: " + << edgesProcId[edgeToFEdge[i]]; + if (triaId0 != NotAnId) { + std::cout << ". first tria0: " << triaId0 << " on proc: " + << procTria0; + } + if (triaId1 != NotAnId) { + std::cout << ".. second tria0:" << std::endl; + } + if ((triaId0 == NotAnId) || (triaId1 == NotAnId)) { + std::cout << ". and to Tria: " << triaId1 << " on proc: " << procTria1 + << std::endl; + } + + } + + //localSum = std::max(localSum, std::fabs(velOnEdges[i*nLayers+il] - u_normal_F[edgeToFEdge[i]*nLayers+il])); + } + } + + MPI_Allreduce(&localSumInt, &sumInt, 1, MPI_INT, MPI_SUM, comm); + + int localNum(sendEdgesListReversed.size()), num(0); + + MPI_Allreduce(&localNum, &num, 1, MPI_INT, MPI_SUM, comm); + + std::cout << "Edges change: " << sumInt << " " << num << std::endl; + +#endif + + + +} + + +void velocity_solver_export_fo_velocity() { + + if (isDomainEmpty) + return; + + velocity_solver_export_fo_velocity__(reducedComm); +} + +void velocity_solver_finalize() { + velocity_solver_finalize__(); + delete sendCellsList_F; + delete recvCellsList_F; + delete sendEdgesList_F; + delete recvEdgesList_F; + delete sendVerticesList_F; + delete recvVerticesList_F; +} + +/*duality: + * + * mpas(F) | lifev + * ---------|--------- + * cell | vertex + * vertex | triangle + * edge | edge + * + */ + +void velocity_solver_compute_2d_grid(int const* verticesMask_F) { + int numProcs, me; + + MPI_Comm_size(comm, &numProcs); + MPI_Comm_rank(comm, &me); + std::vector partialOffset(numProcs + 1), globalOffsetTriangles( + numProcs + 1), globalOffsetVertices(numProcs + 1), globalOffsetEdge( + numProcs + 1); + + std::vector triangleToFVertex; + triangleToFVertex.reserve(nVertices_F); + std::vector fVertexToTriangle(nVertices_F, NotAnId); + bool changed = false; + for (int i(0); i < nVerticesSolve_F; i++) { + if ((verticesMask_F[i] & 0x02) && !isGhostTriangle(i)) { + fVertexToTriangle[i] = triangleToFVertex.size(); + triangleToFVertex.push_back(i); + } + changed = changed || (verticesMask_F[i] != mask[i]); + } + + for (int i(0); i < nVertices_F; i++) + mask[i] = verticesMask_F[i]; + + if (changed) + std::cout << "mask changed!!" << std::endl; + + if ((me == 0) && (triangleToFVertex.size() == 0)) + for (int i(0); i < nVerticesSolve_F; i++) { + if (!isGhostTriangle(i)) { + fVertexToTriangle[i] = triangleToFVertex.size(); + triangleToFVertex.push_back(i); + break; + } + } + + nTriangles = triangleToFVertex.size(); + + initialize_iceProblem(nTriangles); + + //Compute the global number of triangles, and the localOffset on the local processor, such that a globalID = localOffset + index + int localOffset(0); + nGlobalTriangles = 0; + computeLocalOffset(nTriangles, localOffset, nGlobalTriangles); + + //Communicate the globalIDs, computed locally, to the other processors. + indexToTriangleID.resize(nTriangles); + + //To make local, not used + fVertexToTriangleID.assign(nVertices_F, NotAnId); + // std::vector fVertexToTriangleID(nVertices_F, NotAnId); + for (int index(0); index < nTriangles; index++) + fVertexToTriangleID[triangleToFVertex[index]] = index + localOffset; + + allToAll(fVertexToTriangleID, sendVerticesList_F, recvVerticesList_F); + + for (int index(0); index < nTriangles; index++) + indexToTriangleID[index] = fVertexToTriangleID[triangleToFVertex[index]]; + + //Compute triangle edges + std::vector fEdgeToEdge(nEdges_F), edgesToSend, trianglesProcIds( + nVertices_F); + getProcIds(trianglesProcIds, recvVerticesList_F); + + int interfaceSize(0); + + std::vector fEdgeToEdgeID(nEdges_F, NotAnId); + edgesToReceive.clear(); + edgeToFEdge.clear(); + isBoundaryEdge.clear(); + trianglesOnEdge.clear(); + + edgesToReceive.reserve(nEdges_F - nEdgesSolve_F); + edgeToFEdge.reserve(nEdges_F); + trianglesOnEdge.reserve(nEdges_F * 2); + edgesToSend.reserve(nEdgesSolve_F); + isBoundaryEdge.reserve(nEdges_F); + + //first, we compute boundary edges (boundary edges must be the first edges) + for (int i = 0; i < nEdges_F; i++) { + ID fVertex1(verticesOnEdge_F[2 * i] - 1), fVertex2( + verticesOnEdge_F[2 * i + 1] - 1); + ID triaId_1 = fVertexToTriangleID[fVertex1]; + ID triaId_2 = fVertexToTriangleID[fVertex2]; + bool isboundary = (triaId_1 == NotAnId) || (triaId_2 == NotAnId); + + ID iTria1 = fVertexToTriangle[fVertex1]; + ID iTria2 = fVertexToTriangle[fVertex2]; + if (iTria1 == NotAnId) + std::swap(iTria1, iTria2); + bool belongsToLocalTriangle = (iTria1 != NotAnId) || (iTria2 != NotAnId); + + if (belongsToLocalTriangle) { + if (isboundary) { + fEdgeToEdge[i] = edgeToFEdge.size(); + edgeToFEdge.push_back(i); + trianglesOnEdge.push_back(iTria1); + trianglesOnEdge.push_back(iTria2); + isBoundaryEdge.push_back(true); + } else + interfaceSize += (iTria2 == NotAnId); + } + } + + numBoundaryEdges = edgeToFEdge.size(); + + //procOnInterfaceEdge contains the pairs . + std::vector < std::pair > procOnInterfaceEdge; + procOnInterfaceEdge.reserve(interfaceSize); + + //then, we compute the other edges + for (int i = 0; i < nEdges_F; i++) { + + ID fVertex1(verticesOnEdge_F[2 * i] - 1), fVertex2( + verticesOnEdge_F[2 * i + 1] - 1); + ID iTria1 = fVertexToTriangle[fVertex1]; + ID iTria2 = fVertexToTriangle[fVertex2]; + + ID triaId_1 = fVertexToTriangleID[fVertex1]; //global Triangle + ID triaId_2 = fVertexToTriangleID[fVertex2]; //global Triangle + + if (iTria1 == NotAnId) { + std::swap(iTria1, iTria2); + std::swap(fVertex1, fVertex2); + } + + bool belongsToAnyTriangle = (triaId_1 != NotAnId) || (triaId_2 != NotAnId); + bool isboundary = (triaId_1 == NotAnId) || (triaId_2 == NotAnId); + bool belongsToLocalTriangle = (iTria1 != NotAnId); + bool isMine = i < nEdgesSolve_F; + + if (belongsToLocalTriangle && !isboundary) { + fEdgeToEdge[i] = edgeToFEdge.size(); + edgeToFEdge.push_back(i); + trianglesOnEdge.push_back(iTria1); + trianglesOnEdge.push_back(iTria2); + isBoundaryEdge.push_back(false); + if (iTria2 == NotAnId) + procOnInterfaceEdge.push_back( + std::make_pair(fEdgeToEdge[i], trianglesProcIds[fVertex2])); + } + + if (belongsToAnyTriangle && isMine) { + edgesToSend.push_back(i); + if (!belongsToLocalTriangle) + edgesToReceive.push_back(i); + } + + } + + //Compute the global number of edges, and the localOffset on the local processor, such that a globalID = localOffset + index + computeLocalOffset(edgesToSend.size(), localOffset, nGlobalEdges); + + //Communicate the globalIDs, computed locally, to the other processors. + for (ID index = 0; index < edgesToSend.size(); index++) + fEdgeToEdgeID[edgesToSend[index]] = index + localOffset; + + allToAll(fEdgeToEdgeID, sendEdgesList_F, recvEdgesList_F); + + nEdges = edgeToFEdge.size(); + indexToEdgeID.resize(nEdges); + for (int index = 0; index < nEdges; index++) + indexToEdgeID[index] = fEdgeToEdgeID[edgeToFEdge[index]]; + + //Compute vertices: + std::vector fCellsToSend; + fCellsToSend.reserve(nCellsSolve_F); + + vertexToFCell.clear(); + vertexToFCell.reserve(nCells_F); + + fCellToVertex.assign(nCells_F, NotAnId); + std::vector fCellToVertexID(nCells_F, NotAnId); + + fCellsToReceive.clear(); + + // if(! isDomainEmpty) + // { + fCellsToReceive.reserve(nCells_F - nCellsSolve_F); + for (int i = 0; i < nCells_F; i++) { + bool isMine = i < nCellsSolve_F; + bool belongsToLocalTriangle = false; + bool belongsToAnyTriangle = false; + int nEdg = nEdgesOnCells_F[i]; + for (int j = 0; j < nEdg; j++) { + ID fVertex(verticesOnCell_F[maxNEdgesOnCell_F * i + j] - 1); + ID iTria = fVertexToTriangle[fVertex]; + ID triaId = fVertexToTriangleID[fVertex]; + belongsToLocalTriangle = belongsToLocalTriangle || (iTria != NotAnId); + belongsToAnyTriangle = belongsToAnyTriangle || (triaId != NotAnId); + } + + if (belongsToAnyTriangle && isMine) { + fCellsToSend.push_back(i); + if (!belongsToLocalTriangle) + fCellsToReceive.push_back(i); + } + + if (belongsToLocalTriangle) { + fCellToVertex[i] = vertexToFCell.size(); + vertexToFCell.push_back(i); + } + } + // } + + //Compute the global number of vertices, and the localOffset on the local processor, such that a globalID = localOffset + index + computeLocalOffset(fCellsToSend.size(), localOffset, nGlobalVertices); + + //Communicate the globalIDs, computed locally, to the other processors. + for (int index = 0; index < int(fCellsToSend.size()); index++) + fCellToVertexID[fCellsToSend[index]] = index + localOffset; + + allToAll(fCellToVertexID, sendCellsList_F, recvCellsList_F); + + nVertices = vertexToFCell.size(); + std::cout << "\n nvertices: " << nVertices << " " << nGlobalVertices << "\n" + << std::endl; + indexToVertexID.resize(nVertices); + for (int index = 0; index < nVertices; index++) + indexToVertexID[index] = fCellToVertexID[vertexToFCell[index]]; + + createReverseCellsExchangeLists(sendCellsListReversed, recvCellsListReversed, + fVertexToTriangleID, fCellToVertexID); + + //construct the local vector vertices on triangles making sure the area is positive + verticesOnTria.resize(nTriangles * 3); + double x[3], y[3], z[3]; + for (int index = 0; index < nTriangles; index++) { + int iTria = triangleToFVertex[index]; + + for (int j = 0; j < 3; j++) { + int iCell = cellsOnVertex_F[3 * iTria + j] - 1; + verticesOnTria[3 * index + j] = fCellToVertex[iCell]; + x[j] = xCell_F[iCell]; + y[j] = yCell_F[iCell]; + // z[j] = zCell_F[iCell]; + } + if (signedTriangleArea(x, y) < 0) + std::swap(verticesOnTria[3 * index + 1], verticesOnTria[3 * index + 2]); + } + + //construct the local vector vertices on edges + trianglesPositionsOnEdge.resize(2 * nEdges); + isVertexBoundary.assign(nVertices, false); + + verticesOnEdge.resize(2 * nEdges); + + //contains the local id of a triangle and the global id of the edges of the triangle. + //dataForGhostTria[4*i] contains the triangle id + //dataForGhostTria[4*i+1+k] contains the global id of the edge (at position k = 0,1,2) of the triangle. + //Possible Optimization: for our purposes it would be enough to store two of the three edges of a triangle. + std::vector dataForGhostTria(nVertices_F * 4, NotAnId); + + //* + for (int iV = 0; iV < nVertices; iV++) { + int fCell = vertexToFCell[iV]; + int nEdg = nEdgesOnCells_F[fCell]; + int j = 0; + bool isBoundary; + do { + int fVertex = verticesOnCell_F[maxNEdgesOnCell_F * fCell + j++] - 1; + isBoundary = !(verticesMask_F[fVertex] & 0x02); + } while ((j < nEdg) && (!isBoundary)); + isVertexBoundary[iV] = isBoundary; + } + /*/ + for(int index=0; index verticesCoords(3 * nVertices); + + for (int index = 0; index < nVertices; index++) { + int iCell = vertexToFCell[index]; + verticesCoords[index * 3] = xCell_F[iCell] / unit_length; + verticesCoords[index * 3 + 1] = yCell_F[iCell] / unit_length; + verticesCoords[index * 3 + 2] = zCell_F[iCell] / unit_length; + } + + velocity_solver_compute_2d_grid__(nGlobalTriangles, + nGlobalVertices, nGlobalEdges, indexToVertexID, verticesCoords, + isVertexBoundary, verticesOnTria,isBoundaryEdge, trianglesOnEdge, + trianglesPositionsOnEdge, verticesOnEdge, indexToEdgeID, + indexToTriangleID, procOnInterfaceEdge ); +#else + velocity_solver_compute_2d_grid__(reducedComm); +#endif + + /* + + //initialize the mesh + iceProblemPtr->mesh2DPtr.reset (new RegionMesh() ); + + //construct the mesh nodes + constructNodes ( * (iceProblemPtr->mesh2DPtr), indexToVertexID, verticesCoords, isVertexBoundary, nGlobalVertices, 3); + + //construct the mesh elements + constructElements ( * (iceProblemPtr->mesh2DPtr), indexToTriangleID, verticesOnTria, nGlobalTriangles); + + //construct the mesh facets + constructFacets ( * (iceProblemPtr->mesh2DPtr), isBoundaryEdge, trianglesOnEdge, trianglesPositionsOnEdge, verticesOnEdge, indexToEdgeID, procOnInterfaceEdge, nGlobalEdges, 3); + + Switch sw; + std::vector elSign; + checkVolumes ( * (iceProblemPtr->mesh2DPtr), elSign, sw ); + */ +} + +void velocity_solver_extrude_3d_grid(double const* levelsRatio_F, + double const* lowerSurface_F, double const* thickness_F) { + + if (isDomainEmpty) + return; + + layersRatio.resize(nLayers); + // !!Indexing of layers is reversed + for (int i = 0; i < nLayers; i++) + layersRatio[i] = levelsRatio_F[nLayers - 1 - i]; + //std::copy(levelsRatio_F, levelsRatio_F+nLayers, layersRatio.begin()); + + levelsNormalizedThickness.resize(nLayers + 1); + + levelsNormalizedThickness[0] = 0; + for (int i = 0; i < nLayers; i++) + levelsNormalizedThickness[i + 1] = levelsNormalizedThickness[i] + + layersRatio[i]; + + std::vector mpasIndexToVertexID(nVertices); + for (int i = 0; i < nVertices; i++) + mpasIndexToVertexID[i] = indexToCellID_F[vertexToFCell[i]]; + + //construct the local vector of coordinates + std::vector verticesCoords(3 * nVertices); + + for (int index = 0; index < nVertices; index++) { + int iCell = vertexToFCell[index]; + verticesCoords[index * 3] = xCell_F[iCell] / unit_length; + verticesCoords[index * 3 + 1] = yCell_F[iCell] / unit_length; + verticesCoords[index * 3 + 2] = zCell_F[iCell] / unit_length; + } + + velocity_solver_extrude_3d_grid__(nLayers, nGlobalTriangles, nGlobalVertices, + nGlobalEdges, Ordering, reducedComm, indexToVertexID, mpasIndexToVertexID, + verticesCoords, isVertexBoundary, verticesOnTria, isBoundaryEdge, + trianglesOnEdge, trianglesPositionsOnEdge, verticesOnEdge, indexToEdgeID, + indexToTriangleID); + } +} + +//This function computes the average normal velocity on the edges/faces of MPAS cells. +//The function rely on the assumption that the locations of the circumcenters of two triangles sharing an edge are inside the union of the triangles and that +//the locations of the cicumcenters should not coincide and should not be inverted(i.e. if triangle 1 precedes triangle 2 on the circumcenters line, then circumcenter 1 should preced circumceter 2). +//The flux obtained multiplying normal velocity with the area of the face corresponding that edge will be exact for linear-bilinear finite elements on the prisms. +//The flux will be second order accurate for other finite elements (e.g. linear or quadratic on Tetrahedra). + +void get_prism_velocity_on_FEdges(double * uNormal, + const std::vector& velocityOnCells, + const std::vector& edgeToFEdge) { + + //using layout of velocityOnCells + int columnShift = 1; + int layerShift = (nLayers + 1); + + UInt nPoints3D = nCells_F * (nLayers + 1); + + //Looping through the internal edges of the triangulation + for (int i = numBoundaryEdges; i < nEdges; i++) { + + //identifying vertices on the edge + ID lId0 = verticesOnEdge[2 * i]; + ID lId1 = verticesOnEdge[2 * i + 1]; + int iCell0 = vertexToFCell[lId0]; + int iCell1 = vertexToFCell[lId1]; + + //computing normal to the cell edge (dual of triangular edge) + double nx = xCell_F[iCell1] - xCell_F[iCell0]; + double ny = yCell_F[iCell1] - yCell_F[iCell0]; + double n = sqrt(nx * nx + ny * ny); + nx /= n; + ny /= n; + + //computing midpoint of triangle edge + double p_mid[2] = {0.5*(xCell_F[iCell1] + xCell_F[iCell0]), 0.5*(yCell_F[iCell1] + yCell_F[iCell0])}; + + //identifying triangles that shares the edge + ID iEdge = edgeToFEdge[i]; + ID fVertex0 = verticesOnEdge_F[2 * iEdge] - 1; + ID fVertex1 = verticesOnEdge_F[2 * iEdge + 1] - 1; + ID triaId0 = fVertexToTriangleID[fVertex0]; + ID triaId1 = fVertexToTriangleID[fVertex1]; + double t0[2*3], t1[2*3]; //t0[0] contains the x-coords of vertices of triangle 0 and t0[1] its y-coords. + for (int j = 0; j < 3; j++) { + int iCell = cellsOnVertex_F[3 * fVertex0 + j] - 1; + t0[0 + 2 * j] = xCell_F[iCell]; + t0[1 + 2 * j] = yCell_F[iCell]; + iCell = cellsOnVertex_F[3 * fVertex1 + j] - 1; + t1[0 + 2 * j] = xCell_F[iCell]; + t1[1 + 2 * j] = yCell_F[iCell]; + } + + //getting triangle circumcenters (vertices of MPAS cells). + double circ[2][2] ,p[2],bcoords[2][3]; + circ[0][0] = xVertex_F[fVertex0]; circ[0][1] = yVertex_F[fVertex0]; + circ[1][0] = xVertex_F[fVertex1]; circ[1][1] = yVertex_F[fVertex1]; + + //Identify to what triangle the circumcenters belong and compute its baricentric coordinates + ID circToTria[2]; + ID iCells[2][3]; //iCells[k] is the array of cells indexes of triangle k on iEdge + for (int i=0; i<2; ++i) { //loop on the two vertices of mpas edge iEdge + if(belongToTria(circ[i], t0, bcoords[i])) { + circToTria[i] = fVertex0; + for (int j = 0; j < 3; j++) + iCells[i][j] = cellsOnVertex_F[3 * fVertex0 + j] - 1; + } + else if(belongToTria(circ[i], t1, bcoords[i])) { + circToTria[i] = fVertex1; + for (int j = 0; j < 3; j++) + iCells[i][j] = cellsOnVertex_F[3 * fVertex1 + j] - 1; + } + else { //error, edge midpont does not belong to either triangles + std::cout << "Error, edge midpont does not belong to either triangles" << std::endl; + for (int j = 0; j < 3; j++) + std::cout << "("<& velocityOnVertices, + double* velocityOnCells, int fieldDim, int numLayers, int ordering) { + int lVertexColumnShift = (ordering == 1) ? 1 : nVertices; + int vertexLayerShift = (ordering == 0) ? 1 : numLayers + 1; + + int nVertices3D = nVertices * (numLayers + 1); + for (UInt j = 0; j < nVertices3D; ++j) { + int ib = (ordering == 0) * (j % lVertexColumnShift) + + (ordering == 1) * (j / vertexLayerShift); + int il = (ordering == 0) * (j / lVertexColumnShift) + + (ordering == 1) * (j % vertexLayerShift); + + int iCell = vertexToFCell[ib]; + int cellIndex = iCell * (numLayers + 1) + il; + int vertexIndex = j; + for (int dim = 0; dim < fieldDim; dim++) { + velocityOnCells[cellIndex] = velocityOnVertices[vertexIndex]; + cellIndex += nCells_F * (numLayers + 1); + vertexIndex += nVertices3D; + } + } + + for (int dim = 0; dim < fieldDim; dim++) { + allToAll(&velocityOnCells[dim * nCells_F * (numLayers + 1)], + &sendCellsListReversed, &recvCellsListReversed, (numLayers + 1)); + allToAll(&velocityOnCells[dim * nCells_F * (numLayers + 1)], + sendCellsList_F, recvCellsList_F, (numLayers + 1)); + } +} + +void createReverseCellsExchangeLists(exchangeList_Type& sendListReverse_F, + exchangeList_Type& receiveListReverse_F, + const std::vector& fVertexToTriangleID, + const std::vector& fCellToVertexID) { + sendListReverse_F.clear(); + receiveListReverse_F.clear(); + //std::map > sendMap; + std::map > sendMap, receiveMap; + std::vector cellsProcId(nCells_F), trianglesProcIds(nVertices_F); + getProcIds(cellsProcId, recvCellsList_F); + getProcIds(trianglesProcIds, recvVerticesList_F); + + //std::cout << "SendList " ; + for (int i = 0; i < nVertices; i++) { + int iCell = vertexToFCell[i]; + if (iCell < nCellsSolve_F) + continue; + bool belongToTriaOnSameProc = false; + int j(0); + int nEdg = nEdgesOnCells_F[iCell]; + do { + ID fVertex(verticesOnCell_F[maxNEdgesOnCell_F * iCell + j] - 1); + ID triaId = fVertexToTriangleID[fVertex]; + belongToTriaOnSameProc = (triaId != NotAnId) + && (trianglesProcIds[fVertex] == cellsProcId[iCell]); + } while ((belongToTriaOnSameProc == false) && (++j < nEdg)); + if (!belongToTriaOnSameProc) { + sendMap[cellsProcId[iCell]].insert( + std::make_pair(fCellToVertexID[iCell], iCell)); + // std::cout<< "(" << cellsProcId[iCell] << "," << iCell << ") "; + } + + } + //std::cout < >::const_iterator it = sendMap.begin(); + it != sendMap.end(); it++) { + std::vector sendVec(it->second.size()); + int i = 0; + for (std::map::const_iterator iter = it->second.begin(); + iter != it->second.end(); iter++) + sendVec[i++] = iter->second; + sendListReverse_F.push_back( + exchange(it->first, &sendVec[0], &sendVec[0] + sendVec.size())); + } + + //std::cout << "ReceiveList " ; + for (UInt i = 0; i < fCellsToReceive.size(); i++) { + int iCell = fCellsToReceive[i]; + int nEdg = nEdgesOnCells_F[iCell]; + for (int j = 0; j < nEdg; j++) { + ID fVertex(verticesOnCell_F[maxNEdgesOnCell_F * iCell + j] - 1); + ID triaId = fVertexToTriangleID[fVertex]; + if (triaId != NotAnId) { + receiveMap[trianglesProcIds[fVertex]].insert( + std::make_pair(fCellToVertexID[iCell], iCell)); + // std::cout<< "(" << trianglesProcIds[fVertex] << "," << iCell << ") "; + } + } + } + //std::cout < >::const_iterator it = + receiveMap.begin(); it != receiveMap.end(); it++) { + std::vector receiveVec(it->second.size()); + int i = 0; + for (std::map::const_iterator iter = it->second.begin(); + iter != it->second.end(); iter++) + receiveVec[i++] = iter->second; + receiveListReverse_F.push_back( + exchange(it->first, &receiveVec[0], + &receiveVec[0] + receiveVec.size())); + } +} + +void createReverseEdgesExchangeLists(exchangeList_Type& sendListReverse_F, + exchangeList_Type& receiveListReverse_F, + const std::vector& fVertexToTriangleID, + const std::vector& fEdgeToEdgeID) { + sendListReverse_F.clear(); + receiveListReverse_F.clear(); + //std::map > sendMap; + std::map > sendMap, receiveMap; + std::vector edgesProcId(nEdges_F), trianglesProcIds(nVertices_F); + getProcIds(edgesProcId, recvEdgesList_F); + getProcIds(trianglesProcIds, recvVerticesList_F); + + //std::cout << "EdgesSendList " ; + for (int i = 0; i < nEdges; i++) { + int iEdge = edgeToFEdge[i]; + if (iEdge < nEdgesSolve_F) + continue; + bool belongToTriaOnSameProc = false; + int j(0); + do { + ID fVertex(verticesOnEdge_F[2 * iEdge + j] - 1); + ID triaId = fVertexToTriangleID[fVertex]; + belongToTriaOnSameProc = (triaId != NotAnId) + && (trianglesProcIds[fVertex] == edgesProcId[iEdge]); + } while ((belongToTriaOnSameProc == false) && (++j < 2)); + if (!belongToTriaOnSameProc) { + sendMap[edgesProcId[iEdge]].insert( + std::make_pair(fEdgeToEdgeID[iEdge], iEdge)); + //std::cout<< "(" << edgesProcId[iEdge] << "," << iEdge << ") "; + } + } + //std::cout < >::const_iterator it = sendMap.begin(); + it != sendMap.end(); it++) { + std::vector sendVec(it->second.size()); + int i = 0; + for (std::map::const_iterator iter = it->second.begin(); + iter != it->second.end(); iter++) + sendVec[i++] = iter->second; + sendListReverse_F.push_back( + exchange(it->first, &sendVec[0], &sendVec[0] + sendVec.size())); + } + + //std::cout << "EdgesReceiveList " ; + for (UInt i = 0; i < edgesToReceive.size(); i++) { + int iEdge = edgesToReceive[i]; + for (int j = 0; j < 2; j++) { + ID fVertex(verticesOnEdge_F[2 * iEdge + j] - 1); + ID triaId = fVertexToTriangleID[fVertex]; + if (triaId != NotAnId) { + receiveMap[trianglesProcIds[fVertex]].insert( + std::make_pair(fEdgeToEdgeID[iEdge], iEdge)); + // std::cout<< "(" << trianglesProcIds[fVertex] << "," << iEdge << ") "; + } + } + } + // std::cout < >::const_iterator it = + receiveMap.begin(); it != receiveMap.end(); it++) { + std::vector receiveVec(it->second.size()); + int i = 0; + for (std::map::const_iterator iter = it->second.begin(); + iter != it->second.end(); iter++) + receiveVec[i++] = iter->second; + receiveListReverse_F.push_back( + exchange(it->first, &receiveVec[0], + &receiveVec[0] + receiveVec.size())); + } +} + +void mapCellsToVertices(const std::vector& velocityOnCells, + std::vector& velocityOnVertices, int fieldDim, int numLayers, + int ordering) { + int lVertexColumnShift = (ordering == 1) ? 1 : nVertices; + int vertexLayerShift = (ordering == 0) ? 1 : numLayers + 1; + + int nVertices3D = nVertices * (numLayers + 1); + for (UInt j = 0; j < nVertices3D; ++j) { + int ib = (ordering == 0) * (j % lVertexColumnShift) + + (ordering == 1) * (j / vertexLayerShift); + int il = (ordering == 0) * (j / lVertexColumnShift) + + (ordering == 1) * (j % vertexLayerShift); + + int iCell = vertexToFCell[ib]; + int cellIndex = iCell * (numLayers + 1) + il; + int vertexIndex = j; + for (int dim = 0; dim < fieldDim; dim++) { + velocityOnVertices[vertexIndex] = velocityOnCells[cellIndex]; + cellIndex += nCells_F * (numLayers + 1); + vertexIndex += nVertices3D; + } + } +} + +bool isGhostTriangle(int i, double relTol) { + double x[3], y[3], area; + + for (int j = 0; j < 3; j++) { + int iCell = cellsOnVertex_F[3 * i + j] - 1; + x[j] = xCell_F[iCell]; + y[j] = yCell_F[iCell]; + } + + area = std::fabs(signedTriangleArea(x, y)); + return false; //(std::fabs(areaTriangle_F[i]-area)/areaTriangle_F[i] > relTol); +} + +double signedTriangleArea(const double* x, const double* y) { + double u[2] = { x[1] - x[0], y[1] - y[0] }; + double v[2] = { x[2] - x[0], y[2] - y[0] }; + + return 0.5 * (u[0] * v[1] - u[1] * v[0]); +} + +double signedTriangleAreaOnSphere(const double* x, const double* y, + const double *z) { + double u[3] = { x[1] - x[0], y[1] - y[0], z[1] - z[0] }; + double v[3] = { x[2] - x[0], y[2] - y[0], z[2] - z[0] }; + + double crossProduct[3] = { u[1] * v[2] - u[2] * v[1], u[2] * v[0] + - u[0] * v[2], u[0] * v[1] - u[1] * v[0] }; + double area = 0.5 + * std::sqrt( + crossProduct[0] * crossProduct[0] + crossProduct[1] * crossProduct[1] + + crossProduct[2] * crossProduct[2]); + return + (crossProduct[0] * x[0] + crossProduct[1] * y[0] + crossProduct[2] * z[0] + > 0) ? area : -area; +} + +//TO BE FIXED, Access To verticesOnCell_F is not correct +void extendMaskByOneLayer(int const* verticesMask_F, + std::vector& extendedFVerticesMask) { + extendedFVerticesMask.resize(nVertices_F); + extendedFVerticesMask.assign(&verticesMask_F[0], + &verticesMask_F[0] + nVertices_F); + for (int i = 0; i < nCells_F; i++) { + bool belongsToMarkedTriangle = false; + int nEdg = nEdgesOnCells_F[i]; + for (UInt k = 0; k < nEdg && !belongsToMarkedTriangle; k++) + belongsToMarkedTriangle = belongsToMarkedTriangle + || verticesMask_F[verticesOnCell_F[maxNEdgesOnCell_F * i + k] - 1]; + if (belongsToMarkedTriangle) + for (UInt k = 0; k < nEdg; k++) { + ID fVertex(verticesOnCell_F[maxNEdgesOnCell_F * i + k] - 1); + extendedFVerticesMask[fVertex] = !isGhostTriangle(fVertex); + } + } +} + +void import2DFields(double const * lowerSurface_F, double const * thickness_F, + double const * beta_F, double eps) { + elevationData.assign(nVertices, 1e10); + thicknessData.assign(nVertices, 1e10); + std::map bdExtensionMap; + if (beta_F != 0) + betaData.assign(nVertices, 1e10); + + for (int iV = 0; iV < nVertices; iV++) { + if (isVertexBoundary[iV]) { + int c; + int fCell = vertexToFCell[iV]; + int nEdg = nEdgesOnCells_F[fCell]; + for (int j = 0; j < nEdg; j++) { + int fEdge = edgesOnCell_F[maxNEdgesOnCell_F * fCell + j] - 1; + bool keep = (mask[verticesOnEdge_F[2 * fEdge] - 1] & 0x02) + && (mask[verticesOnEdge_F[2 * fEdge + 1] - 1] & 0x02); + if (!keep) + continue; + + int c0 = cellsOnEdge_F[2 * fEdge] - 1; + int c1 = cellsOnEdge_F[2 * fEdge + 1] - 1; + c = (fCellToVertex[c0] == iV) ? c1 : c0; + double elev = thickness_F[c] + lowerSurface_F[c]; // - 1e-8*std::sqrt(pow(xCell_F[c0],2)+std::pow(yCell_F[c0],2)); + if (elevationData[iV] > elev) { + elevationData[iV] = elev; + bdExtensionMap[iV] = c; + } + } + } + } + + for (std::map::iterator it = bdExtensionMap.begin(); + it != bdExtensionMap.end(); ++it) { + int iv = it->first; + int ic = it->second; + thicknessData[iv] = std::max(thickness_F[ic] / unit_length, eps); + elevationData[iv] = thicknessData[iv] + lowerSurface_F[ic] / unit_length; + if (beta_F != 0) + betaData[iv] = beta_F[ic] / unit_length; + } + + for (int index = 0; index < nVertices; index++) { + int iCell = vertexToFCell[index]; + + if (!isVertexBoundary[index]) { + thicknessData[index] = std::max(thickness_F[iCell] / unit_length, eps); + elevationData[index] = (lowerSurface_F[iCell] / unit_length) + thicknessData[index]; + } + } + + if (beta_F != 0) { + for (int index = 0; index < nVertices; index++) { + int iCell = vertexToFCell[index]; + + if (!isVertexBoundary[index]) + betaData[index] = beta_F[iCell] / unit_length; + } + } + +} + +void importP0Temperature(double const * temperature_F) { + int lElemColumnShift = (Ordering == 1) ? 3 : 3 * indexToTriangleID.size(); + int elemLayerShift = (Ordering == 0) ? 3 : 3 * nLayers; + temperatureOnTetra.resize(3 * nLayers * indexToTriangleID.size()); + for (int index = 0; index < nTriangles; index++) { + for (int il = 0; il < nLayers; il++) { + double temperature = 0; + int ilReversed = nLayers - il - 1; + int nPoints = 0; + for (int iVertex = 0; iVertex < 3; iVertex++) { + int v = verticesOnTria[iVertex + 3 * index]; + if (!isVertexBoundary[v]) { + int iCell = vertexToFCell[v]; + temperature += temperature_F[iCell * nLayers + ilReversed]; + nPoints++; + } + } + if (nPoints == 0) + temperature = T0; + else + temperature = temperature / nPoints + T0; + for (int k = 0; k < 3; k++) + temperatureOnTetra[index * elemLayerShift + il * lElemColumnShift + k] = + temperature; + } + } + +} + +void createReducedMPI(int nLocalEntities, MPI_Comm& reduced_comm_id) { + int numProcs, me; + MPI_Group world_group_id, reduced_group_id; + MPI_Comm_size(comm, &numProcs); + MPI_Comm_rank(comm, &me); + std::vector haveElements(numProcs); + int nonEmpty = int(nLocalEntities > 0); + MPI_Allgather(&nonEmpty, 1, MPI_INT, &haveElements[0], 1, MPI_INT, comm); + std::vector ranks; + for (int i = 0; i < numProcs; i++) { + if (haveElements[i]) + ranks.push_back(i); + } + + MPI_Comm_group(comm, &world_group_id); + MPI_Group_incl(world_group_id, ranks.size(), &ranks[0], &reduced_group_id); + MPI_Comm_create(comm, reduced_group_id, &reduced_comm_id); +} + +void computeLocalOffset(int nLocalEntities, int& localOffset, + int& nGlobalEntities) { + int numProcs, me; + MPI_Comm_size(comm, &numProcs); + MPI_Comm_rank(comm, &me); + std::vector offsetVec(numProcs); + + MPI_Allgather(&nLocalEntities, 1, MPI_INT, &offsetVec[0], 1, MPI_INT, comm); + + localOffset = 0; + for (int i = 0; i < me; i++) + localOffset += offsetVec[i]; + + nGlobalEntities = localOffset; + for (int i = me; i < numProcs; i++) + nGlobalEntities += offsetVec[i]; +} + +void getProcIds(std::vector& field, int const * recvArray) { + int me; + MPI_Comm_rank(comm, &me); + field.assign(field.size(), me); + + //unpack recvArray and set the proc rank into filed + for (int i(1), procID, size; i < recvArray[0]; i += size) { + procID = recvArray[i++]; + size = recvArray[i++]; + if (procID == me) + continue; + for (int k = i; k < i + size; k++) + field[recvArray[k]] = procID; + } +} + +void getProcIds(std::vector& field, exchangeList_Type const * recvList) { + int me; + MPI_Comm_rank(comm, &me); + field.assign(field.size(), me); + exchangeList_Type::const_iterator it; + + for (it = recvList->begin(); it != recvList->end(); ++it) { + if (it->procID == me) + continue; + for (int k = 0; k < (int) it->vec.size(); k++) + field[it->vec[k]] = it->procID; + } +} + +exchangeList_Type unpackMpiArray(int const * array) { + exchangeList_Type list; + for (int i(1), procID, size; i < array[0]; i += size) { + procID = array[i++]; + size = array[i++]; + list.push_back(exchange(procID, &array[i], &array[i + size])); + } + return list; +} + +void allToAll(std::vector& field, int const * sendArray, + int const * recvArray, int fieldDim) { + exchangeList_Type sendList, recvList; + + //unpack sendArray and build the sendList class + for (int i(1), procID, size; i < sendArray[0]; i += size) { + procID = sendArray[i++]; + size = sendArray[i++]; + sendList.push_back( + exchange(procID, &sendArray[i], &sendArray[i + size], fieldDim)); + } + + //unpack recvArray and build the recvList class + for (int i(1), procID, size; i < recvArray[0]; i += size) { + procID = recvArray[i++]; + size = recvArray[i++]; + recvList.push_back( + exchange(procID, &recvArray[i], &recvArray[i + size], fieldDim)); + } + + int me; + MPI_Comm_rank(comm, &me); + + exchangeList_Type::iterator it; + for (it = recvList.begin(); it != recvList.end(); ++it) { + if (it->procID == me) + continue; + MPI_Irecv(&(it->buffer[0]), it->buffer.size(), MPI_INT, it->procID, + it->procID, comm, &it->reqID); + } + + for (it = sendList.begin(); it != sendList.end(); ++it) { + if (it->procID == me) + continue; + for (ID i = 0; i < it->vec.size(); i++) + for (int iComp = 0; iComp < fieldDim; iComp++) + it->buffer[fieldDim * i + iComp] = field[fieldDim * it->vec[i] + iComp]; + + MPI_Isend(&(it->buffer[0]), it->buffer.size(), MPI_INT, it->procID, me, + comm, &it->reqID); + } + + for (it = recvList.begin(); it != recvList.end(); ++it) { + if (it->procID == me) + continue; + MPI_Wait(&it->reqID, MPI_STATUS_IGNORE); + + for (int i = 0; i < int(it->vec.size()); i++) + for (int iComp = 0; iComp < fieldDim; iComp++) + field[fieldDim * it->vec[i] + iComp] = it->buffer[fieldDim * i + iComp]; + } + + for (it = sendList.begin(); it != sendList.end(); ++it) { + if (it->procID == me) + continue; + MPI_Wait(&it->reqID, MPI_STATUS_IGNORE); + } +} + +void allToAll(std::vector& field, exchangeList_Type const * sendList, + exchangeList_Type const * recvList, int fieldDim) { + int me; + MPI_Comm_rank(comm, &me); + + for (int iComp = 0; iComp < fieldDim; iComp++) { + exchangeList_Type::const_iterator it; + for (it = recvList->begin(); it != recvList->end(); ++it) { + if (it->procID == me) + continue; + MPI_Irecv(&(it->buffer[0]), it->buffer.size(), MPI_INT, it->procID, + it->procID, comm, &it->reqID); + } + + for (it = sendList->begin(); it != sendList->end(); ++it) { + if (it->procID == me) + continue; + for (ID i = 0; i < it->vec.size(); i++) + it->buffer[i] = field[fieldDim * it->vec[i] + iComp]; + + MPI_Isend(&(it->buffer[0]), it->buffer.size(), MPI_INT, it->procID, me, + comm, &it->reqID); + } + + for (it = recvList->begin(); it != recvList->end(); ++it) { + if (it->procID == me) + continue; + MPI_Wait(&it->reqID, MPI_STATUS_IGNORE); + + for (int i = 0; i < int(it->vec.size()); i++) + field[fieldDim * it->vec[i] + iComp] = it->buffer[i]; + } + + for (it = sendList->begin(); it != sendList->end(); ++it) { + if (it->procID == me) + continue; + MPI_Wait(&it->reqID, MPI_STATUS_IGNORE); + } + } +} + +void allToAll(double* field, exchangeList_Type const * sendList, + exchangeList_Type const * recvList, int fieldDim) { + int me; + MPI_Comm_rank(comm, &me); + + for (int iComp = 0; iComp < fieldDim; iComp++) { + exchangeList_Type::const_iterator it; + + for (it = recvList->begin(); it != recvList->end(); ++it) { + if (it->procID == me) + continue; + MPI_Irecv(&(it->doubleBuffer[0]), it->doubleBuffer.size(), MPI_DOUBLE, + it->procID, it->procID, comm, &it->reqID); + } + + for (it = sendList->begin(); it != sendList->end(); ++it) { + if (it->procID == me) + continue; + for (ID i = 0; i < it->vec.size(); i++) + it->doubleBuffer[i] = field[fieldDim * it->vec[i] + iComp]; + + MPI_Isend(&(it->doubleBuffer[0]), it->doubleBuffer.size(), MPI_DOUBLE, + it->procID, me, comm, &it->reqID); + } + + for (it = recvList->begin(); it != recvList->end(); ++it) { + if (it->procID == me) + continue; + MPI_Wait(&it->reqID, MPI_STATUS_IGNORE); + + for (int i = 0; i < int(it->vec.size()); i++) + field[fieldDim * it->vec[i] + iComp] = it->doubleBuffer[i]; + } + + for (it = sendList->begin(); it != sendList->end(); ++it) { + if (it->procID == me) + continue; + MPI_Wait(&it->reqID, MPI_STATUS_IGNORE); + } + } +} + +int initialize_iceProblem(int nTriangles) { + bool keep_proc = nTriangles > 0; + + createReducedMPI(keep_proc, reducedComm); + + isDomainEmpty = !keep_proc; + + +#ifdef LIFEV +if(!isDomainEmpty) { + velocity_solver_initialize_iceProblem__(keep_proc, reducedComm); +} +#endif + + // initialize ice problem pointer + if (keep_proc) { + std::cout << nTriangles + << " elements of the triangular grid are stored on this processor" + << std::endl; + } else { + std::cout + << "No elements of the triangular grid are stored on this processor" + << std::endl; + } + + return 0; +} + +//barycentric coordinates bcoords are properly updated only when functions return true. +bool belongToTria(double const* x, double const* t, double bcoords[3], double eps) { + double v1[2],v2[2],v3[2]; + for(int i=0; i<2; ++i) { + v1[i] = t[i + 2 * 0]; + v2[i] = t[i + 2 * 1]; + v3[i] = t[i + 2 * 2]; + } + double det = (v3[1]-v2[1])*(v3[0]-v1[0]) - (v3[0]-v2[0])*(v3[1]-v1[1]); + double c1,c2; + return ( (bcoords[0] = ((v3[1]-v2[1])*(v3[0]-x[0]) - (v3[0]-v2[0])*(v3[1]-x[1]))/det) > -eps) && + ( (bcoords[1] = (-(v3[1]-v1[1])*(v3[0]-x[0]) + (v3[0]-v1[0])*(v3[1]-x[1]))/det) > -eps) && + ( (bcoords[2] = 1.0 - bcoords[0] - bcoords[1]) > -eps ); +} + +int prismType(long long int const* prismVertexMpasIds, int& minIndex) +{ + int PrismVerticesMap[6][6] = {{0, 1, 2, 3, 4, 5}, {1, 2, 0, 4, 5, 3}, {2, 0, 1, 5, 3, 4}, {3, 5, 4, 0, 2, 1}, {4, 3, 5, 1, 0, 2}, {5, 4, 3, 2, 1, 0}}; + minIndex = std::min_element (prismVertexMpasIds, prismVertexMpasIds + 3) - prismVertexMpasIds; + + int v1 (prismVertexMpasIds[PrismVerticesMap[minIndex][1]]); + int v2 (prismVertexMpasIds[PrismVerticesMap[minIndex][2]]); + + return v1 > v2; +} + + void tetrasFromPrismStructured (long long int const* prismVertexMpasIds, long long int const* prismVertexGIds, long long int tetrasIdsOnPrism[][4]) + { + int PrismVerticesMap[6][6] = {{0, 1, 2, 3, 4, 5}, {1, 2, 0, 4, 5, 3}, {2, 0, 1, 5, 3, 4}, {3, 5, 4, 0, 2, 1}, {4, 3, 5, 1, 0, 2}, {5, 4, 3, 2, 1, 0}}; + + int tetraOfPrism[2][3][4] = {{{0, 1, 2, 5}, {0, 1, 5, 4}, {0, 4, 5, 3}}, {{0, 1, 2, 4}, {0, 4, 2, 5}, {0, 4, 5, 3}}}; + + int tetraAdjacentToPrismLateralFace[2][3][2] = {{{1, 2}, {0, 1}, {0, 2}}, {{0, 2}, {0, 1}, {1, 2}}}; + int tetraFaceIdOnPrismLateralFace[2][3][2] = {{{0, 0}, {1, 1}, {2, 2}}, {{0, 0}, {1, 1}, {2, 2}}}; + int tetraAdjacentToBottomFace = 0; //does not depend on type; + int tetraAdjacentToUpperFace = 2; //does not depend on type; + int tetraFaceIdOnBottomFace = 3; //does not depend on type; + int tetraFaceIdOnUpperFace = 0; //does not depend on type; + + int minIndex; + int prismT = prismType(prismVertexMpasIds, minIndex); + + long long int reorderedPrismLIds[6]; + + for (int ii = 0; ii < 6; ii++) + { + reorderedPrismLIds[ii] = prismVertexGIds[PrismVerticesMap[minIndex][ii]]; + } + + for (int iTetra = 0; iTetra < 3; iTetra++) + for (int iVertex = 0; iVertex < 4; iVertex++) + { + tetrasIdsOnPrism[iTetra][iVertex] = reorderedPrismLIds[tetraOfPrism[prismT][iTetra][iVertex]]; + } + } + + + void computeMap() + { + int PrismVerticesMap[6][6] = {{0, 1, 2, 3, 4, 5}, {1, 2, 0, 4, 5, 3}, {2, 0, 1, 5, 3, 4}, {3, 5, 4, 0, 2, 1}, {4, 3, 5, 1, 0, 2}, {5, 4, 3, 2, 1, 0}}; + + int tetraOfPrism[2][3][4] = {{{0, 1, 2, 5}, {0, 1, 5, 4}, {0, 4, 5, 3}}, {{0, 1, 2, 4}, {0, 4, 2, 5}, {0, 4, 5, 3}}}; + + int TetraFaces[4][3] = {{0 , 1 , 3}, {1 , 2 , 3}, {0 , 3 , 2}, {0 , 2 , 1}}; + + int PrismFaces[5][4] = {{0 , 1 , 4 , 3}, {1 , 2 , 5 , 4}, {0 , 3 , 5 , 2}, {0 , 2 , 1 , -1}, {3 , 4 , 5, -1}}; + + + for(int pType=0; pType<2; ++pType){ + std::cout<< "pType: " << pType < v2; + + for (int iTetra = 0; iTetra < 3; iTetra++) + for (int iVertex = 0; iVertex < 4; iVertex++) + { + tetrasIdsOnPrism[iTetra][iVertex] = prismVertexGIds[tetraOfPrism[prismType][iTetra][iVertex]]; + } + + // return; + + int reorderedPrismLIds[6]; + + for (int ii = 0; ii < 6; ii++) + { + reorderedPrismLIds[ii] = prismVertexGIds[PrismVerticesMap[minIndex][ii]]; + } + + for (int iTetra = 0; iTetra < 3; iTetra++) + for (int iVertex = 0; iVertex < 4; iVertex++) + { + tetrasIdsOnPrism[iTetra][iVertex] = reorderedPrismLIds[tetraOfPrism[prismType][iTetra][iVertex]]; + } + } + + + + + void setBdFacesOnPrism (const std::vector > >& prismStruct, const std::vector& prismFaceIds, std::vector& tetraPos, std::vector& facePos) + { + int numTriaFaces = prismFaceIds.size() - 2; + tetraPos.assign(numTriaFaces,-1); + facePos.assign(numTriaFaces,-1); + + + for (int iTetra (0), k (0); (iTetra < 3 && k < numTriaFaces); iTetra++) + { + bool found; + for (int jFaceLocalId = 0; jFaceLocalId < 4; jFaceLocalId++ ) + { + found = true; + for (int ip (0); ip < 3 && found; ip++) + { + int localId = prismStruct[iTetra][jFaceLocalId][ip]; + int j = 0; + found = false; + while ( (j < prismFaceIds.size()) && !found ) + { + found = (localId == prismFaceIds[j]); + j++; + } + } + if (found) + { + tetraPos[k] = iTetra; + facePos[k] = jFaceLocalId; + k += found; + break; + } + } + } + } + diff --git a/src/core_landice/Interface_velocity_solver.hpp b/src/core_landice/Interface_velocity_solver.hpp new file mode 100644 index 0000000000..5b840c40b8 --- /dev/null +++ b/src/core_landice/Interface_velocity_solver.hpp @@ -0,0 +1,281 @@ +/* -*- mode: c++ -*- + + This file is part of the LifeV Applications. + + Author(s): + Date: 2009-03-24 + + Copyright (C) 2009 EPFL + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2.1 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 + USA + */ + +// =================================================== +//! Includes +// =================================================== +//#include +#include +#include +#include +#include +#include +#include +#include + +#define velocity_solver_init_mpi velocity_solver_init_mpi_ +#define velocity_solver_finalize velocity_solver_finalize_ +#define velocity_solver_init_l1l2 velocity_solver_init_l1l2_ +#define velocity_solver_solve_l1l2 velocity_solver_solve_l1l2_ +#define velocity_solver_init_fo velocity_solver_init_fo_ +#define velocity_solver_solve_fo velocity_solver_solve_fo_ +#define velocity_solver_init_stokes velocity_solver_init_stokes_ +#define velocity_solver_solve_stokes velocity_solver_solve_stokes_ +#define velocity_solver_compute_2d_grid velocity_solver_compute_2d_grid_ +#define velocity_solver_set_grid_data velocity_solver_set_grid_data_ +#define velocity_solver_extrude_3d_grid velocity_solver_extrude_3d_grid_ +#define velocity_solver_export_l1l2_velocity velocity_solver_export_l1l2_velocity_ +#define velocity_solver_export_2d_data velocity_solver_export_2d_data_ +#define velocity_solver_export_fo_velocity velocity_solver_export_fo_velocity_ +#define velocity_solver_estimate_SS_SMB velocity_solver_estimate_ss_smb_ + +//#include +//#include + +//#include + +struct exchange { + const int procID; + const std::vector vec; + mutable std::vector buffer; + mutable std::vector doubleBuffer; + mutable MPI_Request reqID; + + exchange(int _procID, int const* vec_first, int const* vec_last, + int fieldDim = 1); +}; + +typedef std::list exchangeList_Type; + +typedef unsigned int ID; +typedef unsigned int UInt; +const ID NotAnId = std::numeric_limits::max(); + +// =================================================== +//! Interface function +// =================================================== +extern "C" { + +int velocity_solver_init_mpi(int* fComm); + +void velocity_solver_finalize(); + +void velocity_solver_init_l1l2(double const* levelsRatio); + +void velocity_solver_init_fo(double const* levelsRatio); + +void velocity_solver_solve_l1l2(double const* lowerSurface_F, + double const* thickness_F, double const* beta_F, + double const* temperature_F, double* u_normal_F = 0, + double* xVelocityOnCell = 0, double* yVelocityOnCell = 0); + +void velocity_solver_solve_fo(double const* lowerSurface_F, + double const* thickness_F, double const* beta_F, + double const* temperature_F, double* u_normal_F = 0, + double* xVelocityOnCell = 0, double* yVelocityOnCell = 0); + + +void velocity_solver_compute_2d_grid(int const* verticesMask_F); + +void velocity_solver_set_grid_data(int const* _nCells_F, int const* _nEdges_F, + int const* _nVertices_F, int const* _nLayers, int const* _nCellsSolve_F, + int const* _nEdgesSolve_F, int const* _nVerticesSolve_F, + int const* _maxNEdgesOnCell_F, double const* radius_F, + int const* _cellsOnEdge_F, int const* _cellsOnVertex_F, + int const* _verticesOnCell_F, int const* _verticesOnEdge_F, + int const* _edgesOnCell_F, int const* _nEdgesOnCells_F, + int const* _indexToCellID_F, + double const* _xCell_F, double const* _yCell_F, double const* _zCell_F, + double const* _xVertex_F, double const* _yVertex_F, double const* _zVertex_F, + double const* _areaTriangle_F, + int const* sendCellsArray_F, int const* recvCellsArray_F, + int const* sendEdgesArray_F, int const* recvEdgesArray_F, + int const* sendVerticesArray_F, int const* recvVerticesArray_F); + +void velocity_solver_extrude_3d_grid(double const* levelsRatio_F, + double const* lowerSurface_F, double const* thickness_F); + +void velocity_solver_export_l1l2_velocity(); + +void velocity_solver_export_fo_velocity(); + +//void velocity_solver_estimate_SS_SMB (const double* u_normal_F, double* sfcMassBal); + +} + +extern void velocity_solver_finalize__(); + +#ifdef LIFEV +extern void velocity_solver_init_l1l2__(const std::vector& layersRatio, const std::vector& velocityOnVertices, bool initialize_velocity); + +extern void velocity_solver_solve_l1l2__(const std::vector& elevationData, + const std::vector& thicknessData, const std::vector& betaData, + const std::vector& temperatureData, const std::vector& indexToVertexID, + std::vector& velocityOnVertices); + +extern void velocity_solver_init_fo__(const std::vector& layersRatio, const std::vector& velocityOnVertices, const std::vector& indexToVertexID, bool initialize_velocity); + +extern void velocity_solver_export_l1l2_velocity__(const std::vector& layersRatio, const std::vector& elevationData, const std::vector& regulThk, + const std::vector& mpasIndexToVertexID, MPI_Comm reducedComm); + +#endif + + + +extern void velocity_solver_solve_fo__(int nLayers, int nGlobalVertices, + int nGlobalTriangles, bool ordering, bool first_time_step, + const std::vector& indexToVertexID, + const std::vector& indexToTriangleID, double minBeta, + const std::vector& regulThk, + const std::vector& levelsNormalizedThickness, + const std::vector& elevationData, + const std::vector& thicknessData, + const std::vector& betaData, + const std::vector& temperatureOnTetra, + std::vector& velocityOnVertices); + + +#ifdef LIFEV +extern void velocity_solver_compute_2d_grid__(int nGlobalTriangles, + int nGlobalVertices, int nGlobalEdges, + const std::vector& indexToVertexID, + const std::vector& verticesCoords, + const std::vector& isVertexBoundary, + const std::vector& verticesOnTria, + const std::vector& isBoundaryEdge, + const std::vector& trianglesOnEdge, + const std::vector& trianglesPositionsOnEdge, + const std::vector& verticesOnEdge, + const std::vector& indexToEdgeID, + const std::vector& indexToTriangleID, + const std::vector < std::pair >& procOnInterfaceEdge); + +#else +extern void velocity_solver_compute_2d_grid__(MPI_Comm); +#endif + + +extern void velocity_solver_export_2d_data__(MPI_Comm reducedComm, + const std::vector& elevationData, + const std::vector& thicknessData, + const std::vector& betaData, + const std::vector& indexToVertexID); + +extern void velocity_solver_extrude_3d_grid__(int nLayers, int nGlobalTriangles, + int nGlobalVertices, int nGlobalEdges, int Ordering, MPI_Comm reducedComm, + const std::vector& indexToVertexID, + const std::vector& mpasIndexToVertexID, + const std::vector& verticesCoords, + const std::vector& isVertexBoundary, + const std::vector& verticesOnTria, + const std::vector& isBoundaryEdge, + const std::vector& trianglesOnEdge, + const std::vector& trianglesPositionsOnEdge, + const std::vector& verticesOnEdge, + const std::vector& indexToEdgeID, + const std::vector& indexToTriangleID); + +//extern void velocity_solver_export_l1l2_velocity__(); + +extern void velocity_solver_export_fo_velocity__(MPI_Comm reducedComm); + + + +#ifdef LIFEV +extern int velocity_solver_initialize_iceProblem__(bool keep_proc, MPI_Comm reducedComm); +#endif + +//extern void velocity_solver_estimate_SS_SMB__ (const double* u_normal_F, double* sfcMassBal); + +exchangeList_Type unpackMpiArray(int const* array); + +bool isGhostTriangle(int i, double relTol = 1e-1); + +double signedTriangleArea(const double* x, const double* y); + +double signedTriangleArea(const double* x, const double* y, const double* z); + +void createReducedMPI(int nLocalEntities, MPI_Comm& reduced_comm_id); + +void import2DFields(double const* lowerSurface_F, double const* thickness_F, + double const* beta_F = 0, double eps = 0); + +std::vector extendMaskByOneLayer(int const* verticesMask_F); + +void extendMaskByOneLayer(int const* verticesMask_F, + std::vector& extendedFVerticesMask); + +void importP0Temperature(double const* temperature_F); + +void get_prism_velocity_on_FEdges(double* uNormal, + const std::vector& velocityOnCells, + const std::vector& edgeToFEdge); + +int initialize_iceProblem(int nTriangles); + +void createReverseCellsExchangeLists(exchangeList_Type& sendListReverse_F, + exchangeList_Type& receiveListReverse_F, + const std::vector& fVertexToTriangleID, + const std::vector& fCellToVertexID); + +void createReverseEdgesExchangeLists(exchangeList_Type& sendListReverse_F, + exchangeList_Type& receiveListReverse_F, + const std::vector& fVertexToTriangleID, + const std::vector& fEdgeToEdgeID); + +void mapCellsToVertices(const std::vector& velocityOnCells, + std::vector& velocityOnVertices, int fieldDim, int numLayers, + int ordering); + +void mapVerticesToCells(const std::vector& velocityOnVertices, + double* velocityOnCells, int fieldDim, int numLayers, int ordering); + +void computeLocalOffset(int nLocalEntities, int& localOffset, + int& nGlobalEntities); + +void getProcIds(std::vector& field, int const* recvArray); + +void getProcIds(std::vector& field, exchangeList_Type const* recvList); + +void allToAll(std::vector& field, int const* sendArray, + int const* recvArray, int fieldDim = 1); + +void allToAll(std::vector& field, exchangeList_Type const* sendList, + exchangeList_Type const* recvList, int fieldDim = 1); + +void allToAll(double* field, exchangeList_Type const* sendList, + exchangeList_Type const* recvList, int fieldDim = 1); + +int prismType(long long int const* prismVertexMpasIds, int& minIndex); +void tetrasFromPrismStructured (long long int const* prismVertexMpasIds, long long int const* prismVertexGIds, long long int tetrasIdsOnPrism[][4]); +void computeMap(); + +void setBdFacesOnPrism (const std::vector > >& prismStruct, const std::vector& prismFaceIds, std::vector& tetraPos, std::vector& facePos); +void tetrasFromPrismStructured (int const* prismVertexMpasIds, int const* prismVertexGIds, int tetrasIdsOnPrism[][4]); + +bool belongToTria(double const* x, double const* t, double bcoords[3], double eps = 1e-3); + + + diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index 02da7d6136..e45c6b1f4b 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -1,4 +1,45 @@ -.SUFFIXES: .F .o +# =================================== +# Check if building with LifeV, Albany, and/or PHG external libraries + +BUILD_INTERFACE=false # This will become true if any of the external libraries are being used. + +# LifeV can solve L1L2 or FO +ifeq "$(LIFEV)" "true" + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_L1L2 + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER + BUILD_INTERFACE = true +endif # LIFEV IF + +# Albany can only solve FO at present +ifeq "$(ALBANY)" "true" + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER + BUILD_INTERFACE = true +endif # ALBANY IF + +# Currently LifeV AND Albany is not allowed +ifeq "$(LIFEV)" "true" +ifeq "$(ALBANY)" "true" + $(error Compiling with both LifeV and Albany is not allowed at this time.) +endif +endif + +# PHG currently requires LifeV +ifeq "$(PHG)" "true" +ifneq "$(LIFEV)" "true" + $(error Compiling with PHG requires LifeV at this time.) +endif +endif +# PHG can only Stokes at present +ifeq "$(PHG)" "true" + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_STOKES + BUILD_INTERFACE = true +endif # PHG IF + +override CPPFLAGS += $(EXTERNAL_DYCORE_FLAG) +# =================================== + + +.SUFFIXES: .F .o .cpp OBJS = mpas_li_mpas_core.o \ mpas_li_time_integration.o \ @@ -9,7 +50,14 @@ OBJS = mpas_li_mpas_core.o \ mpas_li_statistics.o \ mpas_li_velocity.o \ mpas_li_sia.o \ - mpas_li_mask.o + mpas_li_mask.o \ + mpas_li_velocity_external.o + +ifeq "$(BUILD_INTERFACE)" "true" + OBJS += Interface_velocity_solver.o +endif + + all: core_landice @@ -41,7 +89,8 @@ mpas_li_diagnostic_vars.o: mpas_li_mask.o \ mpas_li_velocity.o mpas_li_velocity.o: mpas_li_sia.o \ - mpas_li_setup.o + mpas_li_setup.o \ + mpas_li_velocity_external.o mpas_li_sia.o: mpas_li_mask.o \ mpas_li_setup.o @@ -54,6 +103,10 @@ mpas_li_mask.o: mpas_li_setup.o mpas_li_constants.o: +mpas_li_velocity_external.o: + +Interface_velocity_solver.o: + clean: $(RM) *.o *.mod *.f90 libdycore.a $(RM) Registry_processed.xml @@ -65,3 +118,6 @@ clean: $(RM) $@ $*.mod $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 + +.cpp.o: + $(CXX) $(CXXFLAGS) -c $*.cpp $(CXINCLUDES) $(CPPINCLUDES) -lmpi_cxx -lstdc++ $(CPPFLAGS) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 91eeb477ef..7cb3efaa60 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -45,7 +45,7 @@ + @@ -265,9 +269,9 @@ - + @@ -380,7 +384,6 @@ - @@ -415,6 +418,9 @@ + @@ -546,7 +552,7 @@ description="Area of the portions of each dual cell that are part of each cellsOnVertex." /> + + diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index 7ac1b3f0d2..3ae6b85104 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -94,6 +94,8 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) !----------------------------------------------------------------- type (domain_type), intent(inout) :: domain !< Input/Output: domain object + ! Note: domain is passed in because halo updates are needed in this routine + ! and halo updates have to happen outside block loops, which requires domain. !----------------------------------------------------------------- ! @@ -117,7 +119,6 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) real (kind=RKIND), dimension(:), pointer :: surfaceSpeed, basalSpeed integer, pointer :: nVertInterfaces integer :: err_tmp -!!! integer :: blockVertexMaskChanged, procVertexMaskChanged, anyVertexMaskChanged err = 0 @@ -129,36 +130,11 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) ! === call mpas_timer_start("calc. diagnostic vars except vel") - call diagnostic_solve_before_velocity(domain, timeLevel, err_tmp) ! perhaps velocity solve should move in here. + call diagnostic_solve_before_velocity(domain, timeLevel, err_tmp) err = ior(err, err_tmp) -! This information is only needed for some external dycores. This can be added back in when they are implemented. -! Should make this conditional to avoid unnecessary MPI comms. -!!! block => domain % blocklist -!!! do while (associated(block)) -!!! stateNew => block % state % time_levs(2) % state -!!! stateOld => block % state % time_levs(1) % state -!!! ! Determine if the vertex mask changed during this time step for this block (needed for LifeV) -!!! ! \todo: there may be some aspects of the mask that are ok change for LifeV, but for now just check the whole thing. -!!! if ( sum(stateNew % vertexMask % array - stateOld % vertexMask % array) /= 0 ) then -!!! blockVertexMaskChanged = 1 -!!! else -!!! blockVertexMaskChanged = 0 -!!! endif -!!! !print *, 'blockVertexMaskChanged ', blockVertexMaskChanged - -!!! ! Determine if any blocks on this processor had a change to the vertex mask -!!! procVertexMaskChanged = max(procVertexMaskChanged, blockVertexMaskChanged) - -!!! block => block % next -!!! end do -!!! -!!! ! Determine if the vertex mask has changed on any processor (need to exit the block loop to do so) -!!! call mpas_dmpar_max_int(dminfo, procVertexMaskChanged, anyVertexMaskChanged) - call mpas_timer_stop("calc. diagnostic vars except vel") - ! === ! === Diagnostic solve of velocity ! === @@ -172,11 +148,8 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) -!!! ! Assign the vertex-changed flag to each block -!!! stateNew % anyVertexMaskChanged % scalar = anyVertexMaskChanged -!!! !print *, 'anyVertexMaskChanged: ', anyVertexMaskChanged - call li_velocity_solve(meshPool, statePool, timeLevel, err_tmp) ! ****** Calculate Velocity ****** + err = ior(err, err_tmp) block => block % next @@ -317,6 +290,7 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! local variables ! !----------------------------------------------------------------- + ! pointers to get from pools type (block_type), pointer :: block type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: statePool @@ -324,16 +298,20 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ lowerSurface, bedTopography, upperSurfaceVertex, slopeEdge, & normalSlopeEdge, tangentSlopeEdge, dcEdge, dvEdge integer, dimension(:), pointer :: cellMask, edgeMask + integer, dimension(:), pointer :: vertexMaskOld, vertexMaskNew integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge integer, dimension(:,:), pointer :: baryCellsOnVertex real (kind=RKIND), dimension(:,:), pointer :: layerThickness, baryWeightsOnVertex real (kind=RKIND), dimension(:,:,:), pointer :: tracers type (field1DInteger), pointer :: cellMaskField, edgeMaskField, vertexMaskField integer, pointer :: nCells, nVertices, nEdges + integer, pointer :: anyVertexMaskChanged real (kind=RKIND), pointer :: config_sea_level, config_ice_density, config_ocean_density character (len=StrKIND), pointer :: config_velocity_solver, config_sia_tangent_slope_calculation + ! truly local variables real (kind=RKIND) :: thisThk integer :: iCell, iLevel, iEdge, cell1, cell2 + integer :: blockVertexMaskChanged, procVertexMaskChanged integer :: err_tmp @@ -496,6 +474,41 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ end do + ! This information is only needed for some external dycores. + if (config_velocity_solver /= 'sia') then + procVertexMaskChanged = 0 + + ! Note: External dycores don't support multiple blocks per proc., but checking across + ! blocks anyway, in case some day they do. + block => domain % blocklist + do while (associated(block)) + + ! Determine if the vertex mask changed during this time step for this block (needed for external dycores) + ! TODO: there may be some aspects of the mask that are ok change for external dycores, but for now just check the whole thing. + ! TODO: if we ever have more than one time level, then this logic should be revisited. + call mpas_pool_get_array(statePool, 'vertexMask', vertexMaskOld, timeLevel=1) + call mpas_pool_get_array(statePool, 'vertexMask', vertexMaskNew, timeLevel=2) + if ( sum(vertexMaskNew - vertexMaskOld) /= 0 ) then + blockVertexMaskChanged = 1 + else + blockVertexMaskChanged = 0 + endif + !print *, 'blockVertexMaskChanged ', blockVertexMaskChanged + + ! Determine if any blocks on this processor had a change to the vertex mask + procVertexMaskChanged = max(procVertexMaskChanged, blockVertexMaskChanged) + !print *,'procVertexMaskChanged', procVertexMaskChanged + + block => block % next + end do + + ! Determine if the vertex mask has changed on any processor and store the value for later use (need to exit the block loop to do so) + call mpas_pool_get_array(statePool, 'anyVertexMaskChanged', anyVertexMaskChanged, timeLevel=timeLevel) + call mpas_dmpar_max_int(domain % dminfo, procVertexMaskChanged, anyVertexMaskChanged) + !print *,'anyVertexMaskChanged', anyVertexMaskChanged + end if + + ! === error check if (err > 0) then write (0,*) "An error has occurred in diagnostic_solve_before_velocity." diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index b06e951071..ea228152a7 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -642,6 +642,7 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) !----------------------------------------------------------------- type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: statePool + integer, dimension(:), pointer :: vertexMask character (len=StrKIND), pointer :: xtime type (MPAS_Time_Type) :: currTime integer :: err, err_tmp @@ -653,6 +654,15 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + + ! Copy data from first time level into all other time levels + call mpas_pool_initialize_time_levels(statePool) + + ! Initialize vertexMask on time level 2 to junk, so diagnostic_solve_before_velocity in li_diagnostic_vars says that the vertexMask has changed (needed by external dycore) + call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel = 2) + vertexMask = -9999 + + ! === ! === Call init routines === ! === diff --git a/src/core_landice/mpas_li_tendency.F b/src/core_landice/mpas_li_tendency.F index d5d5890128..11557e7a2e 100644 --- a/src/core_landice/mpas_li_tendency.F +++ b/src/core_landice/mpas_li_tendency.F @@ -650,7 +650,7 @@ subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknes layerNormalVelocity = 0.5_RKIND * (normalVelocity(k, iEdge) + normalVelocity(k+1, iEdge)) if (abs(layerNormalVelocity) > 0.0_RKIND) then - maxAllowableDt = (0.5_RKIND * dcEdge(iEdge)) / abs(layerNormalVelocity) ! in years + maxAllowableDt = (0.5_RKIND * dcEdge(iEdge)) / abs(layerNormalVelocity) else maxAllowableDt = 1.0e36_RKIND endif diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index d2853d0183..81169dcdf6 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -25,7 +25,7 @@ module li_velocity use mpas_grid_types use mpas_configure -!!! use li_lifev + use li_velocity_external use li_sia use li_setup @@ -112,22 +112,16 @@ subroutine li_velocity_init(domain, err) select case (config_velocity_solver) case ('sia') call li_sia_init(domain, err) -!!! case ('L1L2') -!!! call li_lifev_init(domain, err) -!!! case ('FO') -!!! call li_lifev_init(domain, err) -!!! case ('Stokes') -!!! call li_lifev_init(domain, err) -!!! call li_phg_init(domain, err) + case ('L1L2', 'FO', 'Stokes') + call li_velocity_external_init(domain, err) case default - write(*,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' + write(0,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 - return end select ! === error check if (err > 0) then - write (0,*) "An error has occurred in li_timestep." + write (0,*) "An error has occurred in li_velocity_init." endif !-------------------------------------------------------------------- @@ -185,12 +179,8 @@ subroutine li_velocity_block_init(block, err) select case (config_velocity_solver) case ('sia') call li_sia_block_init(block, err) -!!! case ('L1L2') -!!! call li_lifev_block_init(block, err) -!!! case ('FO') -!!! call li_lifev_block_init(block, err) -!!! case ('Stokes') -!!! call li_lifev_block_init(block, err) + case ('L1L2', 'FO', 'Stokes') + call li_velocity_external_block_init(block, err) case default write(*,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 @@ -221,7 +211,7 @@ end subroutine li_velocity_block_init !----------------------------------------------------------------------- subroutine li_velocity_solve(meshPool, statePool, timeLevel, err) - use li_sia + use li_mask !----------------------------------------------------------------- ! @@ -256,45 +246,48 @@ subroutine li_velocity_solve(meshPool, statePool, timeLevel, err) ! local variables ! !----------------------------------------------------------------- + ! pointers to get from pools character (len=StrKIND), pointer :: config_velocity_solver -! integer :: iEdge, nEdges -! real (kind=RKIND), dimension(:,:), pointer :: normalVelocity -! integer, dimension(:), pointer :: edgeMask + integer, pointer :: nEdges + real (kind=RKIND), dimension(:,:), pointer :: normalVelocity + integer, dimension(:), pointer :: edgeMask + ! truly local variables + integer :: iEdge err = 0 + ! Get variables from pools call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) -! nEdges = mesh % nEdges -! normalVelocity => state % normalVelocity % array -! edgeMask => state % edgeMask % array select case (config_velocity_solver) case ('sia') call li_sia_solve(meshPool, statePool, timeLevel, err) -!!! case ('L1L2') -!!! call li_lifev_solve(mesh, state, timeLevel, err) -!!! case ('FO') -!!! call li_lifev_solve(mesh, state, timeLevel, err) -!!! case ('Stokes') -!!! call li_lifev_solve(mesh, state, timeLevel, err) + case ('L1L2', 'FO', 'Stokes') + call li_velocity_external_solve(meshPool, statePool, timeLevel, err) case default - write(*,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' + write(0,*) 'Error: ', trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 return end select - -!!! do iEdge = 1, nEdges -!!! if ( MASK_IS_THIN_ICE(edgeMask(iEdge)) .and. (maxval(abs(normalVelocity(:,iEdge))) /= 0.0_RKIND) ) then -!!! err = 1 -!!! normalVelocity(:,iEdge) = 0.0_RKIND ! this is a hack because the rest of the code requires this, but this condition should really cause a fatal error. -!!! endif -!!! enddo -!!! if (err == 1) then -!!! write(0,*) 'Velocity has been calculated on non-dynamic edges. There is a problem with the velocity solver. Velocity on those edges have been set to 0, but this should be a fatal error.' -!!! err = 0 ! a hack to let the code continue until this can be fixed in the velocity solver -!!! end if + ! Check if the velocity solver has returned a velocity on any non-dynamic edges + do iEdge = 1, nEdges + if ( li_mask_is_ice(edgeMask(iEdge)) .and. & + (.not.(li_mask_is_dynamic_ice(edgeMask(iEdge)))) .and. & + (maxval(abs(normalVelocity(:,iEdge))) /= 0.0_RKIND) & + ) then + err = 1 + !!!normalVelocity(:,iEdge) = 0.0_RKIND ! this is a hack because the rest of the code requires this, but this condition should really cause a fatal error. + endif + enddo + if (err == 1) then + write(0,*) 'Error: Velocity has been calculated on non-dynamic edges. There is a problem with the velocity solver.' !!! Velocity on those edges have been set to 0, but this should be a fatal error.' + err = 1 ! a hack to let the code continue until this can be fixed in the velocity solver + end if ! === error check if (err > 0) then @@ -356,12 +349,8 @@ subroutine li_velocity_finalize(domain, err) select case (config_velocity_solver) case ('sia') call li_sia_finalize(domain, err) -!!! case ('L1L2') -!!! call li_lifev_finalize(domain, err) -!!! case ('FO') -!!! call li_lifev_finalize(domain, err) -!!! case ('Stokes') -!!! call li_lifev_finalize(domain, err) + case ('L1L2', 'FO', 'Stokes') + call li_velocity_external_finalize(err) case default write(*,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F new file mode 100644 index 0000000000..fdb3bbea60 --- /dev/null +++ b/src/core_landice/mpas_li_velocity_external.F @@ -0,0 +1,865 @@ +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! li_velocity_external +! +!> \MPAS land-ice velocity driver for external dycores +!> \author Matt Hoffman +!> \date 3 October 2013 +!> \version SVN:$Id:$ +!> \details +!> This module contains the routines for interfacing with +!> external velocity solvers. These currently are LifeV (L1L2, First order), +!> Albany (First order), and PHG (Stokes). +!> +! +!----------------------------------------------------------------------- + +module li_velocity_external + + + use mpas_grid_types + use mpas_configure + use mpas_dmpar + use li_setup + !use, intrinsic :: iso_c_binding + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: li_velocity_external_init, & + li_velocity_external_block_init, & + li_velocity_external_solve, & + li_velocity_external_finalize + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + +!*********************************************************************** + + + +contains + + + +!*********************************************************************** +! +! routine li_velocity_external_init +! +!> \brief Initializes velocity solver +!> \author Matt Hoffman +!> \date 3 October 2013 +!> \version SVN:$Id$ +!> \details +!> This routine initializes the ice velocity solver in +!> external velocity solvers. +! +!----------------------------------------------------------------------- + + subroutine li_velocity_external_init(domain, err) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + integer, pointer :: config_num_halos, config_number_of_blocks + character (len=StrKIND), pointer :: config_velocity_solver + integer :: err_tmp + + err = 0 + err_tmp = 0 + + call mpas_pool_get_config(liConfigs, 'config_num_halos', config_num_halos) + call mpas_pool_get_config(liConfigs, 'config_number_of_blocks', config_number_of_blocks) + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + + ! Check for configuration options that are incompatible with external velocity solver conventions + if (config_num_halos < 2) then + write(0,*) "Error: External velocity solvers require that config_num_halos >= 2" + err_tmp = 1 + endif + err = ior(err,err_tmp) + if (config_number_of_blocks /= 0) then + write(0,*) "Error: External velocity solvers require that config_number_of_blocks=0" + err_tmp = 1 + endif + err = ior(err,err_tmp) + + + ! These calls are needed for setting up the external velocity solvers + +#if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) + !call external first order solver to set the grid of the velocity solver + call velocity_solver_init_mpi(domain % dminfo % comm) +#else + err = 1 + write(0,*) "Error: To run with an external velocity solver you must compile MPAS with one." +#endif + + + if (config_velocity_solver == 'Stokes') then +#ifdef USE_EXTERNAL_STOKES + call interface_phg_init(domain, err) +#else + write(0,*) "Error: External Stokes library needed to run stokes dycore." + err = 1 + return +#endif + endif + err = ior(err,err_tmp) + + + ! === error check + if (err > 0) then + write (0,*) "An error has occurred in li_velocity_external_init." + endif + + !-------------------------------------------------------------------- + end subroutine li_velocity_external_init + + + +!*********************************************************************** +! +! routine li_velocity_external_block_init +! +!> \brief Initializes blocks for external velocity solver use +!> \author Matt Hoffman +!> \date 3 October 2013 +!> \version SVN:$Id$ +!> \details +!> This routine initializes each block of the ice velocity solver in the +!> external velocity solver. +!> Note: LifeV/Albany/PHG only support one block per processor, but this has (hopefully) +!> been written to work if that were to change. (That's why all these external dycore init +!> calls are in li_velocity_external_block_init instead of li_velocity_external_init.) +! +!----------------------------------------------------------------------- + + subroutine li_velocity_external_block_init(block, err) + + use mpas_timer + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (block_type), intent(in) :: & + block !< Input: mesh information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), pointer :: meshPool + integer, pointer :: nCells, nEdges, nVertices, nCellsSolve, nEdgesSolve, nVerticesSolve, nVertInterfaces, maxNEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnCell, verticesOnEdge, edgesOnCell + integer, dimension(:), pointer :: indexToCellID, indexToEdgeID, indexToVertexID, nEdgesOnCell + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xVertex, yVertex, zVertex, areaTriangle + real (kind=RKIND), pointer :: radius + type (field1DInteger), pointer :: indexToCellIDField, indexToEdgeIDField, indexToVertexIDField + + ! halo exchange arrays + integer, dimension(:), pointer :: sendCellsArray, & + recvCellsArray, & + sendVerticesArray, & + recvVerticesArray, & + sendEdgesArray, & + recvEdgesArray + + err = 0 + + !extract data from domain + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nVerticesSolve', nVerticesSolve) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'nVertInterfaces', nVertInterfaces) + call mpas_pool_get_dimension(meshPool, 'maxEdges', maxNEdgesOnCell) + call mpas_pool_get_config(meshPool, 'sphere_radius', radius) + + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(meshPool, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'indexToCellID', indexToCellID) + call mpas_pool_get_array(meshPool, 'indexToEdgeID', indexToEdgeID) + call mpas_pool_get_array(meshPool, 'indexToVertexID', indexToVertexID) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + + call mpas_pool_get_field(meshPool, 'indexToCellID', indexToCellIDField) + call mpas_pool_get_field(meshPool, 'indexToEdgeID', indexToEdgeIDField) + call mpas_pool_get_field(meshPool, 'indexToVertexID', indexToVertexIDField) + + ! build send and receive arrays using exchange_list + call array_from_exchange_list(indexToCellIDField, sendCellsArray, recvCellsArray) + call array_from_exchange_list(indexToEdgeIDField, sendEdgesArray, recvEdgesArray) + call array_from_exchange_list(indexToVertexIDField, sendVerticesArray, recvVerticesArray) + + +#if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) + ! These calls are needed for using any of the external velocity solvers + + !zCell is supposed to be zero when working on planar geometries (radius = 0) + !nVertLevels should be equal to nVertLevelsSolve (no splitting of the domain in the vertical direction) + call mpas_timer_start("velocity_solver_set_grid_data") + call velocity_solver_set_grid_data(nCells, nEdges, nVertices, nVertInterfaces, & + nCellsSolve, nEdgesSolve, nVerticesSolve, maxNEdgesOnCell, radius, & + cellsOnEdge, cellsOnVertex, verticesOnCell, verticesOnEdge, edgesOnCell, & + nEdgesOnCell, indexToCellID, & + xCell, yCell, zCell, xVertex, yVertex, zVertex, areaTriangle, & + sendCellsArray, recvCellsArray, & + sendEdgesArray, recvEdgesArray, & + sendVerticesArray, recvVerticesArray) + call mpas_timer_stop("velocity_solver_set_grid_data") +#else + write(0,*) "Error: To run with an external velocity solver you must compile MPAS with one." + err = 1 +#endif + + !these can be deallocated because they have been copied on the c++ side + deallocate(sendCellsArray, & + recvCellsArray, & + sendVerticesArray, & + recvVerticesArray, & + sendEdgesArray, & + recvEdgesArray) + + ! === error check + if (err > 0) then + write (0,*) "An error has occurred in li_velocity_external_block_init." + endif + + !-------------------------------------------------------------------- + end subroutine li_velocity_external_block_init + + + +!*********************************************************************** +! +! routine li_velocity_external_solve +! +!> \brief Interface to call external velocity solvers +!> \author Matt Hoffman +!> \date 3 October 2013 +!> \version SVN:$Id$ +!> \details +!> This routine calls external first-order velocity solvers and/or Stokes velocity solvers. +! +!----------------------------------------------------------------------- + + subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) + + use mpas_timer + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + integer, intent(in) :: & + timeLevel !< Input: time level from which to calculate velocity + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(inout) :: & + statePool !< Input: state information + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + integer, pointer :: index_temperature + real (kind=RKIND), dimension(:), pointer :: & + thickness, lowerSurface, upperSurface, layerThicknessFractions, beta + real (kind=RKIND), dimension(:,:), pointer :: & + normalVelocity, uReconstructX, uReconstructY, uReconstructZ + real (kind=RKIND), dimension(:,:,:), pointer :: & + tracers + integer, dimension(:), pointer :: vertexMask + character (len=StrKIND), pointer :: config_velocity_solver + logical, pointer :: config_always_compute_fem_grid + integer, pointer :: anyVertexMaskChanged + + err = 0 + + ! configs + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + call mpas_pool_get_config(liConfigs, 'config_always_compute_fem_grid', config_always_compute_fem_grid) + + ! Mesh variables + call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(meshPool, 'beta', beta) + + ! State variables + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'uReconstructX', uReconstructX, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'uReconstructY', uReconstructY, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'uReconstructZ', uReconstructZ, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'lowerSurface', lowerSurface, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'upperSurface', upperSurface, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel=timeLevel) + call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) + call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'anyVertexMaskChanged', anyVertexMaskChanged, timeLevel=timeLevel) + + + ! ================================================================== + ! External dycore calls to be made only when vertex mask changes + ! ================================================================== + + if ((anyVertexMaskChanged == 1) .or. (config_always_compute_fem_grid)) then +#if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) + call mpas_timer_start("velocity_solver_compute_2d_grid") + call velocity_solver_compute_2d_grid(vertexMask) + call mpas_timer_stop("velocity_solver_compute_2d_grid") +#else + write(0,*) "Error: To run with an external velocity solver you must compile MPAS with one." + err = 1 + return +#endif + + select case (config_velocity_solver) + case ('L1L2') ! =============================================== +#ifdef USE_EXTERNAL_L1L2 + call mpas_timer_start("velocity_solver_init_L1L2") + !call velocity_solver_extrude_3d_grid(layerThicknessFractions, lowerSurface, thickness) + call velocity_solver_init_L1L2(layerThicknessFractions) + call mpas_timer_stop("velocity_solver_init_L1L2") +#else + write(0,*) "Error: External LifeV library needed to run L1L2 dycore." + err = 1 + return +#endif + + case ('FO') ! =============================================== +#ifdef USE_EXTERNAL_FIRSTORDER + call mpas_timer_start("velocity_solver_extrude_3d_grid") + call velocity_solver_extrude_3d_grid(layerThicknessFractions, lowerSurface, thickness) + call mpas_timer_stop("velocity_solver_extrude_3d_grid") + call mpas_timer_start("velocity_solver_init_FO") + call velocity_solver_init_FO(layerThicknessFractions) + call mpas_timer_stop("velocity_solver_init_FO") +#else + write(0,*) "Error: External library needed to run FO dycore." + err = 1 + return +#endif + + case ('Stokes') ! =============================================== +#ifdef USE_EXTERNAL_STOKES + call mpas_timer_start("velocity_solver_extrude_3d_grid") + call velocity_solver_extrude_3d_grid(layerThicknessFractions, lowerSurface, thickness) + call mpas_timer_stop("velocity_solver_extrude_3d_grid") + call mpas_timer_start("velocity_solver_init_stokes") + call velocity_solver_init_stokes(layerThicknessFractions) + call mpas_timer_stop("velocity_solver_init_stokes") +#else + write(0,*) "Error: External Stokes library needed to run stokes dycore." + err = 1 + return +#endif + end select + endif + + + ! ================================================================== + ! External dycore calls to be made every time step (solve velocity!) + ! ================================================================== + + select case (config_velocity_solver) + case ('L1L2') ! =============================================== +#ifdef USE_EXTERNAL_L1L2 + call mpas_timer_start("velocity_solver_solve_L1L2") + call velocity_solver_solve_L1L2(lowerSurface, thickness, beta, tracers(index_temperature,:,:), normalVelocity, uReconstructX, uReconstructY) +! call velocity_solver_estimate_SS_SMB(normalVelocity, mesh % sfcMassBal % array) + call mpas_timer_stop("velocity_solver_solve_L1L2") + ! Optional calls to have LifeV output data files + call mpas_timer_start("velocity_solver export") + call velocity_solver_export_2d_data(lowerSurface, thickness, beta) + call velocity_solver_export_L1L2_velocity(); + call mpas_timer_stop("velocity_solver export") +#else + write(0,*) "Error: External LifeV library needed to run L1L2 dycore." + err = 1 + return +#endif + + case ('FO') ! =============================================== +#ifdef USE_EXTERNAL_FIRSTORDER + call mpas_timer_start("velocity_solver_solve_FO") + call velocity_solver_solve_FO(lowerSurface, thickness, beta, tracers(index_temperature,:,:), normalVelocity, uReconstructX, uReconstructY) +! call velocity_solver_estimate_SS_SMB(normalVelocity, mesh % sfcMassBal % array) + call mpas_timer_stop("velocity_solver_solve_FO") + call mpas_timer_start("velocity_solver export") +! call velocity_solver_init_L1L2(layerThicknessFractions) +! call velocity_solver_export_2d_data(lowerSurface, thickness, beta) + call velocity_solver_export_FO_velocity() + call mpas_timer_stop("velocity_solver export") +#else + write(0,*) "Error: External library needed to run FO dycore." + err = 1 + return +#endif + + case ('Stokes') ! =============================================== +#ifdef USE_EXTERNAL_STOKES + call mpas_timer_start("velocity_solver_solve_stokes") + call velocity_solver_solve_stokes(lowerSurface, thickness, beta, tracers(index_temperature,:,:), normalVelocity, uReconstructX, uReconstructY, uReconstructZ) + uReconstructZ = uReconstructZ / (365.0*24.0*3600.0) ! convert from m/yr to m/s + call mpas_timer_stop("velocity_solver_solve_stokes") +#else + write(0,*) "Error: External Stokes library needed to run stokes dycore." + err = 1 + return +#endif + end select + + + normalVelocity = normalVelocity / (365.0*24.0*3600.0) ! convert from m/yr to m/s + uReconstructX = uReconstructX / (365.0*24.0*3600.0) ! convert from m/yr to m/s + uReconstructY = uReconstructY / (365.0*24.0*3600.0) ! convert from m/yr to m/s + + + !-------------------------------------------------------------------- + end subroutine li_velocity_external_solve + + + +!*********************************************************************** +! +! routine li_velocity_external_finalize +! +!> \brief Finalizes external velocity solvers +!> \author Matt Hoffman +!> \date 3 October 2013 +!> \version SVN:$Id$ +!> \details +!> This routine finalizes the ice velocity solver in the external libraries. +! +!----------------------------------------------------------------------- + + subroutine li_velocity_external_finalize(err) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + +#if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) + ! This call is needed for using any of the external velocity solvers + call velocity_solver_finalize() +#else + write(0,*) "Error: To run with an external velocity solver you must compile MPAS with one." + err = 1 + return +#endif + + !-------------------------------------------------------------------- + end subroutine li_velocity_external_finalize + + + +!*********************************************************************** +! private subroutines +!*********************************************************************** + + + +!*********************************************************************** +! +! routine interface_stokes_init +! +!> \brief Initializes stokes external velocity solver +!> \author Matt Hoffman +!> \date 3 October 2013 +!> \details +!> This routine initializes the ice velocity solver in the stokes +!> external library (currently only PHG). +! +!----------------------------------------------------------------------- + + subroutine interface_stokes_init(domain, err) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + +#ifdef USE_EXTERNAL_STOKES + ! This call is needed for using any of the PHG velocity solvers + call phg_init(domain % dminfo % comm) +#else + write(0,*) "Error: External Stokes library needed to run stokes dycore." + err = 1 + return +#endif + + !-------------------------------------------------------------------- + end subroutine interface_stokes_init + + + +!*********************************************************************** +! +! routine array_from_exchange_list +! +!> \brief Converts the MPAS Exchange Lists to flat arrays for external use +!> \author Matt Hoffman +!> \date 3 October 2013 +!> \version SVN:$Id$ +!> \details +!> This routine converts the MPAS Exchange Lists (type mpas_multihalo_exchange_list) +!> to flat arrays for use by external dycores. +!----------------------------------------------------------------------- + + subroutine array_from_exchange_list(field, sendArray, recvArray) + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + type (field1DInteger), pointer, intent(in) :: field !< Input: the field that holds the MPAS exchange lists. + ! Any 1d integer fields will work, but it is suggested to use one of indexToCellID, indexToEdgeID, or IndexToVertexID + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + integer, dimension(:), pointer :: sendArray !< Input/Output: the flat array of elements to send, should be unallocated on input + integer, dimension(:), pointer :: recvArray !< Input/Output: the flat array of elements to receive, should be unallocated on input + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- +! integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + type (mpas_communication_list), pointer :: sendCommList, recvCommList ! Communication lists that will be setup from mpas_multihalo_exchange_list's as an intermediate step to flat arrays + type (mpas_communication_list), pointer :: commListPtr ! A temporary comm list pointer + integer :: nHaloLayers, iHalo + integer, dimension(:), pointer :: haloLayers ! an array of halo layers, needed to setup comm lists - we want all of them + type (field1DInteger), pointer :: fieldCursor + integer :: nAdded, bufferOffset, i + type (mpas_exchange_list), pointer :: exchListPtr + + + ! ======================================================================== + ! Step 1: Generate communication lists from the mpas_multihalo_exchange_list's + ! (this step is written to be compatible with multiple blocks per processor, + ! even though that is not supported for external dycores.) + ! This is done because communication lists have the various halos collapsed + ! into a single list. + ! ======================================================================== + + ! == First prepare communication lists + nHaloLayers = size(field % sendList % halos) + allocate(haloLayers(nHaloLayers)) + do iHalo = 1, nHaloLayers + haloLayers(iHalo) = iHalo + end do + ! Built new send/receive communication lists that have procID & nList filled out. + call mpas_dmpar_build_comm_lists(field % sendList, field % recvList, haloLayers, field % dimsizes, sendCommList, recvCommList) + + + ! == Next populate the commLists' ibuffer field with the element indices to communicate + + ! NOTE: Looping over the various block's via the field linked list is NOT needed + ! because packing the communication list with indices will be garbage + ! if there is more than one block per processor since the indices are block specific. + ! External dycores currently only support one block per processor and + ! this subroutine would need substantial modification to support more. + ! However I am keeping the code that traverses blocks + ! because this section is taken from mpas_dmpar_exch_halo_field1d_integer + ! and retaining it makes comparison to that subroutine easier. The only + ! difference is the assignements to the ibuffers. + ! A check for 1 block per proc is in li_velocity_external_init. + + + ! Allocate space in send lists, and copy data into buffer + commListPtr => sendCommList + do while(associated(commListPtr)) ! Traverse all the processors to be sent to. + allocate(commListPtr % ibuffer(commListPtr % nList)) + nullify(commListPtr % rbuffer) + bufferOffset = 0 + do iHalo = 1, nHaloLayers + nAdded = 0 + + fieldCursor => field + do while(associated(fieldCursor)) ! This is the linked list traversal that is NOT needed. + exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList + do while(associated(exchListPtr)) + if (exchListPtr % endPointID == commListPtr % procID) then + do i = 1, exchListPtr % nList + commListPtr % ibuffer(exchListPtr % destList(i) + bufferOffset) = exchListPtr % srcList(i) ! local indices to go into the send communication list + nAdded = nAdded + 1 + + end do + end if + + exchListPtr => exchListPtr % next + end do + + fieldCursor => fieldCursor % next + end do + bufferOffset = bufferOffset + nAdded + end do + + commListPtr => commListPtr % next + end do + + + ! Allocate space in recv lists, and copy data into buffer + commListPtr => recvCommList + do while(associated(commListPtr)) ! Traverse all the processors to receive from. + allocate(commListPtr % ibuffer(commListPtr % nList)) + nullify(commListPtr % rbuffer) + bufferOffset = 0 + do iHalo = 1, nHaloLayers + nAdded = 0 + fieldCursor => field + do while(associated(fieldCursor)) ! This is the linked list traversal that is NOT needed. + exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList + do while(associated(exchListPtr)) + if (exchListPtr % endPointID == commListPtr % procID) then + do i = 1, exchListPtr % nList + commListPtr % ibuffer( exchListPtr % srcList(i) + bufferOffset ) = exchListPtr % destList(i) ! buffer index to go into the receive communication list + end do + nAdded = max(nAdded, maxval(exchListPtr % srcList)) + end if + exchListPtr => exchListPtr % next + end do + + fieldCursor => fieldCursor % next + end do + bufferOffset = bufferOffset + nAdded + end do + commListPtr => commListPtr % next + end do + + + ! ======================================================================== + ! Step 2: Flatten the communication lists to flat arrays + ! ======================================================================== + call fill_exchange_array(sendCommList, sendArray) + call fill_exchange_array(recvCommList, recvArray) + + + ! Clean up + call mpas_dmpar_destroy_communication_list(sendCommList) + call mpas_dmpar_destroy_communication_list(recvCommList) + deallocate(haloLayers) + + end subroutine array_from_exchange_list +!*********************************************************************** + + +!*********************************************************************** +! +! routine fill_exchange_array +! +!> \brief Fills the flat array for external use with information from an MPAS communication list +!> \author Matt Hoffman +!> \date 15 October 2013 +!> \version SVN:$Id$ +!> \details +!> This routine converts the MPAS Communication Lists (type mpas_communication_list) +!> to flat arrays for use by external dycores. The arrays have this format: +!> +!> Pos 1: total size of array +!> For each processor to be communicated with: +!> Pos 1: processor ID +!> Pos 2: nList (number of elements in this processor's sub-list +!> Pos 3 to 3+nList-1: local indices of elements to be communicated (using 0-based indexing for C/C++) +!----------------------------------------------------------------------- + subroutine fill_exchange_array(commList, commArray) + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + type (mpas_communication_list), pointer, intent(in) :: & + commList !< Input: Communication list to be flattened + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + integer, dimension(:), pointer :: commArray !< Input/Output: the flat array of elements to communicate, should be unallocated on input + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- +! integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + integer :: arraySize ! size of array to house the send or receive list (sendArray, recvArray) + integer :: offset ! offset for adding metadata about each processor into the flat commArray + integer :: i + type (mpas_communication_list), pointer :: commListPtr ! A temporary comm list pointer for traversing linked lists + + arraySize = 1 !in first position we will store the size of the array + commListPtr => commList + do while (associated(commListPtr)) + ! for each processor to be communicated with, we will store the procID, nList, and then the list of local indices to be communicated + arraySize = arraySize + commListPtr % nlist + 2 + commListPtr => commListPtr % next + end do + + allocate(commArray(arraySize)) + + commArray(1) = arraySize + offset = 2 ! we will store the procID, nList before the list of local indices + commListPtr => commList + do while (associated(commListPtr)) + commArray(offset) = commListPtr % procID ! store procID + offset = offset + 1 + commArray(offset) = commListPtr % nlist ! store nList + do i = 1 , commListPtr % nlist + commArray(i+offset) = commListPtr % ibuffer(i) -1 ! add the list of elements to be communicated, switching to 0-based indexing for C/C++ + end do + offset = offset + commListPtr % nlist + 1 + + commListPtr => commListPtr % next + end do + + end subroutine fill_exchange_array +!*********************************************************************** + + +end module li_velocity_external + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| From 0c451983e5c5cead8049335858200c9900ed1557 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 20 Jan 2015 12:45:11 -0700 Subject: [PATCH 0010/1724] LI: Add option to do vector reconst. w/ extern. dycores Recently the external dycore interface was modified so that they pass back u,v velocities on cell centers (which are the native locations of their FEM solution). This commit adds an option that lets MPAS overwrite those values with ones calculated by MPAS using framework's vector reconstruction routines based on the values of normalVelocity supplied by the external dycore. This provides a way to test the calculation of normalVelocity in the interface. --- src/core_landice/Registry.xml | 4 ++++ src/core_landice/mpas_li_diagnostic_vars.F | 5 ++++- src/core_landice/mpas_li_mpas_core.F | 11 +++++++++-- 3 files changed, 17 insertions(+), 3 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 7cb3efaa60..f2458f9f5b 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -54,6 +54,10 @@ 'from_normal_slope' uses the vector operator mpas_tangential_vector_1d to calculate the tangent slopes from the normal slopes on the edges of the adjacent cells. It will work for any mesh configuration, but is the least accurate method." possible_values="'from_vertex_barycentric', 'from_vertex_barycentric_kiteareas', 'from_normal_slope'" /> + diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index 3ae6b85104..04113f12a4 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -114,6 +114,7 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: statePool character (len=StrKIND), pointer :: config_velocity_solver + logical, pointer :: config_do_velocity_reconstruction_for_external_dycore type (field2DReal), pointer :: normalVelocityField, layerThicknessEdgeField real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional real (kind=RKIND), dimension(:), pointer :: surfaceSpeed, basalSpeed @@ -124,6 +125,7 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) err = 0 call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + call mpas_pool_get_config(liConfigs, 'config_do_velocity_reconstruction_for_external_dycore', config_do_velocity_reconstruction_for_external_dycore) ! === ! === Diagnostic solve of variables prior to velocity @@ -188,7 +190,8 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) ! Native SIA dycore needs to have reconstructed velocities calculated. ! External dycores return their native velocities at cell center locations, ! but these can optionally be overwritten by reconstructed velocities for testing. - if ( (trim(config_velocity_solver) == 'sia') ) then + if ( (trim(config_velocity_solver) == 'sia') .or. & + config_do_velocity_reconstruction_for_external_dycore ) then call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'uReconstructZ', uReconstructZ, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'uReconstructZonal', uReconstructZonal, timeLevel=timeLevel) diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index ea228152a7..37d47ba6f8 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -644,6 +644,8 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) type (mpas_pool_type), pointer :: statePool integer, dimension(:), pointer :: vertexMask character (len=StrKIND), pointer :: xtime + character (len=StrKIND), pointer :: config_velocity_solver + logical, pointer :: config_do_velocity_reconstruction_for_external_dycore type (MPAS_Time_Type) :: currTime integer :: err, err_tmp @@ -653,6 +655,8 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! Get pool stuff call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + call mpas_pool_get_config(liConfigs, 'config_do_velocity_reconstruction_for_external_dycore', config_do_velocity_reconstruction_for_external_dycore) ! Copy data from first time level into all other time levels @@ -686,8 +690,11 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) call mpas_timer_stop("initialize velocity") ! Init for reconstruction of velocity - call mpas_rbf_interp_initialize(meshPool) - call mpas_init_reconstruct(meshPool) + if ( (trim(config_velocity_solver) == 'sia') .or. & + config_do_velocity_reconstruction_for_external_dycore ) then + call mpas_rbf_interp_initialize(meshPool) + call mpas_init_reconstruct(meshPool) + endif ! Assign initial time stamp call mpas_pool_get_array(statePool, 'xtime', xtime, timeLevel=1) From ce16d2c6b820f4feac6c859a6aae0b11af64ebf2 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 22 Jan 2015 14:03:06 -0700 Subject: [PATCH 0011/1724] LI: Create package for HO variables Model variables that are only needed for higher-order dycores are only allocated and only read from input file if a higher-order dycore is selected in the namelist file. There was an issue in framework (#296) with streams sharing the same filename_template. So for now the inputHigherOrderVelocity stream has a filename_template of landice_grid.nc2. This needs to be changed to landice_grid.nc in the streams.landice file before running the model. --- src/core_landice/Registry.xml | 29 +++++++++++++++++++--------- src/core_landice/mpas_li_mpas_core.F | 26 +++++++++++++++++++++++-- 2 files changed, 44 insertions(+), 11 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index f2458f9f5b..d96774812c 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -215,6 +215,15 @@ + + + + + + + + + @@ -269,15 +278,22 @@ immutable="true" filename_template="landice_grid.nc" input_interval="initial_only"> - - + + + + - - - - - - - @@ -424,6 +433,7 @@ /> @@ -588,6 +598,7 @@ /> diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index 37d47ba6f8..4869bfa1e9 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -94,6 +94,7 @@ subroutine mpas_core_init(domain, stream_manager, startTimeStamp) ! !----------------------------------------------------------------- type (block_type), pointer :: block + logical, pointer :: higherOrderVelocityActive type (MPAS_Time_Type) :: startTime integer :: i, err, err_tmp, globalErr @@ -105,6 +106,8 @@ subroutine mpas_core_init(domain, stream_manager, startTimeStamp) globalErr = 0 call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) + call mpas_pool_get_package(domain % packages, 'higherOrderVelocityActive', higherOrderVelocityActive) + ! ! Initialize config option settings as needed ! @@ -125,13 +128,23 @@ subroutine mpas_core_init(domain, stream_manager, startTimeStamp) if (config_do_restart) then call mpas_stream_mgr_read(stream_manager, streamID='restart', ierr=err_tmp) + err = ior(err, err_tmp) else call mpas_stream_mgr_read(stream_manager, streamID='input', ierr=err_tmp) + err = ior(err, err_tmp) + if (higherOrderVelocityActive) then + call mpas_stream_mgr_read(stream_manager, streamID='inputHigherOrderVelocity', ierr=err_tmp) + err = ior(err, err_tmp) + endif end if call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='restart', ierr=err_tmp) err = ior(err, err_tmp) call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='input', ierr=err_tmp) err = ior(err, err_tmp) + if (higherOrderVelocityActive) then + call MPAS_stream_mgr_reset_alarms(stream_manager, streamID='inputHigherOrderVelocity', ierr=err_tmp) + err = ior(err, err_tmp) + endif call mpas_stream_mgr_reset_alarms(stream_manager, direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) err = ior(err, err_tmp) @@ -499,16 +512,25 @@ subroutine mpas_core_setup_packages(configPool, packagePool, ierr) type (mpas_pool_type), intent(in) :: configPool type (mpas_pool_type), intent(in) :: packagePool integer, intent(out) :: ierr - ! Locals + ! Local variables character (len=StrKIND), pointer :: config_velocity_solver + logical, pointer :: higherOrderVelocityActive logical, pointer :: SIAvelocityActive + integer :: err_tmp ierr = 0 call mpas_pool_get_config(configPool, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_package(packagePool, 'SIAvelocityActive', SIAvelocityActive) + call mpas_pool_get_package(packagePool, 'higherOrderVelocityActive', higherOrderVelocityActive) - if(trim(config_velocity_solver) == 'sia') SIAvelocityActive = .true. + if (trim(config_velocity_solver) == 'sia') then + SIAvelocityActive = .true. + write (stdoutUnit,*) 'The SIAVelocity package and associated variables and streams has been enabled because the SIA velocity solver is selected.' + else + higherOrderVelocityActive = .true. + write (stdoutUnit,*) 'The higherOrderVelocity package and associated variables and streams has been enabled because a higher-order velocity solver is selected.' + end if end subroutine mpas_core_setup_packages From 866c166c5605110fee96f346fce4d15fd9b7a9c1 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 29 Jan 2015 11:40:41 -0700 Subject: [PATCH 0012/1724] LI: remove inputHigherOrderVelocity stream I've retained these variables being associated with a package, but instead of creating a separate stream for them, they are included in the input stream. Because the package enables/disables the variables, MPAS will only attempt to read them if the package is enabled. Thus, having a separate stream for them seems unnecessarily complicated. This commit and the previous one can be used as a reference if having multiple input streams is ever desired. --- src/core_landice/Registry.xml | 10 +++++++++- src/core_landice/mpas_li_mpas_core.F | 13 +------------ 2 files changed, 10 insertions(+), 13 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index d96774812c..c227456919 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -283,17 +283,25 @@ + + + + + + + +--> + Date: Thu, 22 Jan 2015 22:22:36 -0700 Subject: [PATCH 0013/1724] LI: Add Dirichlet b.c. and floating lateral b.c. to HO dycore This commit adds the fields dirichletVelocityMask, dirichletVelocityXValue, dirichletVelocityYValue, dirichletMaskChanged to Registry to support Dirichlet velocity boundary conditions. The mask field is now passed into the velocity_solver_compute_2d_grid function and the X,YValue fields are passed into the velocity_solver_solve_* function. Note that dirichletVelocityMask is 3d so that one could, e.g, impose no slip basal boundary conditions. In mpas_li_diagnostic_vars.F there is a check if dirichletVelocityMask has changed from the previous time step because the velocity_solver_compute_2d_grid function needs to be re-called if that happens. -- This commit also adds a 1/0 integer mask called floatingEdges of which edges are floating to the velocity_solver_compute_2d_grid function call so that MPAS tells the external dycore where floating lateral b.c. should be applied rather than the dycore determining that on its own or through its config file. Note that in the mask module, floating edges are defined as: ! Floating Edges have at least one neighboring cell floating but this mask is then extrapolated forward as needed to treat the extended mesh of the FEM dycores. To facilitate the floating edge mask calculation, I added new mask routines to return integer masks of where ice is floating rather than just logicals. This way we can pass an integer field to the ext. dycore interface in velocity_solver_compute_2d_grid since passing logical fields between fortran and c++ is iffy. The routine li_calculate_extrapolate_floating_edgemask extends the floating mask forward since the FEM grid is using one extra cell center than the ice extent in the MPAS mesh. --- .../Interface_velocity_solver.cpp | 117 +++++++++++++----- .../Interface_velocity_solver.hpp | 16 ++- src/core_landice/Registry.xml | 37 ++++-- src/core_landice/mpas_li_diagnostic_vars.F | 45 ++++++- src/core_landice/mpas_li_mask.F | 74 +++++++++++ src/core_landice/mpas_li_velocity_external.F | 31 +++-- 6 files changed, 260 insertions(+), 60 deletions(-) diff --git a/src/core_landice/Interface_velocity_solver.cpp b/src/core_landice/Interface_velocity_solver.cpp index 1ff12226b5..42c86ad08d 100644 --- a/src/core_landice/Interface_velocity_solver.cpp +++ b/src/core_landice/Interface_velocity_solver.cpp @@ -3,6 +3,7 @@ // =================================================== #include +#include #include "Interface_velocity_solver.hpp" //#include //#include @@ -27,7 +28,8 @@ int nVertices, nEdges, nTriangles, nGlobalVertices, nGlobalEdges, nGlobalTriangles; int maxNEdgesOnCell_F; int const *cellsOnEdge_F, *cellsOnVertex_F, *verticesOnCell_F, - *verticesOnEdge_F, *edgesOnCell_F, *indexToCellID_F, *nEdgesOnCells_F; + *verticesOnEdge_F, *edgesOnCell_F, *indexToCellID_F, *nEdgesOnCells_F, + *dirichletCellsMask_F, *floatingEdgesMask_F; std::vector layersRatio, levelsNormalizedThickness; int nLayers; double const *xCell_F, *yCell_F, *zCell_F, *xVertex_F, *yVertex_F, *zVertex_F, *areaTriangle_F; @@ -40,7 +42,7 @@ const double minBeta = 1e-5; std::vector edgesToReceive, fCellsToReceive, indexToTriangleID, verticesOnTria, trianglesOnEdge, trianglesPositionsOnEdge, verticesOnEdge; std::vector indexToVertexID, vertexToFCell, indexToEdgeID, edgeToFEdge, - mask, fVertexToTriangleID, fCellToVertex; + mask, fVertexToTriangleID, fCellToVertex, floatingEdgesIds, dirichletNodesIDs; std::vector temperatureOnTetra, velocityOnVertices, velocityOnCells, elevationData, thicknessData, betaData, smb_F, thicknessOnCells; std::vector isVertexBoundary, isBoundaryEdge; @@ -73,15 +75,16 @@ int velocity_solver_init_mpi(int* fComm) { return 0; } + void velocity_solver_export_2d_data(double const* lowerSurface_F, double const* thickness_F, double const* beta_F) { if (isDomainEmpty) return; - +#ifdef LIFEV import2DFields(lowerSurface_F, thickness_F, beta_F, minThick); - velocity_solver_export_2d_data__(reducedComm, elevationData, thicknessData, betaData, indexToVertexID); +#endif } void velocity_solver_set_grid_data(int const* _nCells_F, int const* _nEdges_F, @@ -176,8 +179,9 @@ void velocity_solver_init_l1l2(double const* levelsRatio_F) { void velocity_solver_solve_l1l2(double const* lowerSurface_F, - double const* thickness_F, double const* beta_F, - double const* temperature_F, double* u_normal_F, double* xVelocityOnCell, double* yVelocityOnCell) { + double const* thickness_F, double const* beta_F, double const* temperature_F, + double* const dirichletVelocityXValue, double* const dirichletVelocitYValue, + double* u_normal_F, double* xVelocityOnCell, double* yVelocityOnCell) { #ifdef LIFEV @@ -269,6 +273,7 @@ void velocity_solver_init_fo(double const *levelsRatio_F) { layersRatio[i] = levelsRatio_F[nLayers - 1 - i]; //std::copy(levelsRatio_F, levelsRatio_F+nLayers, layersRatio.begin()); + mapCellsToVertices(velocityOnCells, velocityOnVertices, 2, nLayers, Ordering); #ifdef LIFEV @@ -279,11 +284,31 @@ void velocity_solver_init_fo(double const *levelsRatio_F) { } void velocity_solver_solve_fo(double const* lowerSurface_F, - double const* thickness_F, double const* beta_F, - double const* temperature_F, double* u_normal_F, double* xVelocityOnCell, double* yVelocityOnCell) { + double const* thickness_F, double const* beta_F, double const* temperature_F, + double* const dirichletVelocityXValue, double* const dirichletVelocitYValue, + double* u_normal_F, double* xVelocityOnCell, double* yVelocityOnCell) { std::fill(u_normal_F, u_normal_F + nEdges_F * (nLayers+1), 0.); + //import velocity from initial guess and from dirichlet values. + int sizeVelOnCell = nCells_F * (nLayers + 1); + for(int iCell=0; iCell regulThk(thicknessData); @@ -325,7 +351,6 @@ void velocity_solver_solve_fo(double const* lowerSurface_F, Ordering); //computing x, yVelocityOnCell - int sizeVelOnCell = nCells_F * (nLayers + 1); for(int iCell=0; iCell partialOffset(numProcs + 1), globalOffsetTriangles( @@ -602,8 +630,13 @@ void velocity_solver_compute_2d_grid(int const* verticesMask_F) { nEdges = edgeToFEdge.size(); indexToEdgeID.resize(nEdges); - for (int index = 0; index < nEdges; index++) - indexToEdgeID[index] = fEdgeToEdgeID[edgeToFEdge[index]]; + floatingEdgesIds.reserve(nEdges); + for (int index = 0; index < nEdges; index++) { + int fEdge = edgeToFEdge[index]; + indexToEdgeID[index] = fEdgeToEdgeID[fEdge]; + if((floatingEdgesMask_F[fEdge]!=0)&&(index fCellsToSend; @@ -656,11 +689,24 @@ void velocity_solver_compute_2d_grid(int const* verticesMask_F) { allToAll(fCellToVertexID, sendCellsList_F, recvCellsList_F); nVertices = vertexToFCell.size(); + int lVertexColumnShift = (Ordering == 1) ? 1 : nVertices; + int vertexLayerShift = (Ordering == 0) ? 1 : nLayers + 1; + + std::cout << "\n nvertices: " << nVertices << " " << nGlobalVertices << "\n" << std::endl; indexToVertexID.resize(nVertices); - for (int index = 0; index < nVertices; index++) - indexToVertexID[index] = fCellToVertexID[vertexToFCell[index]]; + dirichletNodesIDs.reserve(nVertices); //need to improve storage efficiency + for (int index = 0; index < nVertices; index++) { + int fCell = vertexToFCell[index]; + indexToVertexID[index] = fCellToVertexID[fCell]; + for(int il=0; il< nLayers+1; ++il) + { + int imask_F = il+(nLayers+1)*fCell; + if(dirichletCellsMask_F[imask_F]!=0) + dirichletNodesIDs.push_back((nLayers-il)*lVertexColumnShift+indexToVertexID[index]*vertexLayerShift); + } + } createReverseCellsExchangeLists(sendCellsListReversed, recvCellsListReversed, fVertexToTriangleID, fCellToVertexID); @@ -843,7 +889,7 @@ void velocity_solver_extrude_3d_grid(double const* levelsRatio_F, nGlobalEdges, Ordering, reducedComm, indexToVertexID, mpasIndexToVertexID, verticesCoords, isVertexBoundary, verticesOnTria, isBoundaryEdge, trianglesOnEdge, trianglesPositionsOnEdge, verticesOnEdge, indexToEdgeID, - indexToTriangleID); + indexToTriangleID, dirichletNodesIDs, floatingEdgesIds); } } @@ -1241,15 +1287,36 @@ void import2DFields(double const * lowerSurface_F, double const * thickness_F, double const * beta_F, double eps) { elevationData.assign(nVertices, 1e10); thicknessData.assign(nVertices, 1e10); - std::map bdExtensionMap; if (beta_F != 0) betaData.assign(nVertices, 1e10); + std::map bdExtensionMap; + + //import fields + for (int index = 0; index < nVertices; index++) { + int iCell = vertexToFCell[index]; + thicknessData[index] = std::max(thickness_F[iCell] / unit_length, eps); + elevationData[index] = (lowerSurface_F[iCell] / unit_length) + thicknessData[index]; + if (beta_F != 0) + betaData[index] = beta_F[iCell] / unit_length; + } + + //extend thickness elevation and basal friction data to the border for floating vertices + std::set::const_iterator iter; + for (int iV = 0; iV < nVertices; iV++) { if (isVertexBoundary[iV]) { int c; int fCell = vertexToFCell[iV]; + if(dirichletCellsMask_F[fCell]!=0) continue; int nEdg = nEdgesOnCells_F[fCell]; + elevationData[iV]=1e10; + bool isFloating = false; + for (int j = 0; (j < nEdg)&&(!isFloating); j++) { + int fEdge = edgesOnCell_F[maxNEdgesOnCell_F * fCell + j] - 1; + isFloating = (floatingEdgesMask_F[fEdge] != 0); + } + if(!isFloating) continue; for (int j = 0; j < nEdg; j++) { int fEdge = edgesOnCell_F[maxNEdgesOnCell_F * fCell + j] - 1; bool keep = (mask[verticesOnEdge_F[2 * fEdge] - 1] & 0x02) @@ -1279,24 +1346,6 @@ void import2DFields(double const * lowerSurface_F, double const * thickness_F, betaData[iv] = beta_F[ic] / unit_length; } - for (int index = 0; index < nVertices; index++) { - int iCell = vertexToFCell[index]; - - if (!isVertexBoundary[index]) { - thicknessData[index] = std::max(thickness_F[iCell] / unit_length, eps); - elevationData[index] = (lowerSurface_F[iCell] / unit_length) + thicknessData[index]; - } - } - - if (beta_F != 0) { - for (int index = 0; index < nVertices; index++) { - int iCell = vertexToFCell[index]; - - if (!isVertexBoundary[index]) - betaData[index] = beta_F[iCell] / unit_length; - } - } - } void importP0Temperature(double const * temperature_F) { diff --git a/src/core_landice/Interface_velocity_solver.hpp b/src/core_landice/Interface_velocity_solver.hpp index 5b840c40b8..a1cd122109 100644 --- a/src/core_landice/Interface_velocity_solver.hpp +++ b/src/core_landice/Interface_velocity_solver.hpp @@ -87,17 +87,19 @@ void velocity_solver_init_l1l2(double const* levelsRatio); void velocity_solver_init_fo(double const* levelsRatio); void velocity_solver_solve_l1l2(double const* lowerSurface_F, - double const* thickness_F, double const* beta_F, - double const* temperature_F, double* u_normal_F = 0, + double const* thickness_F, double const* beta_F, double const* temperature_F, + double* const dirichletVelocityXValue = 0, double* const dirichletVelocitYValue = 0, + double* u_normal_F = 0, double* xVelocityOnCell = 0, double* yVelocityOnCell = 0); void velocity_solver_solve_fo(double const* lowerSurface_F, - double const* thickness_F, double const* beta_F, - double const* temperature_F, double* u_normal_F = 0, + double const* thickness_F, double const* beta_F, double const* temperature_F, + double* const dirichletVelocityXValue = 0, double* const dirichletVelocitYValue = 0, + double* u_normal_F = 0, double* xVelocityOnCell = 0, double* yVelocityOnCell = 0); -void velocity_solver_compute_2d_grid(int const* verticesMask_F); +void velocity_solver_compute_2d_grid(int const* verticesMask_F, int const* dirichletNodesMask_F, int const* floatingEdgeMask_F); void velocity_solver_set_grid_data(int const* _nCells_F, int const* _nEdges_F, int const* _nVertices_F, int const* _nLayers, int const* _nCellsSolve_F, @@ -195,7 +197,9 @@ extern void velocity_solver_extrude_3d_grid__(int nLayers, int nGlobalTriangles, const std::vector& trianglesPositionsOnEdge, const std::vector& verticesOnEdge, const std::vector& indexToEdgeID, - const std::vector& indexToTriangleID); + const std::vector& indexToTriangleID, + const std::vector& dirichletNodes, + const std::vector&floatingEdges); //extern void velocity_solver_export_l1l2_velocity__(); diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index c227456919..5b473f4412 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -299,6 +299,9 @@ filename_template="landice_grid.nc2" input_interval="initial_only"> + + + --> @@ -443,6 +446,28 @@ units="none" description="flag needed by external velocity solvers that indicates if the region to solve on the block's domain has changed (treated as a logical)" packages="higherOrderVelocity" /> + + + + + @@ -625,14 +650,10 @@ description="generic work array with dimensions of (nVertLevels nCells)" persistence="scratch" /> - - - - - + diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index 04113f12a4..24bb54174d 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -300,21 +300,26 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ real (kind=RKIND), dimension(:), pointer :: thickness, upperSurface, & lowerSurface, bedTopography, upperSurfaceVertex, slopeEdge, & normalSlopeEdge, tangentSlopeEdge, dcEdge, dvEdge - integer, dimension(:), pointer :: cellMask, edgeMask + integer, dimension(:), pointer :: cellMask, edgeMask, vertexMask integer, dimension(:), pointer :: vertexMaskOld, vertexMaskNew + integer, dimension(:), pointer :: floatingEdges integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge integer, dimension(:,:), pointer :: baryCellsOnVertex real (kind=RKIND), dimension(:,:), pointer :: layerThickness, baryWeightsOnVertex real (kind=RKIND), dimension(:,:,:), pointer :: tracers - type (field1DInteger), pointer :: cellMaskField, edgeMaskField, vertexMaskField + type (field1DInteger), pointer :: cellMaskField, edgeMaskField, vertexMaskField, floatingEdgesField integer, pointer :: nCells, nVertices, nEdges integer, pointer :: anyVertexMaskChanged + integer, pointer :: dirichletMaskChanged + integer, dimension(:,:), pointer :: dirichletVelocityMaskOld, dirichletVelocityMaskNew real (kind=RKIND), pointer :: config_sea_level, config_ice_density, config_ocean_density character (len=StrKIND), pointer :: config_velocity_solver, config_sia_tangent_slope_calculation ! truly local variables real (kind=RKIND) :: thisThk integer :: iCell, iLevel, iEdge, cell1, cell2 integer :: blockVertexMaskChanged, procVertexMaskChanged + integer :: blockDirichletMaskChanged, procDirichletMaskChanged + integer :: err_tmp @@ -329,6 +334,7 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! Calculate masks - needs to happen before calculating lower surface so we know where the ice is floating call li_calculate_mask(meshPool, statePool, timeLevel, err_tmp) + err = ior(err, err_tmp) block => block % next @@ -374,6 +380,8 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'floatingEdges', floatingEdges, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'upperSurface', upperSurface, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'lowerSurface', lowerSurface, timeLevel=timeLevel) @@ -473,9 +481,26 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ call vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers, err) err = ior(err, err_tmp) + ! This information is only needed by external dycores. + if (config_velocity_solver /= 'sia') then + ! The interface expects an array where 1's are floating edges and 0's are non-floating edges. + floatingEdges = li_mask_is_floating_ice_int(edgeMask) + call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel=timeLevel) + call li_calculate_extrapolate_floating_edgemask(meshPool, vertexMask, floatingEdges) + end if + block => block % next end do + ! This information is only needed by external dycores. + if (config_velocity_solver /= 'sia') then + ! Update halos on masks - the outermost cells/edges/vertices may be wrong for mask components that need neighbor information + call mpas_timer_start("halo updates") + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_field(statePool, 'floatingEdges', floatingEdgesField, timeLevel=timeLevel) + call mpas_dmpar_exch_halo_field(floatingEdgesField) + call mpas_timer_stop("halo updates") + endif ! This information is only needed for some external dycores. if (config_velocity_solver /= 'sia') then @@ -497,11 +522,21 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ blockVertexMaskChanged = 0 endif !print *, 'blockVertexMaskChanged ', blockVertexMaskChanged - ! Determine if any blocks on this processor had a change to the vertex mask procVertexMaskChanged = max(procVertexMaskChanged, blockVertexMaskChanged) !print *,'procVertexMaskChanged', procVertexMaskChanged + ! Also check to see if the Dirichlet b.c. mask has changed + call mpas_pool_get_array(statePool, 'dirichletVelocityMask', dirichletVelocityMaskOld, timeLevel=1) + call mpas_pool_get_array(statePool, 'dirichletVelocityMask', dirichletVelocityMaskNew, timeLevel=2) + if ( sum(dirichletVelocityMaskNew - dirichletVelocityMaskOld) /= 0 ) then + blockDirichletMaskChanged = 1 + else + blockDirichletMaskChanged = 0 + endif + ! Determine if any blocks on this processor had a change to the vertex mask + procDirichletMaskChanged = max(procDirichletMaskChanged, blockDirichletMaskChanged) + block => block % next end do @@ -509,6 +544,10 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ call mpas_pool_get_array(statePool, 'anyVertexMaskChanged', anyVertexMaskChanged, timeLevel=timeLevel) call mpas_dmpar_max_int(domain % dminfo, procVertexMaskChanged, anyVertexMaskChanged) !print *,'anyVertexMaskChanged', anyVertexMaskChanged + ! Do the same for the Dirichlet b.c. mask + call mpas_pool_get_array(statePool, 'dirichletMaskChanged', dirichletMaskChanged, timeLevel=timeLevel) + call mpas_dmpar_max_int(domain % dminfo, procDirichletMaskChanged, dirichletMaskChanged) + !print *,'dirichletMaskChanged', dirichletMaskChanged end if diff --git a/src/core_landice/mpas_li_mask.F b/src/core_landice/mpas_li_mask.F index 67491eddfc..7800bc1e4e 100644 --- a/src/core_landice/mpas_li_mask.F +++ b/src/core_landice/mpas_li_mask.F @@ -76,6 +76,12 @@ module li_mask end interface + interface li_mask_is_floating_ice_int + module procedure li_mask_is_floating_ice_intout_1d + module procedure li_mask_is_floating_ice_intout_0d + end interface + + interface li_mask_is_grounded_ice module procedure li_mask_is_grounded_ice_logout_1d module procedure li_mask_is_grounded_ice_logout_0d @@ -406,6 +412,61 @@ subroutine li_calculate_mask(meshPool, statePool, timeLevel, err) end subroutine li_calculate_mask +!*********************************************************************** +! +! routine li_calculate_extrapolate_floating_edgemask +! +!> \brief Extrapolates floating edges forward as needed by external FEM dycores +!> \author Matt Hoffman +!> \date 29 January 2015 +!> \details +!> External FEM dycores include the first non-ice cells in their mesh. They +!> also use a mask to apply floating lateral boundary conditions on edges. +!> Because they include extra cell center location in their meshes, the triangle +!> edges connecting these extra nodes will not be covered by the standard +!> MPAS edge mask. This routine deals with this problem by 'extrapolating' +!> the floating edge mask forward to cover the edges connecting these extra nodes. +!> It does so by looping over edges, and setting as floating any edge that has +!> at least one neighboring vertex that is 'floating'. This makes use of the +!> convention that "Floating vertices have at least one neighboring cell floating". +! +!----------------------------------------------------------------------- + + subroutine li_calculate_extrapolate_floating_edgemask(meshPool, vertexMask, floatingEdges) + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + integer, dimension(:) :: & + vertexMask !< Input: vertexMask + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + integer, dimension(:) :: & + floatingEdges !< Input/Output: 0/1 mask of floating edges + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + integer, dimension(:,:), pointer :: verticesOnEdge + integer, pointer :: nEdges + integer :: iEdge + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + + do iEdge = 1, nEdges + floatingEdges(iEdge) = maxval(li_mask_is_floating_ice_int(vertexMask(verticesOnEdge(:, iEdge)))) + enddo + + end subroutine li_calculate_extrapolate_floating_edgemask + ! =================================== ! Functions for decoding bitmasks - will work with cellMask, edgeMask, or vertexMask @@ -479,6 +540,19 @@ function li_mask_is_floating_ice_logout_0d(mask) li_mask_is_floating_ice_logout_0d = (iand(mask, li_mask_ValueFloating) == li_mask_ValueFloating) end function li_mask_is_floating_ice_logout_0d + function li_mask_is_floating_ice_intout_1d(mask) + integer, dimension(:), intent(in) :: mask + integer, dimension(size(mask)) :: li_mask_is_floating_ice_intout_1d + + li_mask_is_floating_ice_intout_1d = iand(mask, li_mask_ValueFloating) / li_mask_ValueFloating + end function li_mask_is_floating_ice_intout_1d + + function li_mask_is_floating_ice_intout_0d(mask) + integer, intent(in) :: mask + integer :: li_mask_is_floating_ice_intout_0d + + li_mask_is_floating_ice_intout_0d = iand(mask, li_mask_ValueFloating) / li_mask_ValueFloating + end function li_mask_is_floating_ice_intout_0d ! -- Functions that check for presence of grounded ice -- function li_mask_is_grounded_ice_logout_1d(mask) diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index fdb3bbea60..0460dcb34f 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -320,6 +320,7 @@ end subroutine li_velocity_external_block_init subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) use mpas_timer + use li_mask !----------------------------------------------------------------- ! @@ -362,10 +363,13 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) normalVelocity, uReconstructX, uReconstructY, uReconstructZ real (kind=RKIND), dimension(:,:,:), pointer :: & tracers - integer, dimension(:), pointer :: vertexMask + integer, dimension(:), pointer :: vertexMask, edgeMask, floatingEdges + integer, dimension(:,:), pointer :: dirichletVelocityMask + real (kind=RKIND), dimension(:,:), pointer :: dirichletVelocityXValue, dirichletVelocityYValue character (len=StrKIND), pointer :: config_velocity_solver logical, pointer :: config_always_compute_fem_grid integer, pointer :: anyVertexMaskChanged + integer, pointer :: dirichletMaskChanged err = 0 @@ -388,22 +392,31 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel=timeLevel) call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'anyVertexMaskChanged', anyVertexMaskChanged, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'dirichletMaskChanged', dirichletMaskChanged, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'dirichletVelocityXValue', dirichletVelocityXValue, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'dirichletVelocityYValue', dirichletVelocityYValue, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'floatingEdges', floatingEdges, timeLevel=timeLevel) ! ================================================================== ! External dycore calls to be made only when vertex mask changes ! ================================================================== - if ((anyVertexMaskChanged == 1) .or. (config_always_compute_fem_grid)) then + ! Note these functions will always be called on the first solve because we + ! initialize vertexMask to garbage which sets anyVertexMaskChanged to 1. + if ((anyVertexMaskChanged == 1) .or. (config_always_compute_fem_grid) .or. & + (dirichletMaskChanged == 1) ) then #if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) call mpas_timer_start("velocity_solver_compute_2d_grid") - call velocity_solver_compute_2d_grid(vertexMask) + call velocity_solver_compute_2d_grid(vertexMask, dirichletVelocityMask, floatingEdges) call mpas_timer_stop("velocity_solver_compute_2d_grid") #else - write(0,*) "Error: To run with an external velocity solver you must compile MPAS with one." - err = 1 - return + write(0,*) "Error: To run with an external velocity solver you must compile MPAS with one." + err = 1 + return #endif select case (config_velocity_solver) @@ -458,7 +471,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) case ('L1L2') ! =============================================== #ifdef USE_EXTERNAL_L1L2 call mpas_timer_start("velocity_solver_solve_L1L2") - call velocity_solver_solve_L1L2(lowerSurface, thickness, beta, tracers(index_temperature,:,:), normalVelocity, uReconstructX, uReconstructY) + call velocity_solver_solve_L1L2(lowerSurface, thickness, beta, tracers(index_temperature,:,:), dirichletVelocityXValue, dirichletVelocityYValue, normalVelocity, uReconstructX, uReconstructY) ! call velocity_solver_estimate_SS_SMB(normalVelocity, mesh % sfcMassBal % array) call mpas_timer_stop("velocity_solver_solve_L1L2") ! Optional calls to have LifeV output data files @@ -475,7 +488,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) case ('FO') ! =============================================== #ifdef USE_EXTERNAL_FIRSTORDER call mpas_timer_start("velocity_solver_solve_FO") - call velocity_solver_solve_FO(lowerSurface, thickness, beta, tracers(index_temperature,:,:), normalVelocity, uReconstructX, uReconstructY) + call velocity_solver_solve_FO(lowerSurface, thickness, beta, tracers(index_temperature,:,:), dirichletVelocityXValue, dirichletVelocityYValue, normalVelocity, uReconstructX, uReconstructY) ! call velocity_solver_estimate_SS_SMB(normalVelocity, mesh % sfcMassBal % array) call mpas_timer_stop("velocity_solver_solve_FO") call mpas_timer_start("velocity_solver export") @@ -492,7 +505,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) case ('Stokes') ! =============================================== #ifdef USE_EXTERNAL_STOKES call mpas_timer_start("velocity_solver_solve_stokes") - call velocity_solver_solve_stokes(lowerSurface, thickness, beta, tracers(index_temperature,:,:), normalVelocity, uReconstructX, uReconstructY, uReconstructZ) + call velocity_solver_solve_stokes(lowerSurface, thickness, beta, tracers(index_temperature,:,:), dirichletVelocityXValue, dirichletVelocityYValue, normalVelocity, uReconstructX, uReconstructY, uReconstructZ) uReconstructZ = uReconstructZ / (365.0*24.0*3600.0) ! convert from m/yr to m/s call mpas_timer_stop("velocity_solver_solve_stokes") #else From fe0e9ac62aca5989a6dedda78a2e60e5ef33a37b Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 29 Jan 2015 20:48:21 -0700 Subject: [PATCH 0014/1724] LI: replace dirichletVelocityX/YValue with uReconstructX/Y I've eliminated the dirichletVelocityX/YValue arrays because the uReconstructX/Y arrays can be used for that purpose on input. This eliminates the need for two additional 3d real fields. --- src/core_landice/Registry.xml | 16 ++++------------ src/core_landice/mpas_li_velocity_external.F | 15 +++++++++------ 2 files changed, 13 insertions(+), 18 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 5b473f4412..ad766d16b7 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -287,8 +287,8 @@ - - + + \brief Calculates the flow law parameter A based on temperature +!> \author Matt Hoffman +!> \date 23 Jan 2014 +!> \details +!> This routine calculates the flow law parameter A based on temperature +!> depending on what option is chosen. +!> The default option is a constant A assigned from config_default_flowParamA. +!> The PB1982 option uses this equation from \emph{Paterson and Budd} [1982] +!> and \emph{Paterson} [1994] (copied from CISM): +!> \[ +!> A(T^{*})=A0 \exp \left(\frac{-Q}{RT^{*}}\right) +!> \] +!> This is equation 9 in {\em Payne and Dongelmans}. $A)$ is a constant of proportionality, +!> $Q$ is the activation energy for for ice creep, and $R$ is the universal gas constant. +!> The pressure-corrected temperature, $T^{*}$ is given by: +!> \[ +!> T^{*}=T+T_{pmp} +!> \] +!> \[ +!> T_{pmp}=\sigma \rho g H \Phi +!> \] +!> $T$ is the ice temperature, $T_0$ is the triple point of water, +!> $\rho$ is the ice density, and $\Phi$ is the (constant) rate of change of +!> melting point temperature with pressure. +!> +!> The CP2010 option uses this equation from the 4th Edition of Physics of Glaciers (Eq. 3.35): +!> \[ +!> A(T^{*})=A0 \exp \left(\frac{-Q}{R} ( \frac{1}{T^{*}} - \frac{1}{T_t})\right) +!> \] +!> where the variables are the same as above and $T_t$ is the pressure corrected +!> transition temperature (-10 deg C at 0 pressure). +!> Values for $A0, Q, \Phi$ differ from PB1982. +!> +!> All options are adjusted by the enhancement factor (which defaults to 1.0). +!----------------------------------------------------------------------- + subroutine calculate_flowParamA(meshPool, temperature, thickness, flowParamA, err) + use mpas_constants, only: gravity + use li_constants, only: idealGasConstant + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + real (kind=RKIND), dimension(:,:), intent(in) :: & + temperature !< Input: temperature + real (kind=RKIND), dimension(:), intent(in) :: & + thickness !< Input: thickness + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + integer, intent(inout) :: err + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:), intent(out) :: & + flowParamA !< Input: flowParamA + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + integer, pointer :: nCells, nVertLevels + character (len=StrKIND), pointer :: config_flowParamA_calculation + real (kind=RKIND), pointer :: config_default_flowParamA, & + config_enhancementFactor, & + config_dynamic_thickness, & + config_ice_density + integer :: iCell, iLevel, err_tmp + real (kind=RKIND), dimension(:), pointer :: layerCenterSigma + real (kind=RKIND) :: A0, Q, pressureMeltPointSlope + real (kind=RKIND) :: temperatureCorrected, transitionTemperatureCorrected + + err_tmp = 0 + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) + + call mpas_pool_get_config(liConfigs, 'config_flowParamA_calculation', config_flowParamA_calculation) + call mpas_pool_get_config(liConfigs, 'config_enhancementFactor', config_enhancementFactor) + call mpas_pool_get_config(liConfigs, 'config_default_flowParamA', config_default_flowParamA) + call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) + call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) + + + select case(config_flowParamA_calculation) + !----------------------------------------------------------------- + case('constant') + flowParamA = config_default_flowParamA + !----------------------------------------------------------------- + case('PB1982') + pressureMeltPointSlope = 9.7456e-8_RKIND + do iCell = 1, nCells + if (thickness(iCell) > config_dynamic_thickness) then + do iLevel = 1, nVertLevels + ! Calculate the pressure-corrected temperature + temperatureCorrected = min(273.15_RKIND, temperature(iLevel,iCell) + pressureMeltPointSlope * & + thickness(iCell) * config_ice_density * gravity * layerCenterSigma(iLevel) ) + temperatureCorrected = max(223.15_RKIND, temperatureCorrected) + ! Calculate flow A + if (temperatureCorrected > 263.15_RKIND) then + A0 = 1.733e3_RKIND + Q = 139.0e3_RKIND + else + A0 = 3.613e-13_RKIND + Q = 60.0e3_RKIND + endif + flowParamA(iLevel,iCell) = A0 * exp(-1.0_RKIND * Q / (idealGasConstant * temperatureCorrected)) + enddo ! levels + endif ! if dynamic ice + enddo ! cells + !----------------------------------------------------------------- + case('CP2010') + pressureMeltPointSlope = 7.0e-8_RKIND + do iCell = 1, nCells + if (thickness(iCell) > 0.0_RKIND) then ! SIA solver could make use of A on thin ice if doing 2nd order averaging of flwa onto edges (otherwise this could be the dynamic thickness limit) + do iLevel = 1, nVertLevels + ! Calculate the pressure-corrected temperature + temperatureCorrected = min(273.15_RKIND, temperature(iLevel,iCell) + pressureMeltPointSlope * & + thickness(iCell) * config_ice_density * gravity * layerCenterSigma(iLevel) ) + temperatureCorrected = max(223.15_RKIND, temperatureCorrected) + transitionTemperatureCorrected = 263.15_RKIND + pressureMeltPointSlope * & + thickness(iCell) * config_ice_density * gravity * layerCenterSigma(iLevel) + ! Calculate flow A + A0 = 3.5e-25_RKIND + if (temperatureCorrected > 263.15_RKIND) then + Q = 115.0e3_RKIND + else + Q = 6.0e4_RKIND + endif + flowParamA(iLevel,iCell) = A0 * exp(-1.0_RKIND * Q / idealGasConstant * (1.0_RKIND/temperatureCorrected - 1.0_RKIND/transitionTemperatureCorrected)) + enddo ! levels + else + flowParamA(:,iCell) = 0.0_RKIND ! non-ice cells get 0 + endif ! if dynamic ice + enddo ! cells + !----------------------------------------------------------------- + end select + + !print *,'max flwa', maxval(flowParamA) + !print *,'config_enhancementFactor', config_enhancementFactor + + ! Include enhancement factor + flowParamA = flowParamA * config_enhancementFactor + + err = ior(err, err_tmp) + + end subroutine calculate_flowParamA + + end module li_diagnostic_vars From a5a82b37396d23f4705aed7c874dca62f68d99c2 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 2 Mar 2015 13:49:00 -0700 Subject: [PATCH 0020/1724] LI: Make SIA solver use flwa This requires integrating velocity from the bed up to the surface, assuming flwa is constant within each vertical layer. --- src/core_landice/mpas_li_mask.F | 20 ++++++++++ src/core_landice/mpas_li_sia.F | 68 +++++++++++++++++++-------------- 2 files changed, 60 insertions(+), 28 deletions(-) diff --git a/src/core_landice/mpas_li_mask.F b/src/core_landice/mpas_li_mask.F index 67491eddfc..807d6e77da 100644 --- a/src/core_landice/mpas_li_mask.F +++ b/src/core_landice/mpas_li_mask.F @@ -70,6 +70,12 @@ module li_mask end interface + interface li_mask_is_dynamic_ice_int + module procedure li_mask_is_dynamic_ice_intout_1d + module procedure li_mask_is_dynamic_ice_intout_0d + end interface + + interface li_mask_is_floating_ice module procedure li_mask_is_floating_ice_logout_1d module procedure li_mask_is_floating_ice_logout_0d @@ -463,6 +469,20 @@ function li_mask_is_dynamic_ice_logout_0d(mask) li_mask_is_dynamic_ice_logout_0d = (iand(mask, li_mask_ValueDynamicIce) == li_mask_ValueDynamicIce) end function li_mask_is_dynamic_ice_logout_0d + function li_mask_is_dynamic_ice_intout_1d(mask) + integer, dimension(:), intent(in) :: mask + integer, dimension(size(mask)) :: li_mask_is_dynamic_ice_intout_1d + + li_mask_is_dynamic_ice_intout_1d = iand(mask, li_mask_ValueDynamicIce) / li_mask_ValueDynamicIce + end function li_mask_is_dynamic_ice_intout_1d + + function li_mask_is_dynamic_ice_intout_0d(mask) + integer, intent(in) :: mask + integer :: li_mask_is_dynamic_ice_intout_0d + + li_mask_is_dynamic_ice_intout_0d = iand(mask, li_mask_ValueDynamicIce) / li_mask_ValueDynamicIce + end function li_mask_is_dynamic_ice_intout_0d + ! -- Functions that check for presence of floating ice -- function li_mask_is_floating_ice_logout_1d(mask) diff --git a/src/core_landice/mpas_li_sia.F b/src/core_landice/mpas_li_sia.F index 398ace1569..bea7762b14 100644 --- a/src/core_landice/mpas_li_sia.F +++ b/src/core_landice/mpas_li_sia.F @@ -249,36 +249,35 @@ subroutine li_sia_solve(meshPool, statePool, timeLevel, err) ! !----------------------------------------------------------------- - real (kind=RKIND), dimension(:), pointer :: thickness, layerInterfaceSigma, dcEdge, dvEdge + real (kind=RKIND), dimension(:), pointer :: thickness, layerInterfaceSigma real (kind=RKIND), dimension(:), pointer :: slopeEdge, normalSlopeEdge - real (kind=RKIND), dimension(:,:), pointer :: normalVelocity - integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge - integer, dimension(:), pointer :: edgeMask - integer, pointer :: nVertInterfaces, nEdges, nVertices, vertexDegree - integer :: iLevel, iEdge, iCell, iVertex, cell1, cell2, cellIndex - real (kind=RKIND) :: basalVelocity, & - layerInterfaceHeightOnEdge, thicknessEdge, hVertexAccum + real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, flowParamA + integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:), pointer :: edgeMask, cellMask + integer, pointer :: nVertInterfaces, nEdges + integer :: iLevel, iEdge + integer :: cell1, cell2 + real (kind=RKIND) :: thicknessEdge, flwaLevelEdge + real (kind=RKIND) :: positionIndependentFactor ! The portion of the velocity calculation that is completely independent of position + real (kind=RKIND) :: levelIndependentFactor ! The portion of the velocity calculation that depends on horizontal location but not vertical position real (kind=RKIND), pointer :: rhoi ! ice density - real (kind=RKIND), pointer :: ratefactor ! flow law parameter, A real (kind=RKIND), pointer :: n ! flow law exponent, n + integer :: cell1_is_dynamic, cell2_is_dynamic err = 0 ! Set needed variables and pointers call mpas_pool_get_dimension(meshPool, 'nVertInterfaces', nVertInterfaces) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) - call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) - call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) - call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) - call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'flowParamA', flowParamA, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'slopeEdge', slopeEdge, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'normalSlopeEdge', normalSlopeEdge, timeLevel=timeLevel) @@ -286,33 +285,46 @@ subroutine li_sia_solve(meshPool, statePool, timeLevel, err) ! Get parameters specified in the namelist call mpas_pool_get_config(liConfigs, 'config_ice_density', rhoi) call mpas_pool_get_config(liConfigs, 'config_flowLawExponent', n) - call mpas_pool_get_config(liConfigs, 'config_default_flowParamA', ratefactor) ! units of s^{-1} Pa^{-n} - ! Calculate ratefactor (A) at edge - TODO This should be calculated external to this subroutine and as a function of temperature - basalVelocity = 0.0_RKIND ! Assume no sliding + positionIndependentFactor = -0.5_RKIND * (rhoi * gravity)**n ! could be calculated once on init ! Loop over edges do iEdge = 1, nEdges + ! Only calculate velocity for edges that are part of the dynamic ice sheet.(thick ice) ! Also, the velocity calculation should be valid for non-ice edges (i.e. returns 0). if ( li_mask_is_dynamic_ice(edgeMask(iEdge)) ) then cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + cell1_is_dynamic = li_mask_is_dynamic_ice_int(cellMask(cell1)) + cell2_is_dynamic = li_mask_is_dynamic_ice_int(cellMask(cell2)) + ! Calculate thickness on edge - 2nd order thicknessEdge = (thickness(cell1) + thickness(cell2) ) * 0.5_RKIND - ! Loop over layers - do iLevel = 1, nVertInterfaces - ! Determine the height of each layer above the bed - layerInterfaceHeightOnEdge = thicknessEdge * (1.0_RKIND - layerInterfaceSigma(iLevel) ) - ! Calculate SIA velocity - normalVelocity(iLevel,iEdge) = basalVelocity + & - 0.5_RKIND * ratefactor * (rhoi * gravity)**n * slopeEdge(iEdge)**(n-1) * normalSlopeEdge(iEdge) * & - (thicknessEdge**(n+1) - (thicknessEdge - layerInterfaceHeightOnEdge)**(n+1)) - end do ! Levels +! thicknessEdge = (thickness(cell1) * cell1_is_dynamic + thickness(cell2) * cell2_is_dynamic) / (cell1_is_dynamic + cell2_is_dynamic) ! this version does an upwind thickness on margin edges only. Most Halfar error stats are higher by about 10-20% + ! Also tried upwind everywhere [for dome can be hacked with: thicknessEdge = max(thickness(cell1), thickness(cell2) ] This results in Halfar errors that are about 5x larger than centered difference + + levelIndependentFactor = slopeEdge(iEdge)**(n-1) * normalSlopeEdge(iEdge) * thicknessEdge**(n+1) + + normalVelocity(nVertInterfaces, iEdge) = 0.0_RKIND ! Assume no sliding + + do iLevel = nVertInterfaces-1, 1, -1 ! Loop upwards from second lowest level to surface + ! Calculate flwa on edge for this level - 2nd order, except can't do centered difference into areas where flwa may not be valid, so excluding the downwind flwa value in non-dynamic cells +! flwaLevelEdge = (flowParamA(iLevel, cell1) + flowParamA(iLevel, cell2) ) * 0.5_RKIND + flwaLevelEdge = (flowParamA(iLevel, cell1) * cell1_is_dynamic + & + flowParamA(iLevel, cell2) * cell2_is_dynamic) / & + (cell1_is_dynamic + cell2_is_dynamic) + + ! Calculate SIA velocity for this layer interface by adding on incremental velocity for the layer below + ! (This requires that flwa be constant over that layer, which it is.) + normalVelocity(iLevel, iEdge) = normalVelocity(iLevel+1, iEdge) + & + positionIndependentFactor * levelIndependentFactor * flwaLevelEdge * & + ( (layerInterfaceSigma(iLevel))**(n+1) - (layerInterfaceSigma(iLevel+1))**(n+1) ) + end do else - normalVelocity(:,iEdge) = 0.0_RKIND + normalVelocity(:,iEdge) = 0.0_RKIND ! zero velocity on non-dynamic edges endif - end do ! edges + end do ! edges ! === error check if (err > 0) then From 60d263cac9ed61f850f80412acaf2bb8d1cb1572 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 2 Mar 2015 15:32:37 -0700 Subject: [PATCH 0021/1724] LI: Add 'none' velocity solver This does nothing so applied a velocity field of 0 - or whatever velocity field has been input. --- src/core_landice/Registry.xml | 4 ++-- src/core_landice/mpas_li_velocity.F | 8 ++++++++ 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 3f83b4fee4..014753b99c 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -44,8 +44,8 @@ & velocityOnVertices, From 2c4ef1fb9194286c3992dad2feb44f5430ae7858 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Fri, 13 Mar 2015 09:24:49 -0600 Subject: [PATCH 0024/1724] LI: Fix typos/cleanup comments in extern dycore code --- src/core_landice/Registry.xml | 2 +- src/core_landice/mpas_li_mask.F | 2 +- src/core_landice/mpas_li_velocity_external.F | 12 +++++------- 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index ad766d16b7..f86e970016 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -284,7 +284,7 @@ - + diff --git a/src/core_landice/mpas_li_mask.F b/src/core_landice/mpas_li_mask.F index 785591a37c..ab4f9a4df6 100644 --- a/src/core_landice/mpas_li_mask.F +++ b/src/core_landice/mpas_li_mask.F @@ -432,7 +432,7 @@ end subroutine li_calculate_mask !> \details !> External FEM dycores include the first non-ice cells in their mesh. They !> also use a mask to apply floating lateral boundary conditions on edges. -!> Because they include extra cell center location in their meshes, the triangle +!> Because they include extra cell center locations in their meshes, the triangle !> edges connecting these extra nodes will not be covered by the standard !> MPAS edge mask. This routine deals with this problem by 'extrapolating' !> the floating edge mask forward to cover the edges connecting these extra nodes. diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index 9246bef1b6..884417fe40 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -141,7 +141,7 @@ subroutine li_velocity_external_init(domain, err) #ifdef USE_EXTERNAL_STOKES call interface_phg_init(domain, err) #else - write(0,*) "Error: External Stokes library needed to run stokes dycore." + write(0,*) "Error: External Stokes library needed to run Stokes dycore." err = 1 return #endif @@ -490,11 +490,9 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) call velocity_solver_solve_FO(lowerSurface, thickness, beta, tracers(index_temperature,:,:), & uReconstructX, uReconstructY, & ! Dirichlet boundary values to apply where dirichletVelocityMask=1 normalVelocity, uReconstructX, uReconstructY) ! return values -! call velocity_solver_estimate_SS_SMB(normalVelocity, mesh % sfcMassBal % array) +! call velocity_solver_estimate_SS_SMB(normalVelocity, mesh % sfcMassBal % array) ! this was used only for some ice2sea experiments, and is not a general routine to use call mpas_timer_stop("velocity_solver_solve_FO") call mpas_timer_start("velocity_solver export") -! call velocity_solver_init_L1L2(layerThicknessFractions) -! call velocity_solver_export_2d_data(lowerSurface, thickness, beta) call velocity_solver_export_FO_velocity() call mpas_timer_stop("velocity_solver export") #else @@ -519,9 +517,9 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) end select - normalVelocity = normalVelocity / (365.0*24.0*3600.0) ! convert from m/yr to m/s - uReconstructX = uReconstructX / (365.0*24.0*3600.0) ! convert from m/yr to m/s - uReconstructY = uReconstructY / (365.0*24.0*3600.0) ! convert from m/yr to m/s + normalVelocity = normalVelocity / (365.0*24.0*3600.0) ! convert from m/yr (used by external dycores) to m/s (used by MPAS) + uReconstructX = uReconstructX / (365.0*24.0*3600.0) ! convert from m/yr (used by external dycores) to m/s (used by MPAS) + uReconstructY = uReconstructY / (365.0*24.0*3600.0) ! convert from m/yr (used by external dycores) to m/s (used by MPAS) !-------------------------------------------------------------------- From c618cdb605616aa20cbe017a58a74cdca0f2e754 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 26 Mar 2015 14:24:45 -0600 Subject: [PATCH 0025/1724] LI: use stdoutUnit, stderrUnit in LI core --- src/core_landice/mpas_li_diagnostic_vars.F | 6 ++-- src/core_landice/mpas_li_mask.F | 2 +- src/core_landice/mpas_li_mpas_core.F | 20 ++++++------ src/core_landice/mpas_li_setup.F | 4 +-- src/core_landice/mpas_li_sia.F | 2 +- src/core_landice/mpas_li_tendency.F | 20 ++++++------ src/core_landice/mpas_li_time_integration.F | 10 +++--- .../mpas_li_time_integration_fe.F | 14 ++++---- src/core_landice/mpas_li_velocity.F | 20 ++++++------ src/core_landice/mpas_li_velocity_external.F | 32 +++++++++---------- 10 files changed, 65 insertions(+), 65 deletions(-) diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index 0c4aecb9b1..6c4d437d1c 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -402,7 +402,7 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! Make sure lowerSurface calculation is reasonable. This check could be deleted once this has been throroughly tested. do iCell = 1, nCells if (lowerSurface(iCell) < bedTopography(iCell)) then - write (0,*) 'lowerSurface less than bedTopography at cell:', iCell + write (stderrUnit,*) 'lowerSurface less than bedTopography at cell:', iCell err = 1 endif end do @@ -561,7 +561,7 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! === error check if (err > 0) then - write (0,*) "An error has occurred in diagnostic_solve_before_velocity." + write (stderrUnit,*) "An error has occurred in diagnostic_solve_before_velocity." endif !-------------------------------------------------------------------- @@ -657,7 +657,7 @@ subroutine diagnostic_solve_after_velocity(meshPool, statePool, timeLevel, err) !!!h_edge = (thickness(k) + thickness(k) ) / 2.0 ! 2nd order end do else - !write(6,*) 'layerThicknessEdge not calculated!' + !write(stdoutUnit,*) 'layerThicknessEdge not calculated!' endif ! Note: the outmost layerThicknessEdge may be wrong if its upwind cell is off this block - halo update should be done if this variable will be used. diff --git a/src/core_landice/mpas_li_mask.F b/src/core_landice/mpas_li_mask.F index 528d65e73c..941109fa58 100644 --- a/src/core_landice/mpas_li_mask.F +++ b/src/core_landice/mpas_li_mask.F @@ -421,7 +421,7 @@ subroutine li_calculate_mask(meshPool, statePool, timeLevel, err) ! === error check if (err > 0) then - write (0,*) "An error has occurred in li_calculate_mask." + write (stderrUnit,*) "An error has occurred in li_calculate_mask." endif !-------------------------------------------------------------------- diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index 0ef9f3369b..c2aa396416 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -255,8 +255,8 @@ subroutine mpas_core_run(domain, stream_manager) err = ior(err, err_tmp) call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=err_tmp) err = ior(err, err_tmp) - write(0,*) 'Initial timestep ', trim(timeStamp) - write(6,*) 'Initial timestep ', trim(timeStamp) + write(stderrUnit,*) 'Initial timestep ', trim(timeStamp) + write(stdoutUnit,*) 'Initial timestep ', trim(timeStamp) ! === @@ -331,10 +331,10 @@ subroutine mpas_core_run(domain, stream_manager) currTime = mpas_get_clock_time(clock, MPAS_NOW, err_tmp) call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=err_tmp) err = ior(err, err_tmp) - write(0,*) 'Doing timestep ', trim(timeStamp) - write(6,*) 'Doing timestep ', trim(timeStamp) + write(stderrUnit,*) 'Doing timestep ', trim(timeStamp) + write(stdoutUnit,*) 'Doing timestep ', trim(timeStamp) - !write(6,*) ' dt (s) = ', dtSeconds + !write(stdoutUnit,*) ' dt (s) = ', dtSeconds ! === ! === Perform Timestep @@ -720,7 +720,7 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! === error check if (err > 0) then - write (0,*) "An error has occurred in init_block." + write (stderrUnit,*) "An error has occurred in init_block." endif !-------------------------------------------------------------------- @@ -786,7 +786,7 @@ subroutine landice_timestep(domain, itimestep, dt, timeStamp, err) ! === error check if (err > 0) then - write (0,*) "An error has occurred in mpas_timestep." + write (stderrUnit,*) "An error has occurred in mpas_timestep." endif end subroutine landice_timestep @@ -883,7 +883,7 @@ subroutine simulation_clock_init(core_clock, configs, ierr) call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=err_tmp) ierr = ior(ierr,err_tmp) if(startTime + runduration /= stopTime) then - write(0,*) 'Warning: config_run_duration and config_stop_time are inconsistent: using config_run_duration.' + write(stderrUnit,*) 'Warning: config_run_duration and config_stop_time are inconsistent: using config_run_duration.' end if end if else if (trim(config_stop_time) /= "none") then @@ -892,14 +892,14 @@ subroutine simulation_clock_init(core_clock, configs, ierr) call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=err_tmp) ierr = ior(ierr,err_tmp) else - write(0,*) 'Error: Neither config_run_duration nor config_stop_time were specified.' + write(stderrUnit,*) 'Error: Neither config_run_duration nor config_stop_time were specified.' ierr = 1 end if ! === error check if (ierr > 0) then - write (0,*) "An error has occurred in simulation_clock_init." + write (stderrUnit,*) "An error has occurred in simulation_clock_init." endif !-------------------------------------------------------------------- diff --git a/src/core_landice/mpas_li_setup.F b/src/core_landice/mpas_li_setup.F index cd8bd85609..827160cd73 100644 --- a/src/core_landice/mpas_li_setup.F +++ b/src/core_landice/mpas_li_setup.F @@ -175,10 +175,10 @@ subroutine li_setup_vertical_grid(meshPool, err) fractionTotal = sum(layerThicknessFractions) if (fractionTotal /= 1.0_RKIND) then if (abs(fractionTotal - 1.0_RKIND) > 0.001_RKIND) then - write(0,*) 'Error: The sum of layerThicknessFractions is different from 1.0 by more than 0.001.' + write(stderrUnit,*) 'Error: The sum of layerThicknessFractions is different from 1.0 by more than 0.001.' err = 1 end if - write (6,*), 'Adjusting upper layerThicknessFrac by small amount because sum of layerThicknessFractions is slightly different from 1.0.' + write (stdoutUnit,*), 'Adjusting upper layerThicknessFrac by small amount because sum of layerThicknessFractions is slightly different from 1.0.' ! TODO - distribute the residual amongst all layers (and then put the residual of that in a single layer layerThicknessFractions(1) = layerThicknessFractions(1) - (fractionTotal - 1.0_RKIND) endif diff --git a/src/core_landice/mpas_li_sia.F b/src/core_landice/mpas_li_sia.F index bea7762b14..0aa6756264 100644 --- a/src/core_landice/mpas_li_sia.F +++ b/src/core_landice/mpas_li_sia.F @@ -328,7 +328,7 @@ subroutine li_sia_solve(meshPool, statePool, timeLevel, err) ! === error check if (err > 0) then - write (0,*) "An error has occurred in li_sia_solve." + write (stderrUnit,*) "An error has occurred in li_sia_solve." endif !-------------------------------------------------------------------- diff --git a/src/core_landice/mpas_li_tendency.F b/src/core_landice/mpas_li_tendency.F index 11557e7a2e..db0a5642f5 100644 --- a/src/core_landice/mpas_li_tendency.F +++ b/src/core_landice/mpas_li_tendency.F @@ -191,7 +191,7 @@ subroutine li_tendency_thickness(meshPool, statePool, layerThickness_tend, dt, d case ('none') !=================================================== ! Do nothing case default !=================================================== - write(0,*) trim(config_thickness_advection), ' is not a valid thickness advection option.' + write(stderrUnit,*) trim(config_thickness_advection), ' is not a valid thickness advection option.' err_tmp = 1 end select !=================================================== err = ior(err,err_tmp) @@ -236,7 +236,7 @@ subroutine li_tendency_thickness(meshPool, statePool, layerThickness_tend, dt, d ! === error check if (err > 0) then - write (0,*) "An error has occurred in li_tendency_thickness." + write (stderrUnit,*) "An error has occurred in li_tendency_thickness." endif !-------------------------------------------------------------------- @@ -384,7 +384,7 @@ subroutine li_tendency_tracers(meshPool, statePool, layerThickness_tend, tracer_ !!! case ('None') !=================================================== !!! ! Do nothing !!! case default !=================================================== -!!! write(0,*) trim(config_tracer_advection), ' is not a valid tracer advection option.' +!!! write(stderrUnit,*) trim(config_tracer_advection), ' is not a valid tracer advection option.' !!! call mpas_dmpar_abort(dminfo) !!! end select !=================================================== @@ -483,7 +483,7 @@ subroutine li_apply_calving(meshPool, statePool, err)!{{{ !!! ! Convert to physical thickness - only needed if CFBC is on but this is always defined. !!! physicalThickness = thickness(iCell) * areaCell(iCell) / iceArea(iCell) ! iceArea should always be > 0 since we are only checking on ice cells. !!! if (iceArea(iCell) == 0.0) then -!!! write(0,*) 'iceArea is 0 on a cell with ice!' +!!! write(stderrUnit,*) 'iceArea is 0 on a cell with ice!' !!! err = 1 !!! endif !!! if (physicalThickness <= config_calving_critical_thickness) then @@ -655,7 +655,7 @@ subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknes maxAllowableDt = 1.0e36_RKIND endif if ( maxAllowableDt < dt ) then - !write(0,*) 'CFL violation at level, edge', k, iEdge + !write(stderrUnit,*) 'CFL violation at level, edge', k, iEdge err = err + 1 endif MinOfMaxAllowableDt = min(MinOfMaxAllowableDt, maxAllowableDt) @@ -674,12 +674,12 @@ subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknes err = ior(err,err_tmp) if (err > 0) then - write(0,*) 'CFL violation on this processor on ', err, ' level-edges! Maximum allowable time step (seconds) for this processor is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) + write(stderrUnit,*) 'CFL violation on this processor on ', err, ' level-edges! Maximum allowable time step (seconds) for this processor is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) err = 1 endif if (config_print_thickness_advection_info) then - write(6,*) ' Maximum allowable time step (s) on THIS processor is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) + write(stdoutUnit,*) ' Maximum allowable time step (s) on THIS processor is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) endif ! Optional check for mass conservation @@ -691,7 +691,7 @@ subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknes ! === error check if (err > 0) then - write (0,*) "An error has occurred in tend_layerThickness_fo_upwind." + write (stderrUnit,*) "An error has occurred in tend_layerThickness_fo_upwind." endif !-------------------------------------------------------------------- @@ -917,7 +917,7 @@ end subroutine tracer_advection_tend_fo ! ubar = flux / thickness(cellUpwind) ! if ( (abs(ubar) * dt/SecondsInYear) .gt. (0.5 * dcEdge(iEdge))) then ! !maxAllowableDt = min(maxAllowableDt, (0.5 * dcEdge)/ubar ) -! write(0,*) 'CFL violation at edge', iEdge +! write(stderrUnit,*) 'CFL violation at edge', iEdge ! err = err + 1 ! endif ! thickness_tend(cellUpwind) = thickness_tend(cellUpwind) - flux * dvEdge(iEdge) / areaCell(cellUpwind) @@ -926,7 +926,7 @@ end subroutine tracer_advection_tend_fo ! end do ! if (err .gt. 0) then -! write(6,*) 'CFL violation at ', err, ' edges! Maximum time step should be ', maxAllowableDt +! write(stdoutUnit,*) 'CFL violation at ', err, ' edges! Maximum time step should be ', maxAllowableDt ! err = 1 ! endif ! !-------------------------------------------------------------------- diff --git a/src/core_landice/mpas_li_time_integration.F b/src/core_landice/mpas_li_time_integration.F index 9010fb6cf1..432bd0d77a 100644 --- a/src/core_landice/mpas_li_time_integration.F +++ b/src/core_landice/mpas_li_time_integration.F @@ -109,16 +109,16 @@ subroutine li_timestep(domain, dt, timeStamp, err) call mpas_pool_get_config(liConfigs, 'config_time_integration', config_time_integration) - !write(*,*) 'Using ', trim(config_time_integration), ' time integration.' + !write(stdoutUnit,*) 'Using ', trim(config_time_integration), ' time integration.' select case (config_time_integration) case ('forward_euler') call li_time_integrator_forwardeuler(domain, dt, err_tmp) case ('rk4') - write(0,*) trim(config_time_integration), ' is not currently supported.' + write(stderrUnit,*) trim(config_time_integration), ' is not currently supported.' call mpas_dmpar_abort(domain % dminfo) err_tmp = 1 case default - write(0,*) trim(config_time_integration), ' is not a valid land ice time integration option.' + write(stderrUnit,*) trim(config_time_integration), ' is not a valid land ice time integration option.' err_tmp = 1 end select err = ior(err,err_tmp) @@ -132,7 +132,7 @@ subroutine li_timestep(domain, dt, timeStamp, err) ! ! Abort the simulation if NaNs occur in the velocity field ! if (isNaN(sum(block % state % time_levs(2) % state % u % array))) then -! write(0,*) 'Abort: NaN detected' +! write(stderrUnit,*) 'Abort: NaN detected' ! call mpas_dmpar_abort(dminfo) ! endif @@ -141,7 +141,7 @@ subroutine li_timestep(domain, dt, timeStamp, err) ! === error check if (err > 0) then - write (0,*) "An error has occurred in li_timestep." + write (stderrUnit,*) "An error has occurred in li_timestep." endif !-------------------------------------------------------------------- diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index c062ac0e43..2316638a8b 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -136,7 +136,7 @@ subroutine li_time_integrator_forwardeuler(domain, deltat, err) ! === error check if (err == 1) then - write (0,*) "An error has occurred in li_time_integrator_forwardeuler." + write (stderrUnit,*) "An error has occurred in li_time_integrator_forwardeuler." endif !-------------------------------------------------------------------- @@ -251,11 +251,11 @@ subroutine calculate_tendencies(domain, deltat, err) err = ior(err,err_tmp) call mpas_get_timeInterval(allowableDtMinStringInterval, timeString=allowableDtMinString, ierr=err_tmp) err = ior(err,err_tmp) - write(6,*) ' Maximum allowable time step (yr) for all processors is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) // ' Time step is limited by processor number ', allowableDtMinProcNumber + write(stdoutUnit,*) ' Maximum allowable time step (yr) for all processors is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) // ' Time step is limited by processor number ', allowableDtMinProcNumber endif if (err .gt. 0) then - write(0,*) 'Error in calculating thickness tendency (possibly CFL violation)' + write(stderrUnit,*) 'Error in calculating thickness tendency (possibly CFL violation)' endif @@ -298,7 +298,7 @@ subroutine calculate_tendencies(domain, deltat, err) ! === error check if (err > 0) then - write (0,*) "An error has occurred in calculate_tendencies." + write (stderrUnit,*) "An error has occurred in calculate_tendencies." endif !-------------------------------------------------------------------- @@ -416,7 +416,7 @@ subroutine update_prognostics(domain, deltat, err) if (config_print_thickness_advection_info) then if (sum(masktmp) > 0) then - write(6,*) ' Cells with negative thickness (set to 0):',sum(masktmp) + write(stdoutUnit,*) ' Cells with negative thickness (set to 0):',sum(masktmp) endif ! Note how many cells have ice. @@ -424,7 +424,7 @@ subroutine update_prognostics(domain, deltat, err) where (thicknessNew > 0.0_RKIND) masktmp = 1 end where - write(6,*) ' Cells with nonzero thickness:', sum(masktmp) + write(stdoutUnit,*) ' Cells with nonzero thickness:', sum(masktmp) endif deallocate(masktmp) @@ -453,7 +453,7 @@ subroutine update_prognostics(domain, deltat, err) ! === error check if (err > 0) then - write (0,*) "An error has occurred in update_prognostics." + write (stderrUnit,*) "An error has occurred in update_prognostics." endif diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index 5243811962..a723f4472b 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -108,7 +108,7 @@ subroutine li_velocity_init(domain, err) call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) - write(*,*) 'Using ', trim(config_velocity_solver), ' dynamical core.' + write(stdoutUnit,*) 'Using ', trim(config_velocity_solver), ' dynamical core.' select case (config_velocity_solver) case ('none') ! Do nothing @@ -117,13 +117,13 @@ subroutine li_velocity_init(domain, err) case ('L1L2', 'FO', 'Stokes') call li_velocity_external_init(domain, err) case default - write(0,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' + write(stderrUnit,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 end select ! === error check if (err > 0) then - write (0,*) "An error has occurred in li_velocity_init." + write (stderrUnit,*) "An error has occurred in li_velocity_init." endif !-------------------------------------------------------------------- @@ -186,14 +186,14 @@ subroutine li_velocity_block_init(block, err) case ('L1L2', 'FO', 'Stokes') call li_velocity_external_block_init(block, err) case default - write(*,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' + write(stdoutUnit,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 return end select ! === error check if (err > 0) then - write (0,*) "An error has occurred in li_velocity_block_init." + write (stderrUnit,*) "An error has occurred in li_velocity_block_init." endif !-------------------------------------------------------------------- @@ -275,7 +275,7 @@ subroutine li_velocity_solve(meshPool, statePool, timeLevel, err) case ('L1L2', 'FO', 'Stokes') call li_velocity_external_solve(meshPool, statePool, timeLevel, err) case default - write(0,*) 'Error: ', trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' + write(stderrUnit,*) 'Error: ', trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 return end select @@ -291,13 +291,13 @@ subroutine li_velocity_solve(meshPool, statePool, timeLevel, err) endif enddo if (err == 1) then - write(0,*) 'Error: Velocity has been calculated on non-dynamic edges. There is a problem with the velocity solver.' !!! Velocity on those edges have been set to 0, but this should be a fatal error.' + write(stderrUnit,*) 'Error: Velocity has been calculated on non-dynamic edges. There is a problem with the velocity solver.' !!! Velocity on those edges have been set to 0, but this should be a fatal error.' err = 1 ! a hack to let the code continue until this can be fixed in the velocity solver end if ! === error check if (err > 0) then - write (0,*) "An error has occurred in li_velocity_solve." + write (stderrUnit,*) "An error has occurred in li_velocity_solve." endif !-------------------------------------------------------------------- @@ -360,14 +360,14 @@ subroutine li_velocity_finalize(domain, err) case ('L1L2', 'FO', 'Stokes') call li_velocity_external_finalize(err) case default - write(*,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' + write(stdoutUnit,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 return end select ! === error check if (err > 0) then - write (0,*) "An error has occurred in li_velocity_finalize." + write (stderrUnit,*) "An error has occurred in li_velocity_finalize." endif !-------------------------------------------------------------------- diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index 884417fe40..a90383110a 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -115,12 +115,12 @@ subroutine li_velocity_external_init(domain, err) ! Check for configuration options that are incompatible with external velocity solver conventions if (config_num_halos < 2) then - write(0,*) "Error: External velocity solvers require that config_num_halos >= 2" + write(stderrUnit,*) "Error: External velocity solvers require that config_num_halos >= 2" err_tmp = 1 endif err = ior(err,err_tmp) if (config_number_of_blocks /= 0) then - write(0,*) "Error: External velocity solvers require that config_number_of_blocks=0" + write(stderrUnit,*) "Error: External velocity solvers require that config_number_of_blocks=0" err_tmp = 1 endif err = ior(err,err_tmp) @@ -133,7 +133,7 @@ subroutine li_velocity_external_init(domain, err) call velocity_solver_init_mpi(domain % dminfo % comm) #else err = 1 - write(0,*) "Error: To run with an external velocity solver you must compile MPAS with one." + write(stderrUnit,*) "Error: To run with an external velocity solver you must compile MPAS with one." #endif @@ -141,7 +141,7 @@ subroutine li_velocity_external_init(domain, err) #ifdef USE_EXTERNAL_STOKES call interface_phg_init(domain, err) #else - write(0,*) "Error: External Stokes library needed to run Stokes dycore." + write(stderrUnit,*) "Error: External Stokes library needed to run Stokes dycore." err = 1 return #endif @@ -151,7 +151,7 @@ subroutine li_velocity_external_init(domain, err) ! === error check if (err > 0) then - write (0,*) "An error has occurred in li_velocity_external_init." + write (stderrUnit,*) "An error has occurred in li_velocity_external_init." endif !-------------------------------------------------------------------- @@ -282,7 +282,7 @@ subroutine li_velocity_external_block_init(block, err) sendVerticesArray, recvVerticesArray) call mpas_timer_stop("velocity_solver_set_grid_data") #else - write(0,*) "Error: To run with an external velocity solver you must compile MPAS with one." + write(stderrUnit,*) "Error: To run with an external velocity solver you must compile MPAS with one." err = 1 #endif @@ -296,7 +296,7 @@ subroutine li_velocity_external_block_init(block, err) ! === error check if (err > 0) then - write (0,*) "An error has occurred in li_velocity_external_block_init." + write (stderrUnit,*) "An error has occurred in li_velocity_external_block_init." endif !-------------------------------------------------------------------- @@ -411,7 +411,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) call velocity_solver_compute_2d_grid(vertexMask, dirichletVelocityMask, floatingEdges) call mpas_timer_stop("velocity_solver_compute_2d_grid") #else - write(0,*) "Error: To run with an external velocity solver you must compile MPAS with one." + write(stderrUnit,*) "Error: To run with an external velocity solver you must compile MPAS with one." err = 1 return #endif @@ -424,7 +424,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) call velocity_solver_init_L1L2(layerThicknessFractions) call mpas_timer_stop("velocity_solver_init_L1L2") #else - write(0,*) "Error: External LifeV library needed to run L1L2 dycore." + write(stderrUnit,*) "Error: External LifeV library needed to run L1L2 dycore." err = 1 return #endif @@ -438,7 +438,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) call velocity_solver_init_FO(layerThicknessFractions) call mpas_timer_stop("velocity_solver_init_FO") #else - write(0,*) "Error: External library needed to run FO dycore." + write(stderrUnit,*) "Error: External library needed to run FO dycore." err = 1 return #endif @@ -452,7 +452,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) call velocity_solver_init_stokes(layerThicknessFractions) call mpas_timer_stop("velocity_solver_init_stokes") #else - write(0,*) "Error: External Stokes library needed to run stokes dycore." + write(stderrUnit,*) "Error: External Stokes library needed to run stokes dycore." err = 1 return #endif @@ -479,7 +479,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) call velocity_solver_export_L1L2_velocity(); call mpas_timer_stop("velocity_solver export") #else - write(0,*) "Error: External LifeV library needed to run L1L2 dycore." + write(stderrUnit,*) "Error: External LifeV library needed to run L1L2 dycore." err = 1 return #endif @@ -496,7 +496,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) call velocity_solver_export_FO_velocity() call mpas_timer_stop("velocity_solver export") #else - write(0,*) "Error: External library needed to run FO dycore." + write(stderrUnit,*) "Error: External library needed to run FO dycore." err = 1 return #endif @@ -510,7 +510,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) uReconstructZ = uReconstructZ / (365.0*24.0*3600.0) ! convert from m/yr to m/s call mpas_timer_stop("velocity_solver_solve_stokes") #else - write(0,*) "Error: External Stokes library needed to run stokes dycore." + write(stderrUnit,*) "Error: External Stokes library needed to run stokes dycore." err = 1 return #endif @@ -574,7 +574,7 @@ subroutine li_velocity_external_finalize(err) ! This call is needed for using any of the external velocity solvers call velocity_solver_finalize() #else - write(0,*) "Error: To run with an external velocity solver you must compile MPAS with one." + write(stderrUnit,*) "Error: To run with an external velocity solver you must compile MPAS with one." err = 1 return #endif @@ -639,7 +639,7 @@ subroutine interface_stokes_init(domain, err) ! This call is needed for using any of the PHG velocity solvers call phg_init(domain % dminfo % comm) #else - write(0,*) "Error: External Stokes library needed to run stokes dycore." + write(stderrUnit,*) "Error: External Stokes library needed to run stokes dycore." err = 1 return #endif From 7a4ed2594a174bac00fabead20956358d946b15f Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 31 Mar 2015 15:18:23 -0600 Subject: [PATCH 0026/1724] LI: move set_year_width to mpas_core_setup_clock Previously the year width was set too late to allow restart files to be read properly. --- src/core_landice/mpas_li_mpas_core.F | 5 +++++ src/core_landice/mpas_li_setup.F | 4 ---- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index c2aa396416..1e61eb0ec9 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -549,6 +549,11 @@ subroutine mpas_core_setup_clock(core_clock, configs, ierr) type (MPAS_Clock_type), intent(inout) :: core_clock type (mpas_pool_type), intent(inout) :: configs integer, intent(out) :: ierr + integer, pointer :: config_year_digits + + ! Adjust number of digits representing the year + call mpas_pool_get_config(configs, 'config_year_digits', config_year_digits) + call mpas_timekeeping_set_year_width(config_year_digits) call simulation_clock_init(core_clock, configs, ierr) diff --git a/src/core_landice/mpas_li_setup.F b/src/core_landice/mpas_li_setup.F index 827160cd73..937893ffc3 100644 --- a/src/core_landice/mpas_li_setup.F +++ b/src/core_landice/mpas_li_setup.F @@ -95,7 +95,6 @@ subroutine li_setup_config_options( domain, err ) !----------------------------------------------------------------- ! local variables !----------------------------------------------------------------- - integer, pointer :: config_year_digits err = 0 @@ -106,9 +105,6 @@ subroutine li_setup_config_options( domain, err ) ! Config-specific setup occurs below ! --- - ! Adjust number of digits representing the year - call mpas_pool_get_config(liConfigs, 'config_year_digits', config_year_digits) - call mpas_timekeeping_set_year_width(config_year_digits) !-------------------------------------------------------------------- end subroutine li_setup_config_options From 7ab7d8b5d5794425aa0be6ac3d9ae2e56dc41e5a Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 31 Mar 2015 20:40:45 -0600 Subject: [PATCH 0027/1724] LI: move floatingEdges to within HO calcs in diagnostic_solve_before_velocity Getting floatingEdges from the statePool generates a debug error even though we don't actually attempt to use it unless a HO dycore is selected. This commit cleans that up by only getting the variable from the pool if a HO dycore is selected. --- src/core_landice/mpas_li_diagnostic_vars.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index 6c4d437d1c..bf75f3e651 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -383,7 +383,6 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'floatingEdges', floatingEdges, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'upperSurface', upperSurface, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'lowerSurface', lowerSurface, timeLevel=timeLevel) @@ -492,6 +491,7 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! This information is only needed by external dycores. if (config_velocity_solver /= 'sia') then ! The interface expects an array where 1's are floating edges and 0's are non-floating edges. + call mpas_pool_get_array(statePool, 'floatingEdges', floatingEdges, timeLevel=timeLevel) floatingEdges = li_mask_is_floating_ice_int(edgeMask) call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel=timeLevel) call li_calculate_extrapolate_floating_edgemask(meshPool, vertexMask, floatingEdges) From a0fd74dfd720f2824618dc1afd940d91e70bde0d Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 31 Mar 2015 21:08:40 -0600 Subject: [PATCH 0028/1724] LI: Make SIA calculation over nEdgesSolve only Solving SIA velocity over nEdges can lead to floating-point exception on multiple processors. This avoids that problem (which is fatal in debug mode). A halo update on normalVelocity occurs after this routine anyway, so there is no need so calculate velocity in the halos. --- src/core_landice/mpas_li_sia.F | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/core_landice/mpas_li_sia.F b/src/core_landice/mpas_li_sia.F index 0aa6756264..63c41d2af8 100644 --- a/src/core_landice/mpas_li_sia.F +++ b/src/core_landice/mpas_li_sia.F @@ -192,6 +192,10 @@ subroutine li_sia_block_init(block, err) call mpas_deallocate_scratch_field(vertexIndicesField, .true.) endif + ! === error check + if (err > 0) then + write (stderrUnit,*) "An error has occurred in li_sia_block_init." + endif !-------------------------------------------------------------------- end subroutine li_sia_block_init @@ -254,7 +258,7 @@ subroutine li_sia_solve(meshPool, statePool, timeLevel, err) real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, flowParamA integer, dimension(:,:), pointer :: cellsOnEdge integer, dimension(:), pointer :: edgeMask, cellMask - integer, pointer :: nVertInterfaces, nEdges + integer, pointer :: nVertInterfaces, nEdgesSolve integer :: iLevel, iEdge integer :: cell1, cell2 real (kind=RKIND) :: thicknessEdge, flwaLevelEdge @@ -268,7 +272,7 @@ subroutine li_sia_solve(meshPool, statePool, timeLevel, err) ! Set needed variables and pointers call mpas_pool_get_dimension(meshPool, 'nVertInterfaces', nVertInterfaces) - call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) @@ -289,7 +293,7 @@ subroutine li_sia_solve(meshPool, statePool, timeLevel, err) positionIndependentFactor = -0.5_RKIND * (rhoi * gravity)**n ! could be calculated once on init ! Loop over edges - do iEdge = 1, nEdges + do iEdge = 1, nEdgesSolve ! Only calculate velocity for edges that are part of the dynamic ice sheet.(thick ice) ! Also, the velocity calculation should be valid for non-ice edges (i.e. returns 0). From bf1298c374ea4c197cf012ea4d6492a4b4da6800 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 31 Mar 2015 21:11:23 -0600 Subject: [PATCH 0029/1724] LI: minor cleanup of some error checking statements --- src/core_landice/mpas_li_mpas_core.F | 2 +- src/core_landice/mpas_li_velocity.F | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index 1e61eb0ec9..12e6a9d397 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -725,7 +725,7 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! === error check if (err > 0) then - write (stderrUnit,*) "An error has occurred in init_block." + write (stderrUnit,*) "An error has occurred in landice_init_block." endif !-------------------------------------------------------------------- diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index a723f4472b..4d2f8d6e3a 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -174,6 +174,7 @@ subroutine li_velocity_block_init(block, err) !----------------------------------------------------------------- character (len=StrKIND), pointer :: config_velocity_solver + err = 0 call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) @@ -186,9 +187,8 @@ subroutine li_velocity_block_init(block, err) case ('L1L2', 'FO', 'Stokes') call li_velocity_external_block_init(block, err) case default - write(stdoutUnit,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' + write(stderrUnit,*) trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 - return end select ! === error check From d63f2f1b5ccf4ad45b5aaa39674e79235e249dec Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 31 Mar 2015 21:55:21 -0600 Subject: [PATCH 0030/1724] LI: cleanup of CFL violation messages --- src/core_landice/mpas_li_tendency.F | 15 ++++++++------- src/core_landice/mpas_li_time_integration_fe.F | 12 ++++++------ 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/src/core_landice/mpas_li_tendency.F b/src/core_landice/mpas_li_tendency.F index db0a5642f5..e8d5cb4e60 100644 --- a/src/core_landice/mpas_li_tendency.F +++ b/src/core_landice/mpas_li_tendency.F @@ -618,8 +618,9 @@ subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknes logical, pointer :: config_print_thickness_advection_info real (kind=RKIND) :: invAreaCell, flux, maxAllowableDt, layerNormalVelocity integer :: iEdge, iCell, i, k - type (MPAS_TimeInterval_type) :: allowableDtMinStringInterval + type (MPAS_TimeInterval_type) :: allowableDtMinInterval character (len=StrKIND) :: allowableDtMinString + real (kind=RKIND) :: bigNumber = 1.0e16_RKIND ! This is ~300 million years in seconds, but it is small enough not too overflow integer :: err_tmp ! Only needed for optional check for mass conservation @@ -637,7 +638,7 @@ subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknes call mpas_pool_get_array(meshPool, 'areaCell', areaCell) call mpas_pool_get_config(liConfigs, 'config_print_thickness_advection_info', config_print_thickness_advection_info) - MinOfMaxAllowableDt = 1.0e36_RKIND + MinOfMaxAllowableDt = bigNumber do iCell = 1, nCells invAreaCell = 1.0 / areaCell(iCell) @@ -652,7 +653,7 @@ subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknes if (abs(layerNormalVelocity) > 0.0_RKIND) then maxAllowableDt = (0.5_RKIND * dcEdge(iEdge)) / abs(layerNormalVelocity) else - maxAllowableDt = 1.0e36_RKIND + maxAllowableDt = bigNumber endif if ( maxAllowableDt < dt ) then !write(stderrUnit,*) 'CFL violation at level, edge', k, iEdge @@ -668,18 +669,18 @@ subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknes ! Build a time string of the maximum allowable dt calculated ! (We only need this if a CFL violation occurred or config_print_thickness_advection_info is true) - call mpas_set_timeInterval(allowableDtMinStringInterval, dt=MinOfMaxAllowableDt, ierr=err_tmp) + call mpas_set_timeInterval(allowableDtMinInterval, dt=MinOfMaxAllowableDt, ierr=err_tmp) err = ior(err,err_tmp) - call mpas_get_timeInterval(allowableDtMinStringInterval, timeString=allowableDtMinString, ierr=err_tmp) + call mpas_get_timeInterval(allowableDtMinInterval, timeString=allowableDtMinString, ierr=err_tmp) err = ior(err,err_tmp) if (err > 0) then - write(stderrUnit,*) 'CFL violation on this processor on ', err, ' level-edges! Maximum allowable time step (seconds) for this processor is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) + write(stderrUnit,*) 'CFL violation on this processor on ', err, ' level-edges! Maximum allowable time step for this processor is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) err = 1 endif if (config_print_thickness_advection_info) then - write(stdoutUnit,*) ' Maximum allowable time step (s) on THIS processor is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) + write(stdoutUnit,*) ' Maximum allowable time step on THIS processor is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) endif ! Optional check for mass conservation diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index 2316638a8b..d9f6695e84 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -234,9 +234,9 @@ subroutine calculate_tendencies(domain, deltat, err) call mpas_dmpar_exch_halo_field(layerThickness_tend_field) call mpas_timer_stop("halo updates") - ! If we are printing advection debug information, - ! then find out what the CFL limit is. Don't do this otherwise because it - ! is requires 2 unnecessary MPI communications. + ! If we are printing advection debug information, + ! then find out what the global CFL limit is. Don't do this otherwise because + ! it requires 2 unnecessary MPI communications. if (config_print_thickness_advection_info) then ! Determine CFL limit on all procs call mpas_dmpar_min_real(dminfo, allowableDt, allowableDtMin) @@ -251,11 +251,11 @@ subroutine calculate_tendencies(domain, deltat, err) err = ior(err,err_tmp) call mpas_get_timeInterval(allowableDtMinStringInterval, timeString=allowableDtMinString, ierr=err_tmp) err = ior(err,err_tmp) - write(stdoutUnit,*) ' Maximum allowable time step (yr) for all processors is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) // ' Time step is limited by processor number ', allowableDtMinProcNumber + write(stdoutUnit,*) ' Maximum allowable time step for all processors is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) // ' Time step is limited by processor number ', allowableDtMinProcNumber endif - if (err .gt. 0) then - write(stderrUnit,*) 'Error in calculating thickness tendency (possibly CFL violation)' + if (err > 0) then + write(stderrUnit,*) 'Error in calculating thickness tendency (possibly CFL violation)' endif From c221d857be90326fb8e2e565b9dd598901d38930 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 31 Mar 2015 22:28:32 -0600 Subject: [PATCH 0031/1724] LI: Fix logic to only update FEM mesh when dynamic vertex mask changes Currently the FEM mesh would be updated whenever the vertexMask changes, but it is a bitmask with a number of different components. I've changed the logic to only check the bit for dynamic ice extent and not the other bits. To reflect this change, I've also changed the name of the variable used for this from anyVertexMaskChanged to anyDynamicVertexMaskChanged. --- src/core_landice/Registry.xml | 2 +- src/core_landice/mpas_li_diagnostic_vars.F | 20 ++++++++++---------- src/core_landice/mpas_li_velocity_external.F | 8 ++++---- 3 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 28b4a89705..663138a7e0 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -453,7 +453,7 @@ - diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index bf75f3e651..789696ca95 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -311,7 +311,7 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ integer, pointer :: index_temperature type (field1DInteger), pointer :: cellMaskField, edgeMaskField, vertexMaskField, floatingEdgesField integer, pointer :: nCells, nVertices, nEdges - integer, pointer :: anyVertexMaskChanged + integer, pointer :: anyDynamicVertexMaskChanged integer, pointer :: dirichletMaskChanged integer, dimension(:,:), pointer :: dirichletVelocityMaskOld, dirichletVelocityMaskNew real (kind=RKIND), pointer :: config_sea_level, config_ice_density, config_ocean_density @@ -319,7 +319,7 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! truly local variables real (kind=RKIND) :: thisThk integer :: iCell, iLevel, iEdge, cell1, cell2 - integer :: blockVertexMaskChanged, procVertexMaskChanged + integer :: blockDynamicVertexMaskChanged, procDynamicVertexMaskChanged integer :: blockDirichletMaskChanged, procDirichletMaskChanged integer :: err_tmp @@ -512,7 +512,7 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! This information is only needed for some external dycores. if (config_velocity_solver /= 'sia') then - procVertexMaskChanged = 0 + procDynamicVertexMaskChanged = 0 ! Note: External dycores don't support multiple blocks per proc., but checking across ! blocks anyway, in case some day they do. @@ -524,14 +524,14 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! TODO: if we ever have more than one time level, then this logic should be revisited. call mpas_pool_get_array(statePool, 'vertexMask', vertexMaskOld, timeLevel=1) call mpas_pool_get_array(statePool, 'vertexMask', vertexMaskNew, timeLevel=2) - if ( sum(vertexMaskNew - vertexMaskOld) /= 0 ) then - blockVertexMaskChanged = 1 + if ( sum(li_mask_is_dynamic_ice_int(vertexMaskNew) - li_mask_is_dynamic_ice_int(vertexMaskOld)) /= 0 ) then + blockDynamicVertexMaskChanged = 1 else - blockVertexMaskChanged = 0 + blockDynamicVertexMaskChanged = 0 endif !print *, 'blockVertexMaskChanged ', blockVertexMaskChanged ! Determine if any blocks on this processor had a change to the vertex mask - procVertexMaskChanged = max(procVertexMaskChanged, blockVertexMaskChanged) + procDynamicVertexMaskChanged = max(procDynamicVertexMaskChanged, blockDynamicVertexMaskChanged) !print *,'procVertexMaskChanged', procVertexMaskChanged ! Also check to see if the Dirichlet b.c. mask has changed @@ -549,9 +549,9 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ end do ! Determine if the vertex mask has changed on any processor and store the value for later use (need to exit the block loop to do so) - call mpas_pool_get_array(statePool, 'anyVertexMaskChanged', anyVertexMaskChanged, timeLevel=timeLevel) - call mpas_dmpar_max_int(domain % dminfo, procVertexMaskChanged, anyVertexMaskChanged) - !print *,'anyVertexMaskChanged', anyVertexMaskChanged + call mpas_pool_get_array(statePool, 'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged, timeLevel=timeLevel) + call mpas_dmpar_max_int(domain % dminfo, procDynamicVertexMaskChanged, anyDynamicVertexMaskChanged) + !print *,'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged ! Do the same for the Dirichlet b.c. mask call mpas_pool_get_array(statePool, 'dirichletMaskChanged', dirichletMaskChanged, timeLevel=timeLevel) call mpas_dmpar_max_int(domain % dminfo, procDirichletMaskChanged, dirichletMaskChanged) diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index a90383110a..951a253bdc 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -367,7 +367,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) integer, dimension(:,:), pointer :: dirichletVelocityMask character (len=StrKIND), pointer :: config_velocity_solver logical, pointer :: config_always_compute_fem_grid - integer, pointer :: anyVertexMaskChanged + integer, pointer :: anyDynamicVertexMaskChanged integer, pointer :: dirichletMaskChanged err = 0 @@ -392,7 +392,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'anyVertexMaskChanged', anyVertexMaskChanged, timeLevel=timeLevel) + call mpas_pool_get_array(statePool, 'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'dirichletMaskChanged', dirichletMaskChanged, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'floatingEdges', floatingEdges, timeLevel=timeLevel) @@ -403,8 +403,8 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) ! ================================================================== ! Note these functions will always be called on the first solve because we - ! initialize vertexMask to garbage which sets anyVertexMaskChanged to 1. - if ((anyVertexMaskChanged == 1) .or. (config_always_compute_fem_grid) .or. & + ! initialize vertexMask to garbage which sets anyDynamicVertexMaskChanged to 1. + if ((anyDynamicVertexMaskChanged == 1) .or. (config_always_compute_fem_grid) .or. & (dirichletMaskChanged == 1) ) then #if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) call mpas_timer_start("velocity_solver_compute_2d_grid") From d219facfd1ec95653d76d2e6b08f30dce99e6981 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 31 Mar 2015 22:32:33 -0600 Subject: [PATCH 0032/1724] LI: Don't call HO dycore if there is no dynamic ice I've added a check for ice thicker than the dynamic ice limit to the call to external HO dycores. These dycores may abort if they have no ice to solve on. --- src/core_landice/mpas_li_velocity_external.F | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index 951a253bdc..719f5173f3 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -366,6 +366,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) integer, dimension(:), pointer :: vertexMask, edgeMask, floatingEdges integer, dimension(:,:), pointer :: dirichletVelocityMask character (len=StrKIND), pointer :: config_velocity_solver + real (kind=RKIND), pointer :: config_dynamic_thickness logical, pointer :: config_always_compute_fem_grid integer, pointer :: anyDynamicVertexMaskChanged integer, pointer :: dirichletMaskChanged @@ -375,6 +376,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) ! configs call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_config(liConfigs, 'config_always_compute_fem_grid', config_always_compute_fem_grid) + call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) ! Mesh variables call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) @@ -397,6 +399,14 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) call mpas_pool_get_array(statePool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel=timeLevel) call mpas_pool_get_array(statePool, 'floatingEdges', floatingEdges, timeLevel=timeLevel) + if (maxval(thickness) < config_dynamic_thickness) then + ! External dycores may not be able to handle case when there is no ice + normalVelocity = 0.0_RKIND + uReconstructX = 0.0_RKIND + uReconstructY = 0.0_RKIND + uReconstructZ = 0.0_RKIND + else + ! ================================================================== ! External dycore calls to be made only when vertex mask changes @@ -522,6 +532,8 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) uReconstructY = uReconstructY / (365.0*24.0*3600.0) ! convert from m/yr (used by external dycores) to m/s (used by MPAS) + endif ! if ice + !-------------------------------------------------------------------- end subroutine li_velocity_external_solve From 48beb75e31949b2c850029b485e2afd7be91b4cb Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 2 Apr 2015 22:15:43 -0600 Subject: [PATCH 0033/1724] LI: Allow restarts for HO dycores This required adding some new fields as restart variables: beta, uReconstructX/Y It also required reorganizing the logic for when the FEM mesh gets generated. To ensure BFB restarts, the FEM mesh is now generated for the first time in li_velocity_external_block_init. This ensures the mesh will always be created. When li_velocity_external_solve is called, there still is a check for if the dynamic ice extent has changed, in which case the FEM mesh is re-generated. However, I've changed the vertexMask initialization so that on init the vertexMask will appear to be unchanged. On a cold start this is fine, because the FEM mesh was generated during init. On a restart, velocity is NOT solved on init, but the FEM mesh is still generated on init - this is necessary for the solver to work correctly on the first time step if the dynamic ice extent has not changed at that time. (Note that the FEM mesh will be re-generated on the first time step if the dynamic ice extent has changed. This will be an unnecessary operation, but accounting for this case would add substantially to the logic.) --- src/core_landice/Registry.xml | 8 +- src/core_landice/mpas_li_mpas_core.F | 4 - src/core_landice/mpas_li_velocity_external.F | 178 +++++++++++++------ 3 files changed, 131 insertions(+), 59 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 663138a7e0..7b8a311ee2 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -330,9 +330,15 @@ - + + + + + + + diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index 8931333142..2ec06fbe30 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -713,10 +713,6 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! Copy data from first time level into all other time levels call mpas_pool_initialize_time_levels(statePool) - ! Initialize vertexMask on time level 2 to junk, so diagnostic_solve_before_velocity in li_diagnostic_vars says that the vertexMask has changed (needed by external dycore) - call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel = 2) - vertexMask = -9999 - ! === ! === Call init routines === diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index 719f5173f3..b5ebe89000 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -20,6 +20,7 @@ module li_velocity_external use mpas_grid_types use mpas_configure use mpas_dmpar + use mpas_timer use li_setup !use, intrinsic :: iso_c_binding @@ -178,8 +179,6 @@ end subroutine li_velocity_external_init subroutine li_velocity_external_block_init(block, err) - use mpas_timer - !----------------------------------------------------------------- ! ! input variables @@ -215,6 +214,13 @@ subroutine li_velocity_external_block_init(block, err) real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xVertex, yVertex, zVertex, areaTriangle real (kind=RKIND), pointer :: radius type (field1DInteger), pointer :: indexToCellIDField, indexToEdgeIDField, indexToVertexIDField + ! Variables needed to set FEM mask + type (mpas_pool_type), pointer :: statePool + character (len=StrKIND), pointer :: config_velocity_solver + real (kind=RKIND), dimension(:), pointer :: & + thickness, lowerSurface, layerThicknessFractions + integer, dimension(:), pointer :: vertexMask, floatingEdges + integer, dimension(:,:), pointer :: dirichletVelocityMask ! halo exchange arrays integer, dimension(:), pointer :: sendCellsArray, & @@ -294,6 +300,23 @@ subroutine li_velocity_external_block_init(block, err) sendEdgesArray, & recvEdgesArray) + ! Now build the FEM mesh for the first solve + ! (This needs to be additionally called here so that HO restarts work correctly. + ! However, it won't be called again in solve unless the grid has changed. + ! One exception is on a restart where the dynamic ice extent does not change between the + ! initial time and the first time step - in the case this will be called twice + ! unnecessarily. That seemed preferable to complicating the logic.) + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=1) + call mpas_pool_get_array(statePool, 'lowerSurface', lowerSurface, timeLevel=1) + call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel=1) + call mpas_pool_get_array(statePool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel=1) + call mpas_pool_get_array(statePool, 'floatingEdges', floatingEdges, timeLevel=1) + call generate_fem_grid(config_velocity_solver, vertexMask, dirichletVelocityMask, & + floatingEdges, layerThicknessFractions, lowerSurface, thickness, err) + ! === error check if (err > 0) then write (stderrUnit,*) "An error has occurred in li_velocity_external_block_init." @@ -319,7 +342,6 @@ end subroutine li_velocity_external_block_init subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) - use mpas_timer use li_mask !----------------------------------------------------------------- @@ -416,57 +438,8 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) ! initialize vertexMask to garbage which sets anyDynamicVertexMaskChanged to 1. if ((anyDynamicVertexMaskChanged == 1) .or. (config_always_compute_fem_grid) .or. & (dirichletMaskChanged == 1) ) then -#if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) - call mpas_timer_start("velocity_solver_compute_2d_grid") - call velocity_solver_compute_2d_grid(vertexMask, dirichletVelocityMask, floatingEdges) - call mpas_timer_stop("velocity_solver_compute_2d_grid") -#else - write(stderrUnit,*) "Error: To run with an external velocity solver you must compile MPAS with one." - err = 1 - return -#endif - - select case (config_velocity_solver) - case ('L1L2') ! =============================================== -#ifdef USE_EXTERNAL_L1L2 - call mpas_timer_start("velocity_solver_init_L1L2") - !call velocity_solver_extrude_3d_grid(layerThicknessFractions, lowerSurface, thickness) - call velocity_solver_init_L1L2(layerThicknessFractions) - call mpas_timer_stop("velocity_solver_init_L1L2") -#else - write(stderrUnit,*) "Error: External LifeV library needed to run L1L2 dycore." - err = 1 - return -#endif - - case ('FO') ! =============================================== -#ifdef USE_EXTERNAL_FIRSTORDER - call mpas_timer_start("velocity_solver_extrude_3d_grid") - call velocity_solver_extrude_3d_grid(layerThicknessFractions, lowerSurface, thickness) - call mpas_timer_stop("velocity_solver_extrude_3d_grid") - call mpas_timer_start("velocity_solver_init_FO") - call velocity_solver_init_FO(layerThicknessFractions) - call mpas_timer_stop("velocity_solver_init_FO") -#else - write(stderrUnit,*) "Error: External library needed to run FO dycore." - err = 1 - return -#endif - - case ('Stokes') ! =============================================== -#ifdef USE_EXTERNAL_STOKES - call mpas_timer_start("velocity_solver_extrude_3d_grid") - call velocity_solver_extrude_3d_grid(layerThicknessFractions, lowerSurface, thickness) - call mpas_timer_stop("velocity_solver_extrude_3d_grid") - call mpas_timer_start("velocity_solver_init_stokes") - call velocity_solver_init_stokes(layerThicknessFractions) - call mpas_timer_stop("velocity_solver_init_stokes") -#else - write(stderrUnit,*) "Error: External Stokes library needed to run stokes dycore." - err = 1 - return -#endif - end select + call generate_fem_grid(config_velocity_solver, vertexMask, dirichletVelocityMask, & + floatingEdges, layerThicknessFractions, lowerSurface, thickness, err) endif @@ -661,6 +634,103 @@ end subroutine interface_stokes_init +!*********************************************************************** +! +! routine generate_fem_grid +! +!> \brief Calls to interface to set FEM grid +!> \author Matt Hoffman +!> \date 2 April 2015 +!> \details +!> This routine calls functions in the C interface that generate the FEM grid. +! +!----------------------------------------------------------------------- + + subroutine generate_fem_grid(config_velocity_solver, vertexMask, dirichletVelocityMask, floatingEdges, & + layerThicknessFractions, lowerSurface, thickness, err) + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + character (len=StrKIND), pointer :: config_velocity_solver + integer, pointer, dimension(:), intent(in) :: vertexMask, floatingEdges + integer, pointer, dimension(:,:), intent(in) :: dirichletVelocityMask + real(kind=RKIND), pointer, dimension(:), intent(in) :: layerThicknessFractions, & + lowerSurface, thickness + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + + err = 0 + +#if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) + call mpas_timer_start("velocity_solver_compute_2d_grid") + call velocity_solver_compute_2d_grid(vertexMask, dirichletVelocityMask, floatingEdges) + call mpas_timer_stop("velocity_solver_compute_2d_grid") +#else + write(stderrUnit,*) "Error: To run with an external velocity solver you must compile MPAS with one." + err = 1 + return +#endif + + select case (config_velocity_solver) + case ('L1L2') ! =============================================== +#ifdef USE_EXTERNAL_L1L2 + call mpas_timer_start("velocity_solver_init_L1L2") + !call velocity_solver_extrude_3d_grid(layerThicknessFractions, lowerSurface, thickness) + call velocity_solver_init_L1L2(layerThicknessFractions) + call mpas_timer_stop("velocity_solver_init_L1L2") +#else + write(stderrUnit,*) "Error: External LifeV library needed to run L1L2 dycore." + err = 1 + return +#endif + + case ('FO') ! =============================================== +#ifdef USE_EXTERNAL_FIRSTORDER + call mpas_timer_start("velocity_solver_extrude_3d_grid") + call velocity_solver_extrude_3d_grid(layerThicknessFractions, lowerSurface, thickness) + call mpas_timer_stop("velocity_solver_extrude_3d_grid") + call mpas_timer_start("velocity_solver_init_FO") + call velocity_solver_init_FO(layerThicknessFractions) + call mpas_timer_stop("velocity_solver_init_FO") +#else + write(stderrUnit,*) "Error: External library needed to run FO dycore." + err = 1 + return +#endif + + case ('Stokes') ! =============================================== +#ifdef USE_EXTERNAL_STOKES + call mpas_timer_start("velocity_solver_extrude_3d_grid") + call velocity_solver_extrude_3d_grid(layerThicknessFractions, lowerSurface, thickness) + call mpas_timer_stop("velocity_solver_extrude_3d_grid") + call mpas_timer_start("velocity_solver_init_stokes") + call velocity_solver_init_stokes(layerThicknessFractions) + call mpas_timer_stop("velocity_solver_init_stokes") +#else + write(stderrUnit,*) "Error: External Stokes library needed to run stokes dycore." + err = 1 + return +#endif + end select + + !-------------------------------------------------------------------- + end subroutine generate_fem_grid + + + !*********************************************************************** ! ! routine array_from_exchange_list From e25a173b6a499cabeed263c6243ff1f4d82de5dc Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Fri, 10 Apr 2015 08:58:01 -0600 Subject: [PATCH 0034/1724] LI: Adjust HO restart fix The implementation in the previous commit did not work correctly because it was setting the FEM mesh before vertexMask was calculated for the first time. This is an alternate implementation that goes back to setting the FEM mesh only in the velocity_solve routine (i.e., I've removed the set of FEM mesh from the velocity_block_init routine). At the end of the initial time, I set vertexMask to 0 if the run is a restart with the HO-dycore. This will ensure the FEM mask gets created on the first time step (since the velocity solver is not called on init with a HO dycore). --- src/core_landice/mpas_li_diagnostic_vars.F | 2 +- src/core_landice/mpas_li_mpas_core.F | 33 ++++++++++++++++---- src/core_landice/mpas_li_velocity_external.F | 24 -------------- 3 files changed, 28 insertions(+), 31 deletions(-) diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index 789696ca95..97d88137dc 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -511,7 +511,7 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ endif ! This information is only needed for some external dycores. - if (config_velocity_solver /= 'sia') then + if (trim(config_velocity_solver) /= 'sia') then procDynamicVertexMaskChanged = 0 ! Note: External dycores don't support multiple blocks per proc., but checking across diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index 2ec06fbe30..5afda6d533 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -231,6 +231,7 @@ subroutine mpas_core_run(domain, stream_manager) integer, pointer :: config_stats_interval !< interval (number of timesteps) for writing stats logical, pointer :: config_do_restart, config_write_output_on_startup, config_write_stats_on_startup character(len=StrKIND), pointer :: config_restart_timestamp_name + character(len=StrKIND), pointer :: config_velocity_solver type (MPAS_Time_Type) :: currTime character(len=StrKIND) :: timeStamp @@ -239,6 +240,8 @@ subroutine mpas_core_run(domain, stream_manager) type (MPAS_TimeInterval_type) :: timeStepInterval !< time step as an interval real (kind=RKIND) :: dtSeconds !< time step in seconds + integer, dimension(:), pointer :: vertexMask + err = 0 err_tmp = 0 @@ -250,6 +253,7 @@ subroutine mpas_core_run(domain, stream_manager) call mpas_pool_get_config(liConfigs, 'config_restart_timestamp_name', config_restart_timestamp_name) call mpas_pool_get_config(liConfigs, 'config_write_stats_on_startup', config_write_stats_on_startup) call mpas_pool_get_config(liConfigs, 'config_stats_interval', config_stats_interval) + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_timer_start("land ice core run") currTime = mpas_get_clock_time(clock, MPAS_NOW, err_tmp) @@ -294,12 +298,6 @@ subroutine mpas_core_run(domain, stream_manager) call mpas_timer_stop("write output") - ! === error check and exit - call mpas_dmpar_max_int(domain % dminfo, err, globalErr) ! Find out if any blocks got an error - if (globalErr > 0) then - call mpas_dmpar_global_abort("An error has occurred in mpas_core_run before time-stepping. Aborting...") - endif - if (config_write_stats_on_startup) then call mpas_timer_start("compute_statistics") call li_compute_statistics(domain, 1, 0) ! timelevel = 1, itimestep = 0 @@ -307,6 +305,26 @@ subroutine mpas_core_run(domain, stream_manager) call mpas_timer_stop("compute_statistics") endif + if (config_do_restart .and. (trim(config_velocity_solver) /= 'sia')) then + ! On a restart with the HO dycore, we need to make sure the FEM mesh will be rebuilt + ! on the first time step. Force this by setting the vertexMask at the end of the + ! initial time to garbage. (Do this after writing output.) + block => domain % blocklist + do while(associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel=1) + vertexMask = 0 + block => block % next + end do + endif + + ! === error check and exit + call mpas_dmpar_max_int(domain % dminfo, err, globalErr) ! Find out if any blocks got an error + if (globalErr > 0) then + call mpas_dmpar_global_abort("An error has occurred in mpas_core_run before time-stepping. Aborting...") + endif + + ! During integration, time level 1 stores the model state at the beginning of the ! time step, and time level 2 stores the state advanced dt in time by timestep(...) itimestep = 0 @@ -713,6 +731,9 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! Copy data from first time level into all other time levels call mpas_pool_initialize_time_levels(statePool) + ! Initialize vertexMask on time level 2 to junk, so diagnostic_solve_before_velocity in li_diagnostic_vars says that the vertexMask has changed (needed by external dycore) + call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel = 2) + vertexMask = -9999 ! === ! === Call init routines === diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index b5ebe89000..21cd83e579 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -214,13 +214,6 @@ subroutine li_velocity_external_block_init(block, err) real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xVertex, yVertex, zVertex, areaTriangle real (kind=RKIND), pointer :: radius type (field1DInteger), pointer :: indexToCellIDField, indexToEdgeIDField, indexToVertexIDField - ! Variables needed to set FEM mask - type (mpas_pool_type), pointer :: statePool - character (len=StrKIND), pointer :: config_velocity_solver - real (kind=RKIND), dimension(:), pointer :: & - thickness, lowerSurface, layerThicknessFractions - integer, dimension(:), pointer :: vertexMask, floatingEdges - integer, dimension(:,:), pointer :: dirichletVelocityMask ! halo exchange arrays integer, dimension(:), pointer :: sendCellsArray, & @@ -300,23 +293,6 @@ subroutine li_velocity_external_block_init(block, err) sendEdgesArray, & recvEdgesArray) - ! Now build the FEM mesh for the first solve - ! (This needs to be additionally called here so that HO restarts work correctly. - ! However, it won't be called again in solve unless the grid has changed. - ! One exception is on a restart where the dynamic ice extent does not change between the - ! initial time and the first time step - in the case this will be called twice - ! unnecessarily. That seemed preferable to complicating the logic.) - call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) - call mpas_pool_get_subpool(block % structs, 'state', statePool) - call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) - call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=1) - call mpas_pool_get_array(statePool, 'lowerSurface', lowerSurface, timeLevel=1) - call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel=1) - call mpas_pool_get_array(statePool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel=1) - call mpas_pool_get_array(statePool, 'floatingEdges', floatingEdges, timeLevel=1) - call generate_fem_grid(config_velocity_solver, vertexMask, dirichletVelocityMask, & - floatingEdges, layerThicknessFractions, lowerSurface, thickness, err) - ! === error check if (err > 0) then write (stderrUnit,*) "An error has occurred in li_velocity_external_block_init." From bd189c06b95881a55874da8346cd3481045f62be Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 13 Apr 2015 14:58:59 -0600 Subject: [PATCH 0035/1724] LI: Reorganize variable pools in Registry.xml This replaces the old set of pools which has most everything in 'state' with the following pools: * mesh * meshLI * geometry * velocity * thermal * forcing * tendency * scratch Chanes in this commit are only made to Registry and the code has not been updated! --- src/core_landice/Registry.xml | 265 +++++++++++++++++++--------------- 1 file changed, 145 insertions(+), 120 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 7b8a311ee2..6cbd3a3207 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -377,121 +377,8 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - + + + + + + @@ -632,19 +526,150 @@ - + + + + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + - + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Date: Tue, 14 Apr 2015 09:21:42 -0600 Subject: [PATCH 0036/1724] LI: Additional revisions to var pools --- src/core_landice/Registry.xml | 188 +++++++++++++++------------------- 1 file changed, 80 insertions(+), 108 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 6cbd3a3207..7939581eab 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -228,6 +228,7 @@ + @@ -237,56 +238,13 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + @@ -325,7 +283,8 @@ precision="double" clobber_mode="replace_files"> - + + @@ -353,11 +312,13 @@ clobber_mode="replace_files"> - + + + + - @@ -366,9 +327,6 @@ - - - @@ -378,7 +336,8 @@ - + + - + + + + + + @@ -467,49 +441,30 @@ - - - - - - - - - + - + - - + + - - - + + + + + - + - + + + + + - + + @@ -628,12 +605,10 @@ /> + - + - @@ -643,19 +618,15 @@ /> - - - - - - - + @@ -669,6 +640,7 @@ + From 6cb0fcafd706b8c60bbfe914c3898eec09cdce7c Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 14 Apr 2015 11:01:30 -0600 Subject: [PATCH 0037/1724] LI: Update all code to use new var_structs These changes touch lots of code, but do not change any functionality. --- src/core_landice/Registry.xml | 5 +- src/core_landice/mpas_li_diagnostic_vars.F | 172 ++++++++++-------- src/core_landice/mpas_li_mask.F | 36 ++-- src/core_landice/mpas_li_mpas_core.F | 34 ++-- src/core_landice/mpas_li_setup.F | 21 +-- src/core_landice/mpas_li_sia.F | 34 ++-- src/core_landice/mpas_li_statistics.F | 53 +++--- src/core_landice/mpas_li_tendency.F | 37 ++-- src/core_landice/mpas_li_time_integration.F | 6 +- .../mpas_li_time_integration_fe.F | 39 ++-- src/core_landice/mpas_li_velocity.F | 21 ++- src/core_landice/mpas_li_velocity_external.F | 56 +++--- 12 files changed, 288 insertions(+), 226 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 7939581eab..a399572b28 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -243,6 +243,7 @@ immutable="true" filename_template="landice_grid.nc" input_interval="initial_only"> + @@ -500,10 +501,10 @@ - - domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'meshLI', meshLIPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'thermal', thermalPool) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) - call li_velocity_solve(meshPool, statePool, timeLevel, err_tmp) ! ****** Calculate Velocity ****** + call li_velocity_solve(meshPool, meshLIPool, geometryPool, thermalPool, velocityPool, timeLevel, err) ! ****** Calculate Velocity ****** err = ior(err, err_tmp) @@ -159,8 +165,8 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) ! update halos on velocity call mpas_timer_start("halo updates") - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) - call mpas_pool_get_field(statePool, 'normalVelocity', normalVelocityField, timeLevel=timeLevel) + call mpas_pool_get_subpool(domain % blocklist % structs, 'velocity', velocityPool) + call mpas_pool_get_field(velocityPool, 'normalVelocity', normalVelocityField, timeLevel=timeLevel) call mpas_dmpar_exch_halo_field(normalVelocityField) call mpas_timer_stop("halo updates") @@ -180,22 +186,22 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) call mpas_pool_get_dimension(meshPool, 'nVertInterfaces', nVertInterfaces) - call mpas_pool_get_array(statePool, 'uReconstructX', uReconstructX, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'uReconstructY', uReconstructY, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'surfaceSpeed', surfaceSpeed, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'basalSpeed', basalSpeed, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'uReconstructY', uReconstructY, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'surfaceSpeed', surfaceSpeed, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'basalSpeed', basalSpeed, timeLevel=timeLevel) ! Native SIA dycore needs to have reconstructed velocities calculated. ! External dycores return their native velocities at cell center locations, ! but these can optionally be overwritten by reconstructed velocities for testing. if ( (trim(config_velocity_solver) == 'sia') .or. & config_do_velocity_reconstruction_for_external_dycore ) then - call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'uReconstructZ', uReconstructZ, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'uReconstructZonal', uReconstructZonal, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'uReconstructMeridional', uReconstructMeridional, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'uReconstructZ', uReconstructZ, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'uReconstructZonal', uReconstructZonal, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'uReconstructMeridional', uReconstructMeridional, timeLevel=timeLevel) call mpas_reconstruct(meshPool, normalVelocity, & uReconstructX, uReconstructY, uReconstructZ, & @@ -213,16 +219,17 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'state', statePool) - call diagnostic_solve_after_velocity(meshPool, statePool, timeLevel, err) ! Some diagnostic variables require velocity to compute + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) + call diagnostic_solve_after_velocity(meshPool, geometryPool, velocityPool, timeLevel, err_tmp) ! Some diagnostic variables require velocity to compute err = ior(err, err_tmp) block => block % next end do call mpas_timer_start("halo updates") - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) - call mpas_pool_get_field(statePool, 'layerThicknessEdge', layerThicknessEdgeField, timeLevel=timeLevel) + call mpas_pool_get_subpool(domain % blocklist % structs, 'geometry', geometryPool) + call mpas_pool_get_field(geometryPool, 'layerThicknessEdge', layerThicknessEdgeField, timeLevel=timeLevel) call mpas_dmpar_exch_halo_field(layerThicknessEdgeField) call mpas_timer_stop("halo updates") @@ -296,7 +303,10 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! pointers to get from pools type (block_type), pointer :: block type (mpas_pool_type), pointer :: meshPool - type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshLIPool + type (mpas_pool_type), pointer :: geometryPool + type (mpas_pool_type), pointer :: thermalPool + type (mpas_pool_type), pointer :: velocityPool real (kind=RKIND), dimension(:), pointer :: thickness, upperSurface, & lowerSurface, bedTopography, upperSurfaceVertex, slopeEdge, & normalSlopeEdge, tangentSlopeEdge, dcEdge, dvEdge @@ -332,10 +342,11 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ do while (associated(block)) ! Mesh information call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) ! Calculate masks - needs to happen before calculating lower surface so we know where the ice is floating - call li_calculate_mask(meshPool, statePool, timeLevel, err_tmp) + call li_calculate_mask(meshPool, velocityPool, geometryPool, timeLevel, err_tmp) err = ior(err, err_tmp) @@ -344,10 +355,10 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! Update halos on masks - the outermost cells/edges/vertices may be wrong for mask components that need neighbor information call mpas_timer_start("halo updates") - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) - call mpas_pool_get_field(statePool, 'cellMask', cellMaskField, timeLevel=timeLevel) - call mpas_pool_get_field(statePool, 'edgeMask', edgeMaskField, timeLevel=timeLevel) - call mpas_pool_get_field(statePool, 'vertexMask', vertexMaskField, timeLevel=timeLevel) + call mpas_pool_get_subpool(domain % blocklist % structs, 'geometry', geometryPool) + call mpas_pool_get_field(geometryPool, 'cellMask', cellMaskField, timeLevel=timeLevel) + call mpas_pool_get_field(geometryPool, 'edgeMask', edgeMaskField, timeLevel=timeLevel) + call mpas_pool_get_field(geometryPool, 'vertexMask', vertexMaskField, timeLevel=timeLevel) call mpas_dmpar_exch_halo_field(cellMaskField) call mpas_dmpar_exch_halo_field(edgeMaskField) call mpas_dmpar_exch_halo_field(vertexMaskField) @@ -371,7 +382,8 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'thermal', thermalPool) call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) @@ -381,15 +393,15 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ call mpas_pool_get_config(liConfigs, 'config_ocean_density', config_ocean_density) call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) - call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'upperSurface', upperSurface, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'lowerSurface', lowerSurface, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel=timeLevel) - call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) - call mpas_pool_get_array(meshPool, 'bedTopography', bedTopography) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'thickness', thickness, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'lowerSurface', lowerSurface, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness, timeLevel=timeLevel) + call mpas_pool_get_array(thermalPool, 'tracers', tracers, timeLevel=timeLevel) + call mpas_pool_get_dimension(thermalPool, 'index_temperature', index_temperature) + call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) ! Lower surface is based on floatation for floating ice. For grounded ice (and non-ice areas) it is the bed. @@ -420,17 +432,17 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) - call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'slopeEdge', slopeEdge, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'normalSlopeEdge', normalSlopeEdge, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'tangentSlopeEdge', tangentSlopeEdge, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'upperSurfaceVertex', upperSurfaceVertex, timeLevel=timeLevel) - call mpas_pool_get_array(meshPool, 'baryCellsOnVertex', baryCellsOnVertex) - call mpas_pool_get_array(meshPool, 'baryWeightsOnVertex', baryWeightsOnVertex) - call mpas_pool_get_array(statePool, 'flowParamA', flowParamA, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'slopeEdge', slopeEdge, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'normalSlopeEdge', normalSlopeEdge, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'tangentSlopeEdge', tangentSlopeEdge, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'upperSurfaceVertex', upperSurfaceVertex, timeLevel=timeLevel) + call mpas_pool_get_array(meshLIPool, 'baryCellsOnVertex', baryCellsOnVertex) + call mpas_pool_get_array(meshLIPool, 'baryWeightsOnVertex', baryWeightsOnVertex) + call mpas_pool_get_array(velocityPool, 'flowParamA', flowParamA, timeLevel=timeLevel) ! Calculate flowA - call calculate_flowParamA(meshPool, tracers(index_temperature,:,:), thickness, flowParamA, err_tmp) + call calculate_flowParamA(meshLIPool, tracers(index_temperature,:,:), thickness, flowParamA, err_tmp) err = ior(err, err_tmp) ! Calculate normal slope @@ -485,15 +497,15 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! Do vertical remapping of layerThickness and tracers - call vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers, err) + call vertical_remap(thickness, cellMask, meshLIPool, layerThickness, tracers, err) err = ior(err, err_tmp) ! This information is only needed by external dycores. if (config_velocity_solver /= 'sia') then ! The interface expects an array where 1's are floating edges and 0's are non-floating edges. - call mpas_pool_get_array(statePool, 'floatingEdges', floatingEdges, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'floatingEdges', floatingEdges, timeLevel=timeLevel) floatingEdges = li_mask_is_floating_ice_int(edgeMask) - call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel=timeLevel) call li_calculate_extrapolate_floating_edgemask(meshPool, vertexMask, floatingEdges) end if @@ -504,8 +516,8 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ if (config_velocity_solver /= 'sia') then ! Update halos on masks - the outermost cells/edges/vertices may be wrong for mask components that need neighbor information call mpas_timer_start("halo updates") - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) - call mpas_pool_get_field(statePool, 'floatingEdges', floatingEdgesField, timeLevel=timeLevel) + call mpas_pool_get_subpool(domain % blocklist % structs, 'velocity', velocityPool) + call mpas_pool_get_field(velocityPool, 'floatingEdges', floatingEdgesField, timeLevel=timeLevel) call mpas_dmpar_exch_halo_field(floatingEdgesField) call mpas_timer_stop("halo updates") endif @@ -518,12 +530,13 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! blocks anyway, in case some day they do. block => domain % blocklist do while (associated(block)) - + call mpas_pool_get_subpool(domain % blocklist % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'velocity', velocityPool) ! Determine if the vertex mask changed during this time step for this block (needed for external dycores) ! TODO: there may be some aspects of the mask that are ok change for external dycores, but for now just check the whole thing. ! TODO: if we ever have more than one time level, then this logic should be revisited. - call mpas_pool_get_array(statePool, 'vertexMask', vertexMaskOld, timeLevel=1) - call mpas_pool_get_array(statePool, 'vertexMask', vertexMaskNew, timeLevel=2) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMaskOld, timeLevel=1) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMaskNew, timeLevel=2) if ( sum(li_mask_is_dynamic_ice_int(vertexMaskNew) - li_mask_is_dynamic_ice_int(vertexMaskOld)) /= 0 ) then blockDynamicVertexMaskChanged = 1 else @@ -535,8 +548,8 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ !print *,'procVertexMaskChanged', procVertexMaskChanged ! Also check to see if the Dirichlet b.c. mask has changed - call mpas_pool_get_array(statePool, 'dirichletVelocityMask', dirichletVelocityMaskOld, timeLevel=1) - call mpas_pool_get_array(statePool, 'dirichletVelocityMask', dirichletVelocityMaskNew, timeLevel=2) + call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMaskOld, timeLevel=1) + call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMaskNew, timeLevel=2) if ( sum(dirichletVelocityMaskNew - dirichletVelocityMaskOld) /= 0 ) then blockDirichletMaskChanged = 1 else @@ -549,11 +562,11 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ end do ! Determine if the vertex mask has changed on any processor and store the value for later use (need to exit the block loop to do so) - call mpas_pool_get_array(statePool, 'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged, timeLevel=timeLevel) call mpas_dmpar_max_int(domain % dminfo, procDynamicVertexMaskChanged, anyDynamicVertexMaskChanged) !print *,'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged ! Do the same for the Dirichlet b.c. mask - call mpas_pool_get_array(statePool, 'dirichletMaskChanged', dirichletMaskChanged, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'dirichletMaskChanged', dirichletMaskChanged, timeLevel=timeLevel) call mpas_dmpar_max_int(domain % dminfo, procDirichletMaskChanged, dirichletMaskChanged) !print *,'dirichletMaskChanged', dirichletMaskChanged end if @@ -580,7 +593,7 @@ end subroutine diagnostic_solve_before_velocity !> This routine computes the diagnostic variables that require knowing velocity for land ice ! !----------------------------------------------------------------------- - subroutine diagnostic_solve_after_velocity(meshPool, statePool, timeLevel, err) + subroutine diagnostic_solve_after_velocity(meshPool, geometryPool, velocityPool, timeLevel, err) !----------------------------------------------------------------- ! @@ -590,6 +603,9 @@ subroutine diagnostic_solve_after_velocity(meshPool, statePool, timeLevel, err) type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + velocityPool !< Input: velocity information + integer, intent(in) :: timeLevel !< Input: Time level on which to calculate diagnostic variables !----------------------------------------------------------------- @@ -598,7 +614,7 @@ subroutine diagnostic_solve_after_velocity(meshPool, statePool, timeLevel, err) ! !----------------------------------------------------------------- type (mpas_pool_type), intent(inout) :: & - statePool !< Input/Output: state for which to update diagnostic variables + geometryPool !< Input/Output: geometry info !----------------------------------------------------------------- ! @@ -627,9 +643,9 @@ subroutine diagnostic_solve_after_velocity(meshPool, statePool, timeLevel, err) call mpas_pool_get_config(liConfigs, 'config_thickness_advection', config_thickness_advection) - call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'layerThicknessEdge', layerThicknessEdge, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'layerThicknessEdge', layerThicknessEdge, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) ! Calculate h_edge. This is used by both thickness and tracer advection on the following Forward Euler time step. ! Note: FO-Upwind thickness advection does not explicitly use h_edge but a FO h_edge is implied. @@ -688,7 +704,7 @@ end subroutine diagnostic_solve_after_velocity !> version until tracer advection exists!) ! !----------------------------------------------------------------------- - subroutine vertical_remap_cism_loops(layerThickness, thickness, tracers, meshPool, err) + subroutine vertical_remap_cism_loops(layerThickness, thickness, tracers, meshLIPool, err) !----------------------------------------------------------------- ! ! input variables @@ -699,7 +715,7 @@ subroutine vertical_remap_cism_loops(layerThickness, thickness, tracers, meshPoo thickness !< Input: type (mpas_pool_type), intent(in) :: & - meshPool !< Input: mesh information + meshLIPool !< Input: LI mesh information !----------------------------------------------------------------- ! @@ -740,12 +756,12 @@ subroutine vertical_remap_cism_loops(layerThickness, thickness, tracers, meshPoo err = 0 - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshLIPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshLIPool, 'nVertLevels', nVertLevels) nTracers = size(tracers, 1) - call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) - call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) + call mpas_pool_get_array(meshLIPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(meshLIPool, 'layerInterfaceSigma', layerInterfaceSigma) allocate(recipThickness(nCells+1)) allocate(layerInterfaceSigma_Input(nVertLevels+1, nCells+1)) @@ -844,7 +860,7 @@ end subroutine vertical_remap_cism_loops !> rather than using if/where-statements. ! !----------------------------------------------------------------------- - subroutine vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers, err) + subroutine vertical_remap(thickness, cellMask, meshLIPool, layerThickness, tracers, err) !----------------------------------------------------------------- ! @@ -859,7 +875,7 @@ subroutine vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers cellMask !< Input: mask for cells (needed for determining presence/absence of ice) type (mpas_pool_type), intent(in) :: & - meshPool !< Input: mesh information + meshLIPool !< Input: LI mesh information !----------------------------------------------------------------- ! @@ -900,12 +916,12 @@ subroutine vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers err = 0 - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshLIPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshLIPool, 'nVertLevels', nVertLevels) nTracers = size(tracers, 1) - call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) - call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) + call mpas_pool_get_array(meshLIPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(meshLIPool, 'layerInterfaceSigma', layerInterfaceSigma) allocate(layerInterfaceSigma_Input(nVertLevels+1)) allocate(hTsum(nTracers, nVertLevels)) @@ -1083,7 +1099,7 @@ end subroutine cells_to_vertices_1dfield_using_kiteAreas !> !> All options are adjusted by the enhancement factor (which defaults to 1.0). !----------------------------------------------------------------------- - subroutine calculate_flowParamA(meshPool, temperature, thickness, flowParamA, err) + subroutine calculate_flowParamA(meshLIPool, temperature, thickness, flowParamA, err) use mpas_constants, only: gravity use li_constants, only: idealGasConstant @@ -1094,7 +1110,7 @@ subroutine calculate_flowParamA(meshPool, temperature, thickness, flowParamA, er !----------------------------------------------------------------- type (mpas_pool_type), intent(in) :: & - meshPool !< Input: mesh information + meshLIPool !< Input: mesh information real (kind=RKIND), dimension(:,:), intent(in) :: & temperature !< Input: temperature real (kind=RKIND), dimension(:), intent(in) :: & @@ -1134,10 +1150,10 @@ subroutine calculate_flowParamA(meshPool, temperature, thickness, flowParamA, er err_tmp = 0 - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshLIPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshLIPool, 'nVertLevels', nVertLevels) - call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) + call mpas_pool_get_array(meshLIPool, 'layerCenterSigma', layerCenterSigma) call mpas_pool_get_config(liConfigs, 'config_flowParamA_calculation', config_flowParamA_calculation) call mpas_pool_get_config(liConfigs, 'config_enhancementFactor', config_enhancementFactor) diff --git a/src/core_landice/mpas_li_mask.F b/src/core_landice/mpas_li_mask.F index 941109fa58..e437fa1d94 100644 --- a/src/core_landice/mpas_li_mask.F +++ b/src/core_landice/mpas_li_mask.F @@ -120,7 +120,7 @@ module li_mask ! !----------------------------------------------------------------------- - subroutine li_calculate_mask_init(meshPool, statePool, timeLevel, err) + subroutine li_calculate_mask_init(geometryPool, err) !----------------------------------------------------------------- ! @@ -128,27 +128,19 @@ subroutine li_calculate_mask_init(meshPool, statePool, timeLevel, err) ! !----------------------------------------------------------------- - type (mpas_pool_type), intent(in) :: & - meshPool !< Input: mesh information - - integer, intent(in) :: & - timeLevel !< Input: time level for which to init mask - !----------------------------------------------------------------- ! ! input/output variables ! !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: & - statePool !< Input/Output: state information + geometryPool !< Input/Output: geometry information !----------------------------------------------------------------- ! ! output variables ! !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag !----------------------------------------------------------------- @@ -163,8 +155,8 @@ subroutine li_calculate_mask_init(meshPool, statePool, timeLevel, err) err = 0 ! Assign pointers and variables - call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) call mpas_pool_get_config(liConfigs, 'config_do_restart', config_do_restart) @@ -196,7 +188,7 @@ end subroutine li_calculate_mask_init ! !----------------------------------------------------------------------- - subroutine li_calculate_mask(meshPool, statePool, timeLevel, err) + subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, timeLevel, err) !----------------------------------------------------------------- ! @@ -207,6 +199,9 @@ subroutine li_calculate_mask(meshPool, statePool, timeLevel, err) type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information + type (mpas_pool_type), intent(inout) :: & + velocityPool !< Input: velocity information + integer, intent(in) :: & timeLevel !< Input: time level for which to calculate mask @@ -215,9 +210,8 @@ subroutine li_calculate_mask(meshPool, statePool, timeLevel, err) ! input/output variables ! !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: & - statePool !< Input/Output: state information + geometryPool !< Input/Output: geometry information !----------------------------------------------------------------- ! @@ -258,12 +252,12 @@ subroutine li_calculate_mask(meshPool, statePool, timeLevel, err) call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(meshPool, 'bedTopography', bedTopography) - call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) call mpas_pool_get_config(liConfigs, 'config_ocean_density', config_ocean_density) @@ -291,7 +285,7 @@ subroutine li_calculate_mask(meshPool, statePool, timeLevel, err) cellMask = ior(cellMask, li_mask_ValueDynamicIce) end where else ! HO external FEM dycore - call mpas_pool_get_array(statePool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMask) ! Identify cells where the ice is above the ice dynamics thickness limit but not with a dirichletVelocity condition set where ( (thickness > config_dynamic_thickness) .and. & ! same as for SIA case (dirichletVelocityMask(1,:) == 0) ) ! but exclude dirichletVelocityMask locations set as lateral b.c. To ignore dirichlet b.c. on the basal boundary, just check the surface level diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index 5afda6d533..2339d98943 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -227,7 +227,7 @@ subroutine mpas_core_run(domain, stream_manager) !----------------------------------------------------------------- integer :: itimestep type (block_type), pointer :: block - type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: geometryPool integer, pointer :: config_stats_interval !< interval (number of timesteps) for writing stats logical, pointer :: config_do_restart, config_write_output_on_startup, config_write_stats_on_startup character(len=StrKIND), pointer :: config_restart_timestamp_name @@ -300,7 +300,7 @@ subroutine mpas_core_run(domain, stream_manager) if (config_write_stats_on_startup) then call mpas_timer_start("compute_statistics") - call li_compute_statistics(domain, 1, 0) ! timelevel = 1, itimestep = 0 + call li_compute_statistics(domain, 0) ! itimestep = 0 ! (itimestep is initialized below) call mpas_timer_stop("compute_statistics") endif @@ -311,8 +311,8 @@ subroutine mpas_core_run(domain, stream_manager) ! initial time to garbage. (Do this after writing output.) block => domain % blocklist do while(associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', statePool) - call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel=1) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel=1) vertexMask = 0 block => block % next end do @@ -367,7 +367,7 @@ subroutine mpas_core_run(domain, stream_manager) if (config_stats_interval > 0) then if (mod(itimestep, config_stats_interval) == 0) then call mpas_timer_start("compute_statistics") - call li_compute_statistics(domain, 2, itimestep) + call li_compute_statistics(domain, itimestep) call mpas_timer_stop("compute_statistics") end if end if @@ -375,8 +375,8 @@ subroutine mpas_core_run(domain, stream_manager) ! Move time level 2 fields back into time level 1 for next time step block => domain % blocklist do while(associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', statePool) - call mpas_pool_shift_time_levels(statePool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_shift_time_levels(geometryPool) block => block % next end do @@ -710,7 +710,8 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! !----------------------------------------------------------------- type (mpas_pool_type), pointer :: meshPool - type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshLIPool + type (mpas_pool_type), pointer :: geometryPool integer, dimension(:), pointer :: vertexMask character (len=StrKIND), pointer :: xtime character (len=StrKIND), pointer :: config_velocity_solver @@ -722,26 +723,27 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) err_tmp = 0 ! Get pool stuff - call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'meshLI', meshLIPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_config(liConfigs, 'config_do_velocity_reconstruction_for_external_dycore', config_do_velocity_reconstruction_for_external_dycore) ! Copy data from first time level into all other time levels - call mpas_pool_initialize_time_levels(statePool) + call mpas_pool_initialize_time_levels(geometryPool) ! Initialize vertexMask on time level 2 to junk, so diagnostic_solve_before_velocity in li_diagnostic_vars says that the vertexMask has changed (needed by external dycore) - call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel = 2) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel = 2) vertexMask = -9999 ! === ! === Call init routines === ! === - call li_setup_vertical_grid(meshPool, err_tmp) + call li_setup_vertical_grid(meshLIPool, err_tmp) err = ior(err, err_tmp) - call li_setup_sign_and_index_fields(meshPool) + call li_setup_sign_and_index_fields(meshPool, meshLIPool) ! This was needed to init FCT once. !!! ! Init for FCT tracer advection @@ -765,15 +767,15 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) endif ! Assign initial time stamp - call mpas_pool_get_array(statePool, 'xtime', xtime, timeLevel=1) + call mpas_pool_get_array(meshLIPool, 'xtime', xtime) xtime = startTimeStamp ! Mask init identifies initial ice extent - call li_calculate_mask_init(meshPool, statePool, timeLevel=1, err=err_tmp) + call li_calculate_mask_init(geometryPool, err=err_tmp) err = ior(err, err_tmp) ! Make sure all time levels have a copy of the initial state - call mpas_pool_initialize_time_levels(statePool) + call mpas_pool_initialize_time_levels(geometryPool) ! === error check if (err > 0) then diff --git a/src/core_landice/mpas_li_setup.F b/src/core_landice/mpas_li_setup.F index 937893ffc3..b4b07f4e0a 100644 --- a/src/core_landice/mpas_li_setup.F +++ b/src/core_landice/mpas_li_setup.F @@ -123,7 +123,7 @@ end subroutine li_setup_config_options ! !----------------------------------------------------------------------- - subroutine li_setup_vertical_grid(meshPool, err) + subroutine li_setup_vertical_grid(meshLIPool, err) !----------------------------------------------------------------- ! @@ -131,13 +131,12 @@ subroutine li_setup_vertical_grid(meshPool, err) ! !----------------------------------------------------------------- - !----------------------------------------------------------------- ! ! input/output variables ! !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: meshPool !< Input/Output: mesh object + type (mpas_pool_type), intent(inout) :: meshLIPool !< Input/Output: meshLI object !----------------------------------------------------------------- ! @@ -160,11 +159,11 @@ subroutine li_setup_vertical_grid(meshPool, err) real (kind=RKIND) :: fractionTotal ! Get pool stuff - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshLIPool, 'nVertLevels', nVertLevels) ! layerThicknessFractions is provided by input - call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) - call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) - call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) + call mpas_pool_get_array(meshLIPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(meshLIPool, 'layerCenterSigma', layerCenterSigma) + call mpas_pool_get_array(meshLIPool, 'layerInterfaceSigma', layerInterfaceSigma) ! Check that layerThicknessFractions are valid ! TODO - switch to having the user input the sigma levels instead??? @@ -206,20 +205,21 @@ end subroutine li_setup_vertical_grid !> This routine determines the sign for various mesh items. ! !----------------------------------------------------------------------- - subroutine li_setup_sign_and_index_fields(meshPool) + subroutine li_setup_sign_and_index_fields(meshPool, meshLIPool) !----------------------------------------------------------------- ! ! input variables ! !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh object !----------------------------------------------------------------- ! ! input/output variables ! !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: meshPool !< Input/Output: mesh object + type (mpas_pool_type), intent(inout) :: meshLIPool !< Input/Output: meshLI object !----------------------------------------------------------------- ! @@ -242,11 +242,10 @@ subroutine li_setup_sign_and_index_fields(meshPool) ! Get pool stuff call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - ! layerThicknessFractions is provided by input call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshLIPool, 'edgeSignOnCell', edgeSignOnCell) edgeSignOnCell = 0.0_RKIND !edgeSignOnVertex = 0.0_RKIND diff --git a/src/core_landice/mpas_li_sia.F b/src/core_landice/mpas_li_sia.F index 63c41d2af8..747381bc71 100644 --- a/src/core_landice/mpas_li_sia.F +++ b/src/core_landice/mpas_li_sia.F @@ -154,6 +154,7 @@ subroutine li_sia_block_init(block, err) ! !----------------------------------------------------------------- type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: meshLIPool type (mpas_pool_type), pointer :: scratchPool integer :: iCell, iLevel, i, iVertex, err_tmp integer, pointer :: nVertices @@ -168,9 +169,10 @@ subroutine li_sia_block_init(block, err) err_tmp = 0 call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'meshLI', meshLIPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) - call mpas_pool_get_array(meshPool, 'baryCellsOnVertex', baryCellsOnVertex) - call mpas_pool_get_array(meshPool, 'baryWeightsOnVertex', baryWeightsOnVertex) + call mpas_pool_get_array(meshLIPool, 'baryCellsOnVertex', baryCellsOnVertex) + call mpas_pool_get_array(meshLIPool, 'baryWeightsOnVertex', baryWeightsOnVertex) call mpas_pool_get_array(meshPool, 'xVertex', xVertex) call mpas_pool_get_array(meshPool, 'yVertex', yVertex) call mpas_pool_get_array(meshPool, 'zVertex', zVertex) @@ -215,7 +217,7 @@ end subroutine li_sia_block_init !> on an edge using the average of the two neighboring cells (2nd order). ! !----------------------------------------------------------------------- - subroutine li_sia_solve(meshPool, statePool, timeLevel, err) + subroutine li_sia_solve(meshPool, meshLIPool, geometryPool, timeLevel, velocityPool, err) use mpas_constants, only: gravity !----------------------------------------------------------------- @@ -227,6 +229,12 @@ subroutine li_sia_solve(meshPool, statePool, timeLevel, err) type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshLIPool !< Input: LI mesh information + + type (mpas_pool_type), intent(in) :: & + geometryPool !< Input: geometry information + integer, intent(in) :: & timeLevel !< Input: time level from which to calculate velocity @@ -237,7 +245,7 @@ subroutine li_sia_solve(meshPool, statePool, timeLevel, err) !----------------------------------------------------------------- type (mpas_pool_type), intent(inout) :: & - statePool !< Input: state information + velocityPool !< Input/Output: velocity information !----------------------------------------------------------------- ! @@ -275,15 +283,15 @@ subroutine li_sia_solve(meshPool, statePool, timeLevel, err) call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) - - call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'flowParamA', flowParamA, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'slopeEdge', slopeEdge, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'normalSlopeEdge', normalSlopeEdge, timeLevel=timeLevel) + call mpas_pool_get_array(meshLIPool, 'layerInterfaceSigma', layerInterfaceSigma) + + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'flowParamA', flowParamA, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'thickness', thickness, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'slopeEdge', slopeEdge, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'normalSlopeEdge', normalSlopeEdge, timeLevel=timeLevel) ! Get parameters specified in the namelist diff --git a/src/core_landice/mpas_li_statistics.F b/src/core_landice/mpas_li_statistics.F index 3578e1188f..b9f3a1c96d 100644 --- a/src/core_landice/mpas_li_statistics.F +++ b/src/core_landice/mpas_li_statistics.F @@ -71,14 +71,12 @@ module li_statistics !> !----------------------------------------------------------------------- - subroutine li_compute_statistics(domain, timeLevel, itimestep) + subroutine li_compute_statistics(domain, itimestep) implicit none ! Input/output arguments type (domain_type), intent(inout) :: domain !< Input/Output: domain object - integer, intent(in) :: timeLevel !< Input: time level used by pools for variables with multiple time levels - ! (typically '2' when this subroutine is called at the end of a time step) integer, intent(in) :: itimestep !< Input: current time step counter ! Local variables @@ -87,10 +85,12 @@ subroutine li_compute_statistics(domain, timeLevel, itimestep) type (dm_info), pointer :: dminfo ! pools - type (mpas_pool_type), pointer :: statePool type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: meshLIPool + type (mpas_pool_type), pointer :: geometryPool + type (mpas_pool_type), pointer :: velocityPool + type (mpas_pool_type), pointer :: thermalPool type (mpas_pool_type), pointer :: scratchPool - type (mpas_pool_type), pointer :: diagnosticsPool ! mesh dimensions integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve @@ -207,10 +207,12 @@ subroutine li_compute_statistics(domain, timeLevel, itimestep) ! pools - call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'meshLI', meshLIPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) + call mpas_pool_get_subpool(block % structs, 'thermal', thermalPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) - call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) ! mesh dimensions call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) @@ -223,27 +225,32 @@ subroutine li_compute_statistics(domain, timeLevel, itimestep) call mpas_pool_get_array(meshPool, 'areaCell', areaCell) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) - call mpas_pool_get_array(meshPool, 'bedTopography', bedTopography) - call mpas_pool_get_array(meshPool, 'sfcMassBal', sfcMassBal) - + + ! LI mesh arrays + call mpas_pool_get_array(meshLIPool, 'xtime', xtime) + call mpas_pool_get_array(meshLIPool, 'layerCenterSigma', layerCenterSigma) + + ! Geometry arrays + call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) + call mpas_pool_get_array(geometryPool, 'sfcMassBal', sfcMassBal) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness) + call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface) + ! scratch fields call mpas_pool_get_field(scratchPool, 'iceCellMask', iceCellMaskField) call mpas_pool_get_field(scratchPool, 'iceEdgeMask', iceEdgeMaskField) call mpas_pool_get_field(scratchPool, 'workLevelCell', workLevelCellField) - ! state variables - call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel) - call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel) - call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) - call mpas_pool_get_array(statePool, 'upperSurface', upperSurface, timeLevel) - call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) - call mpas_pool_get_array(statePool, 'surfaceTemperature', surfaceTemperature, timeLevel) - call mpas_pool_get_array(statePool, 'basalTemperature', basalTemperature, timeLevel) - !Note: xtime only has one time level, but stating it explicitly here to avoid confusion - call mpas_pool_get_array(statePool, 'xtime', xtime, timeLevel=1) - call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) + ! velocity variables + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) + + ! thermal variables + call mpas_pool_get_array(thermalPool, 'tracers', tracers) + call mpas_pool_get_array(thermalPool, 'surfaceTemperature', surfaceTemperature) + call mpas_pool_get_array(thermalPool, 'basalTemperature', basalTemperature) + call mpas_pool_get_dimension(thermalPool, 'index_temperature', indexTemperature) ! config settings call mpas_pool_get_config(liConfigs, 'config_ice_density', rhoi) diff --git a/src/core_landice/mpas_li_tendency.F b/src/core_landice/mpas_li_tendency.F index e8d5cb4e60..219d419d01 100644 --- a/src/core_landice/mpas_li_tendency.F +++ b/src/core_landice/mpas_li_tendency.F @@ -73,7 +73,7 @@ module li_tendency ! !----------------------------------------------------------------------- - subroutine li_tendency_thickness(meshPool, statePool, layerThickness_tend, dt, dminfo, allowableDt, err) + subroutine li_tendency_thickness(meshPool, velocityPool, geometryPool, layerThickness_tend, dt, dminfo, allowableDt, err) !----------------------------------------------------------------- ! @@ -84,6 +84,9 @@ subroutine li_tendency_thickness(meshPool, statePool, layerThickness_tend, dt, d type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + velocityPool !< Input: velocity information + real (kind=RKIND), intent(in) :: & dt !< Input: dt @@ -97,8 +100,7 @@ subroutine li_tendency_thickness(meshPool, statePool, layerThickness_tend, dt, d !----------------------------------------------------------------- type (mpas_pool_type), intent(inout) :: & - statePool !< Input: state to use to calculate tendency (old time level) - ! Note: state needs to be inout (rather than just in) so that adjust_marine_boundary_fluxes can modify it. + geometryPool !< Input: geometry information to be updated real (kind=RKIND), dimension(:,:), pointer, intent(inout) :: & layerThickness_tend !< Input/Output: layer thickness tendency @@ -135,12 +137,12 @@ subroutine li_tendency_thickness(meshPool, statePool, layerThickness_tend, dt, d err_tmp = 0 call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - call mpas_pool_get_array(meshPool, 'sfcMassBal', sfcMassBal) + call mpas_pool_get_array(geometryPool, 'sfcMassBal', sfcMassBal) ! Assuming tendency will always be calculated using time level 1! - call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=1) - call mpas_pool_get_array(statePool, 'layerThicknessEdge', layerThicknessEdge, timeLevel=1) - call mpas_pool_get_array(statePool, 'cellMask', cellMask, timeLevel=1) - call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=1) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity, timeLevel=1) + call mpas_pool_get_array(geometryPool, 'layerThicknessEdge', layerThicknessEdge, timeLevel=1) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask, timeLevel=1) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask, timeLevel=1) !!! marineBasalMassBal => mesh % marineBasalMassBal % array !!! iceArea => state % iceArea % array !!! areaCell => mesh % areaCell % array @@ -258,7 +260,7 @@ end subroutine li_tendency_thickness ! !----------------------------------------------------------------------- - subroutine li_tendency_tracers(meshPool, statePool, layerThickness_tend, tracer_tendency, dt, dminfo, err) + subroutine li_tendency_tracers(meshPool, velocityPool, geometryPool, thermalPool, layerThickness_tend, tracer_tendency, dt, dminfo, err) !----------------------------------------------------------------- ! @@ -270,10 +272,16 @@ subroutine li_tendency_tracers(meshPool, statePool, layerThickness_tend, tracer_ meshPool !< Input: mesh information type (mpas_pool_type), intent(in) :: & - statePool !< Input: state to use to calculate tendency + velocityPool !< Input: velocity information + + type (mpas_pool_type), intent(in) :: & + geometryPool !< Input: geometry information + + type (mpas_pool_type), intent(in) :: & + thermalPool !< Input: thermal information real (kind=RKIND), dimension(:,:), pointer, intent(in) :: & - layerThickness_tend !< Input/Output: layer thickness tendency + layerThickness_tend !< Input: layer thickness tendency real (kind=RKIND), intent(in) :: & dt !< Input: dt @@ -405,7 +413,7 @@ end subroutine li_tendency_tracers !> marine-terminating ice. ! !----------------------------------------------------------------------- - subroutine li_apply_calving(meshPool, statePool, err)!{{{ + subroutine li_apply_calving(meshPool, geometryPool, thermalPool, err) !----------------------------------------------------------------- ! @@ -422,8 +430,11 @@ subroutine li_apply_calving(meshPool, statePool, err)!{{{ ! !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: & + geometryPool !< Input/Output: geometry information + type (mpas_pool_type), intent(inout) :: & - statePool !< Input/Output: state for which to update diagnostic variables + thermalPool !< Input/Output: thermal information !----------------------------------------------------------------- ! diff --git a/src/core_landice/mpas_li_time_integration.F b/src/core_landice/mpas_li_time_integration.F index 432bd0d77a..f06bfaf572 100644 --- a/src/core_landice/mpas_li_time_integration.F +++ b/src/core_landice/mpas_li_time_integration.F @@ -99,7 +99,7 @@ subroutine li_timestep(domain, dt, timeStamp, err) ! !----------------------------------------------------------------- type (block_type), pointer :: block - type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshLIPool character (len=StrKIND), pointer :: xtime character (len=StrKIND), pointer :: config_time_integration integer :: err_tmp @@ -126,8 +126,8 @@ subroutine li_timestep(domain, dt, timeStamp, err) block => domain % blocklist do while (associated(block)) ! Assign the time stamp for this time step - call mpas_pool_get_subpool(block % structs, 'state', statePool) - call mpas_pool_get_array(statePool, 'xtime', xtime, timeLevel=1) ! xtime only has one time level, but stating is explicitly here to avoid confusion later. + call mpas_pool_get_subpool(block % structs, 'meshLI', meshLIPool) + call mpas_pool_get_array(meshLIPool, 'xtime', xtime) xtime = timeStamp ! ! Abort the simulation if NaNs occur in the velocity field diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index d9f6695e84..aa18474e4f 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -188,9 +188,10 @@ subroutine calculate_tendencies(domain, deltat, err) !----------------------------------------------------------------- type (dm_info), pointer :: dminfo type (block_type), pointer :: block - type (mpas_pool_type), pointer :: statePool type (mpas_pool_type), pointer :: meshPool - type (mpas_pool_type), pointer :: tendPool + type (mpas_pool_type), pointer :: velocityPool + type (mpas_pool_type), pointer :: geometryPool + type (mpas_pool_type), pointer :: tendencyPool real (kind=RKIND), dimension(:,:), pointer :: layerThickness_tend type (field2DReal), pointer :: layerThickness_tend_field @@ -214,13 +215,14 @@ subroutine calculate_tendencies(domain, deltat, err) ! === block => domain % blocklist do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'tend', tendPool) - call mpas_pool_get_array(tendPool, 'layerThickness', layerThickness_tend) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'tendency', tendencyPool) + call mpas_pool_get_array(tendencyPool, 'layerThickness', layerThickness_tend) ! Calculate thickness tendency using state at time n ========= - call li_tendency_thickness(meshPool, statePool, layerThickness_tend, deltat, dminfo, allowableDt, err_tmp) + call li_tendency_thickness(meshPool, velocityPool, geometryPool, layerThickness_tend, deltat, dminfo, allowableDt, err_tmp) err = ior(err,err_tmp) block => block % next @@ -229,8 +231,8 @@ subroutine calculate_tendencies(domain, deltat, err) ! Now that we have exited the block loop, do any needed halo updates. ! update halos on thickness tend call mpas_timer_start("halo updates") - call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) - call mpas_pool_get_field(tendPool, 'layerThickness', layerThickness_tend_field) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tendency', tendencyPool) + call mpas_pool_get_field(tendencyPool, 'layerThickness', layerThickness_tend_field) call mpas_dmpar_exch_halo_field(layerThickness_tend_field) call mpas_timer_stop("halo updates") @@ -341,7 +343,7 @@ subroutine update_prognostics(domain, deltat, err) !----------------------------------------------------------------- type (dm_info), pointer :: dminfo type (block_type), pointer :: block - type (mpas_pool_type), pointer :: meshPool, statePool, tendPool + type (mpas_pool_type), pointer :: meshLIPool, geometryPool, tendencyPool integer, pointer :: nCells logical, pointer :: config_print_thickness_advection_info @@ -358,26 +360,25 @@ subroutine update_prognostics(domain, deltat, err) block => domain % blocklist do while (associated(block)) - ! Mesh information - call mpas_pool_get_subpool(block % structs, 'state', statePool) - call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'tend', tendPool) - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_subpool(block % structs, 'meshLI', meshLIPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'tendency', tendencyPool) + call mpas_pool_get_dimension(meshLIPool, 'nCells', nCells) + call mpas_pool_get_array(meshLIPool, 'layerThicknessFractions', layerThicknessFractions) ! State at time n - call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessOld, timeLevel=1) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThicknessOld, timeLevel=1) !!! tracersOld => stateOld % tracers % array !!! cellMaskOld => stateOld % cellMask % array ! State at time n+1 (advanced by dt by Forward Euler) - call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, timeLevel=2) - call mpas_pool_get_array(statePool, 'thickness', thicknessNew, timeLevel=2) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThicknessNew, timeLevel=2) + call mpas_pool_get_array(geometryPool, 'thickness', thicknessNew, timeLevel=2) !!! tracersNew => stateNew % tracers % array ! Tendencies - call mpas_pool_get_array(tendPool, 'layerThickness', layerThickness_tend) + call mpas_pool_get_array(tendencyPool, 'layerThickness', layerThickness_tend) !!! tracer_tendency => block % tend % tracers % array diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index 4d2f8d6e3a..80d7434f61 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -213,7 +213,7 @@ end subroutine li_velocity_block_init !> This routine calls velocity solvers. ! !----------------------------------------------------------------------- - subroutine li_velocity_solve(meshPool, statePool, timeLevel, err) + subroutine li_velocity_solve(meshPool, meshLIPool, geometryPool, thermalPool, velocityPool, timeLevel, err) use li_mask @@ -226,6 +226,15 @@ subroutine li_velocity_solve(meshPool, statePool, timeLevel, err) type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshLIPool !< Input: meshLI information + + type (mpas_pool_type), intent(in) :: & + geometryPool !< Input: geometry information + + type (mpas_pool_type), intent(in) :: & + thermalPool !< Input: thermal information + integer, intent(in) :: timeLevel !< Input: Time level on which to calculate diagnostic variables !----------------------------------------------------------------- @@ -235,7 +244,7 @@ subroutine li_velocity_solve(meshPool, statePool, timeLevel, err) !----------------------------------------------------------------- type (mpas_pool_type), intent(inout) :: & - statePool !< Input: state information + velocityPool !< Input: velocity information !----------------------------------------------------------------- ! @@ -263,17 +272,17 @@ subroutine li_velocity_solve(meshPool, statePool, timeLevel, err) ! Get variables from pools call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask, timeLevel=timeLevel) select case (config_velocity_solver) case ('none') ! Do nothing case ('sia') - call li_sia_solve(meshPool, statePool, timeLevel, err) + call li_sia_solve(meshPool, meshLIPool, geometryPool, timeLevel, velocityPool, err) case ('L1L2', 'FO', 'Stokes') - call li_velocity_external_solve(meshPool, statePool, timeLevel, err) + call li_velocity_external_solve(meshPool, meshLIPool, geometryPool, thermalPool, velocityPool, timeLevel, err) case default write(stderrUnit,*) 'Error: ', trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index 21cd83e579..cec851cfb8 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -316,7 +316,7 @@ end subroutine li_velocity_external_block_init ! !----------------------------------------------------------------------- - subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) + subroutine li_velocity_external_solve(meshPool, meshLIPool, geometryPool, thermalPool, velocityPool, timeLevel, err) use li_mask @@ -329,6 +329,15 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: & + meshLIPool !< Input: meshLI information + + type (mpas_pool_type), intent(in) :: & + geometryPool !< Input: geometry information + + type (mpas_pool_type), intent(in) :: & + thermalPool !< Input: thermal information + integer, intent(in) :: & timeLevel !< Input: time level from which to calculate velocity @@ -339,7 +348,7 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) !----------------------------------------------------------------- type (mpas_pool_type), intent(inout) :: & - statePool !< Input: state information + velocityPool !< Input/Output: velocity information !----------------------------------------------------------------- ! @@ -377,25 +386,30 @@ subroutine li_velocity_external_solve(meshPool, statePool, timeLevel, err) call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) ! Mesh variables - call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) - call mpas_pool_get_array(meshPool, 'beta', beta) - - ! State variables - call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'uReconstructX', uReconstructX, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'uReconstructY', uReconstructY, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'uReconstructZ', uReconstructZ, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'thickness', thickness, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'lowerSurface', lowerSurface, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'upperSurface', upperSurface, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel=timeLevel) - call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) - call mpas_pool_get_array(statePool, 'vertexMask', vertexMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'edgeMask', edgeMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'dirichletMaskChanged', dirichletMaskChanged, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel=timeLevel) - call mpas_pool_get_array(statePool, 'floatingEdges', floatingEdges, timeLevel=timeLevel) + call mpas_pool_get_array(meshLIPool, 'layerThicknessFractions', layerThicknessFractions) + + ! Geometry variables + call mpas_pool_get_array(geometryPool, 'thickness', thickness, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'lowerSurface', lowerSurface, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask, timeLevel=timeLevel) + + ! Thermal variables + call mpas_pool_get_array(thermalPool, 'tracers', tracers, timeLevel=timeLevel) + call mpas_pool_get_dimension(thermalPool, 'index_temperature', index_temperature) + + ! Velocity variables + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'uReconstructY', uReconstructY, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'uReconstructZ', uReconstructZ, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'beta', beta) + call mpas_pool_get_array(velocityPool, 'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'dirichletMaskChanged', dirichletMaskChanged, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'floatingEdges', floatingEdges, timeLevel=timeLevel) + if (maxval(thickness) < config_dynamic_thickness) then ! External dycores may not be able to handle case when there is no ice From c1d9834db1c89b5e88913b18952086ad87bd40c5 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Wed, 15 Apr 2015 11:07:24 -0600 Subject: [PATCH 0038/1724] LI: Merge mesh and meshLI var_structs In the previous commits I had separated mesh into two var_structs called mesh and meshLI. I decided that was unnecessarily confusing, so I have merged them back together again (into 'mesh'). --- src/core_landice/Registry.xml | 93 ++++++++++++++----- src/core_landice/mpas_li_diagnostic_vars.F | 47 +++++----- src/core_landice/mpas_li_mpas_core.F | 8 +- src/core_landice/mpas_li_setup.F | 17 ++-- src/core_landice/mpas_li_sia.F | 13 +-- src/core_landice/mpas_li_statistics.F | 6 +- src/core_landice/mpas_li_tendency.F | 2 +- src/core_landice/mpas_li_time_integration.F | 6 +- .../mpas_li_time_integration_fe.F | 8 +- src/core_landice/mpas_li_velocity.F | 9 +- src/core_landice/mpas_li_velocity_external.F | 7 +- 11 files changed, 120 insertions(+), 96 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index a399572b28..062b4a54d0 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -238,13 +238,58 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + @@ -284,7 +329,7 @@ precision="double" clobber_mode="replace_files"> - + @@ -313,7 +358,7 @@ clobber_mode="replace_files"> - + @@ -338,8 +383,8 @@ - + @@ -448,19 +493,25 @@ - - - - - - - + + + + + + - + @@ -473,18 +524,6 @@ - - - - + + diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index f801223c43..cb43f3ebdf 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -112,7 +112,6 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) !----------------------------------------------------------------- type (block_type), pointer :: block type (mpas_pool_type), pointer :: meshPool - type (mpas_pool_type), pointer :: meshLIPool type (mpas_pool_type), pointer :: geometryPool type (mpas_pool_type), pointer :: thermalPool type (mpas_pool_type), pointer :: velocityPool @@ -151,12 +150,11 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'meshLI', meshLIPool) call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) call mpas_pool_get_subpool(block % structs, 'thermal', thermalPool) call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) - call li_velocity_solve(meshPool, meshLIPool, geometryPool, thermalPool, velocityPool, timeLevel, err) ! ****** Calculate Velocity ****** + call li_velocity_solve(meshPool, geometryPool, thermalPool, velocityPool, timeLevel, err) ! ****** Calculate Velocity ****** err = ior(err, err_tmp) @@ -303,7 +301,6 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! pointers to get from pools type (block_type), pointer :: block type (mpas_pool_type), pointer :: meshPool - type (mpas_pool_type), pointer :: meshLIPool type (mpas_pool_type), pointer :: geometryPool type (mpas_pool_type), pointer :: thermalPool type (mpas_pool_type), pointer :: velocityPool @@ -437,12 +434,12 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ call mpas_pool_get_array(geometryPool, 'normalSlopeEdge', normalSlopeEdge, timeLevel=timeLevel) call mpas_pool_get_array(geometryPool, 'tangentSlopeEdge', tangentSlopeEdge, timeLevel=timeLevel) call mpas_pool_get_array(geometryPool, 'upperSurfaceVertex', upperSurfaceVertex, timeLevel=timeLevel) - call mpas_pool_get_array(meshLIPool, 'baryCellsOnVertex', baryCellsOnVertex) - call mpas_pool_get_array(meshLIPool, 'baryWeightsOnVertex', baryWeightsOnVertex) + call mpas_pool_get_array(meshPool, 'baryCellsOnVertex', baryCellsOnVertex) + call mpas_pool_get_array(meshPool, 'baryWeightsOnVertex', baryWeightsOnVertex) call mpas_pool_get_array(velocityPool, 'flowParamA', flowParamA, timeLevel=timeLevel) ! Calculate flowA - call calculate_flowParamA(meshLIPool, tracers(index_temperature,:,:), thickness, flowParamA, err_tmp) + call calculate_flowParamA(meshPool, tracers(index_temperature,:,:), thickness, flowParamA, err_tmp) err = ior(err, err_tmp) ! Calculate normal slope @@ -497,7 +494,7 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! Do vertical remapping of layerThickness and tracers - call vertical_remap(thickness, cellMask, meshLIPool, layerThickness, tracers, err) + call vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers, err) err = ior(err, err_tmp) ! This information is only needed by external dycores. @@ -704,7 +701,7 @@ end subroutine diagnostic_solve_after_velocity !> version until tracer advection exists!) ! !----------------------------------------------------------------------- - subroutine vertical_remap_cism_loops(layerThickness, thickness, tracers, meshLIPool, err) + subroutine vertical_remap_cism_loops(layerThickness, thickness, tracers, meshPool, err) !----------------------------------------------------------------- ! ! input variables @@ -715,7 +712,7 @@ subroutine vertical_remap_cism_loops(layerThickness, thickness, tracers, meshLIP thickness !< Input: type (mpas_pool_type), intent(in) :: & - meshLIPool !< Input: LI mesh information + meshPool !< Input: LI mesh information !----------------------------------------------------------------- ! @@ -756,12 +753,12 @@ subroutine vertical_remap_cism_loops(layerThickness, thickness, tracers, meshLIP err = 0 - call mpas_pool_get_dimension(meshLIPool, 'nCells', nCells) - call mpas_pool_get_dimension(meshLIPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) nTracers = size(tracers, 1) - call mpas_pool_get_array(meshLIPool, 'layerThicknessFractions', layerThicknessFractions) - call mpas_pool_get_array(meshLIPool, 'layerInterfaceSigma', layerInterfaceSigma) + call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) allocate(recipThickness(nCells+1)) allocate(layerInterfaceSigma_Input(nVertLevels+1, nCells+1)) @@ -860,7 +857,7 @@ end subroutine vertical_remap_cism_loops !> rather than using if/where-statements. ! !----------------------------------------------------------------------- - subroutine vertical_remap(thickness, cellMask, meshLIPool, layerThickness, tracers, err) + subroutine vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers, err) !----------------------------------------------------------------- ! @@ -875,7 +872,7 @@ subroutine vertical_remap(thickness, cellMask, meshLIPool, layerThickness, trace cellMask !< Input: mask for cells (needed for determining presence/absence of ice) type (mpas_pool_type), intent(in) :: & - meshLIPool !< Input: LI mesh information + meshPool !< Input: LI mesh information !----------------------------------------------------------------- ! @@ -916,12 +913,12 @@ subroutine vertical_remap(thickness, cellMask, meshLIPool, layerThickness, trace err = 0 - call mpas_pool_get_dimension(meshLIPool, 'nCells', nCells) - call mpas_pool_get_dimension(meshLIPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) nTracers = size(tracers, 1) - call mpas_pool_get_array(meshLIPool, 'layerThicknessFractions', layerThicknessFractions) - call mpas_pool_get_array(meshLIPool, 'layerInterfaceSigma', layerInterfaceSigma) + call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) allocate(layerInterfaceSigma_Input(nVertLevels+1)) allocate(hTsum(nTracers, nVertLevels)) @@ -1099,7 +1096,7 @@ end subroutine cells_to_vertices_1dfield_using_kiteAreas !> !> All options are adjusted by the enhancement factor (which defaults to 1.0). !----------------------------------------------------------------------- - subroutine calculate_flowParamA(meshLIPool, temperature, thickness, flowParamA, err) + subroutine calculate_flowParamA(meshPool, temperature, thickness, flowParamA, err) use mpas_constants, only: gravity use li_constants, only: idealGasConstant @@ -1110,7 +1107,7 @@ subroutine calculate_flowParamA(meshLIPool, temperature, thickness, flowParamA, !----------------------------------------------------------------- type (mpas_pool_type), intent(in) :: & - meshLIPool !< Input: mesh information + meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:), intent(in) :: & temperature !< Input: temperature real (kind=RKIND), dimension(:), intent(in) :: & @@ -1150,10 +1147,10 @@ subroutine calculate_flowParamA(meshLIPool, temperature, thickness, flowParamA, err_tmp = 0 - call mpas_pool_get_dimension(meshLIPool, 'nCells', nCells) - call mpas_pool_get_dimension(meshLIPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - call mpas_pool_get_array(meshLIPool, 'layerCenterSigma', layerCenterSigma) + call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) call mpas_pool_get_config(liConfigs, 'config_flowParamA_calculation', config_flowParamA_calculation) call mpas_pool_get_config(liConfigs, 'config_enhancementFactor', config_enhancementFactor) diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index 2339d98943..9df8ffb45b 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -710,7 +710,6 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! !----------------------------------------------------------------- type (mpas_pool_type), pointer :: meshPool - type (mpas_pool_type), pointer :: meshLIPool type (mpas_pool_type), pointer :: geometryPool integer, dimension(:), pointer :: vertexMask character (len=StrKIND), pointer :: xtime @@ -724,7 +723,6 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! Get pool stuff call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'meshLI', meshLIPool) call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_config(liConfigs, 'config_do_velocity_reconstruction_for_external_dycore', config_do_velocity_reconstruction_for_external_dycore) @@ -740,10 +738,10 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! === ! === Call init routines === ! === - call li_setup_vertical_grid(meshLIPool, err_tmp) + call li_setup_vertical_grid(meshPool, err_tmp) err = ior(err, err_tmp) - call li_setup_sign_and_index_fields(meshPool, meshLIPool) + call li_setup_sign_and_index_fields(meshPool) ! This was needed to init FCT once. !!! ! Init for FCT tracer advection @@ -767,7 +765,7 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) endif ! Assign initial time stamp - call mpas_pool_get_array(meshLIPool, 'xtime', xtime) + call mpas_pool_get_array(meshPool, 'xtime', xtime) xtime = startTimeStamp ! Mask init identifies initial ice extent diff --git a/src/core_landice/mpas_li_setup.F b/src/core_landice/mpas_li_setup.F index b4b07f4e0a..6caba6258c 100644 --- a/src/core_landice/mpas_li_setup.F +++ b/src/core_landice/mpas_li_setup.F @@ -123,7 +123,7 @@ end subroutine li_setup_config_options ! !----------------------------------------------------------------------- - subroutine li_setup_vertical_grid(meshLIPool, err) + subroutine li_setup_vertical_grid(meshPool, err) !----------------------------------------------------------------- ! @@ -136,7 +136,7 @@ subroutine li_setup_vertical_grid(meshLIPool, err) ! input/output variables ! !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: meshLIPool !< Input/Output: meshLI object + type (mpas_pool_type), intent(inout) :: meshPool !< Input/Output: mesh object !----------------------------------------------------------------- ! @@ -159,11 +159,11 @@ subroutine li_setup_vertical_grid(meshLIPool, err) real (kind=RKIND) :: fractionTotal ! Get pool stuff - call mpas_pool_get_dimension(meshLIPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) ! layerThicknessFractions is provided by input - call mpas_pool_get_array(meshLIPool, 'layerThicknessFractions', layerThicknessFractions) - call mpas_pool_get_array(meshLIPool, 'layerCenterSigma', layerCenterSigma) - call mpas_pool_get_array(meshLIPool, 'layerInterfaceSigma', layerInterfaceSigma) + call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) + call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) ! Check that layerThicknessFractions are valid ! TODO - switch to having the user input the sigma levels instead??? @@ -205,7 +205,7 @@ end subroutine li_setup_vertical_grid !> This routine determines the sign for various mesh items. ! !----------------------------------------------------------------------- - subroutine li_setup_sign_and_index_fields(meshPool, meshLIPool) + subroutine li_setup_sign_and_index_fields(meshPool) !----------------------------------------------------------------- ! @@ -219,7 +219,6 @@ subroutine li_setup_sign_and_index_fields(meshPool, meshLIPool) ! input/output variables ! !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: meshLIPool !< Input/Output: meshLI object !----------------------------------------------------------------- ! @@ -245,7 +244,7 @@ subroutine li_setup_sign_and_index_fields(meshPool, meshLIPool) call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(meshLIPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) edgeSignOnCell = 0.0_RKIND !edgeSignOnVertex = 0.0_RKIND diff --git a/src/core_landice/mpas_li_sia.F b/src/core_landice/mpas_li_sia.F index 747381bc71..f987febda2 100644 --- a/src/core_landice/mpas_li_sia.F +++ b/src/core_landice/mpas_li_sia.F @@ -154,7 +154,6 @@ subroutine li_sia_block_init(block, err) ! !----------------------------------------------------------------- type (mpas_pool_type), pointer :: meshPool - type (mpas_pool_type), pointer :: meshLIPool type (mpas_pool_type), pointer :: scratchPool integer :: iCell, iLevel, i, iVertex, err_tmp integer, pointer :: nVertices @@ -169,10 +168,9 @@ subroutine li_sia_block_init(block, err) err_tmp = 0 call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'meshLI', meshLIPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) - call mpas_pool_get_array(meshLIPool, 'baryCellsOnVertex', baryCellsOnVertex) - call mpas_pool_get_array(meshLIPool, 'baryWeightsOnVertex', baryWeightsOnVertex) + call mpas_pool_get_array(meshPool, 'baryCellsOnVertex', baryCellsOnVertex) + call mpas_pool_get_array(meshPool, 'baryWeightsOnVertex', baryWeightsOnVertex) call mpas_pool_get_array(meshPool, 'xVertex', xVertex) call mpas_pool_get_array(meshPool, 'yVertex', yVertex) call mpas_pool_get_array(meshPool, 'zVertex', zVertex) @@ -217,7 +215,7 @@ end subroutine li_sia_block_init !> on an edge using the average of the two neighboring cells (2nd order). ! !----------------------------------------------------------------------- - subroutine li_sia_solve(meshPool, meshLIPool, geometryPool, timeLevel, velocityPool, err) + subroutine li_sia_solve(meshPool, geometryPool, timeLevel, velocityPool, err) use mpas_constants, only: gravity !----------------------------------------------------------------- @@ -229,9 +227,6 @@ subroutine li_sia_solve(meshPool, meshLIPool, geometryPool, timeLevel, velocityP type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information - type (mpas_pool_type), intent(in) :: & - meshLIPool !< Input: LI mesh information - type (mpas_pool_type), intent(in) :: & geometryPool !< Input: geometry information @@ -283,7 +278,7 @@ subroutine li_sia_solve(meshPool, meshLIPool, geometryPool, timeLevel, velocityP call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(meshLIPool, 'layerInterfaceSigma', layerInterfaceSigma) + call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) call mpas_pool_get_array(velocityPool, 'flowParamA', flowParamA, timeLevel=timeLevel) diff --git a/src/core_landice/mpas_li_statistics.F b/src/core_landice/mpas_li_statistics.F index b9f3a1c96d..251554ad9a 100644 --- a/src/core_landice/mpas_li_statistics.F +++ b/src/core_landice/mpas_li_statistics.F @@ -86,7 +86,6 @@ subroutine li_compute_statistics(domain, itimestep) ! pools type (mpas_pool_type), pointer :: meshPool - type (mpas_pool_type), pointer :: meshLIPool type (mpas_pool_type), pointer :: geometryPool type (mpas_pool_type), pointer :: velocityPool type (mpas_pool_type), pointer :: thermalPool @@ -208,7 +207,6 @@ subroutine li_compute_statistics(domain, itimestep) ! pools call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'meshLI', meshLIPool) call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) call mpas_pool_get_subpool(block % structs, 'thermal', thermalPool) @@ -227,8 +225,8 @@ subroutine li_compute_statistics(domain, itimestep) call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) ! LI mesh arrays - call mpas_pool_get_array(meshLIPool, 'xtime', xtime) - call mpas_pool_get_array(meshLIPool, 'layerCenterSigma', layerCenterSigma) + call mpas_pool_get_array(meshPool, 'xtime', xtime) + call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) ! Geometry arrays call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) diff --git a/src/core_landice/mpas_li_tendency.F b/src/core_landice/mpas_li_tendency.F index 219d419d01..ffff643fb8 100644 --- a/src/core_landice/mpas_li_tendency.F +++ b/src/core_landice/mpas_li_tendency.F @@ -574,7 +574,7 @@ end subroutine li_apply_calving !> results. ! !----------------------------------------------------------------------- - subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknessEdge, edgeMask, tend, dt, MinOfMaxAllowableDt, err)!{{{ + subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknessEdge, edgeMask, tend, dt, MinOfMaxAllowableDt, err) use mpas_timekeeping diff --git a/src/core_landice/mpas_li_time_integration.F b/src/core_landice/mpas_li_time_integration.F index f06bfaf572..a1c680825c 100644 --- a/src/core_landice/mpas_li_time_integration.F +++ b/src/core_landice/mpas_li_time_integration.F @@ -99,7 +99,7 @@ subroutine li_timestep(domain, dt, timeStamp, err) ! !----------------------------------------------------------------- type (block_type), pointer :: block - type (mpas_pool_type), pointer :: meshLIPool + type (mpas_pool_type), pointer :: meshPool character (len=StrKIND), pointer :: xtime character (len=StrKIND), pointer :: config_time_integration integer :: err_tmp @@ -126,8 +126,8 @@ subroutine li_timestep(domain, dt, timeStamp, err) block => domain % blocklist do while (associated(block)) ! Assign the time stamp for this time step - call mpas_pool_get_subpool(block % structs, 'meshLI', meshLIPool) - call mpas_pool_get_array(meshLIPool, 'xtime', xtime) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_array(meshPool, 'xtime', xtime) xtime = timeStamp ! ! Abort the simulation if NaNs occur in the velocity field diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index aa18474e4f..9d53446404 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -343,7 +343,7 @@ subroutine update_prognostics(domain, deltat, err) !----------------------------------------------------------------- type (dm_info), pointer :: dminfo type (block_type), pointer :: block - type (mpas_pool_type), pointer :: meshLIPool, geometryPool, tendencyPool + type (mpas_pool_type), pointer :: meshPool, geometryPool, tendencyPool integer, pointer :: nCells logical, pointer :: config_print_thickness_advection_info @@ -361,11 +361,11 @@ subroutine update_prognostics(domain, deltat, err) block => domain % blocklist do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'meshLI', meshLIPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) call mpas_pool_get_subpool(block % structs, 'tendency', tendencyPool) - call mpas_pool_get_dimension(meshLIPool, 'nCells', nCells) - call mpas_pool_get_array(meshLIPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) ! State at time n call mpas_pool_get_array(geometryPool, 'layerThickness', layerThicknessOld, timeLevel=1) diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index 80d7434f61..d0659a1f62 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -213,7 +213,7 @@ end subroutine li_velocity_block_init !> This routine calls velocity solvers. ! !----------------------------------------------------------------------- - subroutine li_velocity_solve(meshPool, meshLIPool, geometryPool, thermalPool, velocityPool, timeLevel, err) + subroutine li_velocity_solve(meshPool, geometryPool, thermalPool, velocityPool, timeLevel, err) use li_mask @@ -226,9 +226,6 @@ subroutine li_velocity_solve(meshPool, meshLIPool, geometryPool, thermalPool, ve type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information - type (mpas_pool_type), intent(in) :: & - meshLIPool !< Input: meshLI information - type (mpas_pool_type), intent(in) :: & geometryPool !< Input: geometry information @@ -280,9 +277,9 @@ subroutine li_velocity_solve(meshPool, meshLIPool, geometryPool, thermalPool, ve case ('none') ! Do nothing case ('sia') - call li_sia_solve(meshPool, meshLIPool, geometryPool, timeLevel, velocityPool, err) + call li_sia_solve(meshPool, geometryPool, timeLevel, velocityPool, err) case ('L1L2', 'FO', 'Stokes') - call li_velocity_external_solve(meshPool, meshLIPool, geometryPool, thermalPool, velocityPool, timeLevel, err) + call li_velocity_external_solve(meshPool, geometryPool, thermalPool, velocityPool, timeLevel, err) case default write(stderrUnit,*) 'Error: ', trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index cec851cfb8..a4933c32c7 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -316,7 +316,7 @@ end subroutine li_velocity_external_block_init ! !----------------------------------------------------------------------- - subroutine li_velocity_external_solve(meshPool, meshLIPool, geometryPool, thermalPool, velocityPool, timeLevel, err) + subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, velocityPool, timeLevel, err) use li_mask @@ -329,9 +329,6 @@ subroutine li_velocity_external_solve(meshPool, meshLIPool, geometryPool, therma type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information - type (mpas_pool_type), intent(in) :: & - meshLIPool !< Input: meshLI information - type (mpas_pool_type), intent(in) :: & geometryPool !< Input: geometry information @@ -386,7 +383,7 @@ subroutine li_velocity_external_solve(meshPool, meshLIPool, geometryPool, therma call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) ! Mesh variables - call mpas_pool_get_array(meshLIPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) ! Geometry variables call mpas_pool_get_array(geometryPool, 'thickness', thickness, timeLevel=timeLevel) From 5a354d4218c4803064841c09b60877e106c90641 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Wed, 15 Apr 2015 11:36:32 -0600 Subject: [PATCH 0039/1724] LI: Reorganizing time levels Previously MPAS-LI had 2 time levels for all variables and used the convention that time level 2 was the new time level (to be solved) and time level 1 was the old time level. With the var_struct reorg in the previous commits, almost all variables now have 1 time level, and only a few variables that require a second time level have 2. Therefore, to minimize confusion, I have modified the code to use a new convention that time level 1 is always the *current* time to be solved, and time level 2, where present, is the old value of a variable. In other words, all calculations should be done on time level 1, unless an explicit need for the old value of a variable is needed. As part of this, I have removed the timeLevel argument from all subroutines - it should only ever be used explicitly to get a specific time level (current or old). --- src/core_landice/Registry.xml | 9 ++ src/core_landice/mpas_li_diagnostic_vars.F | 96 +++++++++---------- src/core_landice/mpas_li_mask.F | 7 +- src/core_landice/mpas_li_mpas_core.F | 49 ++++++---- src/core_landice/mpas_li_sia.F | 19 ++-- src/core_landice/mpas_li_tendency.F | 8 +- .../mpas_li_time_integration_fe.F | 8 +- src/core_landice/mpas_li_velocity.F | 12 +-- src/core_landice/mpas_li_velocity_external.F | 33 +++---- 9 files changed, 121 insertions(+), 120 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 062b4a54d0..3c4955910a 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -381,6 +381,15 @@ + + diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index cb43f3ebdf..855d97a3ef 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -70,12 +70,12 @@ module li_diagnostic_vars !> variables. This is done in 3 parts: !> 1. diagnostic solve part 1; 2. solve velocity; 3. diagnostic solve part 2 !> Note: If the velocity solver requires an initial guess, it will be taken -!> from the timeLevel argument. Therefore the normalVelocity in that time level +!> from the current value. Therefore the normalVelocity in that time level !> should be updated with the guess prior to calling this subroutine, if necessary. ! !----------------------------------------------------------------------- - subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) + subroutine li_calculate_diagnostic_vars(domain, solveVelo, err) use mpas_vector_reconstruction @@ -84,7 +84,6 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) ! input variables ! !----------------------------------------------------------------- - integer, intent(in) :: timeLevel !< Input: Time level on which to calculate diagnostic variables logical, intent(in) :: solveVelo !< Input: Whether or not to solve velocity !----------------------------------------------------------------- @@ -134,7 +133,7 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) ! === call mpas_timer_start("calc. diagnostic vars except vel") - call diagnostic_solve_before_velocity(domain, timeLevel, err_tmp) + call diagnostic_solve_before_velocity(domain, err_tmp) err = ior(err, err_tmp) call mpas_timer_stop("calc. diagnostic vars except vel") @@ -154,7 +153,7 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) call mpas_pool_get_subpool(block % structs, 'thermal', thermalPool) call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) - call li_velocity_solve(meshPool, geometryPool, thermalPool, velocityPool, timeLevel, err) ! ****** Calculate Velocity ****** + call li_velocity_solve(meshPool, geometryPool, thermalPool, velocityPool, err) ! ****** Calculate Velocity ****** err = ior(err, err_tmp) @@ -164,7 +163,7 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) ! update halos on velocity call mpas_timer_start("halo updates") call mpas_pool_get_subpool(domain % blocklist % structs, 'velocity', velocityPool) - call mpas_pool_get_field(velocityPool, 'normalVelocity', normalVelocityField, timeLevel=timeLevel) + call mpas_pool_get_field(velocityPool, 'normalVelocity', normalVelocityField) call mpas_dmpar_exch_halo_field(normalVelocityField) call mpas_timer_stop("halo updates") @@ -186,20 +185,20 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) call mpas_pool_get_dimension(meshPool, 'nVertInterfaces', nVertInterfaces) - call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'uReconstructY', uReconstructY, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'surfaceSpeed', surfaceSpeed, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'basalSpeed', basalSpeed, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX) + call mpas_pool_get_array(velocityPool, 'uReconstructY', uReconstructY) + call mpas_pool_get_array(velocityPool, 'surfaceSpeed', surfaceSpeed) + call mpas_pool_get_array(velocityPool, 'basalSpeed', basalSpeed) ! Native SIA dycore needs to have reconstructed velocities calculated. ! External dycores return their native velocities at cell center locations, ! but these can optionally be overwritten by reconstructed velocities for testing. if ( (trim(config_velocity_solver) == 'sia') .or. & config_do_velocity_reconstruction_for_external_dycore ) then - call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'uReconstructZ', uReconstructZ, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'uReconstructZonal', uReconstructZonal, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'uReconstructMeridional', uReconstructMeridional, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) + call mpas_pool_get_array(velocityPool, 'uReconstructZ', uReconstructZ) + call mpas_pool_get_array(velocityPool, 'uReconstructZonal', uReconstructZonal) + call mpas_pool_get_array(velocityPool, 'uReconstructMeridional', uReconstructMeridional) call mpas_reconstruct(meshPool, normalVelocity, & uReconstructX, uReconstructY, uReconstructZ, & @@ -219,7 +218,7 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) - call diagnostic_solve_after_velocity(meshPool, geometryPool, velocityPool, timeLevel, err_tmp) ! Some diagnostic variables require velocity to compute + call diagnostic_solve_after_velocity(meshPool, geometryPool, velocityPool, err_tmp) ! Some diagnostic variables require velocity to compute err = ior(err, err_tmp) block => block % next @@ -227,7 +226,7 @@ subroutine li_calculate_diagnostic_vars(domain, timeLevel, solveVelo, err) call mpas_timer_start("halo updates") call mpas_pool_get_subpool(domain % blocklist % structs, 'geometry', geometryPool) - call mpas_pool_get_field(geometryPool, 'layerThicknessEdge', layerThicknessEdgeField, timeLevel=timeLevel) + call mpas_pool_get_field(geometryPool, 'layerThicknessEdge', layerThicknessEdgeField) call mpas_dmpar_exch_halo_field(layerThicknessEdgeField) call mpas_timer_stop("halo updates") @@ -264,7 +263,7 @@ end subroutine li_calculate_diagnostic_vars !> that are needed before velocity is solved. ! !----------------------------------------------------------------------- - subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ + subroutine diagnostic_solve_before_velocity(domain, err)!{{{ use mpas_geometry_utils, only: mpas_cells_to_points_using_baryweights use mpas_vector_operations, only: mpas_tangential_vector_1d @@ -274,7 +273,6 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! input variables ! !----------------------------------------------------------------- - integer, intent(in) :: timeLevel !< Input: Time level on which to calculate diagnostic variables !----------------------------------------------------------------- ! @@ -343,7 +341,7 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) ! Calculate masks - needs to happen before calculating lower surface so we know where the ice is floating - call li_calculate_mask(meshPool, velocityPool, geometryPool, timeLevel, err_tmp) + call li_calculate_mask(meshPool, velocityPool, geometryPool, err_tmp) err = ior(err, err_tmp) @@ -353,9 +351,9 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! Update halos on masks - the outermost cells/edges/vertices may be wrong for mask components that need neighbor information call mpas_timer_start("halo updates") call mpas_pool_get_subpool(domain % blocklist % structs, 'geometry', geometryPool) - call mpas_pool_get_field(geometryPool, 'cellMask', cellMaskField, timeLevel=timeLevel) - call mpas_pool_get_field(geometryPool, 'edgeMask', edgeMaskField, timeLevel=timeLevel) - call mpas_pool_get_field(geometryPool, 'vertexMask', vertexMaskField, timeLevel=timeLevel) + call mpas_pool_get_field(geometryPool, 'cellMask', cellMaskField) + call mpas_pool_get_field(geometryPool, 'edgeMask', edgeMaskField) + call mpas_pool_get_field(geometryPool, 'vertexMask', vertexMaskField) call mpas_dmpar_exch_halo_field(cellMaskField) call mpas_dmpar_exch_halo_field(edgeMaskField) call mpas_dmpar_exch_halo_field(vertexMaskField) @@ -390,13 +388,13 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ call mpas_pool_get_config(liConfigs, 'config_ocean_density', config_ocean_density) call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) - call mpas_pool_get_array(geometryPool, 'cellMask', cellMask, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'thickness', thickness, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'lowerSurface', lowerSurface, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness, timeLevel=timeLevel) - call mpas_pool_get_array(thermalPool, 'tracers', tracers, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface) + call mpas_pool_get_array(geometryPool, 'lowerSurface', lowerSurface) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness) + call mpas_pool_get_array(thermalPool, 'tracers', tracers) call mpas_pool_get_dimension(thermalPool, 'index_temperature', index_temperature) call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) @@ -429,14 +427,14 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) - call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'slopeEdge', slopeEdge, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'normalSlopeEdge', normalSlopeEdge, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'tangentSlopeEdge', tangentSlopeEdge, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'upperSurfaceVertex', upperSurfaceVertex, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(geometryPool, 'slopeEdge', slopeEdge) + call mpas_pool_get_array(geometryPool, 'normalSlopeEdge', normalSlopeEdge) + call mpas_pool_get_array(geometryPool, 'tangentSlopeEdge', tangentSlopeEdge) + call mpas_pool_get_array(geometryPool, 'upperSurfaceVertex', upperSurfaceVertex) call mpas_pool_get_array(meshPool, 'baryCellsOnVertex', baryCellsOnVertex) call mpas_pool_get_array(meshPool, 'baryWeightsOnVertex', baryWeightsOnVertex) - call mpas_pool_get_array(velocityPool, 'flowParamA', flowParamA, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'flowParamA', flowParamA) ! Calculate flowA call calculate_flowParamA(meshPool, tracers(index_temperature,:,:), thickness, flowParamA, err_tmp) @@ -500,9 +498,9 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! This information is only needed by external dycores. if (config_velocity_solver /= 'sia') then ! The interface expects an array where 1's are floating edges and 0's are non-floating edges. - call mpas_pool_get_array(velocityPool, 'floatingEdges', floatingEdges, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'floatingEdges', floatingEdges) floatingEdges = li_mask_is_floating_ice_int(edgeMask) - call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask) call li_calculate_extrapolate_floating_edgemask(meshPool, vertexMask, floatingEdges) end if @@ -514,7 +512,7 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! Update halos on masks - the outermost cells/edges/vertices may be wrong for mask components that need neighbor information call mpas_timer_start("halo updates") call mpas_pool_get_subpool(domain % blocklist % structs, 'velocity', velocityPool) - call mpas_pool_get_field(velocityPool, 'floatingEdges', floatingEdgesField, timeLevel=timeLevel) + call mpas_pool_get_field(velocityPool, 'floatingEdges', floatingEdgesField) call mpas_dmpar_exch_halo_field(floatingEdgesField) call mpas_timer_stop("halo updates") endif @@ -532,8 +530,8 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ ! Determine if the vertex mask changed during this time step for this block (needed for external dycores) ! TODO: there may be some aspects of the mask that are ok change for external dycores, but for now just check the whole thing. ! TODO: if we ever have more than one time level, then this logic should be revisited. - call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMaskOld, timeLevel=1) - call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMaskNew, timeLevel=2) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMaskOld, timeLevel=2) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMaskNew, timeLevel=1) if ( sum(li_mask_is_dynamic_ice_int(vertexMaskNew) - li_mask_is_dynamic_ice_int(vertexMaskOld)) /= 0 ) then blockDynamicVertexMaskChanged = 1 else @@ -545,8 +543,8 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ !print *,'procVertexMaskChanged', procVertexMaskChanged ! Also check to see if the Dirichlet b.c. mask has changed - call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMaskOld, timeLevel=1) - call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMaskNew, timeLevel=2) + call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMaskOld, timeLevel=2) + call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMaskNew, timeLevel=1) if ( sum(dirichletVelocityMaskNew - dirichletVelocityMaskOld) /= 0 ) then blockDirichletMaskChanged = 1 else @@ -559,11 +557,11 @@ subroutine diagnostic_solve_before_velocity(domain, timeLevel, err)!{{{ end do ! Determine if the vertex mask has changed on any processor and store the value for later use (need to exit the block loop to do so) - call mpas_pool_get_array(velocityPool, 'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged) call mpas_dmpar_max_int(domain % dminfo, procDynamicVertexMaskChanged, anyDynamicVertexMaskChanged) !print *,'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged ! Do the same for the Dirichlet b.c. mask - call mpas_pool_get_array(velocityPool, 'dirichletMaskChanged', dirichletMaskChanged, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'dirichletMaskChanged', dirichletMaskChanged) call mpas_dmpar_max_int(domain % dminfo, procDirichletMaskChanged, dirichletMaskChanged) !print *,'dirichletMaskChanged', dirichletMaskChanged end if @@ -590,7 +588,7 @@ end subroutine diagnostic_solve_before_velocity !> This routine computes the diagnostic variables that require knowing velocity for land ice ! !----------------------------------------------------------------------- - subroutine diagnostic_solve_after_velocity(meshPool, geometryPool, velocityPool, timeLevel, err) + subroutine diagnostic_solve_after_velocity(meshPool, geometryPool, velocityPool, err) !----------------------------------------------------------------- ! @@ -603,8 +601,6 @@ subroutine diagnostic_solve_after_velocity(meshPool, geometryPool, velocityPool, type (mpas_pool_type), intent(in) :: & velocityPool !< Input: velocity information - integer, intent(in) :: timeLevel !< Input: Time level on which to calculate diagnostic variables - !----------------------------------------------------------------- ! ! input/output variables @@ -640,9 +636,9 @@ subroutine diagnostic_solve_after_velocity(meshPool, geometryPool, velocityPool, call mpas_pool_get_config(liConfigs, 'config_thickness_advection', config_thickness_advection) - call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'layerThicknessEdge', layerThicknessEdge, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness) + call mpas_pool_get_array(geometryPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) ! Calculate h_edge. This is used by both thickness and tracer advection on the following Forward Euler time step. ! Note: FO-Upwind thickness advection does not explicitly use h_edge but a FO h_edge is implied. diff --git a/src/core_landice/mpas_li_mask.F b/src/core_landice/mpas_li_mask.F index e437fa1d94..7dcd10f92d 100644 --- a/src/core_landice/mpas_li_mask.F +++ b/src/core_landice/mpas_li_mask.F @@ -188,7 +188,7 @@ end subroutine li_calculate_mask_init ! !----------------------------------------------------------------------- - subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, timeLevel, err) + subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) !----------------------------------------------------------------- ! @@ -202,9 +202,6 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, timeLevel, er type (mpas_pool_type), intent(inout) :: & velocityPool !< Input: velocity information - integer, intent(in) :: & - timeLevel !< Input: time level for which to calculate mask - !----------------------------------------------------------------- ! ! input/output variables @@ -256,7 +253,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, timeLevel, er call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) - call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask) call mpas_pool_get_array(geometryPool, 'thickness', thickness) call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) diff --git a/src/core_landice/mpas_li_mpas_core.F b/src/core_landice/mpas_li_mpas_core.F index 9df8ffb45b..39c22573e2 100644 --- a/src/core_landice/mpas_li_mpas_core.F +++ b/src/core_landice/mpas_li_mpas_core.F @@ -282,11 +282,18 @@ subroutine mpas_core_run(domain, stream_manager) solveVelo = .true. endif - call li_calculate_diagnostic_vars(domain, timeLevel=1, solveVelo=solveVelo, err=err_tmp) + call li_calculate_diagnostic_vars(domain, solveVelo=solveVelo, err=err_tmp) err = ior(err, err_tmp) call mpas_timer_stop("initial state calculation") + if (config_write_stats_on_startup) then + call mpas_timer_start("compute_statistics") + call li_compute_statistics(domain, 0) ! itimestep = 0 + ! (itimestep is initialized below) + call mpas_timer_stop("compute_statistics") + endif + ! === ! === Write Initial Output ! === @@ -298,21 +305,23 @@ subroutine mpas_core_run(domain, stream_manager) call mpas_timer_stop("write output") - if (config_write_stats_on_startup) then - call mpas_timer_start("compute_statistics") - call li_compute_statistics(domain, 0) ! itimestep = 0 - ! (itimestep is initialized below) - call mpas_timer_stop("compute_statistics") - endif + ! Move time level 1 fields (current values) into time level 2 (old values) for next time step + ! (for those fields with multiple time levels) + block => domain % blocklist + do while(associated(block)) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_shift_time_levels(geometryPool) + block => block % next + end do if (config_do_restart .and. (trim(config_velocity_solver) /= 'sia')) then ! On a restart with the HO dycore, we need to make sure the FEM mesh will be rebuilt ! on the first time step. Force this by setting the vertexMask at the end of the - ! initial time to garbage. (Do this after writing output.) + ! initial time to 0. (Do this after writing output.) block => domain % blocklist do while(associated(block)) call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) - call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel=1) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel=2) ! Get the old vertexMask vertexMask = 0 block => block % next end do @@ -372,14 +381,6 @@ subroutine mpas_core_run(domain, stream_manager) end if end if - ! Move time level 2 fields back into time level 1 for next time step - block => domain % blocklist - do while(associated(block)) - call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) - call mpas_pool_shift_time_levels(geometryPool) - block => block % next - end do - call mpas_timer_stop("time integration") ! === @@ -418,6 +419,14 @@ subroutine mpas_core_run(domain, stream_manager) err = ior(err, err_tmp) call mpas_timer_stop("write output") + ! Move time level 1 fields (current values) into time level 2 (old values) for next time step + ! (for those fields with multiple time levels) + block => domain % blocklist + do while(associated(block)) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_shift_time_levels(geometryPool) + block => block % next + end do ! === error check and exit call mpas_dmpar_max_int(domain % dminfo, err, globalErr) ! Find out if any blocks got an error @@ -731,9 +740,9 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! Copy data from first time level into all other time levels call mpas_pool_initialize_time_levels(geometryPool) - ! Initialize vertexMask on time level 2 to junk, so diagnostic_solve_before_velocity in li_diagnostic_vars says that the vertexMask has changed (needed by external dycore) + ! Initialize vertexMask on time level 2 to 0, so diagnostic_solve_before_velocity in li_diagnostic_vars says that the vertexMask has changed (needed by external dycore) call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel = 2) - vertexMask = -9999 + vertexMask = 0 ! === ! === Call init routines === @@ -772,8 +781,6 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) call li_calculate_mask_init(geometryPool, err=err_tmp) err = ior(err, err_tmp) - ! Make sure all time levels have a copy of the initial state - call mpas_pool_initialize_time_levels(geometryPool) ! === error check if (err > 0) then diff --git a/src/core_landice/mpas_li_sia.F b/src/core_landice/mpas_li_sia.F index f987febda2..19cb6b37bd 100644 --- a/src/core_landice/mpas_li_sia.F +++ b/src/core_landice/mpas_li_sia.F @@ -215,7 +215,7 @@ end subroutine li_sia_block_init !> on an edge using the average of the two neighboring cells (2nd order). ! !----------------------------------------------------------------------- - subroutine li_sia_solve(meshPool, geometryPool, timeLevel, velocityPool, err) + subroutine li_sia_solve(meshPool, geometryPool, velocityPool, err) use mpas_constants, only: gravity !----------------------------------------------------------------- @@ -230,9 +230,6 @@ subroutine li_sia_solve(meshPool, geometryPool, timeLevel, velocityPool, err) type (mpas_pool_type), intent(in) :: & geometryPool !< Input: geometry information - integer, intent(in) :: & - timeLevel !< Input: time level from which to calculate velocity - !----------------------------------------------------------------- ! ! input/output variables @@ -280,13 +277,13 @@ subroutine li_sia_solve(meshPool, geometryPool, timeLevel, velocityPool, err) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) - call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'flowParamA', flowParamA, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'thickness', thickness, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'cellMask', cellMask, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'slopeEdge', slopeEdge, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'normalSlopeEdge', normalSlopeEdge, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) + call mpas_pool_get_array(velocityPool, 'flowParamA', flowParamA) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(geometryPool, 'slopeEdge', slopeEdge) + call mpas_pool_get_array(geometryPool, 'normalSlopeEdge', normalSlopeEdge) ! Get parameters specified in the namelist diff --git a/src/core_landice/mpas_li_tendency.F b/src/core_landice/mpas_li_tendency.F index ffff643fb8..1fcdf4dbc4 100644 --- a/src/core_landice/mpas_li_tendency.F +++ b/src/core_landice/mpas_li_tendency.F @@ -139,10 +139,10 @@ subroutine li_tendency_thickness(meshPool, velocityPool, geometryPool, layerThic call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_array(geometryPool, 'sfcMassBal', sfcMassBal) ! Assuming tendency will always be calculated using time level 1! - call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity, timeLevel=1) - call mpas_pool_get_array(geometryPool, 'layerThicknessEdge', layerThicknessEdge, timeLevel=1) - call mpas_pool_get_array(geometryPool, 'cellMask', cellMask, timeLevel=1) - call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask, timeLevel=1) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) + call mpas_pool_get_array(geometryPool, 'layerThicknessEdge', layerThicknessEdge) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) !!! marineBasalMassBal => mesh % marineBasalMassBal % array !!! iceArea => state % iceArea % array !!! areaCell => mesh % areaCell % array diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index 9d53446404..1588609b4f 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -128,7 +128,7 @@ subroutine li_time_integrator_forwardeuler(domain, deltat, err) ! If needed, that guess should be inserted into normalVelocity ! in time level 2 before calling li_calculate_diagnostic_vars. - call li_calculate_diagnostic_vars(domain, timeLevel=2, solveVelo=.true., err=err_tmp) + call li_calculate_diagnostic_vars(domain, solveVelo=.true., err=err_tmp) err = ior(err, err_tmp) @@ -368,13 +368,13 @@ subroutine update_prognostics(domain, deltat, err) call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) ! State at time n - call mpas_pool_get_array(geometryPool, 'layerThickness', layerThicknessOld, timeLevel=1) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThicknessOld, timeLevel=2) !!! tracersOld => stateOld % tracers % array !!! cellMaskOld => stateOld % cellMask % array ! State at time n+1 (advanced by dt by Forward Euler) - call mpas_pool_get_array(geometryPool, 'layerThickness', layerThicknessNew, timeLevel=2) - call mpas_pool_get_array(geometryPool, 'thickness', thicknessNew, timeLevel=2) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThicknessNew, timeLevel=1) + call mpas_pool_get_array(geometryPool, 'thickness', thicknessNew, timeLevel=1) !!! tracersNew => stateNew % tracers % array ! Tendencies diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index d0659a1f62..3c34519258 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -213,7 +213,7 @@ end subroutine li_velocity_block_init !> This routine calls velocity solvers. ! !----------------------------------------------------------------------- - subroutine li_velocity_solve(meshPool, geometryPool, thermalPool, velocityPool, timeLevel, err) + subroutine li_velocity_solve(meshPool, geometryPool, thermalPool, velocityPool, err) use li_mask @@ -232,8 +232,6 @@ subroutine li_velocity_solve(meshPool, geometryPool, thermalPool, velocityPool, type (mpas_pool_type), intent(in) :: & thermalPool !< Input: thermal information - integer, intent(in) :: timeLevel !< Input: Time level on which to calculate diagnostic variables - !----------------------------------------------------------------- ! ! input/output variables @@ -269,17 +267,17 @@ subroutine li_velocity_solve(meshPool, geometryPool, thermalPool, velocityPool, ! Get variables from pools call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) select case (config_velocity_solver) case ('none') ! Do nothing case ('sia') - call li_sia_solve(meshPool, geometryPool, timeLevel, velocityPool, err) + call li_sia_solve(meshPool, geometryPool, velocityPool, err) case ('L1L2', 'FO', 'Stokes') - call li_velocity_external_solve(meshPool, geometryPool, thermalPool, velocityPool, timeLevel, err) + call li_velocity_external_solve(meshPool, geometryPool, thermalPool, velocityPool, err) case default write(stderrUnit,*) 'Error: ', trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index a4933c32c7..728a4422cb 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -316,7 +316,7 @@ end subroutine li_velocity_external_block_init ! !----------------------------------------------------------------------- - subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, velocityPool, timeLevel, err) + subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, velocityPool, err) use li_mask @@ -335,9 +335,6 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc type (mpas_pool_type), intent(in) :: & thermalPool !< Input: thermal information - integer, intent(in) :: & - timeLevel !< Input: time level from which to calculate velocity - !----------------------------------------------------------------- ! ! input/output variables @@ -386,26 +383,26 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) ! Geometry variables - call mpas_pool_get_array(geometryPool, 'thickness', thickness, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'lowerSurface', lowerSurface, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel=timeLevel) - call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask, timeLevel=timeLevel) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'lowerSurface', lowerSurface) + call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) ! Thermal variables - call mpas_pool_get_array(thermalPool, 'tracers', tracers, timeLevel=timeLevel) + call mpas_pool_get_array(thermalPool, 'tracers', tracers) call mpas_pool_get_dimension(thermalPool, 'index_temperature', index_temperature) ! Velocity variables - call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'uReconstructY', uReconstructY, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'uReconstructZ', uReconstructZ, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) + call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX) + call mpas_pool_get_array(velocityPool, 'uReconstructY', uReconstructY) + call mpas_pool_get_array(velocityPool, 'uReconstructZ', uReconstructZ) call mpas_pool_get_array(velocityPool, 'beta', beta) - call mpas_pool_get_array(velocityPool, 'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'dirichletMaskChanged', dirichletMaskChanged, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel=timeLevel) - call mpas_pool_get_array(velocityPool, 'floatingEdges', floatingEdges, timeLevel=timeLevel) + call mpas_pool_get_array(velocityPool, 'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged) + call mpas_pool_get_array(velocityPool, 'dirichletMaskChanged', dirichletMaskChanged) + call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMask) + call mpas_pool_get_array(velocityPool, 'floatingEdges', floatingEdges) if (maxval(thickness) < config_dynamic_thickness) then From 3218facb73383de8f36705cfe946e4925ce3c2da Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 16 Apr 2015 10:44:38 -0600 Subject: [PATCH 0040/1724] LI: Creating adaptive timestepping This commit includes the initial work to get a basic adaptive timestep for the Forward Euler time integrator. The adaptive time step is simply a specified fraction of the CFL-limited timestep. Four new namelist options are introduced: config_adaptive_timestep config_min_adaptive_timestep config_max_adaptive_timestep config_adaptive_timestep_CFL_fraction (see Registry for details on their usage). This required reorganizing some of the timekeeping steps in mpas_core_run and adding some timekeeping operations to mpas_li_time_integration. That is where the time step gets set in the clock object. I have also removed the subroutine 'landice_timestep' from module mpas_core because it seemed like an unnecessary wrapper to li_timestep. Note that currently there is no adjustment of the time step to hit the specified output interval - you just get output on the first time level greater than the output interval. --- src/core_landice/Registry.xml | 16 +++ src/core_landice/mpas_li_core.F | 120 +++--------------- src/core_landice/mpas_li_tendency.F | 18 --- src/core_landice/mpas_li_time_integration.F | 66 +++++++++- .../mpas_li_time_integration_fe.F | 108 ++++++++++++++-- 5 files changed, 191 insertions(+), 137 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 3b388f80e0..3f791a81c9 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -124,6 +124,22 @@ description="Time integration method." possible_values="'forward_euler'" /> + + + + diff --git a/src/core_landice/mpas_li_core.F b/src/core_landice/mpas_li_core.F index 6bafeac4ac..80c263871b 100644 --- a/src/core_landice/mpas_li_core.F +++ b/src/core_landice/mpas_li_core.F @@ -13,7 +13,6 @@ module li_core implicit none private - type (MPAS_Clock_type), pointer :: clock !-------------------------------------------------------------------- ! @@ -109,15 +108,10 @@ function li_core_init(domain, startTimeStamp) result(err) call li_setup_config_options( domain, err_tmp ) err = ior(err, err_tmp) - ! - ! Set "local" clock to point to the clock contained in the domain type - ! - clock => domain % clock - ! ! Set startTimeStamp based on the start time of the simulation clock ! - startTime = mpas_get_clock_time(clock, MPAS_START_TIME, err_tmp) + startTime = mpas_get_clock_time(domain % clock, MPAS_START_TIME, err_tmp) call mpas_get_time(startTime, dateTimeString=startTimeStamp) err = ior(err, err_tmp) @@ -194,10 +188,11 @@ function li_core_run(domain) result(err) use li_diagnostic_vars use li_setup use li_statistics + use li_time_integration use mpas_io_streams, only: MPAS_STREAM_LATEST_BEFORE implicit none - + !----------------------------------------------------------------- ! ! input variables @@ -229,13 +224,12 @@ function li_core_run(domain) result(err) logical, pointer :: config_do_restart, config_write_output_on_startup, config_write_stats_on_startup character(len=StrKIND), pointer :: config_restart_timestamp_name character(len=StrKIND), pointer :: config_velocity_solver - + ! Variables needed for printing timestamps type (MPAS_Time_Type) :: currTime character(len=StrKIND) :: timeStamp + integer :: err, err_tmp, globalErr logical :: solveVelo - type (MPAS_TimeInterval_type) :: timeStepInterval !< time step as an interval - real (kind=RKIND) :: dtSeconds !< time step in seconds integer, dimension(:), pointer :: vertexMask @@ -253,10 +247,10 @@ function li_core_run(domain) result(err) call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_timer_start("land ice core run") - currTime = mpas_get_clock_time(clock, MPAS_NOW, err_tmp) + currTime = mpas_get_clock_time(domain % clock, MPAS_NOW, err_tmp) err = ior(err, err_tmp) call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=err_tmp) - err = ior(err, err_tmp) + err = ior(err, err_tmp) write(stderrUnit,*) 'Initial timestep ', trim(timeStamp) write(stdoutUnit,*) 'Initial timestep ', trim(timeStamp) @@ -337,36 +331,19 @@ function li_core_run(domain) result(err) ! === ! === Time step loop ! === - do while (.not. mpas_is_clock_stop_time(clock)) + do while (.not. mpas_is_clock_stop_time(domain % clock)) itimestep = itimestep + 1 + write(stderrUnit,*) 'Starting timestep number ', iTimeStep + write(stdoutUnit,*) 'Starting timestep number ', iTimeStep - ! Get the interval at this point in time - currently this does not change during the simulation, but re-calculating it explicitly for generality - timeStepInterval = mpas_get_clock_timestep(clock, ierr=err_tmp) - err = ior(err,err_tmp) - ! Convert the clock's time interval into a dt in seconds to be used by the time stepper, using the currTime as the start time for this interval. - ! (We want to do this conversion before advancing the clock because the dt in seconds may change - ! as the base time changes, and we want the old time as the base time. - ! For example, the number of seconds in a year will be longer in a leap year.) - call mpas_get_timeInterval(timeStepInterval, StartTimeIn=currTime, dt=dtSeconds, ierr=err_tmp) - err = ior(err,err_tmp) - - call mpas_advance_clock(clock) - - currTime = mpas_get_clock_time(clock, MPAS_NOW, err_tmp) - call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=err_tmp) - err = ior(err, err_tmp) - write(stderrUnit,*) 'Doing timestep ', trim(timeStamp) - write(stdoutUnit,*) 'Doing timestep ', trim(timeStamp) - - !write(stdoutUnit,*) ' dt (s) = ', dtSeconds ! === ! === Perform Timestep ! === call mpas_timer_start("time integration") - call landice_timestep(domain, itimestep, dtSeconds, timeStamp, err_tmp) + call li_timestep(domain, err_tmp) err = ior(err,err_tmp) ! Write statistics at designated interval @@ -402,6 +379,12 @@ function li_core_run(domain) result(err) call mpas_timer_start("write output") ! Update the restart_timestamp file with the new time, if needed. if ( mpas_stream_mgr_ringing_alarms(domain % streamManager, streamID='restart', direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) ) then + ! Need updated timestamp for writing restart timestamp + currTime = mpas_get_clock_time(domain % clock, MPAS_NOW, err_tmp) + err = ior(err, err_tmp) + call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=err_tmp) + err = ior(err, err_tmp) + ! write the timestamp to file open(22, file=config_restart_timestamp_name, form='formatted', status='replace') write(22, *) timeStamp close(22) @@ -491,7 +474,7 @@ function li_core_finalize(domain) result(err) call li_velocity_finalize(domain, err_tmp) err = ior(err, err_tmp) - call mpas_destroy_clock(clock, err_tmp) + call mpas_destroy_clock(domain % clock, err_tmp) err = ior(err, err_tmp) call mpas_decomp_destroy_decomp_list(domain % decompositions) @@ -570,7 +553,6 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) character (len=StrKIND), pointer :: xtime character (len=StrKIND), pointer :: config_velocity_solver logical, pointer :: config_do_velocity_reconstruction_for_external_dycore - type (MPAS_Time_Type) :: currTime integer :: err, err_tmp err = 0 @@ -640,71 +622,7 @@ end subroutine landice_init_block !*********************************************************************** ! -! routine landice_timestep -! -!> \brief Performs a time step -!> \author Matt Hoffman -!> \date 11 September 2013 -!> \details -!> This routine performs a time step for the land ice core. -! -!----------------------------------------------------------------------- - subroutine landice_timestep(domain, itimestep, dt, timeStamp, err) - - use mpas_derived_types - use li_time_integration - use mpas_timer - - implicit none - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - integer, intent(in) :: itimestep !< Input: time step number - real (kind=RKIND), intent(in) :: dt !< Input: time step, in seconds - character(len=*), intent(in) :: timeStamp !< Input: time stamp of current time step - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain !< Input/output: Domain - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - type (block_type), pointer :: block_ptr - integer :: err_tmp - - err = 0 - err_tmp = 0 - - call li_timestep(domain, dt, timeStamp, err_tmp) - err = ior(err,err_tmp) - - ! === error check - if (err > 0) then - write (stderrUnit,*) "An error has occurred in mpas_timestep." - endif - - end subroutine landice_timestep - - -!*********************************************************************** -! -! routine li_simulation_clock_init +! routine simulation_clock_init ! !> \brief Initializes the simulation clock !> \author ?? diff --git a/src/core_landice/mpas_li_tendency.F b/src/core_landice/mpas_li_tendency.F index d041614171..ae04c46bc4 100644 --- a/src/core_landice/mpas_li_tendency.F +++ b/src/core_landice/mpas_li_tendency.F @@ -630,8 +630,6 @@ subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknes logical, pointer :: config_print_thickness_advection_info real (kind=RKIND) :: invAreaCell, flux, maxAllowableDt, layerNormalVelocity integer :: iEdge, iCell, i, k - type (MPAS_TimeInterval_type) :: allowableDtMinInterval - character (len=StrKIND) :: allowableDtMinString real (kind=RKIND) :: bigNumber = 1.0e16_RKIND ! This is ~300 million years in seconds, but it is small enough not too overflow integer :: err_tmp @@ -648,7 +646,6 @@ subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknes call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) call mpas_pool_get_array(meshPool, 'areaCell', areaCell) - call mpas_pool_get_config(liConfigs, 'config_print_thickness_advection_info', config_print_thickness_advection_info) MinOfMaxAllowableDt = bigNumber @@ -679,21 +676,6 @@ subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknes end do end do - ! Build a time string of the maximum allowable dt calculated - ! (We only need this if a CFL violation occurred or config_print_thickness_advection_info is true) - call mpas_set_timeInterval(allowableDtMinInterval, dt=MinOfMaxAllowableDt, ierr=err_tmp) - err = ior(err,err_tmp) - call mpas_get_timeInterval(allowableDtMinInterval, timeString=allowableDtMinString, ierr=err_tmp) - err = ior(err,err_tmp) - - if (err > 0) then - write(stderrUnit,*) 'CFL violation on this processor on ', err, ' level-edges! Maximum allowable time step for this processor is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) - err = 1 - endif - - if (config_print_thickness_advection_info) then - write(stdoutUnit,*) ' Maximum allowable time step on THIS processor is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) - endif ! Optional check for mass conservation !tendVolSum = 0.0_RKIND diff --git a/src/core_landice/mpas_li_time_integration.F b/src/core_landice/mpas_li_time_integration.F index ec4f5bd556..25baf15e68 100644 --- a/src/core_landice/mpas_li_time_integration.F +++ b/src/core_landice/mpas_li_time_integration.F @@ -26,6 +26,7 @@ module li_time_integration use mpas_configure use mpas_constants use mpas_dmpar + use mpas_timekeeping use li_time_integration_fe use li_setup @@ -70,15 +71,13 @@ module li_time_integration !> Output: domain - upon exit, time level 2 contains !> model state advanced forward in time by dt seconds !----------------------------------------------------------------------- - subroutine li_timestep(domain, dt, timeStamp, err) + subroutine li_timestep(domain, err) !----------------------------------------------------------------- ! ! input variables ! !----------------------------------------------------------------- - real (kind=RKIND), intent(in) :: dt !< Input: time step - character(len=*), intent(in) :: timeStamp !< Input: current time stamp !----------------------------------------------------------------- ! @@ -103,17 +102,49 @@ subroutine li_timestep(domain, dt, timeStamp, err) type (mpas_pool_type), pointer :: meshPool character (len=StrKIND), pointer :: xtime character (len=StrKIND), pointer :: config_time_integration + logical, pointer :: config_adaptive_timestep + type (MPAS_TimeInterval_type) :: timeStepInterval !< the current time step as an interval + real (kind=RKIND) :: dtSeconds !< the current time step in seconds + type (MPAS_Time_Type) :: currTime !< current time as time type + character(len=StrKIND) :: timeStamp !< current time as a string integer :: err_tmp err = 0 err_tmp = 0 call mpas_pool_get_config(liConfigs, 'config_time_integration', config_time_integration) + call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep', config_adaptive_timestep) + + currTime = mpas_get_clock_time(domain % clock, MPAS_NOW, err_tmp) + call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=err_tmp) + + ! === + ! === Non-adpative timestep: Get dt in seconds + ! === + if (.not. config_adaptive_timestep) then + ! Get the interval at this point in time - will be fixed for nonadaptive timestep, but need to get it out of the clock + timeStepInterval = mpas_get_clock_timestep(domain % clock, ierr=err_tmp) + err = ior(err,err_tmp) + ! Convert the clock's time interval into a dt in seconds to be used by the time stepper, + ! using the currTime as the start time for this interval. + ! (We want to do this conversion before doint the timestep and advancing the clock because the dt + ! in seconds may change as the base time changes, and we want the old time as the base time. + ! For example, the number of seconds in a year will be longer in a leap year. + ! That is why nonadaptive timesteps have to be handled before the timestep, while + ! adaptive timesteps are handled after the timestep. + ! It may be possible to have them handled in the same place within li_tendency.F if we want to embed it that deeply.) + call mpas_get_timeInterval(timeStepInterval, StartTimeIn=currTime, dt=dtSeconds, ierr=err_tmp) + err = ior(err,err_tmp) + endif + + ! === + ! === Perform timestep + ! === !write(stdoutUnit,*) 'Using ', trim(config_time_integration), ' time integration.' select case (config_time_integration) case ('forward_euler') - call li_time_integrator_forwardeuler(domain, dt, err_tmp) + call li_time_integrator_forwardeuler(domain, dtSeconds, err_tmp) case ('rk4') write(stderrUnit,*) trim(config_time_integration), ' is not currently supported.' call mpas_dmpar_abort(domain % dminfo) @@ -124,6 +155,33 @@ subroutine li_timestep(domain, dt, timeStamp, err) end select err = ior(err,err_tmp) + + ! === + ! === Adaptive timestep: update clock information + ! === + ! Set time step in clock object since the time step could have changed + if (config_adaptive_timestep) then + ! convert dtSeconds to timeInterval type + call mpas_set_timeInterval(timeStepInterval, dt=dtSeconds, ierr=err_tmp) + err = ior(err,err_tmp) + ! update the clock with the timeInterval + call mpas_set_clock_timestep(domain % clock, timeStepInterval, err_tmp) + err = ior(err,err_tmp) + endif + + ! === + ! === Update clock information + ! === + ! Advance clock - needed to wait until after time step is completed in case the dt has changed! + call mpas_advance_clock(domain % clock) + currTime = mpas_get_clock_time(domain % clock, MPAS_NOW, err_tmp) + call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=err_tmp) + err = ior(err, err_tmp) + write(stderrUnit,*) ' Completed timestep. New time is: ', trim(timeStamp) + write(stdoutUnit,*) ' Completed timestep. New time is: ', trim(timeStamp) + !write(stdoutUnit,*) ' dt (s) = ', dtSeconds + + block => domain % blocklist do while (associated(block)) ! Assign the time stamp for this time step diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index 21b13b3a07..7853933f0f 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -165,14 +165,14 @@ end subroutine li_time_integrator_forwardeuler ! !----------------------------------------------------------------------- - subroutine calculate_tendencies(domain, deltat, err) + subroutine calculate_tendencies(domain, dtSeconds, err) use mpas_timekeeping !----------------------------------------------------------------- ! input variables !----------------------------------------------------------------- - real (kind=RKIND) :: deltat + real (kind=RKIND) :: dtSeconds !----------------------------------------------------------------- ! input/output variables @@ -196,11 +196,12 @@ subroutine calculate_tendencies(domain, deltat, err) real (kind=RKIND), dimension(:,:), pointer :: layerThickness_tend type (field2DReal), pointer :: layerThickness_tend_field - integer :: allowableDtProcNumber, allowableDtMinProcNumber - real (kind=RKIND) :: allowableDt, allowableDtMin logical, pointer :: config_print_thickness_advection_info - type (MPAS_TimeInterval_type) :: allowableDtMinStringInterval - character (len=StrKIND) :: allowableDtMinString + logical, pointer :: config_adaptive_timestep + integer :: allowableDtProcNumber + real (kind=RKIND) :: allowableDt, allowableDtOnProc, allowableDtAllProcs + type (MPAS_TimeInterval_type) :: allowableDtOnProcInterval, allowableDtAllProcsStringInterval + character (len=StrKIND) :: allowableDtOnProcString, allowableDtAllProcsString integer :: err_tmp integer :: y, m, d, hh, mm, ss @@ -208,12 +209,14 @@ subroutine calculate_tendencies(domain, deltat, err) err = 0 call mpas_pool_get_config(liConfigs, 'config_print_thickness_advection_info', config_print_thickness_advection_info) + call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep', config_adaptive_timestep) dminfo => domain % dminfo ! === ! === Thickness tendencies ! === + allowableDtOnProc = 1.0e36 ! set to large number block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) @@ -223,8 +226,9 @@ subroutine calculate_tendencies(domain, deltat, err) call mpas_pool_get_array(tendencyPool, 'layerThickness', layerThickness_tend) ! Calculate thickness tendency using state at time n ========= - call li_tendency_thickness(meshPool, velocityPool, geometryPool, layerThickness_tend, deltat, dminfo, allowableDt, err_tmp) + call li_tendency_thickness(meshPool, velocityPool, geometryPool, layerThickness_tend, dtSeconds, dminfo, allowableDt, err_tmp) err = ior(err,err_tmp) + allowableDtOnProc = min(allowableDtOnProc, allowableDt) block => block % next end do @@ -237,25 +241,51 @@ subroutine calculate_tendencies(domain, deltat, err) call mpas_dmpar_exch_halo_field(layerThickness_tend_field) call mpas_timer_stop("halo updates") + + ! Build a time string of the maximum allowable dt calculated + ! (We only need this if a CFL violation occurred or config_print_thickness_advection_info is true) + call mpas_set_timeInterval(allowableDtOnProcInterval, dt=allowableDtOnProc, ierr=err_tmp) + err = ior(err,err_tmp) + call mpas_get_timeInterval(allowableDtOnProcInterval, timeString=allowableDtOnProcString, ierr=err_tmp) + err = ior(err,err_tmp) + if (dtSeconds > allowableDtOnProc) then + write(stderrUnit,*) 'ERROR: CFL violation on this processor. Maximum allowable time step for this processor is (Days_hhh:mmm:sss): ' // trim(allowableDtOnProcString) + err = ior(err,1) + endif + if (config_print_thickness_advection_info) then + write(stdoutUnit,*) ' Maximum allowable time step on THIS processor is (Days_hhh:mmm:sss): ' // trim(allowableDtOnProcString) + endif + + ! If we are printing advection debug information, ! then find out what the global CFL limit is. Don't do this otherwise because ! it requires 2 unnecessary MPI communications. - if (config_print_thickness_advection_info) then + if (config_print_thickness_advection_info .or. config_adaptive_timestep) then ! Determine CFL limit on all procs - call mpas_dmpar_min_real(dminfo, allowableDt, allowableDtMin) + call mpas_dmpar_min_real(dminfo, allowableDtOnProc, allowableDtAllProcs) ! Determine which processor has the limiting CFL - if (allowableDt .eq. allowableDtMin) then + if (allowableDt == allowableDtAllProcs) then allowableDtProcNumber = dminfo % my_proc_id else allowableDtProcNumber = -1 endif - call mpas_dmpar_max_int(dminfo, allowableDtProcNumber, allowableDtMinProcNumber) - call mpas_set_timeInterval(allowableDtMinStringInterval, dt=allowableDtMin, ierr=err_tmp) + call mpas_dmpar_max_int(dminfo, allowableDtProcNumber, allowableDtProcNumber) + call mpas_set_timeInterval(allowableDtAllProcsStringInterval, dt=allowableDtOnProc, ierr=err_tmp) err = ior(err,err_tmp) - call mpas_get_timeInterval(allowableDtMinStringInterval, timeString=allowableDtMinString, ierr=err_tmp) + call mpas_get_timeInterval(allowableDtAllProcsStringInterval, timeString=allowableDtAllProcsString, ierr=err_tmp) err = ior(err,err_tmp) - write(stdoutUnit,*) ' Maximum allowable time step for all processors is (Days_hhh:mmm:sss): ' // trim(allowableDtMinString) // ' Time step is limited by processor number ', allowableDtMinProcNumber endif + if (config_print_thickness_advection_info) then + write(stdoutUnit,*) ' Maximum allowable time step for all processors is (Days_hhh:mmm:sss): ' // trim(allowableDtAllProcsString) // ' Time step is limited by processor number ', allowableDtProcNumber + endif + if (config_adaptive_timestep) then + call set_timestep(allowableDtAllProcs, dtSeconds, err_tmp) + err = ior(err,err_tmp) + elseif (dtSeconds > allowableDtAllProcs) then + write(stdErrUnit,*) 'Error: CFL violation has occurred on some processor(s)!' + err = ior(err,1) + endif + if (err > 0) then write(stderrUnit,*) 'Error in calculating thickness tendency (possibly CFL violation)' @@ -464,6 +494,56 @@ end subroutine update_prognostics +!*********************************************************************** +! +! routine set_timestep +! +!> \brief Adjusts the time step based on the CFL condition. +!> \author Matthew Hoffman +!> \date 23 Jan 2014 +!> \details +!> This routine sdjusts the time step based on the CFL condition. +! +!----------------------------------------------------------------------- + subroutine set_timestep(allowableDt, dtSeconds, err) + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + real (kind=RKIND) :: allowableDt + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + real (kind=RKIND) :: dtSeconds + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + logical, pointer :: config_adaptive_timestep + real (kind=RKIND), pointer :: config_adaptive_timestep_CFL_fraction + real (kind=RKIND), pointer :: config_max_adaptive_timestep + real (kind=RKIND), pointer :: config_min_adaptive_timestep + + call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep', config_adaptive_timestep) + call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep_CFL_fraction', config_adaptive_timestep_CFL_fraction) + call mpas_pool_get_config(liConfigs, 'config_max_adaptive_timestep', config_max_adaptive_timestep) + call mpas_pool_get_config(liConfigs, 'config_min_adaptive_timestep', config_min_adaptive_timestep) + + if (config_adaptive_timestep) then + dtSeconds = min(allowableDt * config_adaptive_timestep_CFL_fraction, config_max_adaptive_timestep) + write(stdOutUnit,*) ' Setting time step (days) to:', dtSeconds / (86400.0) + if (dtSeconds < config_min_adaptive_timestep) then + write(stdErrUnit,*) 'ERROR: New deltat is less than config_min_adaptive_timestep.' + err = 1 + endif + endif + + !-------------------------------------------------------------------- + end subroutine set_timestep + + + end module li_time_integration_fe From 2b37fc818bbef55e0c1e30899dc7a65cc0ee579c Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 20 Apr 2015 11:34:17 -0600 Subject: [PATCH 0041/1724] LI: Add diffusive CFL check Now the adaptive timestepper can optionally check the diffusive CFL for grounded, dynamic ice. The diffusivity is approximated at cell centers as D = UH/-grad h. --- src/core_landice/Registry.xml | 31 +++- src/core_landice/mpas_li_core_interface.F | 11 ++ src/core_landice/mpas_li_diagnostic_vars.F | 137 ++++++++++++++++- src/core_landice/mpas_li_tendency.F | 2 +- .../mpas_li_time_integration_fe.F | 141 +++++++++++++----- 5 files changed, 278 insertions(+), 44 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 3f791a81c9..cc910dce57 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -21,6 +21,9 @@ + @@ -140,6 +143,10 @@ description="A multiplier on the minimum allowable time step calculated from the CFL condition. (Setting to 1.0 may be unstable, so smaller values are recommended.)" possible_values="Any positive real value less than 1.0." /> + @@ -246,6 +253,9 @@ + + + @@ -602,7 +612,7 @@ is the value of that variable from the *previous* time level! description="Basal mass balance" /> - + @@ -615,6 +625,11 @@ is the value of that variable from the *previous* time level! + + + @@ -726,7 +741,19 @@ is the value of that variable from the *previous* time level! description="generic work array with dimensions of (nVertLevels nCells)" persistence="scratch" /> - + + + diff --git a/src/core_landice/mpas_li_core_interface.F b/src/core_landice/mpas_li_core_interface.F index 2cafabea2b..8db7b17d3b 100644 --- a/src/core_landice/mpas_li_core_interface.F +++ b/src/core_landice/mpas_li_core_interface.F @@ -94,14 +94,20 @@ function li_setup_packages(configPool, packagePool) result(ierr) ! Local variables character (len=StrKIND), pointer :: config_velocity_solver + logical, pointer :: config_adaptive_timestep_include_DCFL + logical, pointer :: higherOrderVelocityActive logical, pointer :: SIAvelocityActive + logical, pointer :: calcDiffusivityActive ierr = 0 call mpas_pool_get_config(configPool, 'config_velocity_solver', config_velocity_solver) + call mpas_pool_get_config(configPool, 'config_adaptive_timestep_include_DCFL', config_adaptive_timestep_include_DCFL) + call mpas_pool_get_package(packagePool, 'SIAvelocityActive', SIAvelocityActive) call mpas_pool_get_package(packagePool, 'higherOrderVelocityActive', higherOrderVelocityActive) + call mpas_pool_get_package(packagePool, 'calcDiffusivityActive', calcDiffusivityActive) if (trim(config_velocity_solver) == 'sia') then SIAvelocityActive = .true. @@ -111,6 +117,11 @@ function li_setup_packages(configPool, packagePool) result(ierr) write (stdoutUnit,*) "The 'higherOrderVelocity' package and associated variables have been enabled because a higher-order velocity solver is selected." end if + if (config_adaptive_timestep_include_DCFL) then + calcDiffusivityActive = .true. + write (stdoutUnit,*) "The 'calcDiffusivity' package and associated variables have been enabled because 'config_adaptive_timestep_include_DCFL' is set to .true." + endif + end function li_setup_packages diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index 47f989de0a..806a20ada6 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -45,7 +45,7 @@ module li_diagnostic_vars ! Public member functions ! !-------------------------------------------------------------------- - public :: li_calculate_diagnostic_vars + public :: li_calculate_diagnostic_vars, li_calculate_apparent_diffusivity !-------------------------------------------------------------------- ! @@ -244,6 +244,141 @@ end subroutine li_calculate_diagnostic_vars +!*********************************************************************** +! +! subroutine li_calculate_apparent_diffusivity +! +!> \brief Computes apparent diffusivity +!> \author Matt Hoffman +!> \date 19 April 2012 +!> \details +!> This routine computes the apparent diffusivity. +!> Estimate diffusivity using the relation that the 2-d flux Q=-D grad h and Q=UH, +!> where h is surface elevation, D is diffusivity, U is 2-d velocity vector, and H is thickness +!> Solving for D = UH/-grad h +!> DCFL: dt = 0.5 * dx**2 / D = 0.5 * dx**2 * slopemag / flux_downslope +!----------------------------------------------------------------------- + subroutine li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool, geometryPool, allowableDiffDt) + use mpas_vector_reconstruction + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + type (mpas_pool_type), intent(in) :: & + velocityPool !< Input: velocity information + + type (mpas_pool_type), intent(in) :: & + scratchPool !< Input: scratch information + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: & + geometryPool !< Input: geometry information + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + real(kind=RKIND), intent(out) :: allowableDiffDt !< Output: allowable timestep based on diffusive CFL + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:), pointer :: normalSlopeEdge + type (field1dReal), pointer :: cellJunk + type (field1dReal), pointer :: slopeCellXField + type (field1dReal), pointer :: slopeCellYField + real (kind=RKIND), dimension(:), pointer :: slopeCellX, slopeCellY + real (kind=RKIND), dimension(:,:), pointer :: layerThickness + real (kind=RKIND), dimension(:,:), pointer :: uReconstructX, uReconstructY + real (kind=RKIND), dimension(:), pointer :: apparentDiffusivity + real (kind=RKIND), dimension(:), pointer :: dcEdge + integer, dimension(:), pointer :: cellMask + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnCell + integer, pointer :: nCells, nVertLevels + logical, pointer :: on_a_sphere + real (kind=RKIND) :: allowableDtHere + real (kind=RKIND) :: cellVeloX, cellVeloY + real (kind=RKIND) :: fluxDownslope + real (kind=RKIND) :: slopeCellMagnitude + real (kind=RKIND) :: dCell + integer :: iCell, iEdge, iLevel + real (kind=RKIND), parameter :: bigNumber = 1.0e16_RKIND ! This is ~300 million years in seconds, but it is small enough not too overflow + real (kind=RKIND), parameter :: smallNumber = 1.0e-36 + + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + if (on_a_sphere) then + write (stdErrUnit, *) "WARNING: Diffusive CFL cannot currently be calculated on a sphere." + return + endif + + ! get needed variables + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(geometryPool, 'normalSlopeEdge', normalSlopeEdge) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness) + call mpas_pool_get_array(geometryPool, 'apparentDiffusivity', apparentDiffusivity) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX) + call mpas_pool_get_array(velocityPool, 'uReconstructY', uReconstructY) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_field(scratchPool, 'workCell', cellJunk) + call mpas_allocate_scratch_field(cellJunk, .true.) + call mpas_pool_get_field(scratchPool, 'slopeCellX', slopeCellXField) + call mpas_allocate_scratch_field(slopeCellXField, .true.) + slopeCellX => slopeCellXField % array + call mpas_pool_get_field(scratchPool, 'slopeCellY', slopeCellYField) + call mpas_allocate_scratch_field(slopeCellYField, .true.) + slopeCellY => slopeCellYField % array + + + ! Initialize output + allowableDiffDt = bigNumber + + ! Approximate slope at cell centers + + call mpas_reconstruct(meshPool, normalSlopeEdge, & + slopeCellX, slopeCellY, cellJunk % array, & + cellJunk % array, cellJunk % array ) + + ! Approximate flux at cell centers + do iCell = 1, nCells + slopeCellMagnitude = sqrt(slopeCellX(iCell)**2 + slopeCellY(iCell)**2) + smallNumber + + fluxDownslope = 0.0_RKIND + do iLevel = 1, nVertLevels + cellVeloX = (uReconstructX(iLevel, iCell) + uReconstructX(iLevel+1, iCell)) * 0.5_RKIND + cellVeloY = (uReconstructY(iLevel, iCell) + uReconstructY(iLevel+1, iCell)) * 0.5_RKIND + fluxDownslope = fluxDownslope + (-1.0_RKIND * slopeCellX(iCell) * cellVeloX - slopeCellY(iCell) * cellVeloY) * layerThickness(iLevel, iCell) /slopeCellMagnitude + enddo + apparentDiffusivity(iCell) = abs(fluxDownslope) / slopeCellMagnitude + + ! Calculate allowable timestep based on DCFL + if ( li_mask_is_grounded_ice(cellMask(iCell)) .and. li_mask_is_dynamic_ice(cellMask(iCell)) ) then + ! Find shortest distance to a neighboring cell center, dCell + dCell = minval(dcEdge(1:nEdgesOnCell(iCell))) + allowableDtHere = 0.5_RKIND * dCell**2 / (apparentDiffusivity(iCell) + smallNumber) + else + allowableDtHere = bigNumber + endif + allowableDiffDt = min(allowableDiffDt, allowableDtHere) + enddo + + call mpas_deallocate_scratch_field(cellJunk, .true.) + call mpas_deallocate_scratch_field(slopeCellXField, .true.) + call mpas_deallocate_scratch_field(slopeCellYField, .true.) + !-------------------------------------------------------------------- + end subroutine li_calculate_apparent_diffusivity + + !*********************************************************************** !*********************************************************************** diff --git a/src/core_landice/mpas_li_tendency.F b/src/core_landice/mpas_li_tendency.F index ae04c46bc4..514b5912ed 100644 --- a/src/core_landice/mpas_li_tendency.F +++ b/src/core_landice/mpas_li_tendency.F @@ -630,7 +630,7 @@ subroutine tend_layerThickness_fo_upwind(meshPool, normalVelocity, layerThicknes logical, pointer :: config_print_thickness_advection_info real (kind=RKIND) :: invAreaCell, flux, maxAllowableDt, layerNormalVelocity integer :: iEdge, iCell, i, k - real (kind=RKIND) :: bigNumber = 1.0e16_RKIND ! This is ~300 million years in seconds, but it is small enough not too overflow + real (kind=RKIND), parameter :: bigNumber = 1.0e16_RKIND ! This is ~300 million years in seconds, but it is small enough not too overflow integer :: err_tmp ! Only needed for optional check for mass conservation diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index 7853933f0f..bfbf98444e 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -193,42 +193,55 @@ subroutine calculate_tendencies(domain, dtSeconds, err) type (mpas_pool_type), pointer :: velocityPool type (mpas_pool_type), pointer :: geometryPool type (mpas_pool_type), pointer :: tendencyPool + type (mpas_pool_type), pointer :: scratchPool real (kind=RKIND), dimension(:,:), pointer :: layerThickness_tend type (field2DReal), pointer :: layerThickness_tend_field logical, pointer :: config_print_thickness_advection_info logical, pointer :: config_adaptive_timestep - integer :: allowableDtProcNumber - real (kind=RKIND) :: allowableDt, allowableDtOnProc, allowableDtAllProcs - type (MPAS_TimeInterval_type) :: allowableDtOnProcInterval, allowableDtAllProcsStringInterval - character (len=StrKIND) :: allowableDtOnProcString, allowableDtAllProcsString + logical, pointer :: config_adaptive_timestep_include_DCFL + integer :: allowableAdvecDtProcNumber + real (kind=RKIND) :: allowableAdvecDt, allowableAdvecDtOnProc, allowableAdvecDtAllProcs + type (MPAS_TimeInterval_type) :: allowableAdvecDtOnProcInterval, allowableAdvecDtAllProcsInterval + character (len=StrKIND) :: allowableAdvecDtOnProcString, allowableAdvecDtAllProcsString + integer :: allowableDiffDtProcNumber + real (kind=RKIND) :: allowableDiffDt, allowableDiffDtOnProc, allowableDiffDtAllProcs + type (MPAS_TimeInterval_type) :: allowableDiffDtOnProcInterval, allowableDiffDtAllProcsInterval + character (len=StrKIND) :: allowableDiffDtOnProcString, allowableDiffDtAllProcsString integer :: err_tmp - integer :: y, m, d, hh, mm, ss - err = 0 call mpas_pool_get_config(liConfigs, 'config_print_thickness_advection_info', config_print_thickness_advection_info) call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep', config_adaptive_timestep) + call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep_include_DCFL', config_adaptive_timestep_include_DCFL) dminfo => domain % dminfo ! === ! === Thickness tendencies ! === - allowableDtOnProc = 1.0e36 ! set to large number + allowableAdvecDtOnProc = 1.0e36 ! set to large number + allowableDiffDtOnProc = 1.0e36 ! set to large number block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) call mpas_pool_get_subpool(block % structs, 'tendency', tendencyPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) call mpas_pool_get_array(tendencyPool, 'layerThickness', layerThickness_tend) ! Calculate thickness tendency using state at time n ========= - call li_tendency_thickness(meshPool, velocityPool, geometryPool, layerThickness_tend, dtSeconds, dminfo, allowableDt, err_tmp) + call li_tendency_thickness(meshPool, velocityPool, geometryPool, layerThickness_tend, dtSeconds, dminfo, allowableAdvecDt, err_tmp) err = ior(err,err_tmp) - allowableDtOnProc = min(allowableDtOnProc, allowableDt) + allowableAdvecDtOnProc = min(allowableAdvecDtOnProc, allowableAdvecDt) + + ! Calculate diffusive CFL timestep, if needed + if (config_adaptive_timestep_include_DCFL) then + call li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool, geometryPool, allowableDiffDt) + allowableDiffDtOnProc = min(allowableDiffDtOnProc, allowableDiffDt) + endif block => block % next end do @@ -242,51 +255,88 @@ subroutine calculate_tendencies(domain, dtSeconds, err) call mpas_timer_stop("halo updates") - ! Build a time string of the maximum allowable dt calculated - ! (We only need this if a CFL violation occurred or config_print_thickness_advection_info is true) - call mpas_set_timeInterval(allowableDtOnProcInterval, dt=allowableDtOnProc, ierr=err_tmp) + ! Local advective CFL info + call mpas_set_timeInterval(allowableAdvecDtOnProcInterval, dt=allowableAdvecDtOnProc, ierr=err_tmp) err = ior(err,err_tmp) - call mpas_get_timeInterval(allowableDtOnProcInterval, timeString=allowableDtOnProcString, ierr=err_tmp) + call mpas_get_timeInterval(allowableAdvecDtOnProcInterval, timeString=allowableAdvecDtOnProcString, ierr=err_tmp) err = ior(err,err_tmp) - if (dtSeconds > allowableDtOnProc) then - write(stderrUnit,*) 'ERROR: CFL violation on this processor. Maximum allowable time step for this processor is (Days_hhh:mmm:sss): ' // trim(allowableDtOnProcString) - err = ior(err,1) - endif + if (config_print_thickness_advection_info) then - write(stdoutUnit,*) ' Maximum allowable time step on THIS processor is (Days_hhh:mmm:sss): ' // trim(allowableDtOnProcString) + write(stdoutUnit,*) ' Maximum allowable time step on THIS processor based on advective CFL is (Days_hhh:mmm:sss): ' // trim(allowableAdvecDtOnProcString) + endif + + if (dtSeconds > allowableAdvecDtOnProc) then + write(stderrUnit,*) 'ERROR: Advective CFL violation on this processor. Maximum allowable time step for this processor is (Days_hhh:mmm:sss): ' // trim(allowableAdvecDtOnProcString) + err = ior(err,1) + endif + + ! Local diffusive CFL info + if (config_adaptive_timestep_include_DCFL) then + call mpas_set_timeInterval(allowableDiffDtOnProcInterval, dt=allowableDiffDtOnProc, ierr=err_tmp) + err = ior(err,err_tmp) + call mpas_get_timeInterval(allowableDiffDtOnProcInterval, timeString=allowableDiffDtOnProcString, ierr=err_tmp) + err = ior(err,err_tmp) + + if (config_print_thickness_advection_info) then + write(stdoutUnit,*) ' Maximum allowable time step on THIS processor based on diffusive CFL is (Days_hhh:mmm:sss): ' // trim(allowableDiffDtOnProcString) + endif + + if (dtSeconds > allowableDiffDtOnProc) then + write(stderrUnit,*) 'WARNING: Diffusive CFL violation on this processor. Maximum allowable time step for this processor is (Days_hhh:mmm:sss): ' // trim(allowableDiffDtOnProcString) + endif endif - ! If we are printing advection debug information, + ! If we are printing advection debug information or adaptive timestepping, ! then find out what the global CFL limit is. Don't do this otherwise because ! it requires 2 unnecessary MPI communications. if (config_print_thickness_advection_info .or. config_adaptive_timestep) then - ! Determine CFL limit on all procs - call mpas_dmpar_min_real(dminfo, allowableDtOnProc, allowableDtAllProcs) + ! Determine ACFL limit on all procs + call mpas_dmpar_min_real(dminfo, allowableAdvecDtOnProc, allowableAdvecDtAllProcs) ! Determine which processor has the limiting CFL - if (allowableDt == allowableDtAllProcs) then - allowableDtProcNumber = dminfo % my_proc_id + if (allowableAdvecDtOnProc == allowableAdvecDtAllProcs) then + allowableAdvecDtProcNumber = dminfo % my_proc_id else - allowableDtProcNumber = -1 + allowableAdvecDtProcNumber = -1 endif - call mpas_dmpar_max_int(dminfo, allowableDtProcNumber, allowableDtProcNumber) - call mpas_set_timeInterval(allowableDtAllProcsStringInterval, dt=allowableDtOnProc, ierr=err_tmp) + call mpas_dmpar_max_int(dminfo, allowableAdvecDtProcNumber, allowableAdvecDtProcNumber) + call mpas_set_timeInterval(allowableAdvecDtAllProcsInterval, dt=allowableAdvecDtAllProcs, ierr=err_tmp) err = ior(err,err_tmp) - call mpas_get_timeInterval(allowableDtAllProcsStringInterval, timeString=allowableDtAllProcsString, ierr=err_tmp) + call mpas_get_timeInterval(allowableAdvecDtAllProcsInterval, timeString=allowableAdvecDtAllProcsString, ierr=err_tmp) err = ior(err,err_tmp) + + ! Repeat for diffusive CFL + if (config_adaptive_timestep_include_DCFL) then + ! Determine DCFL limit on all procs + call mpas_dmpar_min_real(dminfo, allowableDiffDtOnProc, allowableDiffDtAllProcs) + ! Determine which processor has the limiting CFL + if (allowableDiffDtOnProc == allowableDiffDtAllProcs) then + allowableDiffDtProcNumber = dminfo % my_proc_id + else + allowableDiffDtProcNumber = -1 + endif + call mpas_dmpar_max_int(dminfo, allowableDiffDtProcNumber, allowableDiffDtProcNumber) + call mpas_set_timeInterval(allowableDiffDtAllProcsInterval, dt=allowableDiffDtAllProcs, ierr=err_tmp) + err = ior(err,err_tmp) + call mpas_get_timeInterval(allowableDiffDtAllProcsInterval, timeString=allowableDiffDtAllProcsString, ierr=err_tmp) + err = ior(err,err_tmp) + endif endif + + ! Write messages if they are turned on if (config_print_thickness_advection_info) then - write(stdoutUnit,*) ' Maximum allowable time step for all processors is (Days_hhh:mmm:sss): ' // trim(allowableDtAllProcsString) // ' Time step is limited by processor number ', allowableDtProcNumber - endif - if (config_adaptive_timestep) then - call set_timestep(allowableDtAllProcs, dtSeconds, err_tmp) - err = ior(err,err_tmp) - elseif (dtSeconds > allowableDtAllProcs) then - write(stdErrUnit,*) 'Error: CFL violation has occurred on some processor(s)!' - err = ior(err,1) + write(stdoutUnit,*) ' Maximum allowable time step for all processors based on advective CFL is (Days_hhh:mmm:sss): ' // trim(allowableAdvecDtAllProcsString) // ' Time step is limited by processor number ', allowableAdvecDtProcNumber + if (config_adaptive_timestep_include_DCFL) then + write(stdoutUnit,*) ' Maximum allowable time step for all processors based on diffusive CFL is (Days_hhh:mmm:sss): ' // trim(allowableDiffDtAllProcsString) // ' Time step is limited by processor number ', allowableDiffDtProcNumber + endif endif + ! Set adaptive timestep + call set_timestep(allowableAdvecDtAllProcs, allowableDiffDtAllProcs, dtSeconds, err_tmp) + err = ior(err,err_tmp) + + if (err > 0) then write(stderrUnit,*) 'Error in calculating thickness tendency (possibly CFL violation)' endif @@ -505,11 +555,12 @@ end subroutine update_prognostics !> This routine sdjusts the time step based on the CFL condition. ! !----------------------------------------------------------------------- - subroutine set_timestep(allowableDt, dtSeconds, err) + subroutine set_timestep(allowableAdvecDt, allowableDiffDt, dtSeconds, err) !----------------------------------------------------------------- ! input variables !----------------------------------------------------------------- - real (kind=RKIND) :: allowableDt + real (kind=RKIND) :: allowableAdvecDt + real (kind=RKIND) :: allowableDiffDt !----------------------------------------------------------------- ! output variables @@ -521,16 +572,26 @@ subroutine set_timestep(allowableDt, dtSeconds, err) ! local variables !----------------------------------------------------------------- logical, pointer :: config_adaptive_timestep + logical, pointer :: config_adaptive_timestep_include_DCFL real (kind=RKIND), pointer :: config_adaptive_timestep_CFL_fraction real (kind=RKIND), pointer :: config_max_adaptive_timestep real (kind=RKIND), pointer :: config_min_adaptive_timestep + real (kind=RKIND) :: allowableDt call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep', config_adaptive_timestep) - call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep_CFL_fraction', config_adaptive_timestep_CFL_fraction) - call mpas_pool_get_config(liConfigs, 'config_max_adaptive_timestep', config_max_adaptive_timestep) - call mpas_pool_get_config(liConfigs, 'config_min_adaptive_timestep', config_min_adaptive_timestep) if (config_adaptive_timestep) then + call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep_CFL_fraction', config_adaptive_timestep_CFL_fraction) + call mpas_pool_get_config(liConfigs, 'config_max_adaptive_timestep', config_max_adaptive_timestep) + call mpas_pool_get_config(liConfigs, 'config_min_adaptive_timestep', config_min_adaptive_timestep) + call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep_include_DCFL', config_adaptive_timestep_include_DCFL) + + if (config_adaptive_timestep_include_DCFL) then + allowableDt = min(allowableAdvecDt, allowableDiffDt) + else + allowableDt = allowableAdvecDt + endif + dtSeconds = min(allowableDt * config_adaptive_timestep_CFL_fraction, config_max_adaptive_timestep) write(stdOutUnit,*) ' Setting time step (days) to:', dtSeconds / (86400.0) if (dtSeconds < config_min_adaptive_timestep) then From 7589dc7477b43ba90cc7660cbac62344e2215080 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 21 Apr 2015 09:28:04 -0600 Subject: [PATCH 0042/1724] LI: Move velo reconstruct to li_velocity_solve This commit is code cleanup to move the velo reconstruct code and velo halo updates from li_calculate_diagnostic_vars into the li_velocity_solve routine that it calls. This encapsulates any code related to velocity into li_velocity_solve, including diagnostic velocity fields like surfaceSpeed. I think this will be more straightforward. --- src/core_landice/mpas_li_diagnostic_vars.F | 76 +-------- src/core_landice/mpas_li_velocity.F | 181 ++++++++++++++------- 2 files changed, 128 insertions(+), 129 deletions(-) diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index 806a20ada6..34f09cd1d4 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -78,8 +78,6 @@ module li_diagnostic_vars subroutine li_calculate_diagnostic_vars(domain, solveVelo, err) - use mpas_vector_reconstruction - !----------------------------------------------------------------- ! ! input variables @@ -115,20 +113,12 @@ subroutine li_calculate_diagnostic_vars(domain, solveVelo, err) type (mpas_pool_type), pointer :: geometryPool type (mpas_pool_type), pointer :: thermalPool type (mpas_pool_type), pointer :: velocityPool - character (len=StrKIND), pointer :: config_velocity_solver - logical, pointer :: config_do_velocity_reconstruction_for_external_dycore - type (field2DReal), pointer :: normalVelocityField, layerThicknessEdgeField - real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional - real (kind=RKIND), dimension(:), pointer :: surfaceSpeed, basalSpeed - integer, pointer :: nVertInterfaces + type (field2DReal), pointer :: layerThicknessEdgeField integer :: err_tmp err = 0 - call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) - call mpas_pool_get_config(liConfigs, 'config_do_velocity_reconstruction_for_external_dycore', config_do_velocity_reconstruction_for_external_dycore) - ! === ! === Diagnostic solve of variables prior to velocity ! === @@ -143,32 +133,8 @@ subroutine li_calculate_diagnostic_vars(domain, solveVelo, err) ! === Diagnostic solve of velocity ! === if (solveVelo) then - call mpas_timer_start("velocity solve") - - ! TODO Once multiple blocks are supported, this section will need to change. - ! LifeV does not support multiple blocks but the MPAS SIA could. - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) - call mpas_pool_get_subpool(block % structs, 'thermal', thermalPool) - call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) - - call li_velocity_solve(meshPool, geometryPool, thermalPool, velocityPool, err) ! ****** Calculate Velocity ****** - - err = ior(err, err_tmp) - - block => block % next - end do - - ! update halos on velocity - call mpas_timer_start("halo updates") - call mpas_pool_get_subpool(domain % blocklist % structs, 'velocity', velocityPool) - call mpas_pool_get_field(velocityPool, 'normalVelocity', normalVelocityField) - call mpas_dmpar_exch_halo_field(normalVelocityField) - call mpas_timer_stop("halo updates") - - call mpas_timer_stop("velocity solve") + call li_velocity_solve(domain, err) ! ****** Calculate Velocity ****** + err = ior(err, err_tmp) endif @@ -178,42 +144,6 @@ subroutine li_calculate_diagnostic_vars(domain, solveVelo, err) call mpas_timer_start("calc. diagnostic vars except vel") - ! Calculate reconstructed velocities - ! do this after velocity halo update in case velocities on the 1-halo edge are wrong (depends on velocity solver) - ! Still do this even if we didn't calculate velocity because on a restart these will be defined at the initial time. - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) - call mpas_pool_get_dimension(meshPool, 'nVertInterfaces', nVertInterfaces) - call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX) - call mpas_pool_get_array(velocityPool, 'uReconstructY', uReconstructY) - call mpas_pool_get_array(velocityPool, 'surfaceSpeed', surfaceSpeed) - call mpas_pool_get_array(velocityPool, 'basalSpeed', basalSpeed) - - ! Native SIA dycore needs to have reconstructed velocities calculated. - ! External dycores return their native velocities at cell center locations, - ! but these can optionally be overwritten by reconstructed velocities for testing. - if ( (trim(config_velocity_solver) == 'sia') .or. & - config_do_velocity_reconstruction_for_external_dycore ) then - call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) - call mpas_pool_get_array(velocityPool, 'uReconstructZ', uReconstructZ) - call mpas_pool_get_array(velocityPool, 'uReconstructZonal', uReconstructZonal) - call mpas_pool_get_array(velocityPool, 'uReconstructMeridional', uReconstructMeridional) - - call mpas_reconstruct(meshPool, normalVelocity, & - uReconstructX, uReconstructY, uReconstructZ, & - uReconstructZonal, uReconstructMeridional ) - endif - - ! Calculate diagnostic speed arrays - surfaceSpeed = sqrt(uReconstructX(1,:)**2 + uReconstructY(1,:)**2) - basalSpeed = sqrt(uReconstructX(nVertInterfaces,:)**2 + uReconstructY(nVertInterfaces,:)**2) - - block => block % next - end do - - block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index 834a909cd1..1a97d4ad63 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -25,6 +25,7 @@ module li_velocity use mpas_derived_types use mpas_pool_routines + use mpas_timer use mpas_configure use li_velocity_external use li_sia @@ -214,97 +215,165 @@ end subroutine li_velocity_block_init !> This routine calls velocity solvers. ! !----------------------------------------------------------------------- - subroutine li_velocity_solve(meshPool, geometryPool, thermalPool, velocityPool, err) + subroutine li_velocity_solve(domain, err) + use mpas_vector_reconstruction use li_mask !----------------------------------------------------------------- - ! ! input variables - ! !----------------------------------------------------------------- - type (mpas_pool_type), intent(in) :: & - meshPool !< Input: mesh information - - type (mpas_pool_type), intent(in) :: & - geometryPool !< Input: geometry information - - type (mpas_pool_type), intent(in) :: & - thermalPool !< Input: thermal information - !----------------------------------------------------------------- - ! ! input/output variables - ! !----------------------------------------------------------------- - - type (mpas_pool_type), intent(inout) :: & - velocityPool !< Input: velocity information + type (domain_type), intent(inout) :: domain !< Input/Output: domain object + ! Note: domain is passed in because halo updates are needed in this routine + ! and halo updates have to happen outside block loops, which requires domain. !----------------------------------------------------------------- - ! ! output variables - ! !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag !----------------------------------------------------------------- - ! ! local variables - ! !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: geometryPool + type (mpas_pool_type), pointer :: thermalPool + type (mpas_pool_type), pointer :: velocityPool ! pointers to get from pools character (len=StrKIND), pointer :: config_velocity_solver - integer, pointer :: nEdges - real (kind=RKIND), dimension(:,:), pointer :: normalVelocity + logical, pointer :: config_do_velocity_reconstruction_for_external_dycore + integer, pointer :: nEdgesSolve + integer, pointer :: nVertInterfaces integer, dimension(:), pointer :: edgeMask + real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional + real (kind=RKIND), dimension(:), pointer :: surfaceSpeed, basalSpeed + type (field2DReal), pointer :: normalVelocityField ! truly local variables integer :: iEdge + integer :: err_tmp + call mpas_timer_start("velocity solve") + + err_tmp = 0 err = 0 - ! Get variables from pools call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) - call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) - call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) - - - select case (config_velocity_solver) - case ('none') - ! Do nothing - case ('sia') - call li_sia_solve(meshPool, geometryPool, velocityPool, err) - case ('L1L2', 'FO', 'Stokes') - call li_velocity_external_solve(meshPool, geometryPool, thermalPool, velocityPool, err) - case default - write(stderrUnit,*) 'Error: ', trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' - err = 1 - return - end select - - ! Check if the velocity solver has returned a velocity on any non-dynamic edges - do iEdge = 1, nEdges - if ( li_mask_is_ice(edgeMask(iEdge)) .and. & - (.not.(li_mask_is_dynamic_ice(edgeMask(iEdge)))) .and. & - (maxval(abs(normalVelocity(:,iEdge))) /= 0.0_RKIND) & - ) then + call mpas_pool_get_config(liConfigs, 'config_do_velocity_reconstruction_for_external_dycore', config_do_velocity_reconstruction_for_external_dycore) + + ! External solvers do not support multiple blocks but the MPAS SIA solver does. + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'thermal', thermalPool) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) + + ! Get variables from pools + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) + + select case (config_velocity_solver) + case ('none') + ! Do nothing + case ('sia') + call li_sia_solve(meshPool, geometryPool, velocityPool, err_tmp) + case ('L1L2', 'FO', 'Stokes') + call li_velocity_external_solve(meshPool, geometryPool, thermalPool, velocityPool, err_tmp) + case default + write(stderrUnit,*) 'Error: ', trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' + err = 1 + call mpas_timer_stop("velocity solve") + return + end select + err = ior(err, err_tmp) + + ! Check if the velocity solver has returned a velocity on any non-dynamic edges + do iEdge = 1, nEdgesSolve + if ( li_mask_is_ice(edgeMask(iEdge)) .and. & + (.not.(li_mask_is_dynamic_ice(edgeMask(iEdge)))) .and. & + (maxval(abs(normalVelocity(:,iEdge))) /= 0.0_RKIND) & + ) then + err_tmp= 1 + !!!normalVelocity(:,iEdge) = 0.0_RKIND ! this is a hack because the rest of the code requires this, but this condition should really cause a fatal error. + endif + enddo + if (err_tmp == 1) then + write(stderrUnit,*) 'Error: Velocity has been calculated on non-dynamic edges. There is a problem with the velocity solver.' !!! Velocity on those edges have been set to 0, but this should be a fatal error.' err = 1 - !!!normalVelocity(:,iEdge) = 0.0_RKIND ! this is a hack because the rest of the code requires this, but this condition should really cause a fatal error. - endif - enddo - if (err == 1) then - write(stderrUnit,*) 'Error: Velocity has been calculated on non-dynamic edges. There is a problem with the velocity solver.' !!! Velocity on those edges have been set to 0, but this should be a fatal error.' - err = 1 ! a hack to let the code continue until this can be fixed in the velocity solver - end if + end if + + block => block % next + end do + + + ! --- + ! --- update halos on velocity + ! --- + call mpas_timer_start("halo updates") + call mpas_pool_get_subpool(domain % blocklist % structs, 'velocity', velocityPool) + call mpas_pool_get_field(velocityPool, 'normalVelocity', normalVelocityField) + call mpas_dmpar_exch_halo_field(normalVelocityField) + call mpas_timer_stop("halo updates") + + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) + + ! --- + ! --- Calculate reconstructed velocities + ! --- + ! do this after velocity halo update in case velocities on the 1-halo edge are wrong (depends on velocity solver) + ! Still do this even if we didn't calculate velocity because on a restart these will be defined at the initial time. + call mpas_pool_get_dimension(meshPool, 'nVertInterfaces', nVertInterfaces) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) + call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX) + call mpas_pool_get_array(velocityPool, 'uReconstructY', uReconstructY) + call mpas_pool_get_array(velocityPool, 'uReconstructZ', uReconstructZ) + call mpas_pool_get_array(velocityPool, 'uReconstructZonal', uReconstructZonal) + call mpas_pool_get_array(velocityPool, 'uReconstructMeridional', uReconstructMeridional) + call mpas_pool_get_array(velocityPool, 'surfaceSpeed', surfaceSpeed) + call mpas_pool_get_array(velocityPool, 'basalSpeed', basalSpeed) + + ! Native SIA dycore needs to have reconstructed velocities calculated. + ! External dycores return their native velocities at cell center locations, + ! but these can optionally be overwritten by reconstructed velocities for testing. + if ( (trim(config_velocity_solver) == 'sia') .or. & + config_do_velocity_reconstruction_for_external_dycore ) then + call mpas_reconstruct(meshPool, normalVelocity, & + uReconstructX, uReconstructY, uReconstructZ, & + uReconstructZonal, uReconstructMeridional ) + else + ! For 2-d meshes, these are set by mpas_reconstruct, so set them for HO dycores + uReconstructZonal = uReconstructX + uReconstructMeridional = uReconstructY + end if + + + ! --- + ! --- Calculate diagnostic speed arrays + ! --- + surfaceSpeed = sqrt(uReconstructX(1,:)**2 + uReconstructY(1,:)**2) + basalSpeed = sqrt(uReconstructX(nVertInterfaces,:)**2 + uReconstructY(nVertInterfaces,:)**2) + + block => block % next + end do ! === error check if (err > 0) then write (stderrUnit,*) "An error has occurred in li_velocity_solve." endif + call mpas_timer_stop("velocity solve") + !-------------------------------------------------------------------- end subroutine li_velocity_solve From c81ac6e0a7e2dda79f369a8b7c924f9b93eb49a7 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 21 Apr 2015 09:49:42 -0600 Subject: [PATCH 0043/1724] LI: Ext. dycore cleanup: err on spherical mesh, fix velo scaling Also added some stdout messages about the external dycore operations. --- src/core_landice/mpas_li_velocity_external.F | 33 +++++++++++++++----- 1 file changed, 25 insertions(+), 8 deletions(-) diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index 1b9369c842..e2fb596f67 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -119,17 +119,24 @@ subroutine li_velocity_external_init(domain, err) err_tmp = 1 endif err = ior(err,err_tmp) + if (config_number_of_blocks /= 0) then write(stderrUnit,*) "Error: External velocity solvers require that config_number_of_blocks=0" err_tmp = 1 endif err = ior(err,err_tmp) + ! Check if we are on a sphere - not supported by external dycores + if (domain % on_a_sphere) then + write(stderrUnit,*) "ERROR: External velocity solvers cannot be run with a spherical mesh." + err_tmp = 1 + endif + err = ior(err,err_tmp) ! These calls are needed for setting up the external velocity solvers - #if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) !call external first order solver to set the grid of the velocity solver + write(stdoutUnit,*) "Initializing external velocity solver." call velocity_solver_init_mpi(domain % dminfo % comm) #else err = 1 @@ -270,6 +277,7 @@ subroutine li_velocity_external_block_init(block, err) !zCell is supposed to be zero when working on planar geometries (radius = 0) !nVertLevels should be equal to nVertLevelsSolve (no splitting of the domain in the vertical direction) call mpas_timer_start("velocity_solver_set_grid_data") + write(stdoutUnit,*) "Initializing external velocity solver grid data." call velocity_solver_set_grid_data(nCells, nEdges, nVertices, nVertInterfaces, & nCellsSolve, nEdgesSolve, nVerticesSolve, maxNEdgesOnCell, radius, & cellsOnEdge, cellsOnVertex, verticesOnCell, verticesOnEdge, edgesOnCell, & @@ -370,6 +378,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc logical, pointer :: config_always_compute_fem_grid integer, pointer :: anyDynamicVertexMaskChanged integer, pointer :: dirichletMaskChanged + real(kind=RKIND), parameter :: secondsInYear = 365.0 * 24.0 * 3600.0 !< The value of seconds in a year assumed by external dycores err = 0 @@ -410,7 +419,8 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc uReconstructX = 0.0_RKIND uReconstructY = 0.0_RKIND uReconstructZ = 0.0_RKIND - else + return + endif ! ================================================================== @@ -421,6 +431,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc ! initialize vertexMask to garbage which sets anyDynamicVertexMaskChanged to 1. if ((anyDynamicVertexMaskChanged == 1) .or. (config_always_compute_fem_grid) .or. & (dirichletMaskChanged == 1) ) then + write(stdoutUnit,*) "Generating new external velocity solver FEM grid." call generate_fem_grid(config_velocity_solver, vertexMask, dirichletVelocityMask, & floatingEdges, layerThicknessFractions, lowerSurface, thickness, err) endif @@ -430,6 +441,12 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc ! External dycore calls to be made every time step (solve velocity!) ! ================================================================== + ! convert from m/s (used by MPAS) to m/yr (used by external dycores) + normalVelocity = normalVelocity * secondsInYear ! this is intent(out) by dycores, but setting anyway for consistency + uReconstructX = uReconstructX * secondsInYear + uReconstructY = uReconstructY * secondsInYear + + write(stdoutUnit,*) "Beginning velocity solve using external velocity solver." select case (config_velocity_solver) case ('L1L2') ! =============================================== #ifdef USE_EXTERNAL_L1L2 @@ -481,15 +498,15 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc return #endif end select + write(stdoutUnit,*) "Completed velocity solve using external velocity solver." + ! convert from m/yr (used by external dycores) to m/s (used by MPAS) + normalVelocity = normalVelocity / secondsInYear + uReconstructX = uReconstructX / secondsInYear + uReconstructY = uReconstructY / secondsInYear - normalVelocity = normalVelocity / (365.0*24.0*3600.0) ! convert from m/yr (used by external dycores) to m/s (used by MPAS) - uReconstructX = uReconstructX / (365.0*24.0*3600.0) ! convert from m/yr (used by external dycores) to m/s (used by MPAS) - uReconstructY = uReconstructY / (365.0*24.0*3600.0) ! convert from m/yr (used by external dycores) to m/s (used by MPAS) - endif ! if ice - !-------------------------------------------------------------------- end subroutine li_velocity_external_solve @@ -537,7 +554,7 @@ subroutine li_velocity_external_finalize(err) !----------------------------------------------------------------- err = 0 -print *, 'dfghjkhgfhjgf' + #if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) ! This call is needed for using any of the external velocity solvers ! call velocity_solver_finalize() From 2450c08c6c789a9b17d92d87238ee3b731b4c9c3 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 21 Apr 2015 10:38:17 -0600 Subject: [PATCH 0044/1724] LI: Have diffusivity use uReconstructZonal/Meridional This eliminates the restriction that this can only be computed on a plane. This takes advantage of the fact that mpas_reconstruct assigns uReconstructZonal/uReconstructMeridional equal to uReconstructX/Y for planar meshes. I.e, uReconstructZonal/uReconstructMeridional always contain orthogonal components of the vector in the plane of interest, whereas uReconstructX/Y will only be applicable to planar meshes. So using uReconstructZonal/uReconstructMeridional eliminates the need to include logic for sphere vs. plane. --- src/core_landice/Registry.xml | 8 +++ src/core_landice/mpas_li_diagnostic_vars.F | 67 +++++++++++----------- 2 files changed, 43 insertions(+), 32 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index cc910dce57..8182031ef0 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -745,6 +745,14 @@ is the value of that variable from the *previous* time level! description="generic work array with dimensions of (nCells)" persistence="scratch" /> + + where h is surface elevation, D is diffusivity, U is 2-d velocity vector, and H is thickness !> Solving for D = UH/-grad h !> DCFL: dt = 0.5 * dx**2 / D = 0.5 * dx**2 * slopemag / flux_downslope +! !----------------------------------------------------------------------- subroutine li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool, geometryPool, allowableDiffDt) use mpas_vector_reconstruction @@ -218,21 +219,20 @@ subroutine li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool ! local variables !----------------------------------------------------------------- real (kind=RKIND), dimension(:), pointer :: normalSlopeEdge - type (field1dReal), pointer :: cellJunk - type (field1dReal), pointer :: slopeCellXField - type (field1dReal), pointer :: slopeCellYField - real (kind=RKIND), dimension(:), pointer :: slopeCellX, slopeCellY + type (field1dReal), pointer :: slopeReconstructXField, slopeReconstructYField, slopeReconstructZField !< Only needed for calling mpas_reconstruct, but not actually used here + type (field1dReal), pointer :: slopeCellAxis1Field + type (field1dReal), pointer :: slopeCellAxis2Field + real (kind=RKIND), dimension(:), pointer :: slopeCellAxis1, slopeCellAxis2 real (kind=RKIND), dimension(:,:), pointer :: layerThickness - real (kind=RKIND), dimension(:,:), pointer :: uReconstructX, uReconstructY + real (kind=RKIND), dimension(:,:), pointer :: uReconstructAxis1, uReconstructAxis2 real (kind=RKIND), dimension(:), pointer :: apparentDiffusivity real (kind=RKIND), dimension(:), pointer :: dcEdge integer, dimension(:), pointer :: cellMask integer, dimension(:), pointer :: nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnCell integer, pointer :: nCells, nVertLevels - logical, pointer :: on_a_sphere real (kind=RKIND) :: allowableDtHere - real (kind=RKIND) :: cellVeloX, cellVeloY + real (kind=RKIND) :: fluxVeloAxis1, fluxVeloAxis2 real (kind=RKIND) :: fluxDownslope real (kind=RKIND) :: slopeCellMagnitude real (kind=RKIND) :: dCell @@ -240,11 +240,6 @@ subroutine li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool real (kind=RKIND), parameter :: bigNumber = 1.0e16_RKIND ! This is ~300 million years in seconds, but it is small enough not too overflow real (kind=RKIND), parameter :: smallNumber = 1.0e-36 - call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) - if (on_a_sphere) then - write (stdErrUnit, *) "WARNING: Diffusive CFL cannot currently be calculated on a sphere." - return - endif ! get needed variables call mpas_pool_get_dimension(meshPool, 'nCells', nCells) @@ -257,37 +252,43 @@ subroutine li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness) call mpas_pool_get_array(geometryPool, 'apparentDiffusivity', apparentDiffusivity) call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) - call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX) - call mpas_pool_get_array(velocityPool, 'uReconstructY', uReconstructY) + call mpas_pool_get_array(velocityPool, 'uReconstructZonal', uReconstructAxis1) + call mpas_pool_get_array(velocityPool, 'uReconstructMeridional', uReconstructAxis2) call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) - call mpas_pool_get_field(scratchPool, 'workCell', cellJunk) - call mpas_allocate_scratch_field(cellJunk, .true.) - call mpas_pool_get_field(scratchPool, 'slopeCellX', slopeCellXField) - call mpas_allocate_scratch_field(slopeCellXField, .true.) - slopeCellX => slopeCellXField % array - call mpas_pool_get_field(scratchPool, 'slopeCellY', slopeCellYField) - call mpas_allocate_scratch_field(slopeCellYField, .true.) - slopeCellY => slopeCellYField % array + call mpas_pool_get_field(scratchPool, 'workCell', slopeReconstructXField) + call mpas_allocate_scratch_field(slopeReconstructXField, .true.) + call mpas_pool_get_field(scratchPool, 'workCell2', slopeReconstructYField) + call mpas_allocate_scratch_field(slopeReconstructYField, .true.) + call mpas_pool_get_field(scratchPool, 'workCell3', slopeReconstructZField) + call mpas_allocate_scratch_field(slopeReconstructZField, .true.) + call mpas_pool_get_field(scratchPool, 'slopeCellX', slopeCellAxis1Field) + call mpas_allocate_scratch_field(slopeCellAxis1Field, .true.) + slopeCellAxis1 => slopeCellAxis1Field % array + call mpas_pool_get_field(scratchPool, 'slopeCellY', slopeCellAxis2Field) + call mpas_allocate_scratch_field(slopeCellAxis2Field, .true.) + slopeCellAxis2 => slopeCellAxis2Field % array ! Initialize output allowableDiffDt = bigNumber ! Approximate slope at cell centers - + ! reconstruct routines set uReconstructZonal = uReconstructX; uReconstructMeridional = uReconstructY + ! for planar meshes, so those variables can be used as orthogonal components of the vector + ! in either the plane or sphere. This avoids needing to add logic for if we are on a sphere or not. call mpas_reconstruct(meshPool, normalSlopeEdge, & - slopeCellX, slopeCellY, cellJunk % array, & - cellJunk % array, cellJunk % array ) + slopeReconstructXField % array, slopeReconstructYField % array, slopeReconstructZField % array, & + slopeCellAxis1, slopeCellAxis2) ! Approximate flux at cell centers do iCell = 1, nCells - slopeCellMagnitude = sqrt(slopeCellX(iCell)**2 + slopeCellY(iCell)**2) + smallNumber + slopeCellMagnitude = sqrt(slopeCellAxis1(iCell)**2 + slopeCellAxis2(iCell)**2) + smallNumber fluxDownslope = 0.0_RKIND do iLevel = 1, nVertLevels - cellVeloX = (uReconstructX(iLevel, iCell) + uReconstructX(iLevel+1, iCell)) * 0.5_RKIND - cellVeloY = (uReconstructY(iLevel, iCell) + uReconstructY(iLevel+1, iCell)) * 0.5_RKIND - fluxDownslope = fluxDownslope + (-1.0_RKIND * slopeCellX(iCell) * cellVeloX - slopeCellY(iCell) * cellVeloY) * layerThickness(iLevel, iCell) /slopeCellMagnitude + fluxVeloAxis1 = (uReconstructAxis1(iLevel, iCell) + uReconstructAxis1(iLevel+1, iCell)) * 0.5_RKIND + fluxVeloAxis2 = (uReconstructAxis2(iLevel, iCell) + uReconstructAxis2(iLevel+1, iCell)) * 0.5_RKIND + fluxDownslope = fluxDownslope + (-1.0_RKIND * slopeCellAxis1(iCell) * fluxVeloAxis1 - slopeCellAxis2(iCell) * fluxVeloAxis2) * layerThickness(iLevel, iCell) / slopeCellMagnitude enddo apparentDiffusivity(iCell) = abs(fluxDownslope) / slopeCellMagnitude @@ -302,9 +303,11 @@ subroutine li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool allowableDiffDt = min(allowableDiffDt, allowableDtHere) enddo - call mpas_deallocate_scratch_field(cellJunk, .true.) - call mpas_deallocate_scratch_field(slopeCellXField, .true.) - call mpas_deallocate_scratch_field(slopeCellYField, .true.) + call mpas_deallocate_scratch_field(slopeReconstructXField, .true.) + call mpas_deallocate_scratch_field(slopeReconstructYField, .true.) + call mpas_deallocate_scratch_field(slopeReconstructZField, .true.) + call mpas_deallocate_scratch_field(slopeCellAxis1Field, .true.) + call mpas_deallocate_scratch_field(slopeCellAxis2Field, .true.) !-------------------------------------------------------------------- end subroutine li_calculate_apparent_diffusivity From 81f3190e8580831331b68fe737f011f586c9c0dc Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 21 Apr 2015 11:19:46 -0600 Subject: [PATCH 0045/1724] LI: Eliminate "no timeLevel argument given" errors from log.err This commit specifies timeLevels when getting all variables that have multiple time levels so that the log*.err file does not report "no timeLevel argument given" errors. These changes do not change code behavior, as those errors were warnings that defaulted to getting the first time level (which is what was needed in all cases). --- src/core_landice/Registry.xml | 2 +- src/core_landice/mpas_li_diagnostic_vars.F | 4 ++-- src/core_landice/mpas_li_mask.F | 6 +++--- src/core_landice/mpas_li_sia.F | 2 +- src/core_landice/mpas_li_time_integration_fe.F | 12 ++++++------ src/core_landice/mpas_li_velocity_external.F | 2 +- 6 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 8182031ef0..b71d0a757e 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -579,7 +579,7 @@ is the value of that variable from the *previous* time level! - stateNew % tracers % array ! Tendencies @@ -472,7 +472,7 @@ subroutine update_prognostics(domain, deltat, err) layerThicknessNew = layerThicknessOld + layerThickness_tend * deltat - thicknessNew = sum(layerThicknessNew, 1) + thickness = sum(layerThicknessNew, 1) !Optionally print some information about the new thickness @@ -490,9 +490,9 @@ subroutine update_prognostics(domain, deltat, err) !!! endif ! reset negative thickness to 0. This should not happen unless negative MB is larger than entire ice column. - where (thicknessNew < 0.0_RKIND) + where (thickness < 0.0_RKIND) masktmp = 1 - thicknessNew = 0.0_RKIND + thickness = 0.0_RKIND !!! stateNew % iceArea % array = 0.0_RKIND end where @@ -503,7 +503,7 @@ subroutine update_prognostics(domain, deltat, err) ! Note how many cells have ice. masktmp = 0 - where (thicknessNew > 0.0_RKIND) + where (thickness > 0.0_RKIND) masktmp = 1 end where write(stdoutUnit,*) ' Cells with nonzero thickness:', sum(masktmp) diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index e2fb596f67..2e755e9486 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -391,7 +391,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) ! Geometry variables - call mpas_pool_get_array(geometryPool, 'thickness', thickness, timeLevel = 1) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) call mpas_pool_get_array(geometryPool, 'lowerSurface', lowerSurface) call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface) call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel = 1) From 9ba0acf1a52fdd6e125e4a515e71d2bd325508da Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 21 Apr 2015 13:01:56 -0600 Subject: [PATCH 0046/1724] LI: Create new variable 'deltat' to record the timestep used --- src/core_landice/Registry.xml | 5 ++++- src/core_landice/mpas_li_time_integration.F | 10 +++++----- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index b71d0a757e..c3cf883c20 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -566,10 +566,13 @@ is the value of that variable from the *previous* time level! - + + diff --git a/src/core_landice/mpas_li_time_integration.F b/src/core_landice/mpas_li_time_integration.F index 25baf15e68..82d374aaa5 100644 --- a/src/core_landice/mpas_li_time_integration.F +++ b/src/core_landice/mpas_li_time_integration.F @@ -103,6 +103,8 @@ subroutine li_timestep(domain, err) character (len=StrKIND), pointer :: xtime character (len=StrKIND), pointer :: config_time_integration logical, pointer :: config_adaptive_timestep + real (kind=RKIND), pointer :: deltat_output !< variable used for output, in seconds + type (MPAS_TimeInterval_type) :: timeStepInterval !< the current time step as an interval real (kind=RKIND) :: dtSeconds !< the current time step in seconds type (MPAS_Time_Type) :: currTime !< current time as time type @@ -189,11 +191,9 @@ subroutine li_timestep(domain, err) call mpas_pool_get_array(meshPool, 'xtime', xtime) xtime = timeStamp -! ! Abort the simulation if NaNs occur in the velocity field -! if (isNaN(sum(block % state % time_levs(2) % state % u % array))) then -! write(stderrUnit,*) 'Abort: NaN detected' -! call mpas_dmpar_abort(dminfo) -! endif + call mpas_pool_get_array(meshPool, 'deltat', deltat_output) + deltat_output = dtSeconds + block => block % next end do From 36496327a427186152a596f4e194ed4022250f72 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 21 Apr 2015 13:24:35 -0600 Subject: [PATCH 0047/1724] LI: Update adaptive timestep default fraction to 0.25 Also add some more comments about code organization. --- src/core_landice/Registry.xml | 2 +- src/core_landice/mpas_li_diagnostic_vars.F | 5 +++++ src/core_landice/mpas_li_time_integration_fe.F | 11 +++++++++++ 3 files changed, 17 insertions(+), 1 deletion(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index c3cf883c20..f578e732f7 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -139,7 +139,7 @@ description="The maximum allowable time step in seconds. If the CFL condition allows the time step to be longer than this, then the model uses this value instead. Defaults to 100 years (in seconds)." possible_values="Any non-negative real value." /> - diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index 061e737d43..a88333eb1f 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -240,6 +240,11 @@ subroutine li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool real (kind=RKIND), parameter :: bigNumber = 1.0e16_RKIND ! This is ~300 million years in seconds, but it is small enough not too overflow real (kind=RKIND), parameter :: smallNumber = 1.0e-36 + ! Note: This routine could be broken into 2: one to calculate diffusivity + ! and another to get the diffusive CFL timestep. In that case, the first (and possibly the second) + ! could be moved to diagnostic_variable_solve_after_velocity. However, since + ! diffusivity is only used for this check, I don't think it makes sense to separate these + ! calculations for now. ! get needed variables call mpas_pool_get_dimension(meshPool, 'nCells', nCells) diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index 1ef2ae4527..de3a020444 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -242,6 +242,17 @@ subroutine calculate_tendencies(domain, dtSeconds, err) call li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool, geometryPool, allowableDiffDt) allowableDiffDtOnProc = min(allowableDiffDtOnProc, allowableDiffDt) endif + ! Note: The calculation of the ACFL and DCFL timesteps could be calculated in + ! diagnostic_variables_solve_after_velocity. In that case, we could also add + ! variables to store their values, rather than just relying on the values + ! written to the log files. However, the current logic only calculates these + ! values if certain config options are set, so that would need to be dealt with. + ! If the ACFL and DCFL timesteps are moved to diagnostic_variables_solve_after_velocity, + ! Then the setting of the timestep value could happen at the beginning of the timestep, + ! probably in li_timestep rather than here. That might be cleaner, but I have + ! persisted with doing it here, because since the calculation of ACFL/DCFL have a lot + ! in common with the advection calculation, and it seems kind of silly to do those calculations + ! on the previous time step. That said, the calculations are pretty cheap. block => block % next end do From 720506cb293848fdb880e2562cacf31e11335be1 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 21 Apr 2015 15:40:16 -0600 Subject: [PATCH 0048/1724] LI: Add config_adaptive_timestep_force_interval option This allow the user to specify an interval at which the clock should hit when using the adaptive time stepper. This can be used to ensure that the model would output at specified intervals, or for coupling to a climate model to ensure that the model will run for exactly the coupling interval and not longer. --- src/core_landice/Registry.xml | 4 +++ src/core_landice/mpas_li_core.F | 26 +++++++++++++++- .../mpas_li_time_integration_fe.F | 30 +++++++++++++++++-- 3 files changed, 56 insertions(+), 4 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index f578e732f7..0686b551ca 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -147,6 +147,10 @@ description="Option of whether to include the diffusive CFL condition in the determination of the maximum allowable timestep." possible_values=".true. or .false." /> + diff --git a/src/core_landice/mpas_li_core.F b/src/core_landice/mpas_li_core.F index 80c263871b..ace9caa36d 100644 --- a/src/core_landice/mpas_li_core.F +++ b/src/core_landice/mpas_li_core.F @@ -408,6 +408,14 @@ function li_core_run(domain) result(err) block => block % next end do + ! Reset the alarm for checking for force setting of the adaptive timestep interval + if (mpas_is_alarm_ringing(domain % clock, 'adaptiveTimestepForceInterval', ierr=err_tmp)) then + err = ior(err, err_tmp) + call mpas_reset_clock_alarm(domain % clock, 'adaptiveTimestepForceInterval', ierr=err_tmp) + err = ior(err, err_tmp) + endif + err = ior(err, err_tmp) + ! === error check and exit call mpas_dmpar_max_int(domain % dminfo, err, globalErr) ! Find out if any blocks got an error if (globalErr > 0) then @@ -668,8 +676,10 @@ subroutine li_simulation_clock_init(core_clock, configs, ierr) !----------------------------------------------------------------- type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep - character (len=StrKIND), pointer :: config_start_time, config_run_duration, config_stop_time ! MPAS standard configs + type (MPAS_TimeInterval_type) :: adaptDtForceInterval + character (len=StrKIND), pointer :: config_start_time, config_run_duration, config_stop_time, config_output_interval, config_restart_interval ! MPAS standard configs character (len=StrKIND), pointer :: config_dt ! MPAS LI-specific config option + character (len=StrKIND), pointer :: config_adaptive_timestep_force_interval ! MPAS LI-specific config option character (len=StrKIND), pointer :: config_restart_timestamp_name character (len=StrKIND) :: restartTimeStamp !< string to be read from file integer, pointer :: config_year_digits @@ -688,6 +698,7 @@ subroutine li_simulation_clock_init(core_clock, configs, ierr) call mpas_pool_get_config(configs, 'config_run_duration', config_run_duration) call mpas_pool_get_config(configs, 'config_stop_time', config_stop_time) call mpas_pool_get_config(configs, 'config_restart_timestamp_name', config_restart_timestamp_name) + call mpas_pool_get_config(configs, 'config_adaptive_timestep_force_interval', config_adaptive_timestep_force_interval) ! Set time to the user-specified start time OR use a restart time from file @@ -730,6 +741,19 @@ subroutine li_simulation_clock_init(core_clock, configs, ierr) ierr = 1 end if + ! Set up the adaptiveTimestepForceInterval alarm. + ! This is only needed if the adaptive time stepper is being used, but can be set up regardless. + call mpas_set_timeInterval(adaptDtForceInterval, timeString=config_adaptive_timestep_force_interval, ierr=err_tmp) + ierr = ior(ierr,err_tmp) + call mpas_add_clock_alarm(core_clock, 'adaptiveTimestepForceInterval', alarmTime=startTime, alarmTimeInterval=adaptDtForceInterval, ierr=err_tmp) + ierr = ior(ierr,err_tmp) + ! Reset the alarm for checking for force setting of the adaptive timestep interval + if (mpas_is_alarm_ringing(core_clock, 'adaptiveTimestepForceInterval', ierr=err_tmp)) then + ierr = ior(ierr, err_tmp) + call mpas_reset_clock_alarm(core_clock, 'adaptiveTimestepForceInterval', ierr=err_tmp) + ierr = ior(ierr, err_tmp) + endif + ierr = ior(ierr, err_tmp) ! === error check if (ierr > 0) then diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index de3a020444..9845576679 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -344,7 +344,7 @@ subroutine calculate_tendencies(domain, dtSeconds, err) ! Set adaptive timestep - call set_timestep(allowableAdvecDtAllProcs, allowableDiffDtAllProcs, dtSeconds, err_tmp) + call set_timestep(allowableAdvecDtAllProcs, allowableDiffDtAllProcs, domain % clock, dtSeconds, err_tmp) err = ior(err,err_tmp) @@ -566,12 +566,15 @@ end subroutine update_prognostics !> This routine sdjusts the time step based on the CFL condition. ! !----------------------------------------------------------------------- - subroutine set_timestep(allowableAdvecDt, allowableDiffDt, dtSeconds, err) + subroutine set_timestep(allowableAdvecDt, allowableDiffDt, clock, dtSeconds, err) + use mpas_timekeeping + !----------------------------------------------------------------- ! input variables !----------------------------------------------------------------- real (kind=RKIND) :: allowableAdvecDt real (kind=RKIND) :: allowableDiffDt + type (MPAS_Clock_type), intent(in) :: clock !----------------------------------------------------------------- ! output variables @@ -587,7 +590,15 @@ subroutine set_timestep(allowableAdvecDt, allowableDiffDt, dtSeconds, err) real (kind=RKIND), pointer :: config_adaptive_timestep_CFL_fraction real (kind=RKIND), pointer :: config_max_adaptive_timestep real (kind=RKIND), pointer :: config_min_adaptive_timestep + type (MPAS_Time_type) :: nextForceTime, currTime + type (MPAS_TimeInterval_type) :: intervalToNextForceTime + real (kind=RKIND) :: secondsToNextForceTime real (kind=RKIND) :: allowableDt + real (kind=RKIND) :: proposedDt + integer :: err_tmp + + err = 0 + err_tmp = 0 call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep', config_adaptive_timestep) @@ -602,8 +613,21 @@ subroutine set_timestep(allowableAdvecDt, allowableDiffDt, dtSeconds, err) else allowableDt = allowableAdvecDt endif + proposedDt = min(allowableDt * config_adaptive_timestep_CFL_fraction, config_max_adaptive_timestep) + + ! Check if we need to force a timestep length to hit the target interval + currTime = mpas_get_clock_time(clock, MPAS_NOW, err_tmp) + !print *, 'curr', currTime % t % YR, currTime % t % basetime % S + err = ior(err,err_tmp) + nextForceTime = mpas_alarm_get_next_ring_time(clock, 'adaptiveTimestepForceInterval') + !print *, 'ring', nextForceTime % t % YR, nextForceTime % t % basetime % S + intervalToNextForceTime = nextForceTime - currTime + !print *, 'int', intervalToNextForceTime % ti % YR, intervalToNextForceTime % ti % MM, intervalToNextForceTime % ti % basetime % S + call mpas_get_timeInterval(intervalToNextForceTime, dt=secondsToNextForceTime, ierr=err_tmp) + err = ior(err,err_tmp) + !print *, proposedDt, secondsToNextForceTime + dtSeconds = min(proposedDt, secondsToNextForceTime) - dtSeconds = min(allowableDt * config_adaptive_timestep_CFL_fraction, config_max_adaptive_timestep) write(stdOutUnit,*) ' Setting time step (days) to:', dtSeconds / (86400.0) if (dtSeconds < config_min_adaptive_timestep) then write(stdErrUnit,*) 'ERROR: New deltat is less than config_min_adaptive_timestep.' From b95456ba0cbe50288d66ebb978e9a8e8bf87b5a5 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Wed, 22 Apr 2015 15:40:24 -0600 Subject: [PATCH 0049/1724] LI: Include tiny roundoff factor in intervalToNextForceTime In the adaptive time stepper, if we are trying to git a force time, we may end up just shy of the target due to roundoff errors. To avoid this, add one to the numerator of the fractional seconds to make sure we get pushed over the edge. The way ESMF does fractional seconds, this means we get the desired interval to better than 1 part per 100 million seconds. Note that even though this is a *very* tiny fudge factor, it does not affect conservation within MPAS-LI, but it could have a very, very tiny effect on a climate model that thinks we ran for, say, 10 years, but we actually ran for 10 years +/- 1e-8 seconds. --- src/core_landice/mpas_li_time_integration_fe.F | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index 9845576679..63f1f740e1 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -617,12 +617,21 @@ subroutine set_timestep(allowableAdvecDt, allowableDiffDt, clock, dtSeconds, err ! Check if we need to force a timestep length to hit the target interval currTime = mpas_get_clock_time(clock, MPAS_NOW, err_tmp) - !print *, 'curr', currTime % t % YR, currTime % t % basetime % S + !print *, 'curr', currTime % t % YR, currTime % t % basetime % S, currTime % t % basetime % Sn, currTime % t % basetime % Sd err = ior(err,err_tmp) nextForceTime = mpas_alarm_get_next_ring_time(clock, 'adaptiveTimestepForceInterval') - !print *, 'ring', nextForceTime % t % YR, nextForceTime % t % basetime % S + !print *, 'ring', nextForceTime % t % YR, nextForceTime % t % basetime % S, nextForceTime % t % basetime % Sn, nextForceTime % t % basetime % Sd intervalToNextForceTime = nextForceTime - currTime - !print *, 'int', intervalToNextForceTime % ti % YR, intervalToNextForceTime % ti % MM, intervalToNextForceTime % ti % basetime % S + !print *, 'int', intervalToNextForceTime % ti % YR, intervalToNextForceTime % ti % MM, intervalToNextForceTime % ti % basetime % S, intervalToNextForceTime % ti % basetime % Sn, intervalToNextForceTime % ti % basetime % Sd + ! Due to roundoff errors, we might be just shy of the desired time. + ! To avoid this, add one to the numerator of the fractional seconds to + ! make sure we get pushed over the edge. The way ESMF does fractional + ! seconds, this means we get the desired interval to better than 1 part per 100 million seconds + ! Note that even though this is a *very* tiny fudge factor, it does not + ! affect conservation within MPAS-LI, but it could have a very, very tiny + ! effect on a climate model that thinks we ran for, say, 10 years, but we + ! actually ran for 10 years +/- 1e-8 seconds. + intervalToNextForceTime % ti % basetime % Sn = intervalToNextForceTime % ti % basetime % Sn + 1 call mpas_get_timeInterval(intervalToNextForceTime, dt=secondsToNextForceTime, ierr=err_tmp) err = ior(err,err_tmp) !print *, proposedDt, secondsToNextForceTime From 202248f0cff8816c162f03e85606adfff75256f9 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Wed, 22 Apr 2015 16:38:11 -0600 Subject: [PATCH 0050/1724] LI: Use distinct arguments to mpas_dmpar_max_int to eliminate MPI error Some MPI implementation complain if the two arguments to a max are the same. --- src/core_landice/mpas_li_time_integration_fe.F | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index 63f1f740e1..9980626bd3 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -200,11 +200,11 @@ subroutine calculate_tendencies(domain, dtSeconds, err) logical, pointer :: config_print_thickness_advection_info logical, pointer :: config_adaptive_timestep logical, pointer :: config_adaptive_timestep_include_DCFL - integer :: allowableAdvecDtProcNumber + integer :: allowableAdvecDtProcNumberHere, allowableAdvecDtProcNumber real (kind=RKIND) :: allowableAdvecDt, allowableAdvecDtOnProc, allowableAdvecDtAllProcs type (MPAS_TimeInterval_type) :: allowableAdvecDtOnProcInterval, allowableAdvecDtAllProcsInterval character (len=StrKIND) :: allowableAdvecDtOnProcString, allowableAdvecDtAllProcsString - integer :: allowableDiffDtProcNumber + integer :: allowableDiffDtProcNumberHere, allowableDiffDtProcNumber real (kind=RKIND) :: allowableDiffDt, allowableDiffDtOnProc, allowableDiffDtAllProcs type (MPAS_TimeInterval_type) :: allowableDiffDtOnProcInterval, allowableDiffDtAllProcsInterval character (len=StrKIND) :: allowableDiffDtOnProcString, allowableDiffDtAllProcsString @@ -306,11 +306,11 @@ subroutine calculate_tendencies(domain, dtSeconds, err) call mpas_dmpar_min_real(dminfo, allowableAdvecDtOnProc, allowableAdvecDtAllProcs) ! Determine which processor has the limiting CFL if (allowableAdvecDtOnProc == allowableAdvecDtAllProcs) then - allowableAdvecDtProcNumber = dminfo % my_proc_id + allowableAdvecDtProcNumberHere = dminfo % my_proc_id else - allowableAdvecDtProcNumber = -1 + allowableAdvecDtProcNumberHere = -1 endif - call mpas_dmpar_max_int(dminfo, allowableAdvecDtProcNumber, allowableAdvecDtProcNumber) + call mpas_dmpar_max_int(dminfo, allowableAdvecDtProcNumberHere, allowableAdvecDtProcNumber) call mpas_set_timeInterval(allowableAdvecDtAllProcsInterval, dt=allowableAdvecDtAllProcs, ierr=err_tmp) err = ior(err,err_tmp) call mpas_get_timeInterval(allowableAdvecDtAllProcsInterval, timeString=allowableAdvecDtAllProcsString, ierr=err_tmp) @@ -322,11 +322,11 @@ subroutine calculate_tendencies(domain, dtSeconds, err) call mpas_dmpar_min_real(dminfo, allowableDiffDtOnProc, allowableDiffDtAllProcs) ! Determine which processor has the limiting CFL if (allowableDiffDtOnProc == allowableDiffDtAllProcs) then - allowableDiffDtProcNumber = dminfo % my_proc_id + allowableDiffDtProcNumberHere = dminfo % my_proc_id else - allowableDiffDtProcNumber = -1 + allowableDiffDtProcNumberHere = -1 endif - call mpas_dmpar_max_int(dminfo, allowableDiffDtProcNumber, allowableDiffDtProcNumber) + call mpas_dmpar_max_int(dminfo, allowableDiffDtProcNumberHere, allowableDiffDtProcNumber) call mpas_set_timeInterval(allowableDiffDtAllProcsInterval, dt=allowableDiffDtAllProcs, ierr=err_tmp) err = ior(err,err_tmp) call mpas_get_timeInterval(allowableDiffDtAllProcsInterval, timeString=allowableDiffDtAllProcsString, ierr=err_tmp) From 54e193f38e03c6ec1063afc5d51fe9f063e1d496 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Sun, 26 Apr 2015 11:27:23 -0600 Subject: [PATCH 0051/1724] LI: Err if config_stop_time is earlier than config_start_time Otherwise simulation will run forever. --- src/core_landice/mpas_li_core.F | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/core_landice/mpas_li_core.F b/src/core_landice/mpas_li_core.F index ace9caa36d..0fd63193c2 100644 --- a/src/core_landice/mpas_li_core.F +++ b/src/core_landice/mpas_li_core.F @@ -717,7 +717,8 @@ subroutine li_simulation_clock_init(core_clock, configs, ierr) call mpas_set_timeInterval(timeStep, timeString=config_dt, ierr=err_tmp) ierr = ior(ierr,err_tmp) - + ! Setup start/stop/duration times + ! config_run_duration takes precedence over config_stop_time if (trim(config_run_duration) /= "none") then call mpas_set_timeInterval(runDuration, timeString=config_run_duration, ierr=err_tmp) ierr = ior(ierr,err_tmp) @@ -734,11 +735,15 @@ subroutine li_simulation_clock_init(core_clock, configs, ierr) else if (trim(config_stop_time) /= "none") then call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=err_tmp) ierr = ior(ierr,err_tmp) + if (stopTime .lt. startTime) then + write(stderrUnit,*) 'Error: config_stop_time is earlier than config_start_time!' + ierr = 1 + endif call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=err_tmp) ierr = ior(ierr,err_tmp) else - write(stderrUnit,*) 'Error: Neither config_run_duration nor config_stop_time were specified.' - ierr = 1 + write(stderrUnit,*) 'Error: Neither config_run_duration nor config_stop_time were specified.' + ierr = 1 end if ! Set up the adaptiveTimestepForceInterval alarm. From 825c84f59351aaec202a5df3946eb3c6a4dcecd1 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Sun, 26 Apr 2015 12:41:42 -0600 Subject: [PATCH 0052/1724] LI: Zero velo on uphill margin edges Don't allow normalVelocity on edges where an unglaciated cell with higher elevation neighbors a glaciated cell. Some velocity solvers could generate a nonzero velocity on these edges. In the case of a velocity directed into the ice sheet, this probably does no harm for advection because there is no ice to advect in, but it could result in overly restrictive advective CFL conditions. In the case of velocity directed out of the ice sheet, this would result in uphill flow which is highly unlikely to be physically correct. (It could be possible in a HO stress balance where stress transfer 'overrides' the driving stress, but this seems unlikely to be significant.) Therefore, always zero velocity in these situations. --- src/core_landice/mpas_li_mask.F | 42 +++++++++++++++++++++++++++++ src/core_landice/mpas_li_velocity.F | 35 ++++++++++++++++++++++-- 2 files changed, 75 insertions(+), 2 deletions(-) diff --git a/src/core_landice/mpas_li_mask.F b/src/core_landice/mpas_li_mask.F index 9bcf23698a..f7f870ef7f 100644 --- a/src/core_landice/mpas_li_mask.F +++ b/src/core_landice/mpas_li_mask.F @@ -77,6 +77,18 @@ module li_mask end interface + interface li_mask_is_dynamic_margin + module procedure li_mask_is_dynamic_margin_logout_1d + module procedure li_mask_is_dynamic_margin_logout_0d + end interface + + + interface li_mask_is_dynamic_margin_int + module procedure li_mask_is_dynamic_margin_logout_1d + module procedure li_mask_is_dynamic_margin_logout_0d + end interface + + interface li_mask_is_floating_ice module procedure li_mask_is_floating_ice_logout_1d module procedure li_mask_is_floating_ice_logout_0d @@ -545,6 +557,36 @@ function li_mask_is_dynamic_ice_intout_0d(mask) end function li_mask_is_dynamic_ice_intout_0d + ! -- Functions that check for presence of dynamic margin -- + function li_mask_is_dynamic_margin_logout_1d(mask) + integer, dimension(:), intent(in) :: mask + logical, dimension(size(mask)) :: li_mask_is_dynamic_margin_logout_1d + + li_mask_is_dynamic_margin_logout_1d = (iand(mask, li_mask_ValueDynamicIce) == li_mask_ValueDynamicIce) + end function li_mask_is_dynamic_margin_logout_1d + + function li_mask_is_dynamic_margin_logout_0d(mask) + integer, intent(in) :: mask + logical :: li_mask_is_dynamic_margin_logout_0d + + li_mask_is_dynamic_margin_logout_0d = (iand(mask, li_mask_ValueDynamicIce) == li_mask_ValueDynamicIce) + end function li_mask_is_dynamic_margin_logout_0d + + function li_mask_is_dynamic_margin_intout_1d(mask) + integer, dimension(:), intent(in) :: mask + integer, dimension(size(mask)) :: li_mask_is_dynamic_margin_intout_1d + + li_mask_is_dynamic_margin_intout_1d = iand(mask, li_mask_ValueDynamicIce) / li_mask_ValueDynamicIce + end function li_mask_is_dynamic_margin_intout_1d + + function li_mask_is_dynamic_margin_intout_0d(mask) + integer, intent(in) :: mask + integer :: li_mask_is_dynamic_margin_intout_0d + + li_mask_is_dynamic_margin_intout_0d = iand(mask, li_mask_ValueDynamicIce) / li_mask_ValueDynamicIce + end function li_mask_is_dynamic_margin_intout_0d + + ! -- Functions that check for presence of floating ice -- function li_mask_is_floating_ice_logout_1d(mask) integer, dimension(:), intent(in) :: mask diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index 1a97d4ad63..ecb94b9896 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -249,11 +249,14 @@ subroutine li_velocity_solve(domain, err) logical, pointer :: config_do_velocity_reconstruction_for_external_dycore integer, pointer :: nEdgesSolve integer, pointer :: nVertInterfaces - integer, dimension(:), pointer :: edgeMask + integer, dimension(:), pointer :: edgeMask, cellMask real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional real (kind=RKIND), dimension(:), pointer :: surfaceSpeed, basalSpeed + integer, dimension(:,:), pointer :: cellsOnEdge + real (kind=RKIND), dimension(:), pointer :: upperSurface type (field2DReal), pointer :: normalVelocityField ! truly local variables + integer :: cell1, cell2 integer :: iEdge integer :: err_tmp @@ -294,8 +297,35 @@ subroutine li_velocity_solve(domain, err) end select err = ior(err, err_tmp) - ! Check if the velocity solver has returned a velocity on any non-dynamic edges + ! Some "quality control" of normalVelocity + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface) do iEdge = 1, nEdgesSolve + + ! Don't allow normalVelocity on edges where an unglaciated cell with + ! higher elevation neighbors a glaciated cell. Some velocity solvers + ! could generate a nonzero velocity on these edges. In the case of a + ! velocity directed into the ice sheet, this probably does no harm + ! for advection because there is no ice to advect in, but it could result + ! in overly restrictive advective CFL conditions. In the case of velocity + ! directed out of the ice sheet, this would result in uphill flow which is + ! highly unlikely to be physically correct. (It could be possible in a HO + ! stress balance where stress transfer 'overrides' the driving stress, but + ! this seems unlikely to be significant.) Therefore, always zero velocity + ! in these situations. + if ( li_mask_is_dynamic_margin(edgeMask(iEdge)) ) then + cell1 = cellsOnEdge(1, iEdge) + cell2 = cellsOnEdge(1, iEdge) + if ( ( li_mask_is_dynamic_ice(cellMask(cell1)) .and. & + upperSurface(cell2) > upperSurface(cell1) ) .or. & + ( li_mask_is_dynamic_ice(cellMask(cell2)) .and. & + upperSurface(cell1) > upperSurface(cell2) ) ) then + normalVelocity(:, iEdge) = 0.0_RKIND + endif + endif + + ! Check if the velocity solver has returned a velocity on any non-dynamic edges if ( li_mask_is_ice(edgeMask(iEdge)) .and. & (.not.(li_mask_is_dynamic_ice(edgeMask(iEdge)))) .and. & (maxval(abs(normalVelocity(:,iEdge))) /= 0.0_RKIND) & @@ -303,6 +333,7 @@ subroutine li_velocity_solve(domain, err) err_tmp= 1 !!!normalVelocity(:,iEdge) = 0.0_RKIND ! this is a hack because the rest of the code requires this, but this condition should really cause a fatal error. endif + enddo if (err_tmp == 1) then write(stderrUnit,*) 'Error: Velocity has been calculated on non-dynamic edges. There is a problem with the velocity solver.' !!! Velocity on those edges have been set to 0, but this should be a fatal error.' From b18508b76fd29f9aa07b84a8c79d7004ad12a49e Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 27 Apr 2015 12:57:29 -0600 Subject: [PATCH 0053/1724] LI: Make ext. dycore output optional --- src/core_landice/Registry.xml | 4 +++ src/core_landice/mpas_li_velocity_external.F | 26 +++++++++++++------- 2 files changed, 21 insertions(+), 9 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 0686b551ca..d795335f42 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -211,6 +211,10 @@ description="Integer specifying the number of digits used to represent the year in time strings." possible_values="Any positive integer value greater than 0." /> + diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index 2e755e9486..d0515d6eea 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -376,6 +376,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc character (len=StrKIND), pointer :: config_velocity_solver real (kind=RKIND), pointer :: config_dynamic_thickness logical, pointer :: config_always_compute_fem_grid + logical, pointer :: config_output_external_velocity_solver_data integer, pointer :: anyDynamicVertexMaskChanged integer, pointer :: dirichletMaskChanged real(kind=RKIND), parameter :: secondsInYear = 365.0 * 24.0 * 3600.0 !< The value of seconds in a year assumed by external dycores @@ -386,6 +387,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_config(liConfigs, 'config_always_compute_fem_grid', config_always_compute_fem_grid) call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) + call mpas_pool_get_config(liConfigs, 'config_output_external_velocity_solver_data', config_output_external_velocity_solver_data) ! Mesh variables call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) @@ -456,11 +458,14 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc normalVelocity, uReconstructX, uReconstructY) ! return values ! call velocity_solver_estimate_SS_SMB(normalVelocity, mesh % sfcMassBal % array) call mpas_timer_stop("velocity_solver_solve_L1L2") - ! Optional calls to have LifeV output data files - call mpas_timer_start("velocity_solver export") - call velocity_solver_export_2d_data(lowerSurface, thickness, beta) - call velocity_solver_export_L1L2_velocity(); - call mpas_timer_stop("velocity_solver export") + + if (config_output_external_velocity_solver_data) then + ! Optional calls to have LifeV output data files + call mpas_timer_start("velocity_solver export") + call velocity_solver_export_2d_data(lowerSurface, thickness, beta) + call velocity_solver_export_L1L2_velocity(); + call mpas_timer_stop("velocity_solver export") + endif #else write(stderrUnit,*) "Error: External LifeV library needed to run L1L2 dycore." err = 1 @@ -474,10 +479,13 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc uReconstructX, uReconstructY, & ! Dirichlet boundary values to apply where dirichletVelocityMask=1 normalVelocity, uReconstructX, uReconstructY) ! return values ! call velocity_solver_estimate_SS_SMB(normalVelocity, mesh % sfcMassBal % array) ! this was used only for some ice2sea experiments, and is not a general routine to use - call mpas_timer_stop("velocity_solver_solve_FO") - call mpas_timer_start("velocity_solver export") - call velocity_solver_export_FO_velocity() - call mpas_timer_stop("velocity_solver export") + + if (config_output_external_velocity_solver_data) then + call mpas_timer_stop("velocity_solver_solve_FO") + call mpas_timer_start("velocity_solver export") + call velocity_solver_export_FO_velocity() + call mpas_timer_stop("velocity_solver export") + endif #else write(stderrUnit,*) "Error: External library needed to run FO dycore." err = 1 From 1e2ae9ec4e8456842c8b896e7604f5690f780324 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 11 May 2015 16:27:19 -0600 Subject: [PATCH 0054/1724] Allow nondynamic 'inlet' edge case for velo check for nondynamic edges After external velocity solves return velocity, we check if the velocity solver has returned a velocity on any non-dynamic edges. We recently discovered an edge case where this is ok so this commit allows it without error. If there are two peninsulas of dynamic ice with a single 'row' of nondynamic cells between them, the FEM velo solver will likely calculate a nonzero velocity on an edge that has 0 thickness. The two FEM elements neighboring this edge have nonzero thickness everywhere except along this edge, and so there is no guarantee of zero-velocity on this edge. Schematically, this looks like: \ I / A |--e--| A / I \ where the lines are edges, and e is the edge with the issue. I's are inactive cells, and A's are active cells. So check for this specific situation before calling this an error. Additionally, set the edge velocity to 0 on these edges. --- src/core_landice/mpas_li_velocity.F | 85 ++++++++++++++++++++++++----- 1 file changed, 71 insertions(+), 14 deletions(-) diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index ecb94b9896..f41e86b3aa 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -253,11 +253,17 @@ subroutine li_velocity_solve(domain, err) real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional real (kind=RKIND), dimension(:), pointer :: surfaceSpeed, basalSpeed integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:,:), pointer :: cellsOnVertex + integer, dimension(:,:), pointer :: verticesOnEdge real (kind=RKIND), dimension(:), pointer :: upperSurface type (field2DReal), pointer :: normalVelocityField + integer, dimension(:), pointer :: indexToEdgeID ! truly local variables integer :: cell1, cell2 + integer :: cell3, cell4, thisCell + integer :: vertex1, vertex2 integer :: iEdge + integer :: iCell integer :: err_tmp call mpas_timer_start("velocity solve") @@ -271,17 +277,15 @@ subroutine li_velocity_solve(domain, err) ! External solvers do not support multiple blocks but the MPAS SIA solver does. block => domain % blocklist do while (associated(block)) + ! Get variables from pools call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) call mpas_pool_get_subpool(block % structs, 'thermal', thermalPool) call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) - - ! Get variables from pools call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) - call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) - call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) - call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) + + ! Solve velocity select case (config_velocity_solver) case ('none') ! Do nothing @@ -297,12 +301,73 @@ subroutine li_velocity_solve(domain, err) end select err = ior(err, err_tmp) + ! Some "quality control" of normalVelocity + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(meshPool, 'indexToEdgeID', indexToEdgeID) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface) + do iEdge = 1, nEdgesSolve + ! Check if the velocity solver has returned a velocity on any non-dynamic edges + if ( li_mask_is_ice(edgeMask(iEdge)) .and. & + (.not.(li_mask_is_dynamic_ice(edgeMask(iEdge)))) .and. & + (maxval(abs(normalVelocity(:,iEdge))) /= 0.0_RKIND) & + ) then + ! There is an edge case where this is ok. If there are two peninsulas of dynamic ice + ! with a single 'row' of nondynamic cells between them, the FEM velo solver will likely + ! calculate a nonzero velocity on an edge that has 0 thickness. The two FEM elements + ! neighboring this edge have nonzero thickness everywhere except along this edge, and + ! so there is no guarantee of zero-velocity on this edge. Schematically, this looks like: + ! + ! \ I / + ! A |--e--| A + ! / I \ + ! + ! where the lines are edges, and e is the edge with the issue. I's are inactive cells, and + ! A's are active cells. So check for this specific situation before calling this an error. + cell1 = cellsOnEdge(1, iEdge) + cell2 = cellsOnEdge(2, iEdge) + ! Criterion 1: both cells adjacent to edge are inactive + if ( ( .not. li_mask_is_dynamic_ice(cellMask(cell1)) ) .and. & + ( .not. li_mask_is_dynamic_ice(cellMask(cell2)) ) ) then + ! Criterion 2: both remaining cells adjacent to edge's vertices are active + vertex1 = verticesOnEdge(1, iEdge) + cell3 = -999 + do iCell = 1, 3 + thisCell = cellsOnVertex(iCell, vertex1) + if ((thisCell /= cell1) .and. (thisCell /= cell2)) then + cell3 = thisCell + exit ! we found the remaining cell on the vertex + endif + enddo + vertex2 = verticesOnEdge(2, iEdge) + cell4 = -999 + do iCell = 1, 3 + thisCell = cellsOnVertex(iCell, vertex2) + if ((thisCell /= cell1) .and. (thisCell /= cell2)) then + cell4 = thisCell + exit ! we found the remaining cell on the vertex + endif + enddo + if ( (li_mask_is_dynamic_ice(cellMask(cell3))) .and. & + (li_mask_is_dynamic_ice(cellMask(cell4))) ) then + write (stderrUnit,*) "Notice: External velocity solver returned a normalVelocity on a non-dynamic edge, but this is ok because the location is in a non-dynamic 'inlet'. normalVelocity has been set to 0 at this location. Location is edge index:", indexToEdgeID(iEdge) + normalVelocity(:,iEdge) = 0.0_RKIND + else + write (stderrUnit,*) 'ERROR: VELO ON NON-DYNAMIC EDGE, edge=', indexToEdgeID(iEdge) + err_tmp= 1 + !!!normalVelocity(:,iEdge) = 0.0_RKIND ! a hack to ignore this error. + endif ! Criterion 2 check + endif ! Criterion 1 check + endif + ! Don't allow normalVelocity on edges where an unglaciated cell with ! higher elevation neighbors a glaciated cell. Some velocity solvers ! could generate a nonzero velocity on these edges. In the case of a @@ -325,16 +390,8 @@ subroutine li_velocity_solve(domain, err) endif endif - ! Check if the velocity solver has returned a velocity on any non-dynamic edges - if ( li_mask_is_ice(edgeMask(iEdge)) .and. & - (.not.(li_mask_is_dynamic_ice(edgeMask(iEdge)))) .and. & - (maxval(abs(normalVelocity(:,iEdge))) /= 0.0_RKIND) & - ) then - err_tmp= 1 - !!!normalVelocity(:,iEdge) = 0.0_RKIND ! this is a hack because the rest of the code requires this, but this condition should really cause a fatal error. - endif - enddo + if (err_tmp == 1) then write(stderrUnit,*) 'Error: Velocity has been calculated on non-dynamic edges. There is a problem with the velocity solver.' !!! Velocity on those edges have been set to 0, but this should be a fatal error.' err = 1 From 1f0d0c5eb32c0e5b8a922dc0d367eb235238fa1b Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 11 May 2015 16:34:11 -0600 Subject: [PATCH 0055/1724] Fix bugs in check for nonzero velocity on 'uphill margin' This check was not working correctly for two reasons: 1. There was a typo in the line that gets cell2 2. The mask routine li_mask_is_dynamic_margin was decoding the wrong bit This commit also does some other minor cleanup, like fixing the comments describing how edgeMask bits are defined, and it adds a notice to stderr if the uphill margin adjustment is applied. --- src/core_landice/mpas_li_mask.F | 12 ++++++------ src/core_landice/mpas_li_velocity.F | 3 ++- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/core_landice/mpas_li_mask.F b/src/core_landice/mpas_li_mask.F index f7f870ef7f..c686a1f82b 100644 --- a/src/core_landice/mpas_li_mask.F +++ b/src/core_landice/mpas_li_mask.F @@ -384,8 +384,8 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) ! Bit: Edges with ice are ones with at least one adjacent cell with ice ! Bit: Edges with dynamic ice are ones with at least one adjacent cell with dynamic ice ! Bit: Floating Edges have at least one neighboring cell floating - ! Bit: Edges on margin are vertices with one neighboring cell with ice and one neighboring cell without ice - ! Bit: Edges on dynamic margin are vertices with at least one neighboring cell with dynamic ice and at least one neighboring cell without dynamic ice + ! Bit: Edges on margin are edges with one neighboring cell with ice and one neighboring cell without ice + ! Bit: Edges on dynamic margin are edges with one neighboring cell with dynamic ice and one neighboring cell without dynamic ice edgeMask = 0 do i = 1,nEdges aCellOnEdgeHasIce = .false. @@ -562,28 +562,28 @@ function li_mask_is_dynamic_margin_logout_1d(mask) integer, dimension(:), intent(in) :: mask logical, dimension(size(mask)) :: li_mask_is_dynamic_margin_logout_1d - li_mask_is_dynamic_margin_logout_1d = (iand(mask, li_mask_ValueDynamicIce) == li_mask_ValueDynamicIce) + li_mask_is_dynamic_margin_logout_1d = (iand(mask, li_mask_ValueDynamicMargin) == li_mask_ValueDynamicMargin) end function li_mask_is_dynamic_margin_logout_1d function li_mask_is_dynamic_margin_logout_0d(mask) integer, intent(in) :: mask logical :: li_mask_is_dynamic_margin_logout_0d - li_mask_is_dynamic_margin_logout_0d = (iand(mask, li_mask_ValueDynamicIce) == li_mask_ValueDynamicIce) + li_mask_is_dynamic_margin_logout_0d = (iand(mask, li_mask_ValueDynamicMargin) == li_mask_ValueDynamicMargin) end function li_mask_is_dynamic_margin_logout_0d function li_mask_is_dynamic_margin_intout_1d(mask) integer, dimension(:), intent(in) :: mask integer, dimension(size(mask)) :: li_mask_is_dynamic_margin_intout_1d - li_mask_is_dynamic_margin_intout_1d = iand(mask, li_mask_ValueDynamicIce) / li_mask_ValueDynamicIce + li_mask_is_dynamic_margin_intout_1d = iand(mask, li_mask_ValueDynamicMargin) / li_mask_ValueDynamicMargin end function li_mask_is_dynamic_margin_intout_1d function li_mask_is_dynamic_margin_intout_0d(mask) integer, intent(in) :: mask integer :: li_mask_is_dynamic_margin_intout_0d - li_mask_is_dynamic_margin_intout_0d = iand(mask, li_mask_ValueDynamicIce) / li_mask_ValueDynamicIce + li_mask_is_dynamic_margin_intout_0d = iand(mask, li_mask_ValueDynamicMargin) / li_mask_ValueDynamicMargin end function li_mask_is_dynamic_margin_intout_0d diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index f41e86b3aa..9898c512aa 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -381,11 +381,12 @@ subroutine li_velocity_solve(domain, err) ! in these situations. if ( li_mask_is_dynamic_margin(edgeMask(iEdge)) ) then cell1 = cellsOnEdge(1, iEdge) - cell2 = cellsOnEdge(1, iEdge) + cell2 = cellsOnEdge(2, iEdge) if ( ( li_mask_is_dynamic_ice(cellMask(cell1)) .and. & upperSurface(cell2) > upperSurface(cell1) ) .or. & ( li_mask_is_dynamic_ice(cellMask(cell2)) .and. & upperSurface(cell1) > upperSurface(cell2) ) ) then + write (stderrUnit,*) "Notice: A nonzero velocity has been calculated on an 'uphill' margin edge. Velocity here has been set to 0. Location is edge index:", indexToEdgeID(iEdge) normalVelocity(:, iEdge) = 0.0_RKIND endif endif From d5967793edd316db742adfae141b57456f9add93 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 12 May 2015 15:16:41 -0600 Subject: [PATCH 0056/1724] Calculate normalSlopeEdge if DCFL check is enabled w/HO dycore This adds normalSlopeEdge variable to calcDiffusivity package and calculates it if either velocity solver is SIA *or* the DCFL check is enabled. Without this fix if the adaptive time stepper is set to calculate diffusivity when a HO dycore is used, there is a segfault because normalSlopeEdge is not allocated or calculated. --- src/core_landice/Registry.xml | 2 +- src/core_landice/mpas_li_diagnostic_vars.F | 41 ++++++++++++---------- 2 files changed, 24 insertions(+), 19 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index d795335f42..efe695038e 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -628,7 +628,7 @@ is the value of that variable from the *previous* time level! description="elevation at top of ice on vertices" packages="SIAvelocity" /> Date: Tue, 12 May 2015 16:25:49 -0600 Subject: [PATCH 0057/1724] Move CFL error check to after adaptive timestep update The CFL check that sets an error if the timestep is too small was occurring before the adaptive timestepper was setting the new time step value. In most cases this did not lead to an error but could if the previous time step was longer than the current CFL criteria. This was also complicated by the fact that if the adaptive timestepper was being used, the variable dtSeconds was uninitialized. If the compiler initialized it to 0, there was no problem, but in optimized mode, the compiler I was testing was setting it to a large value, which triggered a CFL error because the updated value for dtSeconds had yet to be applied. I have also initialized the dtSeconds variable to 0 when the adaptive time stepper is used to avoid an error from tend_layerThickness_fo_upwind. --- src/core_landice/mpas_li_time_integration.F | 4 +++ .../mpas_li_time_integration_fe.F | 26 ++++++++++--------- 2 files changed, 18 insertions(+), 12 deletions(-) diff --git a/src/core_landice/mpas_li_time_integration.F b/src/core_landice/mpas_li_time_integration.F index 82d374aaa5..694bf9f1f7 100644 --- a/src/core_landice/mpas_li_time_integration.F +++ b/src/core_landice/mpas_li_time_integration.F @@ -137,6 +137,10 @@ subroutine li_timestep(domain, err) ! It may be possible to have them handled in the same place within li_tendency.F if we want to embed it that deeply.) call mpas_get_timeInterval(timeStepInterval, StartTimeIn=currTime, dt=dtSeconds, ierr=err_tmp) err = ior(err,err_tmp) + else + ! initialize the dt to 0 when using the adaptive timestepper + ! it will be set by the time stepper but needs to avoid triggering an error in tend_layerThickness_fo_upwind + dtSeconds = 0.0_RKIND endif diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index 9980626bd3..6a2049a7af 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -276,11 +276,6 @@ subroutine calculate_tendencies(domain, dtSeconds, err) write(stdoutUnit,*) ' Maximum allowable time step on THIS processor based on advective CFL is (Days_hhh:mmm:sss): ' // trim(allowableAdvecDtOnProcString) endif - if (dtSeconds > allowableAdvecDtOnProc) then - write(stderrUnit,*) 'ERROR: Advective CFL violation on this processor. Maximum allowable time step for this processor is (Days_hhh:mmm:sss): ' // trim(allowableAdvecDtOnProcString) - err = ior(err,1) - endif - ! Local diffusive CFL info if (config_adaptive_timestep_include_DCFL) then call mpas_set_timeInterval(allowableDiffDtOnProcInterval, dt=allowableDiffDtOnProc, ierr=err_tmp) @@ -291,10 +286,6 @@ subroutine calculate_tendencies(domain, dtSeconds, err) if (config_print_thickness_advection_info) then write(stdoutUnit,*) ' Maximum allowable time step on THIS processor based on diffusive CFL is (Days_hhh:mmm:sss): ' // trim(allowableDiffDtOnProcString) endif - - if (dtSeconds > allowableDiffDtOnProc) then - write(stderrUnit,*) 'WARNING: Diffusive CFL violation on this processor. Maximum allowable time step for this processor is (Days_hhh:mmm:sss): ' // trim(allowableDiffDtOnProcString) - endif endif @@ -348,6 +339,17 @@ subroutine calculate_tendencies(domain, dtSeconds, err) err = ior(err,err_tmp) + + ! Check for CFL error before finishing + if (dtSeconds > allowableAdvecDtOnProc) then + write(stderrUnit,*) 'ERROR: Advective CFL violation on this processor. Maximum allowable time step for this processor is (Days_hhh:mmm:sss): ' // trim(allowableAdvecDtOnProcString) + err = ior(err,1) + endif + ! Local diffusive CFL info + if ( (config_adaptive_timestep_include_DCFL) .and. (dtSeconds > allowableDiffDtOnProc) ) then + write(stderrUnit,*) 'WARNING: Diffusive CFL violation on this processor. Maximum allowable time step for this processor is (Days_hhh:mmm:sss): ' // trim(allowableDiffDtOnProcString) + endif + if (err > 0) then write(stderrUnit,*) 'Error in calculating thickness tendency (possibly CFL violation)' endif @@ -572,14 +574,14 @@ subroutine set_timestep(allowableAdvecDt, allowableDiffDt, clock, dtSeconds, err !----------------------------------------------------------------- ! input variables !----------------------------------------------------------------- - real (kind=RKIND) :: allowableAdvecDt - real (kind=RKIND) :: allowableDiffDt + real (kind=RKIND), intent(in) :: allowableAdvecDt + real (kind=RKIND), intent(in) :: allowableDiffDt type (MPAS_Clock_type), intent(in) :: clock !----------------------------------------------------------------- ! output variables !----------------------------------------------------------------- - real (kind=RKIND) :: dtSeconds + real (kind=RKIND), intent(out) :: dtSeconds integer, intent(out) :: err !< Output: error flag !----------------------------------------------------------------- From 312a14d857241ad2ce46c0e812c3915c7e77589f Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 14 May 2015 20:56:40 -0600 Subject: [PATCH 0058/1724] Add config_print_velocity_cleanup_details option This hides the detailed output added in the last two commits for situations where the normalVelocity fields needs to be cleaned up due to specific geometric configurations. This commit also introduces summary information of how many edges were adjusted, even if the detailed information is disabled. --- src/core_landice/Registry.xml | 4 ++++ src/core_landice/mpas_li_velocity.F | 22 ++++++++++++++++++++-- 2 files changed, 24 insertions(+), 2 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index d795335f42..51bc17f606 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -251,6 +251,10 @@ description="Always compute finite-element grid information for external dycores rather than only doing so when the ice extent changes." possible_values=".true. or .false." /> + diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index 9898c512aa..abddd98f5f 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -247,6 +247,7 @@ subroutine li_velocity_solve(domain, err) ! pointers to get from pools character (len=StrKIND), pointer :: config_velocity_solver logical, pointer :: config_do_velocity_reconstruction_for_external_dycore + logical, pointer :: config_print_velocity_cleanup_details integer, pointer :: nEdgesSolve integer, pointer :: nVertInterfaces integer, dimension(:), pointer :: edgeMask, cellMask @@ -264,6 +265,7 @@ subroutine li_velocity_solve(domain, err) integer :: vertex1, vertex2 integer :: iEdge integer :: iCell + integer :: inletEdgesFixed, uphillMarginEdgesFixed integer :: err_tmp call mpas_timer_start("velocity solve") @@ -273,6 +275,10 @@ subroutine li_velocity_solve(domain, err) call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_config(liConfigs, 'config_do_velocity_reconstruction_for_external_dycore', config_do_velocity_reconstruction_for_external_dycore) + call mpas_pool_get_config(liConfigs, 'config_print_velocity_cleanup_details', config_print_velocity_cleanup_details) + + inletEdgesFixed = 0 + uphillMarginEdgesFixed = 0 ! External solvers do not support multiple blocks but the MPAS SIA solver does. block => domain % blocklist @@ -358,8 +364,11 @@ subroutine li_velocity_solve(domain, err) enddo if ( (li_mask_is_dynamic_ice(cellMask(cell3))) .and. & (li_mask_is_dynamic_ice(cellMask(cell4))) ) then - write (stderrUnit,*) "Notice: External velocity solver returned a normalVelocity on a non-dynamic edge, but this is ok because the location is in a non-dynamic 'inlet'. normalVelocity has been set to 0 at this location. Location is edge index:", indexToEdgeID(iEdge) + if (config_print_velocity_cleanup_details) then + write (stderrUnit,*) "Notice: External velocity solver returned a nonzero normalVelocity on a non-dynamic edge, but this is ok because the location is in a non-dynamic 'inlet'. normalVelocity has been set to 0 at this location. Location is edge index:", indexToEdgeID(iEdge) + endif normalVelocity(:,iEdge) = 0.0_RKIND + inletEdgesFixed = inletEdgesFixed + 1 else write (stderrUnit,*) 'ERROR: VELO ON NON-DYNAMIC EDGE, edge=', indexToEdgeID(iEdge) err_tmp= 1 @@ -386,8 +395,11 @@ subroutine li_velocity_solve(domain, err) upperSurface(cell2) > upperSurface(cell1) ) .or. & ( li_mask_is_dynamic_ice(cellMask(cell2)) .and. & upperSurface(cell1) > upperSurface(cell2) ) ) then - write (stderrUnit,*) "Notice: A nonzero velocity has been calculated on an 'uphill' margin edge. Velocity here has been set to 0. Location is edge index:", indexToEdgeID(iEdge) + if (config_print_velocity_cleanup_details) then + write (stderrUnit,*) "Notice: Nonzero velocity has been calculated on an 'uphill' margin edge. normalVelocity here has been set to 0. Location is edge index:", indexToEdgeID(iEdge) + endif normalVelocity(:, iEdge) = 0.0_RKIND + uphillMarginEdgesFixed = uphillMarginEdgesFixed + 1 endif endif @@ -401,6 +413,12 @@ subroutine li_velocity_solve(domain, err) block => block % next end do + if (inletEdgesFixed > 0) then + write (stderrUnit,*) "Notice: External velocity solver returned a nonzero normalVelocity on non-dynamic edge(s), but this is ok because the location is in a non-dynamic 'inlet'. normalVelocity has been set to 0 at these location(s). Number of edges affected on this processor:", inletEdgesFixed + endif + if (uphillMarginEdgesFixed > 0) then + write (stderrUnit,*) "Notice: Nonzero velocity has been calculated on 'uphill' margin edge(s). normalVelocity has been set to 0 at these location(s). Number of edges affected on this processor:", uphillMarginEdgesFixed + endif ! --- ! --- update halos on velocity From c26fad85137fdc5c2b95c26b75f40652c2d68677 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 18 May 2015 11:25:46 -0600 Subject: [PATCH 0059/1724] Fix bug in HO velo check for no ice Commit d219fac introduced a check for if the domain has no dynamic ice, in which case external velocity solvers are not called. This is because external velocity solvers may abort if there is no ice. However, the implementation was written in a way that would cause problems (e.g. Albany hangs) if some procs have no dynamic ice but others do. This commit makes a more general implementation that properly handles that situation. --- src/core_landice/mpas_li_velocity.F | 59 ++++++++++++++++---- src/core_landice/mpas_li_velocity_external.F | 12 ---- 2 files changed, 47 insertions(+), 24 deletions(-) diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index abddd98f5f..8d225de1b6 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -248,10 +248,12 @@ subroutine li_velocity_solve(domain, err) character (len=StrKIND), pointer :: config_velocity_solver logical, pointer :: config_do_velocity_reconstruction_for_external_dycore logical, pointer :: config_print_velocity_cleanup_details + real (kind=RKIND), pointer :: config_dynamic_thickness integer, pointer :: nEdgesSolve integer, pointer :: nVertInterfaces integer, dimension(:), pointer :: edgeMask, cellMask real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional + real (kind=RKIND), dimension(:), pointer :: thickness real (kind=RKIND), dimension(:), pointer :: surfaceSpeed, basalSpeed integer, dimension(:,:), pointer :: cellsOnEdge integer, dimension(:,:), pointer :: cellsOnVertex @@ -267,6 +269,7 @@ subroutine li_velocity_solve(domain, err) integer :: iCell integer :: inletEdgesFixed, uphillMarginEdgesFixed integer :: err_tmp + real (kind=RKIND) :: maxThicknessOnProc, maxThicknessAllProcs call mpas_timer_start("velocity solve") @@ -276,10 +279,31 @@ subroutine li_velocity_solve(domain, err) call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_config(liConfigs, 'config_do_velocity_reconstruction_for_external_dycore', config_do_velocity_reconstruction_for_external_dycore) call mpas_pool_get_config(liConfigs, 'config_print_velocity_cleanup_details', config_print_velocity_cleanup_details) + call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) inletEdgesFixed = 0 uphillMarginEdgesFixed = 0 + + ! External solvers may not be able to cope with no ice in the domain, so determine if that is the case + ! Don't bother checking this with SIA because it requires an extra global reduce + if ( (trim(config_velocity_solver) == 'L1L2') .or. (trim(config_velocity_solver) == 'FO') .or. & + (trim(config_velocity_solver) == 'Stokes') ) then + maxThicknessOnProc = 0.0 ! initialize to 0 + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + maxThicknessOnProc = max(maxThicknessOnProc, maxval(thickness)) + + block => block % next + end do + + call mpas_dmpar_max_real(domain % dminfo, maxThicknessOnProc, maxThicknessAllProcs) + endif + + + ! External solvers do not support multiple blocks but the MPAS SIA solver does. block => domain % blocklist do while (associated(block)) @@ -288,7 +312,16 @@ subroutine li_velocity_solve(domain, err) call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) call mpas_pool_get_subpool(block % structs, 'thermal', thermalPool) call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) - call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(meshPool, 'indexToEdgeID', indexToEdgeID) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface) ! Solve velocity @@ -298,7 +331,19 @@ subroutine li_velocity_solve(domain, err) case ('sia') call li_sia_solve(meshPool, geometryPool, velocityPool, err_tmp) case ('L1L2', 'FO', 'Stokes') - call li_velocity_external_solve(meshPool, geometryPool, thermalPool, velocityPool, err_tmp) + if (maxThicknessAllProcs < config_dynamic_thickness) then + ! External dycores may not be able to handle case when there is no ice + call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX) + call mpas_pool_get_array(velocityPool, 'uReconstructY', uReconstructY) + call mpas_pool_get_array(velocityPool, 'uReconstructZ', uReconstructZ) + normalVelocity = 0.0_RKIND + uReconstructX = 0.0_RKIND + uReconstructY = 0.0_RKIND + uReconstructZ = 0.0_RKIND + write (stderrUnit,*) "Notice: Skipping velocity solve because there is no dynamic ice in domain." + else + call li_velocity_external_solve(meshPool, geometryPool, thermalPool, velocityPool, err_tmp) + endif case default write(stderrUnit,*) 'Error: ', trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 @@ -309,16 +354,6 @@ subroutine li_velocity_solve(domain, err) ! Some "quality control" of normalVelocity - call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) - call mpas_pool_get_array(velocityPool, 'normalVelocity', normalVelocity) - call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) - call mpas_pool_get_array(meshPool, 'indexToEdgeID', indexToEdgeID) - call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) - call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) - call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) - call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface) - do iEdge = 1, nEdgesSolve ! Check if the velocity solver has returned a velocity on any non-dynamic edges diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index d0515d6eea..c083644ded 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -374,7 +374,6 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc integer, dimension(:), pointer :: vertexMask, edgeMask, floatingEdges integer, dimension(:,:), pointer :: dirichletVelocityMask character (len=StrKIND), pointer :: config_velocity_solver - real (kind=RKIND), pointer :: config_dynamic_thickness logical, pointer :: config_always_compute_fem_grid logical, pointer :: config_output_external_velocity_solver_data integer, pointer :: anyDynamicVertexMaskChanged @@ -386,7 +385,6 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc ! configs call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_config(liConfigs, 'config_always_compute_fem_grid', config_always_compute_fem_grid) - call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) call mpas_pool_get_config(liConfigs, 'config_output_external_velocity_solver_data', config_output_external_velocity_solver_data) ! Mesh variables @@ -415,16 +413,6 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc call mpas_pool_get_array(velocityPool, 'floatingEdges', floatingEdges) - if (maxval(thickness) < config_dynamic_thickness) then - ! External dycores may not be able to handle case when there is no ice - normalVelocity = 0.0_RKIND - uReconstructX = 0.0_RKIND - uReconstructY = 0.0_RKIND - uReconstructZ = 0.0_RKIND - return - endif - - ! ================================================================== ! External dycore calls to be made only when vertex mask changes ! ================================================================== From 6e20828e72143ef837d9f6034c025294018e09ff Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 18 May 2015 11:34:14 -0600 Subject: [PATCH 0060/1724] Change mpas_dmpar_abort to mpas_dmpar_global_abort Any occurrences of mpas_dmpar_abort have been changed to mpas_dmpar_global_abort for consistency. These are all in comments or in checks that are rarely used. --- src/core_landice/mpas_li_diagnostic_vars.F | 2 +- src/core_landice/mpas_li_tendency.F | 2 +- src/core_landice/mpas_li_time_integration.F | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index 67dc76fd31..682db1fc8e 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -166,7 +166,7 @@ subroutine li_calculate_diagnostic_vars(domain, solveVelo, err) ! === error check and exit if (err == 1) then print *, "An error has occurred in li_calculate_diagnostic_vars. Aborting..." - !call mpas_dmpar_abort(dminfo) + !call mpas_dmpar_global_abort(dminfo) endif !-------------------------------------------------------------------- diff --git a/src/core_landice/mpas_li_tendency.F b/src/core_landice/mpas_li_tendency.F index 514b5912ed..1ce404825a 100644 --- a/src/core_landice/mpas_li_tendency.F +++ b/src/core_landice/mpas_li_tendency.F @@ -394,7 +394,7 @@ subroutine li_tendency_tracers(meshPool, velocityPool, geometryPool, thermalPool !!! ! Do nothing !!! case default !=================================================== !!! write(stderrUnit,*) trim(config_tracer_advection), ' is not a valid tracer advection option.' -!!! call mpas_dmpar_abort(dminfo) +!!! call mpas_dmpar_global_abort(dminfo) !!! end select !=================================================== !-------------------------------------------------------------------- diff --git a/src/core_landice/mpas_li_time_integration.F b/src/core_landice/mpas_li_time_integration.F index 694bf9f1f7..cb5ca5f3ac 100644 --- a/src/core_landice/mpas_li_time_integration.F +++ b/src/core_landice/mpas_li_time_integration.F @@ -153,7 +153,7 @@ subroutine li_timestep(domain, err) call li_time_integrator_forwardeuler(domain, dtSeconds, err_tmp) case ('rk4') write(stderrUnit,*) trim(config_time_integration), ' is not currently supported.' - call mpas_dmpar_abort(domain % dminfo) + call mpas_dmpar_global_abort(domain % dminfo) err_tmp = 1 case default write(stderrUnit,*) trim(config_time_integration), ' is not a valid land ice time integration option.' From 9754651ecdd610a41e4c45370661723da750fc9a Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 18 May 2015 11:39:37 -0600 Subject: [PATCH 0061/1724] Flush logs before external velocity solver calls --- src/core_landice/mpas_li_velocity_external.F | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mpas_li_velocity_external.F index c083644ded..b70b56efb4 100644 --- a/src/core_landice/mpas_li_velocity_external.F +++ b/src/core_landice/mpas_li_velocity_external.F @@ -137,6 +137,9 @@ subroutine li_velocity_external_init(domain, err) #if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) !call external first order solver to set the grid of the velocity solver write(stdoutUnit,*) "Initializing external velocity solver." + flush(stdoutUnit) ! Flush log files before handing control to C++ + flush(stderrUnit) + call velocity_solver_init_mpi(domain % dminfo % comm) #else err = 1 @@ -278,6 +281,9 @@ subroutine li_velocity_external_block_init(block, err) !nVertLevels should be equal to nVertLevelsSolve (no splitting of the domain in the vertical direction) call mpas_timer_start("velocity_solver_set_grid_data") write(stdoutUnit,*) "Initializing external velocity solver grid data." + flush(stdoutUnit) ! Flush log files before handing control to C++ + flush(stderrUnit) + call velocity_solver_set_grid_data(nCells, nEdges, nVertices, nVertInterfaces, & nCellsSolve, nEdgesSolve, nVerticesSolve, maxNEdgesOnCell, radius, & cellsOnEdge, cellsOnVertex, verticesOnCell, verticesOnEdge, edgesOnCell, & @@ -422,6 +428,8 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc if ((anyDynamicVertexMaskChanged == 1) .or. (config_always_compute_fem_grid) .or. & (dirichletMaskChanged == 1) ) then write(stdoutUnit,*) "Generating new external velocity solver FEM grid." + flush(stdoutUnit) ! Flush log files before handing control to C++ + flush(stderrUnit) call generate_fem_grid(config_velocity_solver, vertexMask, dirichletVelocityMask, & floatingEdges, layerThicknessFractions, lowerSurface, thickness, err) endif @@ -437,6 +445,9 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc uReconstructY = uReconstructY * secondsInYear write(stdoutUnit,*) "Beginning velocity solve using external velocity solver." + flush(stdoutUnit) ! Flush log files before handing control to C++ + flush(stderrUnit) + select case (config_velocity_solver) case ('L1L2') ! =============================================== #ifdef USE_EXTERNAL_L1L2 From d51d85888df9c7e83a5393c763cf9920b153d8c6 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 28 May 2015 12:36:26 -0600 Subject: [PATCH 0062/1724] Enable vector reconstruct init for HO dycore if DCFL is requested Without this fix, the diffusivity is always calculated to be 0 if a HO dycore is used. --- src/core_landice/mpas_li_core.F | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/core_landice/mpas_li_core.F b/src/core_landice/mpas_li_core.F index 0fd63193c2..46ae71cf76 100644 --- a/src/core_landice/mpas_li_core.F +++ b/src/core_landice/mpas_li_core.F @@ -561,6 +561,7 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) character (len=StrKIND), pointer :: xtime character (len=StrKIND), pointer :: config_velocity_solver logical, pointer :: config_do_velocity_reconstruction_for_external_dycore + logical, pointer :: config_adaptive_timestep_include_DCFL integer :: err, err_tmp err = 0 @@ -571,7 +572,7 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_pool_get_config(liConfigs, 'config_do_velocity_reconstruction_for_external_dycore', config_do_velocity_reconstruction_for_external_dycore) - + call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep_include_DCFL', config_adaptive_timestep_include_DCFL) ! Copy data from first time level into all other time levels call mpas_pool_initialize_time_levels(geometryPool) @@ -604,7 +605,8 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! Init for reconstruction of velocity if ( (trim(config_velocity_solver) == 'sia') .or. & - config_do_velocity_reconstruction_for_external_dycore ) then + config_do_velocity_reconstruction_for_external_dycore .or. & + config_adaptive_timestep_include_DCFL) then call mpas_rbf_interp_initialize(meshPool) call mpas_init_reconstruct(meshPool) endif From 87e9fe78341d3ce0001834b4a2d8c195f218f3e7 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 28 May 2015 13:10:58 -0600 Subject: [PATCH 0063/1724] Initialize layerThickness from input thickness Otherwise layerThickness does not get calculated until after the first time step, which causes problems to routines that need layerThickness (like the diffusivity calculation). --- src/core_landice/mpas_li_core.F | 2 +- src/core_landice/mpas_li_setup.F | 14 +++++++++++++- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/src/core_landice/mpas_li_core.F b/src/core_landice/mpas_li_core.F index 46ae71cf76..1d81e1f76e 100644 --- a/src/core_landice/mpas_li_core.F +++ b/src/core_landice/mpas_li_core.F @@ -584,7 +584,7 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! === ! === Call init routines === ! === - call li_setup_vertical_grid(meshPool, err_tmp) + call li_setup_vertical_grid(meshPool, geometryPool, err_tmp) err = ior(err, err_tmp) call li_setup_sign_and_index_fields(meshPool) diff --git a/src/core_landice/mpas_li_setup.F b/src/core_landice/mpas_li_setup.F index aa0ad8fd6a..165f1bdcd2 100644 --- a/src/core_landice/mpas_li_setup.F +++ b/src/core_landice/mpas_li_setup.F @@ -124,7 +124,7 @@ end subroutine li_setup_config_options ! !----------------------------------------------------------------------- - subroutine li_setup_vertical_grid(meshPool, err) + subroutine li_setup_vertical_grid(meshPool, geometryPool, err) !----------------------------------------------------------------- ! @@ -138,6 +138,7 @@ subroutine li_setup_vertical_grid(meshPool, err) ! !----------------------------------------------------------------- type (mpas_pool_type), intent(inout) :: meshPool !< Input/Output: mesh object + type (mpas_pool_type), intent(inout) :: geometryPool !< Input/Output: geometry object !----------------------------------------------------------------- ! @@ -155,6 +156,8 @@ subroutine li_setup_vertical_grid(meshPool, err) ! Pool pointers integer, pointer :: nVertLevels ! Dimensions real (kind=RKIND), dimension(:), pointer :: layerThicknessFractions, layerCenterSigma, layerInterfaceSigma + real (kind=RKIND), dimension(:), pointer :: thickness + real (kind=RKIND), dimension(:,:), pointer :: layerThickness1, layerThickness2 ! Truly locals integer :: k real (kind=RKIND) :: fractionTotal @@ -165,6 +168,9 @@ subroutine li_setup_vertical_grid(meshPool, err) call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness1, timeLevel=1) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness2, timeLevel=2) ! Check that layerThicknessFractions are valid ! TODO - switch to having the user input the sigma levels instead??? @@ -190,6 +196,12 @@ subroutine li_setup_vertical_grid(meshPool, err) end do layerInterfaceSigma(nVertLevels+1) = 1.0_RKIND + ! Also, initialize the layerThickness field + do k = 1, nVertLevels + layerThickness1(k,:) = thickness(:) * layerThicknessFractions(k) + enddo + layerThickness2 = layerThickness1 + !-------------------------------------------------------------------- end subroutine li_setup_vertical_grid From a80c59a1eea40b4045b767bf88705d42957efb9d Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Thu, 28 May 2015 15:44:21 -0600 Subject: [PATCH 0064/1724] Added .xml and .F files for Eliassen-Palm diagnos Added the .xml and .F files that will be used to perform the Eliassen-Palm flux tensor analysis member calculations --- .../Registry_eliassen_palm_flux_tensor.xml | 39 ++ .../mpas_ocn_eliassen_palm_flux_tensor.F | 543 ++++++++++++++++++ 2 files changed, 582 insertions(+) create mode 100644 src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml create mode 100644 src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml new file mode 100644 index 0000000000..62d80fb9ee --- /dev/null +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml @@ -0,0 +1,39 @@ + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F new file mode 100644 index 0000000000..177c638fa8 --- /dev/null +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F @@ -0,0 +1,543 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! oac_epft +! +!> \brief MPAS ocean analysis core member: epft +!> \author Juan A. Saenz, Todd Ringler +!> \date May, 2015 +!> \details +!> This module contains the routines for computing the Eliassen and Palm Flux Tensor +!> in buoyancy coordinates, and related quantities. +! +!----------------------------------------------------------------------- + +module ocn_eliassen_palm_flux_tensor + + use mpas_grid_types + use mpas_timer + use mpas_dmpar + use mpas_timekeeping + use mpas_stream_manager + + use ocn_constants + use ocn_diagnostics_routines + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_setup_packages_eliassen_palm_flux_tensor, & + ocn_init_eliassen_palm_flux_tensor, & + ocn_compute_eliassen_palm_flux_tensor, & + ocn_restart_eliassen_palm_flux_tensor, & + ocn_finalize_eliassen_palm_flux_tensor + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + type (timer_node), pointer :: am_eliassen_palm_flux_tensorTimer + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_setup_packages_eliassen_palm_flux_tensor +! +!> \brief Set up packages for MPAS-Ocean analysis member +!> \author Mark Petersen +!> \date November 2013 +!> \details +!> This routine is intended to configure the packages for this MPAS +!> ocean analysis member +! +!----------------------------------------------------------------------- + + subroutine ocn_setup_packages_eliassen_palm_flux_tensor(configPool, packagePool, err)!{{{ + + use mpas_packages + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + logical, pointer :: am_eliassen_palm_flux_tensor_Active + + err = 0 + + call mpas_pool_get_package(packagePool, & + 'am_eliassen_palm_flux_tensor_Active', am_eliassen_palm_flux_tensor_Active) + + ! turn on package for this analysis member + am_eliassen_palm_flux_tensor_Active = .true. + + end subroutine ocn_setup_packages_eliassen_palm_flux_tensor!}}} + + +!*********************************************************************** +! +! routine ocn_init_eliassen_palm_flux_tensor +! +!> \brief Initialize MPAS-Ocean analysis member +!> \author Juan A. Saenz +!> \date May 2015 +!> \details +!> This routine conducts all initializations required for the +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ + + use mpas_packages + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + integer :: err_tmp + integer :: k + !real(KIND=RKIND) :: global_min, global_max, local_min, local_max + + type (block_type), pointer :: block + type (amEPFT_type), pointer :: amEPFT + + real(KIND=RKIND), dimension(:), pointer :: potentialDensityMidRef + real(KIND=RKIND), dimension(:), pointer :: potentialDensityTopRef + real(KIND=RKIND), dimension(:,:), pointer :: buoyMaskEA + + + + err = 0 + + block => domain % blocklist + do while (associated(block)) + + amEPFT => block % amEPFT + + ! Calculate target values + potentialDensityMidRef => amEPFT % potentialDensityMidRef % array + potentialDensityTopRef => amEPFT % potentialDensityTopRef % array + + do k = 1, config_nBuoyancyLayers + potentialDensityTopRef(k) = config_rhomin_buoycoor + & + (config_rhomax_buoycoor - config_rhomin_buoycoor) / & + (config_nBuoyancyLayers) * (k-1) + end do + do k = 1, config_nBuoyancyLayers-1 + potentialDensityMidRef(k) = & + 0.5*(potentialDensityTopRef(k) + potentialDensityTopRef(k+1)) + end do + potentialDensityMidRef(config_nBuoyancyLayers) = & + 0.5*(potentialDensityTopRef(config_nBuoyancyLayers) + config_rhomax_buoycoor) + + if (.not. config_do_restart .or. config_oac_epft_reset) then + amEPFT % buoyMaskEA % array = 0.0 + amEPFT % sigmaEA % array = 0.0 + amEPFT % nSamplesEA % scalar = 0.0 + amEPFT % heightMidBuoyCoorEA % array = 0.0 + amEPFT % montgPotBuoyCoorEA % array = 0.0 + amEPFT % montgPotGradZonalEA % array = 0.0 + amEPFT % montgPotGradMeridEA % array = 0.0 + amEPFT % heightMidBuoyCoorSqEA % array = 0.0 + amEPFT % HeightMGradZonalEA % array = 0.0 + amEPFT % HeightMGradMeridEA % array = 0.0 + amEPFT % usigmaEA % array = 0.0 + amEPFT % vsigmaEA % array = 0.0 + amEPFT % uusigmaEA % array = 0.0 + amEPFT % vvsigmaEA % array = 0.0 + amEPFT % uvsigmaEA % array = 0.0 + amEPFT % uwsigmaEA % array = 0.0 + amEPFT % vwsigmaEA % array = 0.0 + end if + + block => block % next + + end do + + + end subroutine ocn_init_eliassen_palm_flux_tensor!}}} + +!*********************************************************************** +! +! routine ocn_compute_eliassen_palm_flux_tensor +! +!> \brief Compute Eliassen-Palm flux tensor +!> \author Juan A. Saenz +!> \date May 2015 +!> \details +!> This routine conducts all computation required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + integer, intent(in) :: timeLevel + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: am_eliassen_palm_flux_tensorPool + type (dm_info) :: dminfo + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: scratchPool + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: am_eliassen_palm_flux_tensor + + ! Here are some example variables which may be needed for your analysis member + integer, pointer :: nVertLevels, nBuoyLayers, nBuoyLayersP1 + integer, pointer :: nEdges, nCells, nCellsSolve, nCellsCum ! nCellsSolve includes halos + + integer, dimension(:), pointer :: maxLevelCell + integer, dimension(:), pointer :: firstLayerBuoyCoor + integer, dimension(:), pointer :: lastLayerBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: buoyMask + + integer :: nSamplesEA + real(KIND=RKIND), dimension(:,:), pointer :: sigmaEA + real(KIND=RKIND), dimension(:,:), pointer :: heightMidBuoyCoorEA + real(KIND=RKIND), dimension(:,:), pointer :: montgPotBuoyCoorEA + real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradZonalEA + real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradMeridEA + real(KIND=RKIND), dimension(:,:), pointer :: heightMidBuoyCoorSqEA + real(KIND=RKIND), dimension(:,:), pointer :: HeightMGradZonalEA + real(KIND=RKIND), dimension(:,:), pointer :: HeightMGradMeridEA + real(KIND=RKIND), dimension(:,:), pointer :: usigmaEA + real(KIND=RKIND), dimension(:,:), pointer :: vsigmaEA + !real(KIND=RKIND), dimension(:,:), pointer :: wsigmaEA + real(KIND=RKIND), dimension(:,:), pointer :: uusigmaEA + real(KIND=RKIND), dimension(:,:), pointer :: vvsigmaEA + real(KIND=RKIND), dimension(:,:), pointer :: uvsigmaEA + real(KIND=RKIND), dimension(:,:), pointer :: uwsigmaEA + real(KIND=RKIND), dimension(:,:), pointer :: vwsigmaEA + + real(KIND=RKIND), dimension(:,:), pointer :: uTWA + real(KIND=RKIND), dimension(:,:), pointer :: vTWA + real(KIND=RKIND), dimension(:,:), pointer :: wTWA + + real(KIND=RKIND), dimension(:,:,:,:), pointer :: EPFT + real(KIND=RKIND), dimension(:,:,:), pointer :: divEPFT + real(KIND=RKIND), dimension(:,:,:), pointer :: ErtelPVFlux + real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVTendency + real(KIND=RKIND), dimension(:,:), pointer :: ErtelPV + + + real(KIND=RKIND), dimension(:), pointer :: potentialDensityMidRef + real(KIND=RKIND), dimension(:), pointer :: potentialDensityTopRef + real(KIND=RKIND), dimension(:), pointer :: buoyancyMidRef + real(KIND=RKIND), dimension(:), pointer :: buoyancyInterfaceRef + real(KIND=RKIND), dimension(:), pointer :: bottomDepth + + real(KIND=RKIND), dimension(:,:), pointer :: buoyMaskEA + real(KIND=RKIND), dimension(:,:), pointer :: heightMidBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: heightTopBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: heightInterfaceBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: uMidBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: vMidBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: densityMidBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: densityTopBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: sigma + real(KIND=RKIND), dimension(:,:), pointer :: montgPotBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: montgPotNormalGradOnEdge + real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradX + real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradY + real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradZ + real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradZonal + real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradMerid + + real(KIND=RKIND), dimension(:), pointer :: surfacePressure + real(KIND=RKIND), dimension(:), pointer :: SSH + real(KIND=RKIND), dimension(:,:), pointer :: zMid + real(KIND=RKIND), dimension(:,:), pointer :: zTop + real(KIND=RKIND), dimension(:,:), pointer :: density + real(KIND=RKIND), dimension(:,:), pointer :: potentialDensity + real(KIND=RKIND), dimension(:,:), pointer :: pressure + real(KIND=RKIND), dimension(:,:), pointer :: uCellCenter + real(KIND=RKIND), dimension(:,:), pointer :: vCellCenter +! real(KIND=RKIND), dimension(:,:) :: wCellCenter + + ! work variables + integer :: k + real(KIND=RKIND), dimension(:,:), pointer :: wrk3DnVertLevels + real(KIND=RKIND), dimension(:,:), pointer :: wrk3DBuoyCoor + + ! test variables + integer :: nCellsGlobal, i + real(KIND=RKIND) :: RMSlocal1, RMSglobal1 + real(KIND=RKIND) :: RMSlocal2, RMSglobal2 + real(KIND=RKIND) :: RMSPVFlux1local, RMSPVFlux1global + real(KIND=RKIND) :: RMSPVFlux2local, RMSPVFlux2global + real(KIND=RKIND), dimension(:,:), pointer :: array1_3D + real(KIND=RKIND), dimension(:,:), pointer :: array2_3D + real(KIND=RKIND), dimension(:,:), pointer :: array3_3D + real(KIND=RKIND), dimension(:,:), pointer :: array1_3Dbuoy + real(KIND=RKIND), dimension(:,:), pointer :: array2_3Dbuoy + real(KIND=RKIND), dimension(:,:), pointer :: PVMidBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: PVMidBuoyCoorEA + real(KIND=RKIND), dimension(:,:), pointer :: uMidBuoyCoorEA + real(KIND=RKIND), dimension(:,:), pointer :: vMidBuoyCoorEA + real(KIND=RKIND), dimension(:,:), pointer :: uPVMidBuoyCoorEA + real(KIND=RKIND), dimension(:,:), pointer :: vPVMidBuoyCoorEA + real(KIND=RKIND), dimension(:,:,:), pointer :: PVFluxTest + real(KIND=RKIND), dimension(:,:), pointer :: relativeVorticityCell + real(KIND=RKIND), dimension(:), pointer :: fCell + + err = 0 + + dminfo = domain % dminfo + + call mpas_timer_start("compute_eliassen_palm_flux_tensor", .false., am_eliassen_palm_flux_tensorTimer) + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'am_eliassen_palm_flux_tensor', am_eliassen_palm_flux_tensorPool) + + ! Here are some example variables which may be needed for your analysis member + call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(block % dimensions, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(block % dimensions, 'nVerticesSolve', nVerticesSolve) + + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelVertexBot', maxLevelVertexBot) + + ! Computations which are functions of nCells, nEdges, or nVertices + ! must be placed within this block loop + ! Here are some example loops + do iCell = 1,nCellsSolve + do k = 1, maxLevelCell(iCell) + do iTracer = 1, num_tracers + ! computations on tracers(iTracer,k, iCell) + end do + end do + end do + + block => block % next + end do + + ! mpi gather/scatter calls may be placed here. + ! Here are some examples. See mpas_oac_global_stats.F for further details. +! call mpas_dmpar_sum_real_array(dminfo, nVariables, sumSquares(1:nVariables), reductions(1:nVariables)) +! call mpas_dmpar_min_real_array(dminfo, nMins, mins(1:nMins), reductions(1:nMins)) +! call mpas_dmpar_max_real_array(dminfo, nMaxes, maxes(1:nMaxes), reductions(1:nMaxes)) + + ! Even though some variables do not include an index that is decomposed amongst + ! domain partitions, we assign them within a block loop so that all blocks have the + ! correct values for writing output. + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'am_eliassen_palm_flux_tensor', am_eliassen_palm_flux_tensorPool) + + ! assignment of final am_eliassen_palm_flux_tensor variables could occur here. + + block => block % next + end do + + call mpas_timer_stop("eliassen_palm_flux_tensor", am_eliassen_palm_flux_tensorTimer) + + end subroutine ocn_compute_eliassen_palm_flux_tensor!}}} + +!*********************************************************************** +! +! routine ocn_restart_eliassen_palm_flux_tensor +! +!> \brief Save restart for MPAS-Ocean analysis member +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE +!> \details +!> This routine conducts computation required to save a restart state +!> for the MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_restart_eliassen_palm_flux_tensor(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_restart_eliassen_palm_flux_tensor!}}} + +!*********************************************************************** +! +! routine ocn_finalize_eliassen_palm_flux_tensor +! +!> \brief Finalize MPAS-Ocean analysis member +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE +!> \details +!> This routine conducts all finalizations required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_finalize_eliassen_palm_flux_tensor(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_finalize_eliassen_palm_flux_tensor!}}} + +end module ocn_eliassen_palm_flux_tensor + +! vim: foldmethod=marker From c42117a38d7c483e3fa5b92c83f5ca561f06bb5e Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 28 May 2015 18:02:41 -0600 Subject: [PATCH 0065/1724] Ignore 'divide singularity' in diffusivity calculation This uses somewhat arbitrary thresholds for slope AND velocity to ignore the singulariy in diffusivity that occurs at divides. --- src/core_landice/mpas_li_diagnostic_vars.F | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index 682db1fc8e..ea80b7952c 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -289,13 +289,19 @@ subroutine li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool do iCell = 1, nCells slopeCellMagnitude = sqrt(slopeCellAxis1(iCell)**2 + slopeCellAxis2(iCell)**2) + smallNumber - fluxDownslope = 0.0_RKIND - do iLevel = 1, nVertLevels - fluxVeloAxis1 = (uReconstructAxis1(iLevel, iCell) + uReconstructAxis1(iLevel+1, iCell)) * 0.5_RKIND - fluxVeloAxis2 = (uReconstructAxis2(iLevel, iCell) + uReconstructAxis2(iLevel+1, iCell)) * 0.5_RKIND - fluxDownslope = fluxDownslope + (-1.0_RKIND * slopeCellAxis1(iCell) * fluxVeloAxis1 - slopeCellAxis2(iCell) * fluxVeloAxis2) * layerThickness(iLevel, iCell) / slopeCellMagnitude - enddo - apparentDiffusivity(iCell) = abs(fluxDownslope) / slopeCellMagnitude + if ( (slopeCellMagnitude < 1.0e-5_RKIND) .and. & + (max(maxval(uReconstructAxis1(:,iCell)), maxval(uReconstructAxis2(:,iCell))) < 3.18e-10_RKIND) ) then ! 3.18e-10=0.01 m/yr in m/s + ! Ignore diffusivity near 'divide-singularities' + apparentDiffusivity(iCell) = 0.0_RKIND + else + fluxDownslope = 0.0_RKIND + do iLevel = 1, nVertLevels + fluxVeloAxis1 = (uReconstructAxis1(iLevel, iCell) + uReconstructAxis1(iLevel+1, iCell)) * 0.5_RKIND + fluxVeloAxis2 = (uReconstructAxis2(iLevel, iCell) + uReconstructAxis2(iLevel+1, iCell)) * 0.5_RKIND + fluxDownslope = fluxDownslope + (-1.0_RKIND * slopeCellAxis1(iCell) * fluxVeloAxis1 - slopeCellAxis2(iCell) * fluxVeloAxis2) * layerThickness(iLevel, iCell) / slopeCellMagnitude + enddo + apparentDiffusivity(iCell) = abs(fluxDownslope) / slopeCellMagnitude + endif ! Calculate allowable timestep based on DCFL if ( li_mask_is_grounded_ice(cellMask(iCell)) .and. li_mask_is_dynamic_ice(cellMask(iCell)) ) then From d3f5fffda93c62391e6445717ebefb31a0c1110c Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 28 May 2015 18:28:18 -0600 Subject: [PATCH 0066/1724] Adjust 'divide' threshold, add notice if 'divide' found In calculating diffusivity, the previous commit adds logic to ignore flat and slow cells that presumed to be divides where diffusivity is undefined. This commit adjusts the speed threshold based on false negatives encountered in running the dome for 500 yrs with Albany-FO. It also adds a notice to the error log when divides are detected so if the user encounters instabilities they are aware that a false positive may have occurred. --- src/core_landice/mpas_li_diagnostic_vars.F | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mpas_li_diagnostic_vars.F index ea80b7952c..bedbc3ef10 100644 --- a/src/core_landice/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mpas_li_diagnostic_vars.F @@ -239,6 +239,7 @@ subroutine li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool integer :: iCell, iEdge, iLevel real (kind=RKIND), parameter :: bigNumber = 1.0e16_RKIND ! This is ~300 million years in seconds, but it is small enough not too overflow real (kind=RKIND), parameter :: smallNumber = 1.0e-36 + logical :: divideSingularityFound ! Note: This routine could be broken into 2: one to calculate diffusivity ! and another to get the diffusive CFL timestep. In that case, the first (and possibly the second) @@ -285,14 +286,17 @@ subroutine li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool slopeReconstructXField % array, slopeReconstructYField % array, slopeReconstructZField % array, & slopeCellAxis1, slopeCellAxis2) + ! Approximate flux at cell centers + divideSingularityFound = .false. do iCell = 1, nCells slopeCellMagnitude = sqrt(slopeCellAxis1(iCell)**2 + slopeCellAxis2(iCell)**2) + smallNumber - if ( (slopeCellMagnitude < 1.0e-5_RKIND) .and. & - (max(maxval(uReconstructAxis1(:,iCell)), maxval(uReconstructAxis2(:,iCell))) < 3.18e-10_RKIND) ) then ! 3.18e-10=0.01 m/yr in m/s + if ( (slopeCellMagnitude < 1.0e-4_RKIND) .and. & + (max(maxval(uReconstructAxis1(:,iCell)), maxval(uReconstructAxis2(:,iCell))) < 3.18e-8_RKIND) ) then ! 3.18e-8=1 m/yr in m/s ! Ignore diffusivity near 'divide-singularities' apparentDiffusivity(iCell) = 0.0_RKIND + divideSingularityFound = .true. else fluxDownslope = 0.0_RKIND do iLevel = 1, nVertLevels @@ -314,6 +318,10 @@ subroutine li_calculate_apparent_diffusivity(meshPool, velocityPool, scratchPool allowableDiffDt = min(allowableDiffDt, allowableDtHere) enddo + if (divideSingularityFound) then + write (stderrUnit,*) 'Notice: In calculating apparentDiffusivity, one or more cells have been ignored due to flat slope and low velocity (assumed to be a divide where diffusivity is undefined).' + endif + call mpas_deallocate_scratch_field(slopeReconstructXField, .true.) call mpas_deallocate_scratch_field(slopeReconstructYField, .true.) call mpas_deallocate_scratch_field(slopeReconstructZField, .true.) From 31cbd3967b0033ca3498946970d7f46966525f1f Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 28 May 2015 19:01:43 -0600 Subject: [PATCH 0067/1724] Add allowableDtACFL & allowableDtDCFL output variables In addition to these values being printed in the log file, this makes them available as fields in an output file. Note that the CFL variables will only be calculated if config_print_thickness_advection_info .or. config_adaptive_timestep and the DCFL variable if one of those plus config_adaptive_timestep_include_DCFL. You can still get the fields in the output file if you do not have those settings enabled but the values will not be calculated. --- src/core_landice/Registry.xml | 6 ++++++ .../mpas_li_time_integration_fe.F | 21 +++++++++++++++++++ 2 files changed, 27 insertions(+) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index e3ce28d7dd..8e1d656cbb 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -585,6 +585,12 @@ is the value of that variable from the *previous* time level! + + diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mpas_li_time_integration_fe.F index 6a2049a7af..2705a7a8fe 100644 --- a/src/core_landice/mpas_li_time_integration_fe.F +++ b/src/core_landice/mpas_li_time_integration_fe.F @@ -208,6 +208,7 @@ subroutine calculate_tendencies(domain, dtSeconds, err) real (kind=RKIND) :: allowableDiffDt, allowableDiffDtOnProc, allowableDiffDtAllProcs type (MPAS_TimeInterval_type) :: allowableDiffDtOnProcInterval, allowableDiffDtAllProcsInterval character (len=StrKIND) :: allowableDiffDtOnProcString, allowableDiffDtAllProcsString + real (kind=RKIND), pointer :: allowableDtACFL, allowableDtDCFL integer :: err_tmp err = 0 @@ -216,6 +217,9 @@ subroutine calculate_tendencies(domain, dtSeconds, err) call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep', config_adaptive_timestep) call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep_include_DCFL', config_adaptive_timestep_include_DCFL) + allowableAdvecDtAllProcs = 0.0_RKIND + allowableDiffDtAllProcs = 0.0_RKIND + dminfo => domain % dminfo ! === @@ -355,6 +359,23 @@ subroutine calculate_tendencies(domain, dtSeconds, err) endif + ! set CFL variables if they have been calculated - every block should be set to the same value! + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + if (config_print_thickness_advection_info .or. config_adaptive_timestep) then + call mpas_pool_get_array(meshPool, 'allowableDtACFL', allowableDtACFL) + allowableDtACFL = allowableAdvecDtAllProcs + if (config_adaptive_timestep_include_DCFL) then + call mpas_pool_get_array(meshPool, 'allowableDtDCFL', allowableDtDCFL) + allowableDtDCFL = allowableDiffDtAllProcs + endif + endif + + block => block % next + end do + + ! === ! === Tracer tendencies ! === From e93c429a61ef899cc151380e231695499732cea9 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Fri, 29 May 2015 15:12:27 -0600 Subject: [PATCH 0068/1724] populated the Registry file for epft --- .../Registry_eliassen_palm_flux_tensor.xml | 672 +++++++++++++++++- 1 file changed, 637 insertions(+), 35 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml index 62d80fb9ee..4f48cb2b31 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml @@ -1,39 +1,641 @@ - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + - + + + + + - - - - - - - - - - - - - + - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + From 6d14436bbd05f3f5a350a6d1657770049d6293d2 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Fri, 29 May 2015 15:12:56 -0600 Subject: [PATCH 0069/1724] started populating up to ocn_compute_ routine --- .../mpas_ocn_eliassen_palm_flux_tensor.F | 699 ++++++++++++++++-- 1 file changed, 643 insertions(+), 56 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F index 177c638fa8..4e870edc55 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F @@ -7,7 +7,7 @@ ! !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! -! oac_epft +! ocn_epft ! !> \brief MPAS ocean analysis core member: epft !> \author Juan A. Saenz, Todd Ringler @@ -26,6 +26,7 @@ module ocn_eliassen_palm_flux_tensor use mpas_timekeeping use mpas_stream_manager + use mpas_configure use ocn_constants use ocn_diagnostics_routines @@ -58,6 +59,8 @@ module ocn_eliassen_palm_flux_tensor !-------------------------------------------------------------------- type (timer_node), pointer :: am_eliassen_palm_flux_tensorTimer + logical :: amEPFTOn + real (kind=RKIND), parameter :: epsilonEPFT=1.0e-15 !*********************************************************************** @@ -68,8 +71,8 @@ module ocn_eliassen_palm_flux_tensor ! routine ocn_setup_packages_eliassen_palm_flux_tensor ! !> \brief Set up packages for MPAS-Ocean analysis member -!> \author Mark Petersen -!> \date November 2013 +!> \author Juan Saenz, Todd Ringler +!> \date May 2015 !> \details !> This routine is intended to configure the packages for this MPAS !> ocean analysis member @@ -111,6 +114,7 @@ subroutine ocn_setup_packages_eliassen_palm_flux_tensor(configPool, packagePool, err = 0 + call mpas_pool_get_config(configPool, "config_use_epft", config_use_epft) call mpas_pool_get_package(packagePool, & 'am_eliassen_palm_flux_tensor_Active', am_eliassen_palm_flux_tensor_Active) @@ -125,7 +129,7 @@ end subroutine ocn_setup_packages_eliassen_palm_flux_tensor!}}} ! routine ocn_init_eliassen_palm_flux_tensor ! !> \brief Initialize MPAS-Ocean analysis member -!> \author Juan A. Saenz +!> \author Juan A. Saenz, Todd Ringler !> \date May 2015 !> \details !> This routine conducts all initializations required for the @@ -137,6 +141,9 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ use mpas_packages + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + !----------------------------------------------------------------- ! ! input variables @@ -232,16 +239,22 @@ end subroutine ocn_init_eliassen_palm_flux_tensor!}}} ! routine ocn_compute_eliassen_palm_flux_tensor ! !> \brief Compute Eliassen-Palm flux tensor -!> \author Juan A. Saenz +!> \author Juan A. Saenz, Todd Ringler !> \date May 2015 !> \details -!> This routine conducts all computation required for this -!> MPAS-Ocean analysis member. +!> This routine conducts all computation required for the EPFT analysis member. +!> Each time this AM is called, the instananeous ocean state is interpolated +!> onto the target buoyancy values. The state is then accumulated in the +!> accumulated into the ensemble average (*EA) arrays. Based on the current +!> estimate of the ensemble average, thickness-weight velocities are estimates +!> along with the computation of the Eliassen-Palm flux tensor ! !----------------------------------------------------------------------- subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ + use mpas_vector_reconstruction + !----------------------------------------------------------------- ! ! input variables @@ -272,18 +285,27 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! !----------------------------------------------------------------- - type (mpas_pool_type), pointer :: am_eliassen_palm_flux_tensorPool + !----------------------------------------------------------------- + ! define types that live inside of domain + !----------------------------------------------------------------- type (dm_info) :: dminfo type (block_type), pointer :: block type (mpas_pool_type), pointer :: statePool type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: forcingPool ! jas-issue does this exist? type (mpas_pool_type), pointer :: scratchPool - type (mpas_pool_type), pointer :: diagnosticsPool - type (mpas_pool_type), pointer :: am_eliassen_palm_flux_tensor + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: am_epftPool + type (mpas_pool_type), pointer :: am_eliassen_palm_flux_tensor ! jas issue ? + + logical, pointer :: config_epft_debug - ! Here are some example variables which may be needed for your analysis member + !----------------------------------------------------------------- + ! define local scalars holding length of dimensions + !----------------------------------------------------------------- integer, pointer :: nVertLevels, nBuoyLayers, nBuoyLayersP1 - integer, pointer :: nEdges, nCells, nCellsSolve, nCellsCum ! nCellsSolve includes halos + integer, pointer :: nEdges, nCells, nCellsSolve ! nCellsSolve includes halos + integer, dimension(:), pointer :: maxLevelCell integer, dimension(:), pointer :: firstLayerBuoyCoor @@ -291,12 +313,18 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: buoyMask integer :: nSamplesEA + + real(KIND=RKIND), dimension(:), pointer :: potentialDensityMidRef + real(KIND=RKIND), dimension(:), pointer :: potentialDensityTopRef + real(KIND=RKIND), dimension(:), pointer :: buoyancyMidRef + real(KIND=RKIND), dimension(:), pointer :: buoyancyInterfaceRef + real(KIND=RKIND), dimension(:,:), pointer :: buoyMaskEA real(KIND=RKIND), dimension(:,:), pointer :: sigmaEA real(KIND=RKIND), dimension(:,:), pointer :: heightMidBuoyCoorEA - real(KIND=RKIND), dimension(:,:), pointer :: montgPotBuoyCoorEA real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradZonalEA real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradMeridEA real(KIND=RKIND), dimension(:,:), pointer :: heightMidBuoyCoorSqEA + real(KIND=RKIND), dimension(:,:), pointer :: montgPotBuoyCoorEA real(KIND=RKIND), dimension(:,:), pointer :: HeightMGradZonalEA real(KIND=RKIND), dimension(:,:), pointer :: HeightMGradMeridEA real(KIND=RKIND), dimension(:,:), pointer :: usigmaEA @@ -307,11 +335,9 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: uvsigmaEA real(KIND=RKIND), dimension(:,:), pointer :: uwsigmaEA real(KIND=RKIND), dimension(:,:), pointer :: vwsigmaEA - real(KIND=RKIND), dimension(:,:), pointer :: uTWA real(KIND=RKIND), dimension(:,:), pointer :: vTWA real(KIND=RKIND), dimension(:,:), pointer :: wTWA - real(KIND=RKIND), dimension(:,:,:,:), pointer :: EPFT real(KIND=RKIND), dimension(:,:,:), pointer :: divEPFT real(KIND=RKIND), dimension(:,:,:), pointer :: ErtelPVFlux @@ -319,13 +345,10 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: ErtelPV - real(KIND=RKIND), dimension(:), pointer :: potentialDensityMidRef - real(KIND=RKIND), dimension(:), pointer :: potentialDensityTopRef - real(KIND=RKIND), dimension(:), pointer :: buoyancyMidRef - real(KIND=RKIND), dimension(:), pointer :: buoyancyInterfaceRef + real(KIND=RKIND), dimension(:), pointer :: SSH + real(KIND=RKIND), dimension(:), pointer :: bottomDepth - real(KIND=RKIND), dimension(:,:), pointer :: buoyMaskEA real(KIND=RKIND), dimension(:,:), pointer :: heightMidBuoyCoor real(KIND=RKIND), dimension(:,:), pointer :: heightTopBuoyCoor real(KIND=RKIND), dimension(:,:), pointer :: heightInterfaceBuoyCoor @@ -343,7 +366,6 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradMerid real(KIND=RKIND), dimension(:), pointer :: surfacePressure - real(KIND=RKIND), dimension(:), pointer :: SSH real(KIND=RKIND), dimension(:,:), pointer :: zMid real(KIND=RKIND), dimension(:,:), pointer :: zTop real(KIND=RKIND), dimension(:,:), pointer :: density @@ -360,10 +382,6 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! test variables integer :: nCellsGlobal, i - real(KIND=RKIND) :: RMSlocal1, RMSglobal1 - real(KIND=RKIND) :: RMSlocal2, RMSglobal2 - real(KIND=RKIND) :: RMSPVFlux1local, RMSPVFlux1global - real(KIND=RKIND) :: RMSPVFlux2local, RMSPVFlux2global real(KIND=RKIND), dimension(:,:), pointer :: array1_3D real(KIND=RKIND), dimension(:,:), pointer :: array2_3D real(KIND=RKIND), dimension(:,:), pointer :: array3_3D @@ -383,57 +401,626 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ dminfo = domain % dminfo - call mpas_timer_start("compute_eliassen_palm_flux_tensor", .false., am_eliassen_palm_flux_tensorTimer) + call mpas_timer_start("compute_eliassen_palm_flux_tensor", .false., & + am_eliassen_palm_flux_tensorTimer) + + call mpas_pool_get_config(domain % configs, 'config_epft_debug', config_epft_debug) + block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block % structs, 'eliassenPalmFluxTensorScratch', scratchPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) - call mpas_pool_get_subpool(block % structs, 'am_eliassen_palm_flux_tensor', am_eliassen_palm_flux_tensorPool) - - ! Here are some example variables which may be needed for your analysis member - call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + call mpas_pool_get_subpool(block % structs, 'amEliassenPalmFluxTensor', am_epftPool) call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(block % dimensions, 'nBuoyLayers', nBuoyLayers) + !call mpas_pool_get_dimension(block % dimensions, 'nBuoyLayersP1', nBuoyLayersP1) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(block % dimensions, 'nEdgesSolve', nEdgesSolve) - call mpas_pool_get_dimension(block % dimensions, 'nVerticesSolve', nVerticesSolve) - call mpas_pool_get_array(meshPool, 'areaCell', areaCell) - call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) - call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) - call mpas_pool_get_array(meshPool, 'maxLevelVertexBot', maxLevelVertexBot) - - ! Computations which are functions of nCells, nEdges, or nVertices - ! must be placed within this block loop - ! Here are some example loops - do iCell = 1,nCellsSolve - do k = 1, maxLevelCell(iCell) - do iTracer = 1, num_tracers - ! computations on tracers(iTracer,k, iCell) + + call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', surfacePressure) + + call mpas_pool_get_field(scratchPool, 'heightMidBuoyCoor', heightMidBuoyCoor) + call mpas_pool_get_field(scratchPool, 'heightTopBuoyCoor', heightTopBuoyCoor) + call mpas_pool_get_field(scratchPool, 'heightInterfaceBuoyCoor', heightInterfaceBuoyCoor) + call mpas_pool_get_field(scratchPool, 'uMidBuoyCoor', uMidBuoyCoor) + call mpas_pool_get_field(scratchPool, 'vMidBuoyCoor', vMidBuoyCoor) + call mpas_pool_get_field(scratchPool, 'densityMidBuoyCoor', densityMidBuoyCoor) + call mpas_pool_get_field(scratchPool, 'densityTopBuoyCoor', densityTopBuoyCoor) + call mpas_pool_get_field(scratchPool, 'sigma', sigma) + call mpas_pool_get_field(scratchPool, 'montgPotBuoyCoor', montgPotBuoyCoor) + call mpas_pool_get_field(scratchPool, 'montgPotNormalGradOnEdge', montgPotNormalGradOnEdge) + call mpas_pool_get_field(scratchPool, 'firstLayerBuoyCoor', firstLayerBuoyCoor) + call mpas_pool_get_field(scratchPool, 'lastLayerBuoyCoor', lastLayerBuoyCoor) + call mpas_pool_get_field(scratchPool, 'buoyMask', buoyMask) + call mpas_pool_get_field(scratchPool, 'montgPotGradX', montgPotGradX) + call mpas_pool_get_field(scratchPool, 'montgPotGradY', montgPotGradY) + call mpas_pool_get_field(scratchPool, 'montgPotGradZ', montgPotGradZ) + call mpas_pool_get_field(scratchPool, 'montgPotGradZonal', montgPotGradZonal) + call mpas_pool_get_field(scratchPool, 'montgPotGradMerid', montgPotGradMerid) + call mpas_pool_get_field(scratchPool, 'wrk3DnVertLevelsP1', wrk3DnVertLevelsP1) + call mpas_pool_get_field(scratchPool, 'wrk3DnVertLevels', wrk3DnVertLevels) + call mpas_pool_get_field(scratchPool, 'wrk3DBuoyCoor', wrk3DBuoyCoor) + + call mpas_allocate_scratch_field(heightMidBuoyCoor, .true.) + call mpas_allocate_scratch_field(heightTopBuoyCoor, .true.) + call mpas_allocate_scratch_field(heightInterfaceBuoyCoor, .true.) + call mpas_allocate_scratch_field(uMidBuoyCoor, .true.) + call mpas_allocate_scratch_field(vMidBuoyCoor, .true.) + call mpas_allocate_scratch_field(densityMidBuoyCoor, .true.) + call mpas_allocate_scratch_field(densityTopBuoyCoor, .true.) + call mpas_allocate_scratch_field(sigma, .true.) + call mpas_allocate_scratch_field(montgPotBuoyCoor, .true.) + call mpas_allocate_scratch_field(montgPotNormalGradOnEdge, .true.) + call mpas_allocate_scratch_field(firstLayerBuoyCoor, .true.) + call mpas_allocate_scratch_field(lastLayerBuoyCoor, .true.) + call mpas_allocate_scratch_field(buoyMask, .true.) + call mpas_allocate_scratch_field(montgPotGradX, .true.) + call mpas_allocate_scratch_field(montgPotGradY, .true.) + call mpas_allocate_scratch_field(montgPotGradZ, .true.) + call mpas_allocate_scratch_field(montgPotGradZonal, .true.) + call mpas_allocate_scratch_field(montgPotGradMerid, .true.) + call mpas_allocate_scratch_field(wrk3DnVertLevelsP1, .true.) + call mpas_allocate_scratch_field(wrk3DnVertLevels, .true.) + call mpas_allocate_scratch_field(wrk3DBuoyCoor, .true.) + + ! test variables + call mpas_pool_get_field(scratchPool, 'array1_3D', array1_3D) + call mpas_pool_get_field(scratchPool, 'array2_3D', array2_3D) + call mpas_pool_get_field(scratchPool, 'array3_3D', array3_3D) + call mpas_pool_get_field(scratchPool, 'array1_3Dbuoy', array1_3Dbuoy) + call mpas_pool_get_field(scratchPool, 'array2_3Dbuoy', array2_3Dbuoy) + + call mpas_allocate_scratch_field(array1_3D, .true.) + call mpas_allocate_scratch_field(array2_3D, .true.) + call mpas_allocate_scratch_field(array3_3D, .true.) + call mpas_allocate_scratch_field(array1_3Dbuoy, .true.) + call mpas_allocate_scratch_field(array2_3Dbuoy, .true.) + + call mpas_pool_get_field('PVMidBuoyCoor', PVMidBuoyCoor) + call mpas_pool_get_field('PVMidBuoyCoorEA', PVMidBuoyCoorEA) + call mpas_pool_get_field('uMidBuoyCoorEA', uMidBuoyCoorEA) + call mpas_pool_get_field('vMidBuoyCoorEA', vMidBuoyCoorEA) + call mpas_pool_get_field('uPVMidBuoyCoorEA', uPVMidBuoyCoorEA) + call mpas_pool_get_field('vPVMidBuoyCoorEA', vPVMidBuoyCoorEA) + call mpas_pool_get_field('PVFluxTest', PVFluxTest) + + call mpas_allocate_scratch_field(PVMidBuoyCoor, .true.) + call mpas_allocate_scratch_field(PVMidBuoyCoorEA, .true.) + call mpas_allocate_scratch_field(uMidBuoyCoorEA , .true.) + call mpas_allocate_scratch_field(vMidBuoyCoorEA , .true.) + call mpas_allocate_scratch_field(uPVMidBuoyCoorEA , .true.) + call mpas_allocate_scratch_field(vPVMidBuoyCoorEA, .true.) + call mpas_allocate_scratch_field(PVFluxTest, .true.) + + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + call mpas_pool_get_array(diagnosticsPool, 'zTop', zTop) + call mpas_pool_get_array(diagnosticsPool, 'density', density) + call mpas_pool_get_array(diagnosticsPool, 'potentialdensity', potentialDensity) + call mpas_pool_get_array(diagnosticsPool, 'pressure', pressure) + call mpas_pool_get_array(diagnosticsPool, 'normalVelocityZonal', uCellCenter) + call mpas_pool_get_array(diagnosticsPool, 'normalVelocityMeridional', vCellCenter) + + call mpas_pool_get_array(am_epftPool, 'potentialDensityMidRef', potentialDensityMidRef) + call mpas_pool_get_array(am_epftPool, 'potentialDensityTopRef', potentialDensityTopRef) + call mpas_pool_get_array(am_epftPool, 'buoyancyMidRef', buoyancyMidRef) + call mpas_pool_get_array(am_epftPool, 'buoyancyInterfaceRef', buoyancyInterfaceRef) + call mpas_pool_get_array(am_epftPool, 'buoyMaskEA', buoyMaskEA) + call mpas_pool_get_array(am_epftPool, 'sigmaEA', sigmaEA) + call mpas_pool_get_array(am_epftPool, 'heightMidBuoyCoorEA', heightMidBuoyCoorEA) + call mpas_pool_get_array(am_epftPool, 'montgPotGradZonalEA', montgPotGradZonalEA) + call mpas_pool_get_array(am_epftPool, 'montgPotGradMeridEA', montgPotGradMeridEA) + call mpas_pool_get_array(am_epftPool, 'heightMidBuoyCoorSqEA', heightMidBuoyCoorSqEA) + call mpas_pool_get_array(am_epftPool, 'montgPotBuoyCoorEA', montgPotBuoyCoorEA) + call mpas_pool_get_array(am_epftPool, 'HeightMGradZonalEA', HeightMGradZonalEA) + call mpas_pool_get_array(am_epftPool, 'HeightMGradMeridEA', HeightMGradMeridEA) + call mpas_pool_get_array(am_epftPool, 'usigmaEA', usigmaEA) + call mpas_pool_get_array(am_epftPool, 'vsigmaEA', vsigmaEA) + call mpas_pool_get_array(am_epftPool, 'uusigmaEA', uusigmaEA) + call mpas_pool_get_array(am_epftPool, 'vvsigmaEA', vvsigmaEA) + call mpas_pool_get_array(am_epftPool, 'uvsigmaEA', uvsigmaEA) + call mpas_pool_get_array(am_epftPool, 'uwsigmaEA', uwsigmaEA) + call mpas_pool_get_array(am_epftPool, 'vwsigmaEA', vwsigmaEA) + call mpas_pool_get_array(am_epftPool, 'uTWA', uTWA) + call mpas_pool_get_array(am_epftPool, 'vTWA', vTWA) + call mpas_pool_get_array(am_epftPool, 'wTWA', wTWA) + call mpas_pool_get_array(am_epftPool, 'EPFT', EPFT) + call mpas_pool_get_array(am_epftPool, 'divEPFT', divEPFT) + call mpas_pool_get_array(am_epftPool, 'ErtelPVFlux', ErtelPVFlux) + call mpas_pool_get_array(am_epftPool, 'ErtelPVTendency', ErtelPVTendency) + call mpas_pool_get_array(am_epftPool, 'ErtelPV', ErtelPV) + + call mpas_pool_get_array(statePool, 'SSH', SSH) + + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + + nSamplesEA = nSamplesEA % scalar + + heightMidBuoyCoor => heightMidBuoyCoor % array + heightTopBuoyCoor => heightTopBuoyCoor % array + heightInterfaceBuoyCoor => heightInterfaceBuoyCoor % array + uMidBuoyCoor => uMidBuoyCoor % array + vMidBuoyCoor => vMidBuoyCoor % array + densityMidBuoyCoor => densityMidBuoyCoor % array + densityTopBuoyCoor => densityTopBuoyCoor % array + sigma => sigma % array + montgPotBuoyCoor => montgPotBuoyCoor % array + montgPotNormalGradOnEdge=> montgPotNormalGradOnEdge % array + firstLayerBuoyCoor => firstLayerBuoyCoor % array + lastLayerBuoyCoor => lastLayerBuoyCoor % array + buoyMask => buoyMask % array + montgPotGradX => montgPotGradX % array + montgPotGradY => montgPotGradY % array + montgPotGradZ => montgPotGradZ % array + montgPotGradZonal => montgPotGradZonal % array + montgPotGradMerid => montgPotGradMerid % array + wrk3DnVertLevelsP1 => wrk3DnVertLevelsP1 % array + wrk3DnVertLevels => wrk3DnVertLevels % array + wrk3DBuoyCoor => wrk3DBuoyCoor % array + + array1_3D => array1_3D % array + array2_3D => array2_3D % array + array3_3D => array3_3D % array + array1_3Dbuoy => array1_3Dbuoy % array + array2_3Dbuoy => array2_3Dbuoy % array + + PVMidBuoyCoor => PVMidBuoyCoor % array + PVMidBuoyCoorEA => PVMidBuoyCoorEA % array + uMidBuoyCoorEA => uMidBuoyCoorEA % array + vMidBuoyCoorEA => vMidBuoyCoorEA % array + uPVMidBuoyCoorEA => uPVMidBuoyCoorEA % array + vPVMidBuoyCoorEA => vPVMidBuoyCoorEA % array + PVFluxTest => PVFluxTest % array + + + nBuoyLayersP1 = nBuoyLayers+1 + + + ! jas diabatic terms + !diabaticHeating(nVertLevels,nCells)! "vertical velocity" in buoyancy space + !wCellCenter = 0.0 + + !jas issue + ! Get diabaticTimeTendency of a buoyancy surface, omega with funny hat, if any. + !call any existing MPAS-O subroutines for this + + + !------------------------------------------------------------- + ! begin computation + !------------------------------------------------------------- + + call get_masks_in_buoyancy_coordinates(nVertLevels, nCells, nBuoyLayers, & + maxLevelCell, potentialDensity, potentialDensityMidRef, & + firstLayerBuoyCoor, lastLayerBuoyCoor, buoyMask) + + if(config_oac_epft_debug) then + print *, ' ' + print *, 'timeLevel:', timeLevel + print *, ' ' + print *, 'potentialDensityTopRef' + print *, potentialDensityTopRef + print *, 'potentialDensityMidRef' + print *, potentialDensityMidRef + print *, 'nCells*nBuoyLayers', nCells*nBuoyLayers + print *, 'sum(buoyMask)', sum(buoyMask) + print *, 'nCells*nVertLevels', nCells*nVertLevels + print *, 'sum(mesh%cellMask%array)', sum(mesh%cellMask%array) + print *, 'minval(potentialDensity), maxval(potentialDensity)' + print *, minval(potentialDensity), maxval(potentialDensity) + print *, 'minval(density), maxval(density)' + print *, minval(density), maxval(density) + endif + + +! INTERPOLATION TEST 1 +! stratified, horizontally uniform +! Interpolating from z, rho to z, rho + if(config_oac_epft_debug) then + do i = 1, nCells + array1_3D(:,i) = -zMid(:,nCells/2) + array2_3D(:,i) = potentialDensity(:,nCells/2) + end do + print *, ' ' + print *, 'Testing interpolatoin function' + print *, 'Interpolating from z, rho to z, rho' + print *, 'call linear_interp_1d_field_along_column(nVertLevels, nCells, & + nVertLevels, maxLevelCell, array1_3D, array2_3D, array1_3D(:,1), array3_3D)' + + print *, 'sum(array1_3D)/nCells + sum(zMid(:,nCells/2))' + print *, sum(array1_3D)/nCells + sum(zMid(:,nCells/2)) + print *, 'sum(array1_3D)/nCells - sum(array1_3D(:,1))' + print *, sum(array1_3D)/nCells - sum(array1_3D(:,1)) + + call linear_interp_1d_field_along_column(nVertLevels, nCells, nVertLevels, & + maxLevelCell, array1_3D, array2_3D, array1_3D(:,1), array3_3D) + print *, 'array1_3D(:,1)' + print *, array1_3D(:,1) + print *, '-zMid(:,nCells/2)' + print *, -zMid(:,nCells/2) + print *, 'array2_3D(:,1)' + print *, array2_3D(:,1) + print *, 'array3_3D(:,1)' + print *, array3_3D(:,1) + print *, 'array2_3D(:,1)-array3_3D(:,1)' + print *, array2_3D(:,1)-array3_3D(:,1) + + do i = 1,nCells + do k = 1, maxLevelCell(i) + RMSlocal1 = RMSlocal1 + & + ((array3_3D(k,i) - array2_3D(k,i)))**2 + !((array3_3D(k,i) - array2_3D(k,i))/array2_3D(k,i))**2 + end do + end do + endif + + +! INTERPOLATION TEST 2 +! Define a stratification where potential density varies linearly with depth +! Using reference potential density that varies linearly with index +! Interpolate z from that potential density to reference potential density +! compare to expected values + if(config_oac_epft_debug) then + do i = 1,nCells + do k = 1, nVertLevels + array1_3D(k,i) = config_rhomin_buoycoor*1.02 + & + (zMid(k,i)-zMid(1,i)) * & + (config_rhomax_buoycoor*0.98 - config_rhomin_buoycoor*1.02) / & + (zMid(nVertLevels,i) - zMid(1,i)) + array2_3D(k,i) = config_rhomin_buoycoor*1.02 + & + (zTop(k,i)-zMid(1,i)) * & + (config_rhomax_buoycoor*0.98 - config_rhomin_buoycoor*1.02) / & + (zMid(nVertLevels,i) - zMid(1,i)) end do end do - end do + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + maxLevelCell, array1_3D, zMid, potentialDensityMidRef, array1_3Dbuoy) + + do i = 1,nCells + do k = 1, nBuoyLayers + array2_3Dbuoy(k,i) = zMid(1,i) + & + (potentialDensityMidRef(k) - config_rhomin_buoycoor*1.02) * & + (zMid(nVertLevels,i) - zMid(1,i)) / & + (config_rhomax_buoycoor*0.98 - config_rhomin_buoycoor*1.02) + end do + end do + do i = 1,nCells + do k = 1, nBuoyLayers + RMSlocal2 = RMSlocal2 + & + ((array1_3Dbuoy(k,i) - array2_3Dbuoy(k,i))/array2_3Dbuoy(k,i))**2 + end do + end do + endif + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!! end chunk for testing +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!! start chunk commented during testing +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call check_potentialDensityRef_range(nVertLevels, nCells, maxLevelCell, potentialDensity) + + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + maxLevelCell, -potentialDensity, zMid, & + -potentialDensityMidRef, heightMidBuoyCoor) + + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + maxLevelCell, -potentialDensity, zMid, & + -potentialDensityTopRef, heightTopBuoyCoor) + do i=1,nCells + !correct the top of heightTopBuoyCoor + do k=1,firstLayerBuoyCoor(i) + heightTopBuoyCoor(k,i)=zTop(1,i) + enddo + ! correct the bottom of heightTopBuoyCoor + do k=lastLayerBuoyCoor(i)+1,nBuoyLayers + heightTopBuoyCoor(k,i)=-bottomDepth(i) + enddo + ! copy into interface variable + heightInterfaceBuoyCoor(1:nBuoyLayers,i)=heightTopBuoyCoor(1:nBuoyLayers,i) + heightInterfaceBuoyCoor(nBuoyLayers+1,i)=-bottomDepth(i) + enddo + + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + maxLevelCell, -potentialDensity, uCellCenter, & + -potentialDensityMidRef, uMidBuoyCoor) + + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + maxLevelCell, -potentialDensity, vCellCenter, & + -potentialDensityMidRef, vMidBuoyCoor) + + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + maxLevelCell, -potentialDensity, density, & + -potentialDensityMidRef, densityMidBuoyCoor) + + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + maxLevelCell, -potentialDensity, density, & + -potentialDensityTopRef, densityTopBuoyCoor) + + !call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + ! maxLevelCell, -potentialDensity, Q, potentialDensityTopRef, QMidRef) + + + call computeBuoyancyColumn(nBuoyLayers, potentialDensityMidRef, buoyancyMidRef) + call computeBuoyancyColumnP1(nBuoyLayersP1, potentialDensityTopRef, & + buoyancyInterfaceRef) + + + call computeSigma(nCells, nBuoyLayers, firstLayerBuoyCoor, lastLayerBuoyCoor, & + heightInterfaceBuoyCoor, buoyancyInterfaceRef, sigma) + + + call computeMontgomeryPotential(nBuoyLayers, nCells, surfacePressure, & + firstLayerBuoyCoor, lastLayerBuoyCoor, SSH, densityMidBuoyCoor, & + potentialDensityMidRef, heightInterfaceBuoyCoor, montgPotBuoyCoor) + call computeNormalGradientOnEdge(nBuoyLayers, nCells, nEdges, & + mesh, & + montgPotBuoyCoor, montgPotNormalGradOnEdge) + call mpas_reconstruct(mesh, montgPotNormalGradOnEdge, & + montgPotGradX, montgPotGradY, montgPotGradZ, & + montgPotGradZonal, montgPotGradMerid) + +! jas issue: in some cases it might be cleaner to pass mesh instead of +! nBuoyLayers, nCells, maxLevelCell... + + ! Increment first-order running mean fields: + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + buoyMask, buoyMaskEA) + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + sigma, sigmaEA) + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + heightMidBuoyCoor, heightMidBuoyCoorEA) + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + montgPotBuoyCoor, montgPotBuoyCoorEA) + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + montgPotGradZonal, montgPotGradZonalEA) + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + montgPotGradMerid, montgPotGradMeridEA) + + + ! Increment second-order running mean fields + wrk3DBuoyCoor = heightMidBuoyCoor * heightMidBuoyCoor + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + wrk3DBuoyCoor, heightMidBuoyCoorSqEA) + + wrk3DBuoyCoor = heightMidBuoyCoor * montgPotGradZonal + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + wrk3DBuoyCoor, HeightMGradZonalEA) + + wrk3DBuoyCoor = heightMidBuoyCoor * montgPotGradMerid + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + wrk3DBuoyCoor, HeightMGradMeridEA) + + wrk3DBuoyCoor = uMidBuoyCoor * sigma + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + wrk3DBuoyCoor, usigmaEA) + + wrk3DBuoyCoor = vMidBuoyCoor * sigma + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + wrk3DBuoyCoor, vsigmaEA) + + !wrk3DBuoyCoor = wMidBuoyCoor * sigma + !call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + ! wrk3DBuoyCoor, wsigmaEA) + + + ! Increment third-order running mean fields + wrk3DBuoyCoor = uMidBuoyCoor * uMidBuoyCoor * sigma + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + wrk3DBuoyCoor, uusigmaEA) + + wrk3DBuoyCoor = vMidBuoyCoor * vMidBuoyCoor * sigma + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + wrk3DBuoyCoor, vvsigmaEA) + + wrk3DBuoyCoor = uMidBuoyCoor * vMidBuoyCoor * sigma + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + wrk3DBuoyCoor, uvsigmaEA) + + !wrk3DBuoyCoor = uMidBuoyCoor * wMidBuoyCoor * sigma + !call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + ! wrk3DBuoyCoor, uwsigmaEA) + uwsigmaEA = 0.0 + + !wrk3DBuoyCoor = vMidBuoyCoor * wMidBuoyCoor* sigma + !call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + ! wrk3DBuoyCoor, vwsigmaEA) + vwsigmaEA = 0.0 + + ! update number of samples in ensemble average + amEPFT % nSamplesEA % scalar = amEPFT % nSamplesEA % scalar + 1 + + + + ! Calculate the thickness weighted averages + call calculateTWA(nBuoyLayers, nCells, nBuoyLayers, & + sigmaEA, usigmaEA, uTWA) + call calculateTWA(nBuoyLayers, nCells, nBuoyLayers, & + sigmaEA, vsigmaEA, vTWA) + !call calculateTWA(nBuoyLayers, nCells, nBuoyLayers, & + ! sigmaEA, wsigmaEA, wTWA) + wTWA = 0.0 + + + call calculateEPFTfromTWA(nBuoyLayers, nCells, & + sigmaEA, heightMidBuoyCoorEA, & + heightMidBuoyCoorSqEA, montgPotGradZonalEA, montgPotGradMeridEA, & + HeightMGradZonalEA, HeightMGradMeridEA, uTWA, vTWA, wTWA, & + uusigmaEA, vvsigmaEA, uvsigmaEA, uwsigmaEA, vwsigmaEA, EPFT) + + call calculateDivEPFT(nBuoyLayers, nCells, nEdges, & + mesh, buoyancyInterfaceRef, sigmaEA, buoyMaskEA, EPFT, divEPFT) + + call calculateErtelPVFlux(nCells, nBuoyLayers, & + sigmaEA, divEPFT, ErtelPVFlux) + + call calculateErtelPVTendencyFromPVFlux(nBuoyLayers, nCells, nEdges, & + mesh, sigmaEA, ErtelPVFlux, ErtelPVTendency) + + + fCell => mesh % fCell % array + call computeErtelPV(nCells, nBuoyLayers, nEdges, mesh, & + fCell, uTWA, vTWA, sigmaEA, ErtelPV) + + ! Compute the geometric decomposition in terms of angles and + ! eccentricities using the entries of EPFT. + !call eddyGeomDecompEPFT(EPFT, ...) + + + + + ! calculate potential vorticity fluxes using curl of u + if(config_oac_epft_debug) then + + relativeVorticityCell => diagnostics % relativeVorticityCell % array + + ! store relVortMidBuoyCoor in array1_3Dbuoy + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + maxLevelCell, -potentialDensity, relativeVorticityCell, & + -potentialDensityMidRef, array1_3Dbuoy) + + do i = 1,nCells + do k=firstLayerBuoyCoor(i), lastLayerBuoyCoor(i) + PVMidBuoyCoor(k,i) = (fCell(i) + array1_3Dbuoy(k,i) ) / sigma(k,i) + end do + end do + + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + uMidBuoyCoor, uMidBuoyCoorEA) + + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + vMidBuoyCoor, vMidBuoyCoorEA) + + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + PVMidBuoyCoor, PVMidBuoyCoorEA) + + wrk3DBuoyCoor = uMidBuoyCoor * PVMidBuoyCoor + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + wrk3DBuoyCoor, uPVMidBuoyCoorEA) + + wrk3DBuoyCoor = vMidBuoyCoor * PVMidBuoyCoor + call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + wrk3DBuoyCoor, vPVMidBuoyCoorEA) + + PVFluxTest(1,:,:) = uPVMidBuoyCoorEA - uMidBuoyCoorEA * PVMidBuoyCoorEA + PVFluxTest(2,:,:) = vPVMidBuoyCoorEA - vMidBuoyCoorEA * PVMidBuoyCoorEA + + do i = 1,nCells + do k = firstLayerBuoyCoor(i), lastLayerBuoyCoor(i) + RMSPVFlux1Local = RMSPVFlux1local + & + ( ErtelPVFlux(1,k,i) - PVFLuxTest(1,k,i) )**2 + RMSPVFlux2Local = RMSPVFlux2local + & + ( ErtelPVFlux(2,k,i) - PVFLuxTest(2,k,i) )**2 + end do + end do + + end if + + + + ! Clean up + ! jas issue: make sure I deallocate everything + call mpas_deallocate_scratch_field(amEPFT % firstLayerBuoyCoor, .true.) + call mpas_deallocate_scratch_field(amEPFT % lastLayerBuoyCoor, .true.) + call mpas_deallocate_scratch_field(amEPFT % buoyMask, .true.) + call mpas_deallocate_scratch_field(amEPFT % heightMidBuoyCoor, .true.) + call mpas_deallocate_scratch_field(amEPFT % heightTopBuoyCoor, .true.) + call mpas_deallocate_scratch_field(amEPFT % heightInterfaceBuoyCoor, .true.) + call mpas_deallocate_scratch_field(amEPFT % uMidBuoyCoor, .true.) + call mpas_deallocate_scratch_field(amEPFT % vMidBuoyCoor, .true.) + call mpas_deallocate_scratch_field(amEPFT % densityMidBuoyCoor, .true.) + call mpas_deallocate_scratch_field(amEPFT % densityTopBuoyCoor, .true.) + call mpas_deallocate_scratch_field(amEPFT % buoyancyMidRef, .true.) + call mpas_deallocate_scratch_field(amEPFT % buoyancyInterfaceRef, .true.) + call mpas_deallocate_scratch_field(amEPFT % sigma, .true.) + call mpas_deallocate_scratch_field(amEPFT % montgPotBuoyCoor, .true.) + call mpas_deallocate_scratch_field(amEPFT % montgPotNormalGradOnEdge, .true.) + call mpas_deallocate_scratch_field(amEPFT % wrk3DnVertLevels, .true.) + call mpas_deallocate_scratch_field(amEPFT % wrk3DBuoyCoor, .true.) + + call mpas_deallocate_scratch_field(amEPFT % array1_3D, .true.) + call mpas_deallocate_scratch_field(amEPFT % array2_3D, .true.) + call mpas_deallocate_scratch_field(amEPFT % array3_3D, .true.) + call mpas_deallocate_scratch_field(amEPFT % array1_3Dbuoy, .true.) + call mpas_deallocate_scratch_field(amEPFT % array2_3Dbuoy, .true.) + + call mpas_deallocate_scratch_field(amEPFT % PVMidBuoyCoor, .true.) + call mpas_deallocate_scratch_field(amEPFT % PVMidBuoyCoorEA, .true.) + call mpas_deallocate_scratch_field(amEPFT % uPVMidBuoyCoorEA , .true.) + call mpas_deallocate_scratch_field(amEPFT % vPVMidBuoyCoorEA, .true.) + call mpas_deallocate_scratch_field(amEPFT % PVFluxTest, .true.) + + + nCellsCum = nCellsCum + nCells block => block % next end do ! mpi gather/scatter calls may be placed here. - ! Here are some examples. See mpas_oac_global_stats.F for further details. -! call mpas_dmpar_sum_real_array(dminfo, nVariables, sumSquares(1:nVariables), reductions(1:nVariables)) -! call mpas_dmpar_min_real_array(dminfo, nMins, mins(1:nMins), reductions(1:nMins)) -! call mpas_dmpar_max_real_array(dminfo, nMaxes, maxes(1:nMaxes), reductions(1:nMaxes)) - - ! Even though some variables do not include an index that is decomposed amongst - ! domain partitions, we assign them within a block loop so that all blocks have the - ! correct values for writing output. + if(config_oac_epft_debug) then + RMSglobal1 = 1.0D36 + call mpas_dmpar_sum_int(dminfo, nCellsCum, nCellsGlobal) + call mpas_dmpar_sum_real(dminfo, RMSlocal1, RMSglobal1) + call mpas_dmpar_sum_real(dminfo, RMSlocal2, RMSglobal2) + + if (dminfo % my_proc_id == IO_NODE) then + print *, ' ' + print *, 'RKIND=', RKIND + print *, 'rms relative error interp test1:',sqrt(RMSglobal1/nCellsGlobal) + print *, 'rms relative error interp test2:',sqrt(RMSglobal2/nCellsGlobal) + + print *, ' ' + endif + + + call mpas_dmpar_sum_real(dminfo, sum(abs(ErtelPVFlux(1,:,:))), RMSglobal1) + call mpas_dmpar_max_real(dminfo, maxval(abs(ErtelPVFlux(1,:,:))), RMSglobal2) + if (dminfo % my_proc_id == IO_NODE) then + print *, 'Checking ErtelPVFlux' + print *, 'Global sum(abs(ErtelPVFlux(1,:,:))) = ', RMSglobal1 + print *, 'Global max(abs(ErtelPVFlux(1,:,:))) = ', RMSglobal2 + endif + + call mpas_dmpar_sum_real(dminfo, sum(abs(ErtelPVFlux(2,:,:))), RMSglobal1) + call mpas_dmpar_max_real(dminfo, maxval(abs(ErtelPVFlux(2,:,:))), RMSglobal2) + if (dminfo % my_proc_id == IO_NODE) then + print *, 'Global sum(abs(ErtelPVFlux(2,:,:))) = ', RMSglobal1 + print *, 'Global max(abs(ErtelPVFlux(2,:,:))) = ', RMSglobal2 + endif + + call mpas_dmpar_sum_real(dminfo, sum(abs(ErtelPVFlux(3,:,:))), RMSglobal1) + call mpas_dmpar_max_real(dminfo, maxval(abs(ErtelPVFlux(3,:,:))), RMSglobal2) + if (dminfo % my_proc_id == IO_NODE) then + print *, 'Global sum(abs(ErtelPVFlux(3,:,:))) = ', RMSglobal1 + print *, 'Global max(abs(ErtelPVFlux(3,:,:))) = ', RMSglobal2 + endif + + call mpas_dmpar_sum_real(dminfo, RMSPVFlux1Local, RMSPVFlux1global) + call mpas_dmpar_sum_real(dminfo, RMSPVFlux2Local, RMSPVFlux2global) + if (dminfo % my_proc_id == IO_NODE) then + print *, 'rms relative error test PVFlux1:',sqrt(RMSPVFlux1global/nCellsGlobal) + print *, 'rms relative error test PVFlux2:',sqrt(RMSPVFLux2global/nCellsGlobal) + + print *, ' ' + endif + + endif + + block => domain % blocklist do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'am_eliassen_palm_flux_tensor', am_eliassen_palm_flux_tensorPool) + call mpas_pool_get_subpool(block % structs, 'am_eliassen_palm_flux_tensor', am_epftPool) ! assignment of final am_eliassen_palm_flux_tensor variables could occur here. From 08d8fd1d8cf48e13d5176f45c58266f994963266 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Fri, 29 May 2015 15:16:18 -0600 Subject: [PATCH 0070/1724] populated the rest of the routines, beyond compute populated the rest of the routines, after compute. copied them from the old epftDiag branch. --- .../mpas_ocn_eliassen_palm_flux_tensor.F | 1241 +++++++++++++++++ 1 file changed, 1241 insertions(+) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F index 4e870edc55..0375ca04bd 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F @@ -1125,6 +1125,1247 @@ subroutine ocn_finalize_eliassen_palm_flux_tensor(domain, err)!{{{ end subroutine ocn_finalize_eliassen_palm_flux_tensor!}}} + +!*********************************************************************** +! +! subroutine get_masks_in_buoyancy_coordinates +! +!> \brief Get masks in buoyancy coordinates +!> \author Juan A. Saenz +!> \date Jan 2014 +!> \details +!> firstLayerBuoyCoor(iCell): the index of the smallest reference density that +!> is >= the smallest actual density in a column. +!> lastLayerBuoyCoor(iCell): the index of the largest reference density that is <= the +!> largest actual density in a column. +!> Set masks in buoyancy coordinates: +!> mask = 1: cell is a valid ocean cell +!> mask = 0: cell is not a valid ocean cell +!> Required: potentialDensityMidRef monotonically increases with index value +! +!----------------------------------------------------------------------- + subroutine get_masks_in_buoyancy_coordinates(nVertLevels, nCells, nBuoyLayers, & + maxLevelCell, potentialDensity, potentialDensityMidRef, & + firstLayerBuoyCoor, lastLayerBuoyCoor, buoyMask)!{{{ + + integer, intent(in) :: nVertLevels, nCells, nBuoyLayers + integer, dimension(nCells), intent(in) :: maxLevelCell + integer, dimension(nCells), intent(out) :: firstLayerBuoyCoor + integer, dimension(nCells), intent(out) :: lastLayerBuoyCoor + real (kind=RKIND), dimension(nBuoyLayers, nCells), intent(out) :: buoyMask + real (kind=RKIND), dimension(nVertLevels, nCells), intent(in) :: potentialDensity + real (kind=RKIND), dimension(nBuoyLayers), intent(in) :: potentialDensityMidRef + + ! Local variables + integer :: iCell, maxLevel, kB, kBBottom, kBTop + + firstLayerBuoyCoor = 1 + lastLayerBuoyCoor = nBuoyLayers + buoyMask = 0.0 + + + do iCell = 1, nCells + + maxLevel = maxLevelCell(iCell) + + do kB = 1, nBuoyLayers + if (potentialDensityMidRef(kB) >= potentialDensity(1,iCell) ) then + firstLayerBuoyCoor(iCell) = kB + exit + endif + enddo + + do kB = nBuoyLayers, 1, -1 + if (potentialDensityMidRef(kB) <= potentialDensity(maxLevel,iCell) ) then + lastLayerBuoyCoor(iCell) = kB + exit + endif + enddo + + ! set mask to 1 inside the range + do kB = firstLayerBuoyCoor(iCell), lastLayerBuoyCoor(iCell) + buoyMask(kB,iCell) = 1.0 + enddo + + enddo + + end subroutine get_masks_in_buoyancy_coordinates!}}} + + + +!*********************************************************************** +! +! subroutine check_potentialDensityRef_range +! +!> \brief Check if the range of values in potentialDensityTopRef contains current state +!> \author Juan A. Saenz +!> \date Jan 2014 +!> \details +!> Check if the range of values in potentialDesnityTopRef contains all values in +!> potentialDensity of the current state. +!> If not, print a warning. +! +!----------------------------------------------------------------------- + subroutine check_potentialDensityRef_range(nVertLevels, nCells, maxLevelCell, & + potentialDensity)!{{{ + integer, intent(in) :: nVertLevels, nCells + integer, dimension(nCells), intent(in) :: maxLevelCell + real (kind=RKIND), dimension(nVertLevels, nCells), intent(in) :: potentialDensity + + ! Local variables + integer :: k, i + logical :: printWarning + + printWarning = .false. + + do i = 1, nCells + if (potentialDensity(1,i) < config_rhomin_buoycoor) then + printWarning = .true. + exit + end if + if (potentialDensity(maxLevelCell(i),i) > config_rhomax_buoycoor) then + printWarning = .true. + exit + end if + enddo + + !jas issue: do we want to print a warning once, or at every i,k out of range? + if (printWarning) then + write(stderrUnit,*) 'Warning: in EPFT package, reference potential density does & + not span the values of potentialDensity in the current state' + end if + + end subroutine check_potentialDensityRef_range!}}} + + + + +!*********************************************************************** +! +! subroutine linear_interp_1d_field_along_column +! +!> \brief One-dimensional interpolation in buoyancy coordinates +!> \author Juan A. Saenz, Todd Ringler +!> \date 17 December 2013 +!> \details +!> Interpolate a field yFieldIn residing on xFieldIn onto xColumnOut and store +!> and return in yFieldOut. +!> Interpolation is done using one-dimensional interpolation along xColumnOut. +!> Required: xFieldIn monotonically decreases with index value +! +!----------------------------------------------------------------------- + + subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + maxLevelCell, xFieldIn, yFieldIn, xColumnOut, yFieldOut)!{{{ + + integer, intent(in) :: nVertLevels, nCells, nBuoyLayers + integer, dimension(nCells), intent(in) :: maxLevelCell + real (kind=RKIND), dimension(nVertLevels, nCells), intent(in) :: xFieldIn + real (kind=RKIND), dimension(nVertLevels, nCells), intent(in) :: yFieldIn + real (kind=RKIND), dimension(nBuoyLayers), intent(in) :: xColumnOut + real (kind=RKIND), dimension(nBuoyLayers, nCells), intent(out) :: yFieldOut + + ! Local variables + integer :: iCell, maxLevel, kB, kBBottom, kBTop, kDataAbove, kDataBelow, kData + real (kind=RKIND) :: dx, dy + + yFieldOut = 0.0 + + do iCell = 1, nCells + + ! find the index of the bottom level of a column + maxLevel = maxLevelCell(iCell) + + ! Monotonically decreasing xFieldIn required + ! Find index of first element in xColumnOut that is inside xFieldIn(:,iCell) + kBTop = 1 + do kB = 1, nBuoyLayers + ! the following line ensures that + ! if all xColumnOut > xFieldIn(1,iCell) then kBTop = nBuoyLayers + kBTop = kB + if (xColumnOut(kB) <= xFieldIn(1,iCell) ) then + exit + endif + enddo + + !find last target buoyancy level inside column + kBBottom = nBuoyLayers + do kB = nBuoyLayers, 1, -1 + ! the following line ensures that + ! if all xColumnOut < xFieldIn(1,iCell) then kBBottom = 1 + kBBottom = kB + if (xColumnOut(kB) >= xFieldIn(maxLevel,iCell) ) then + exit + endif + enddo + + + ! For the target x levels outside the x range in a column: + ! set data from 1:kBTop-1 to surface values + do kB = 1, kBTop-1 + yFieldOut(kB,iCell) = yFieldIn(1,iCell) + enddo + !set data from kBBottom+1:nBuoyLayers to bottom values + do kB = kBBottom+1, nBuoyLayers + yFieldOut(kB,iCell) = yFieldIn(maxLevel,iCell) + enddo + + ! The interpolation: + ! for the target buoyancy levels within the buoyancy range in a column: + ! jas issue: this can be replaced by a call to + ! src/operators/mpas_spline_interpolatoin.F:mpas_interpolate_linear() + kDataAbove = 1 + kDataBelow = kDataAbove + 1 + do kB = kBTop, kBBottom + ! for each xColumnOut(kB) value, find the corresponding upper and lower + ! xFieldIn value in the field data, then interpolate y between those values. + if (xColumnOut(kB) < xFieldIn(kDataBelow,iCell)) then + do kData = kDataBelow, maxLevel + if (xColumnOut(kB) > xFieldIn(kData,iCell) ) then + kDataBelow=kData + kDataAbove=kDataBelow-1 + exit + endif + enddo + endif + + dx = xFieldIn(kDataBelow,iCell) - xFieldIn(kDataAbove,iCell) + dy = yFieldIn(kDataBelow,iCell) - yFieldIn(kDataAbove,iCell) + yFieldOut(kB,iCell) = yFieldIn(kDataAbove,iCell) + & + (xColumnOut(kB)-xFieldIn(kDataAbove,iCell)) * dy/dx + enddo + + enddo + + end subroutine linear_interp_1d_field_along_column!}}} + + +!*********************************************************************** +! +! subroutine computeBuoyancyColumn +! +!> \brief Compute buoyancy +!> \author Juan A. Saenz +!> \date 17 December 2013 +!> \details +!> This subroutine computes buoyancy +! +!----------------------------------------------------------------------- + + subroutine computeBuoyancyColumn(nLayers, potentialDensity, buoyancy)!{{{ + integer, intent(in) :: nLayers + real (kind=RKIND), dimension(nLayers), intent(in) :: potentialDensity + real (kind=RKIND), dimension(nLayers), intent(out) :: buoyancy + + !local variables + integer :: i, k + real (kind=RKIND) :: rho0 + + rho0 = config_density0 + + buoyancy = 0.0 + + do k = 1, nLayers + buoyancy(k) = -gravity * (potentialDensity(k)-rho0) / rho0 + enddo + + end subroutine computeBuoyancyColumn!}}} + + +!*********************************************************************** +! +! subroutine computeBuoyancyColumnP1 +! +!> \brief Compute buoyancy +!> \author Juan A. Saenz +!> \date Jan 2014 +!> \details +!> This subroutine computes buoyancy +! +!----------------------------------------------------------------------- + + subroutine computeBuoyancyColumnP1(nLayers, potentialDensity, buoyancy)!{{{ + integer, intent(in) :: nLayers + real (kind=RKIND), dimension(nLayers-1), intent(in) :: potentialDensity + real (kind=RKIND), dimension(nLayers), intent(out) :: buoyancy + + !local variables + integer :: i, k + real (kind=RKIND) :: rho0 + + rho0 = config_density0 + + buoyancy = 0.0 + + do k = 1, nLayers-1 + buoyancy(k) = -gravity * (potentialDensity(k)-rho0) / rho0 + enddo + + buoyancy(nLayers) = -gravity * (config_rhomax_buoycoor-rho0) / rho0 + + + end subroutine computeBuoyancyColumnP1!}}} + + + +!*********************************************************************** +! +! subroutine computeSigma +! +!> \brief Calculate the inverse of the derivative of buoy wrt z +!> \author Juan A. Saenz +!> \date December 2013 +!> \details +!> This subroutine calculates the inverse of the derivative of buoy wrt z. +! +!----------------------------------------------------------------------- + + subroutine computeSigma(nCells, nLayers, firstLayerBuoyCoor, & + lastLayerBuoyCoor, heightInterface, buoyInterface, sigma)!{{{ + integer, intent(in) :: nCells, nLayers + integer, dimension(:), intent(in) :: firstLayerBuoyCoor + integer, dimension(:), intent(in) :: lastLayerBuoyCoor + real (kind=RKIND), dimension(:,:), intent(in) :: heightInterface + real (kind=RKIND), dimension(:), intent(in) :: buoyInterface + real (kind=RKIND), dimension(:,:), intent(out) :: sigma + + + ! local variables + integer :: i, k + + sigma = 0.0 + + do i = 1, nCells + do k = 1,nLayers + sigma(k,i) = (heightInterface(k,i) - heightInterface(k+1,i)) / & + (buoyInterface(k) - buoyInterface(k+1)) + enddo + enddo + + end subroutine computeSigma!}}} + + + +!*********************************************************************** +! +! subroutine computeMontgomeryPotential +! +!> \brief Compute the Montgomery potential +!> \author Juan A. Saenz +!> \date 17 December 2013 +!> \details +!> This subroutine computes the Montgomery potential using eqn 2.10 in +!> R.L. Higdon and R.A. Szoeke (1997), J. Comp. Phys. 135, 30–53, Article No. CP975733 +! +!> Montgomery Potential (MP) in layer k is MP(k-1) + pInterface(k)*deltaAlpha +!> where deltaAlpha is (1/potDens(k) - 1/potDens(k-1)) +!> and pInterface(k) is the pressure at interface k, i.e. at top of layer k. +!> +!> Montgomery potential of a layer is constant across layer +!----------------------------------------------------------------------- + + subroutine computeMontgomeryPotential(nLayers, nCells, pSurface, firstLayer, & + lastLayer, SSH, density, potDens, heightInterface, MontgomeryPotential)!{{{ + integer, intent(in) :: nLayers, nCells + integer, dimension(nCells), intent(in) :: firstLayer + integer, dimension(nCells), intent(in) :: lastLayer + real (kind=RKIND), dimension(nCells), intent(in) :: pSurface + real (kind=RKIND), dimension(nCells), intent(in) :: SSH + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: density + real (kind=RKIND), dimension(nLayers), intent(in) :: potDens + real (kind=RKIND), dimension(nLayers+1, nCells), intent(in) :: heightInterface + real (kind=RKIND), dimension(nLayers, nCells), intent(out) :: MontgomeryPotential + + ! local variables + integer :: i, k + real (kind=RKIND) :: pInterfacek ! pressure at interface k, i.e. at top of layer k + + MontgomeryPotential = 0.0 + + + do i = 1, nCells + + !pInterfacek = pSurface(i) + pInterfacek = 0.0 + k = 1 + MontgomeryPotential(k,i) = pInterfacek/potDens(k) + gravity*heightInterface(k,i) + + do k = 2, nLayers + pInterfacek = pInterfacek + & + gravity * ( heightInterface(k-1,i)-heightInterface(k,i) ) * density(k-1,i) + MontgomeryPotential(k,i) = MontgomeryPotential(k-1,i) + & + pInterfacek * ( 1/potDens(k) - 1/potDens(k-1) ) + enddo + + enddo + + end subroutine computeMontgomeryPotential!}}} + + + +!*********************************************************************** +! +! subroutine computeNormalGradientOnEdge +! +!> \brief Compute the gradient of a quantity that exists on cell centers +!> \author Juan A. Saenz +!> \date December 2013 +!> \details +!> This subroutine computes the gradient of a quantity that exists on cell centers +! +!----------------------------------------------------------------------- + + subroutine computeNormalGradientOnEdge(nBLayers, nCells, nEdges, & + mesh, field, normalGradOnEdge)!{{{ + integer, intent(in) :: nBLayers, nCells, nEdges + type (mesh_type), intent(in) :: mesh !< Input: mesh information + real (kind=RKIND), dimension(:,:), intent(in) :: field + real (kind=RKIND), dimension(:,:), intent(out) :: normalGradOnEdge + + !local variables + integer :: nEdgesSolve, iEdge, k, cell1, cell2, kMin, kMax + integer, dimension(:), pointer :: maxLevelEdgeTop + integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:,:), pointer :: boundaryEdge + real (kind=RKIND), dimension(:), pointer :: dcEdge + real (kind=RKIND) :: invLength + + cellsOnEdge => mesh % cellsOnEdge % array + dcEdge => mesh % dcEdge % array + maxLevelEdgeTop => mesh % maxLevelEdgeTop % array + boundaryEdge => mesh % boundaryEdge % array + + normalGradOnEdge = 0.0 + + do iEdge = 1, nEdges + ! enforce enforce zero gradient on boundary edges + if (boundaryEdge(1,iEdge) == 1) then + normalGradOnEdge(:,iEdge) = 0.0 + else + cell1 = cellsOnEdge(1, iEdge) + cell2 = cellsOnEdge(2, iEdge) + invLength = 1.0 / dcEdge(iEdge) + do k = 1, mesh % nBuoyancyLayers + normalGradOnEdge(k,iEdge) = ( field(k,cell2) - field(k,cell1) )*invLength + enddo + end if + enddo + + end subroutine computeNormalGradientOnEdge!}}} + + + +!*********************************************************************** +! +! subroutine updateEnsembleAverage +! +!> \brief Update ensemble average +!> \author Juan A. Saenz +!> \date 17 December 2013 +!> \details +!> This subroutine updates the ensemble average +! +!----------------------------------------------------------------------- + + subroutine updateEnsembleAverage(nLayers, nCells, nSamples, A, Abar)!{{{ + integer, intent(in) :: nLayers, nCells, nSamples + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: A + real (kind=RKIND), dimension(nLayers, nCells), intent(inout) :: Abar + + !test + integer :: i, k + + do i = 1, nCells + do k = 1, nLayers + Abar(k,i) = (nSamples * Abar(k,i) + A(k,i)) / (nSamples + 1.0) + enddo + enddo + + end subroutine updateEnsembleAverage!}}} + + +!*********************************************************************** +! +! subroutine calculateTWA +! +!> \brief Calculate the thickness weighted average +!> \author Juan A. Saenz +!> \date January 2014 +!> \details +!> This subroutine calculates the thickness weighted average +! +!----------------------------------------------------------------------- + subroutine calculateTWA(nLayers, nCells, nBuoyancyLayers, sigmaEA, & + varSigmaEA, varTWA)!{{{ + integer, intent(in) :: nLayers, nCells, nBuoyancyLayers + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: sigmaEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: varSigmaEA + real (kind=RKIND), dimension(nLayers, nCells), intent(out) :: varTWA + + ! local variables + integer :: i, k + + varTWA = 0.0 + + do i = 1, nCells + do k = 1,nBuoyancyLayers + varTWA(k,i) = varSigmaEA(k,i) / max(1.0e-15,sigmaEA(k,i)) + enddo + enddo + + end subroutine calculateTWA!}}} + + +!*********************************************************************** +! +! subroutine calculateEPFTfromTWA +! +!> \brief Calculate the Eliassen-Palm flux tensor from TWAs +!> \author Juan A. Saenz +!> \date January 2014 +!> \details +!> This subroutine calculates the Eliassen and Palm flux tensor from thickness +!> weighted averages. +!> EPTF_pq(x,y,z) is represented as EPFT(p,q,k,i) +!----------------------------------------------------------------------- + + subroutine calculateEPFTfromTWA(nLayers, nCells, & + sigmaEA, heightEA, heightSqEA, MxEA, MyEA, HMxEA, HMyEA, uTWA, vTWA, wTWA, & + uuSigmaEA, vvSigmaEA, uvSigmaEA, uwSigmaEA, vwSigmaEA, Etensor)!{{{ + integer, intent(in) :: nLayers, nCells + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: sigmaEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: heightEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: heightSqEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: MxEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: MyEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: HMxEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: HMyEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: uTWA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: vTWA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: wTWA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: uuSigmaEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: vvSigmaEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: uvSigmaEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: uwSigmaEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: vwSigmaEA + real (kind=RKIND), dimension(3, 3, nLayers, nCells), intent(out) :: Etensor + + ! local variables + integer :: iCell, kLayer + real (kind=RKIND) :: sigma + real (kind=RKIND) :: uppupp, vppvpp, uppvpp, uppwpp, vppwpp + real (kind=RKIND) :: HpHp, HpMxp, HpMyp + + Etensor = 0.0 + + do iCell = 1, nCells + do kLayer = 1,nLayers + + sigma = max(sigmaEA(kLayer,iCell), 1.0e-15) + + uppupp = uuSigmaEA(kLayer,iCell) / sigma - uTWA(kLayer,iCell)*uTWA(kLayer,iCell) + vppvpp = vvSigmaEA(kLayer,iCell) / sigma - vTWA(kLayer,iCell)*vTWA(kLayer,iCell) + uppvpp = uvSigmaEA(kLayer,iCell) / sigma - uTWA(kLayer,iCell)*vTWA(kLayer,iCell) + uppwpp = uwSigmaEA(kLayer,iCell) / sigma - uTWA(kLayer,iCell)*wTWA(kLayer,iCell) + vppwpp = vwSigmaEA(kLayer,iCell) / sigma - vTWA(kLayer,iCell)*wTWA(kLayer,iCell) + HpHp = heightSqEA(kLayer,iCell) - heightEA(kLayer,iCell)*heightEA(kLayer,iCell) + HpMxp = HMxEA(kLayer,iCell) - heightEA(kLayer,iCell)*MxEA(kLayer,iCell) + HpMyp = HMyEA(kLayer,iCell) - heightEA(kLayer,iCell)*MyEA(kLayer,iCell) + + !EPTF_pq(x,y,z) is represented as EPFT(p,q,kLayer,iCell) + !column 1: Eu + Etensor(1,1,kLayer,iCell) = uppupp + 0.5 * HpHp / sigma + Etensor(2,1,kLayer,iCell) = uppvpp + Etensor(3,1,kLayer,iCell) = uppwpp + HpMxp / sigma + + !column 2: Ev + Etensor(1,2,kLayer,iCell) = uppvpp + Etensor(2,2,kLayer,iCell) = vppvpp + 0.5 * HpHp / sigma + Etensor(3,2,kLayer,iCell) = vppwpp + HpMyp / sigma + + !column 3: Ew + Etensor(1,3,kLayer,iCell) = 0.0 + Etensor(2,3,kLayer,iCell) = 0.0 + Etensor(3,3,kLayer,iCell) = 0.0 + + enddo + enddo + + end subroutine calculateEPFTfromTWA!}}} + + +!*********************************************************************** +! +! subroutine calculateDivEPFT +! +!> \brief Calculate the divergence of EPFT +!> \author Juan A. Saenz +!> \date January 2014 +!> \details +!> This subroutine calculates the divergence of the Elliassen-Palm flux tensor +! +!----------------------------------------------------------------------- + + subroutine calculateDivEPFT(nLayers, nCells, nEdges, & + mesh, buoyancyInterfaceRef, sigmaEA, buoyMaskEA, tensorCellIn, vectorCellOut)!{{{ + + use mpas_vector_operations + + integer, intent(in) :: nLayers, nCells, nEdges + type (mesh_type), intent(in) :: mesh + real (kind=RKIND), dimension(:), intent(in) :: buoyancyInterfaceRef + real (kind=RKIND), dimension(:,:), intent(in) :: sigmaEA + real (kind=RKIND), dimension(:,:), intent(in) :: buoyMaskEA + real (kind=RKIND), dimension(:,:,:,:), intent(in) :: tensorCellIn + real (kind=RKIND), dimension(:,:,:), intent(out) :: vectorCellOut + + ! local variables + logical :: includeHalo, on_a_sphere + integer :: q, iCell, kLayer, iComponent + real (kind=RKIND) :: wrk, wrkAbove, wrkBelow, sigma, db + real (kind=RKIND), dimension(:), pointer :: latCell + real (kind=RKIND), dimension(:), pointer :: lonCell + integer, dimension(:,:), pointer :: edgeSignOnCell + real (kind=RKIND), dimension(:,:), allocatable :: scalarWrk1 + real (kind=RKIND), dimension(:,:,:), allocatable :: vectorCellWrk1 + real (kind=RKIND), dimension(:,:,:), allocatable :: vectorCellWrk2 + real (kind=RKIND), dimension(:,:,:), allocatable :: vectorEdgeWrk1 + real (kind=RKIND), dimension(:), allocatable :: vertVector + real (kind=RKIND) :: rho0 + + ! variables used for testing and debugging + real (kind=RKIND), dimension(:), allocatable :: divExact + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + xCell => mesh % xCell % array + yCell => mesh % yCell % array + zCell => mesh % zCell % array + + if (config_oac_epft_debug) then + allocate(divExact(nCells+1)) + end if + + + rho0 = config_density0 + + allocate(scalarWrk1(nLayers,nCells+1)) + allocate(vectorCellWrk1(3,nLayers,nCells+1)) + allocate(vectorCellWrk2(3,nLayers,nCells+1)) + allocate(vectorEdgeWrk1(3,nLayers,nEdges)) + allocate(vertVector(nLayers)) + + on_a_sphere = mesh % on_a_sphere + edgeSignOnCell => mesh % edgeSignOnCell % array + latCell => mesh % latCell % array + lonCell => mesh % lonCell % array + + includeHalo = .true. + + + ! initialize work and intent(out) + vectorCellOut = 0.0 + + ! loop over all three column vectors + do q = 1, 3 + + scalarWrk1 = 0.0 + + ! horizontal derivatives + vectorCellWrk1 = tensorCellIn(:,q,:,:) + + ! weight the vector with sigmaEA(:,:) + do iComponent = 1,3 + vectorCellWrk1(iComponent,:,:) = sigmaEA(:,:)*vectorCellWrk1(iComponent,:,:) + enddo + + + ! use q=3 as a test vector + if (q.eq.3 .and. config_oac_epft_debug) then + do iCell = 1,nCells + vectorCellWrk1(1,:,iCell) = xCell(iCell) + vectorCellWrk1(2,:,iCell) = yCell(iCell) + vectorCellWrk1(3,:,iCell) = zCell(iCell) + ! the analytical divergence: + divExact(iCell) = -1.0*sin(lonCell(iCell)) * & + (1.0 + 2.0*sin(latCell(iCell))) !+ 3.0*sin(latCell(iCell)) + enddo + endif + + ! zero the vertical component of vectorCellWrk1 + ! the vertical will be treated seperately below + vectorCellWrk1(3,:,:) = 0.0 + + if (on_a_sphere) then + + do iCell = 1,nCells + do kLayer = 1,nLayers + call mpas_vector_LonLatR_to_R3(vectorCellWrk1(:,kLayer,iCell), & + lonCell(iCell), latCell(iCell), vectorCellWrk2(:,kLayer,iCell)) + end do + end do + + vectorCellWrk1 = vectorCellWrk2 + + end if + + call mpas_vector_R3Cell_to_Edge(vectorCellWrk1, mesh, & + vectorEdgeWrk1) + + call mpas_divergence_in_r3_buoyancy(vectorEdgeWrk1, mesh, & + edgeSignOnCell, includeHalo, scalarWrk1) + + ! use q=3 as a test vector + if (q.eq.3 .and. config_oac_epft_debug) then + print *, ' ' + do kLayer = 1,nLayers + wrk = sqrt( & + sum( & + ( & + (divExact(:)-scalarWrk1(kLayer,:))/ max(abs(divExact(:)),1.0e-15) & + )**2 * & + (1.0 - mesh % boundaryCell % array(1,:)) & + ) / nCells ) + print *, 'div RMS relative error on layer:', wrk + enddo + endif + + + if (q < 3 .or. .not. config_oac_epft_debug) then + do iCell = 1,nCells + do kLayer = 1,nLayers + sigma = max(sigmaEA(kLayer,iCell), 1.0e-15) + scalarWrk1(kLayer,iCell) = scalarWrk1(kLayer,iCell) / sigma + end do + end do + end if + + + ! vertical derivative + do iCell = 1,nCells + + ! copy the vertical component of EPFT into a work array + vertVector(:) = tensorCellIn(3,q,:,iCell) + + ! use q=3 as a test vector + if (q.eq.3 .and. config_oac_epft_debug) then + vertVector(:) = 0.0 + endif + + + do kLayer = 1,nLayers + + wrk = 0.0 + + ! jas issue: change buoyancyInterfaceRef to buoyancyMidRef and generalize + if(kLayer.eq.1) then + wrkAbove=sigmaEA(kLayer,iCell)*vertVector(kLayer) + wrkBelow=sigmaEA(kLayer+1,iCell)*vertVector(kLayer+1) + db = buoyancyInterfaceRef(kLayer)-buoyancyInterfaceRef(kLayer+1) + else if (kLayer.eq.nLayers) then + wrkAbove=sigmaEA(kLayer-1,iCell)*vertVector(kLayer-1) + wrkBelow=sigmaEA(kLayer,iCell)*vertVector(kLayer) + db = buoyancyInterfaceRef(kLayer)-buoyancyInterfaceRef(kLayer+1) + else + wrkAbove=sigmaEA(kLayer-1,iCell)*vertVector(kLayer-1) + wrkBelow=sigmaEA(kLayer+1,iCell)*vertVector(kLayer+1) + db = 2.0*(buoyancyInterfaceRef(kLayer)-buoyancyInterfaceRef(kLayer+1)) + endif + + ! jas issue: should sigma also be clipped like this for k-1 and k+1? + sigma = max(sigmaEA(kLayer,iCell), 1.0e-15) + wrk = (wrkAbove - wrkBelow) / db / sigma + + scalarWrk1(kLayer,iCell) = scalarWrk1(kLayer,iCell) + wrk + + ! temporarily mask divEPFT to add in visualization + !if(buoyMaskEA(kLayer,iCell).lt.0.5) scalarWrk1(kLayer,iCell) = 0.0 + + end do + + end do + + vectorCellOut(q,:,:) = scalarWrk1 + + end do + + + deallocate(scalarWrk1) + deallocate(vectorCellWrk1) + deallocate(vectorCellWrk2) + deallocate(vectorEdgeWrk1) + deallocate(vertVector) + + + end subroutine calculateDivEPFT!}}} + + + +!*********************************************************************** +! +! subroutine calculateErtelPVFlux +! +!> \brief Calculate the Ertel potential vorticity fluxes +!> \author Juan A. Saenz +!> \date January 2014 +!> \details +!> This subroutine calculates the Ertel potential vorticity fluxes +!> using the divergence of EPFT, as outlined in eqn 129 of Young 2012. +! +!----------------------------------------------------------------------- + + subroutine calculateErtelPVFlux(nCells, nBuoyancyLayers, & + sigma, divEPFT, ErtelPVFlux)!{{{ + + integer, intent(in) :: nCells, nBuoyancyLayers + real (kind=RKIND), dimension(:,:), intent(in) :: sigma + real (kind=RKIND), dimension(:,:,:), intent(in) :: divEPFT + real (kind=RKIND), dimension(:,:,:), intent(out) :: ErtelPVFlux + + ! local variables + integer :: i, k + + ErtelPVFlux(1,:,:) = divEPFT(2,:,:) + ErtelPVFlux(2,:,:) = -1.0 * divEPFT(1,:,:) + ErtelPVFlux(3,:,:) = 0.0 + + do i = 1, nCells + do k = 1,nBuoyancyLayers + ErtelPVFlux(:,k,i) = ErtelPVFlux(:,k,i) / max(sigma(k,i),1.0e-15) + end do + end do + + end subroutine calculateErtelPVFlux + + + +!*********************************************************************** +! +! routine mpas_tensor_cell_to_edge_BuoyCoor +! +!> \brief Interpolate a matrix from cell to edge +!> \author Mark Petersen, Juan A. Saenz +!> \date Jan 2014 +!> \details +!> This routine interpolates a matrix from cell to edge locations, +!> looping through nBuoyancyLayers. +! +!----------------------------------------------------------------------- + + subroutine mpas_tensor_cell_to_edge_BuoyCoor(matrixCell, grid, & + includeHalo, matrixEdge)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:,:,:), intent(in) :: & + matrixCell !< Input: matrix located at Cell + + type (mesh_type), intent(in) :: & + grid !< Input: grid information + + logical, intent(in) :: & + includeHalo !< Input: If true, halo cells and edges are included in computation + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:,:,:), intent(out) :: & + matrixEdge !< Output: matrix located at Edge + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iEdge, cell1, cell2, p, q, k + integer :: nEdgesCompute, nBuoyLayers, nCells + integer, dimension(:,:), pointer :: cellsOnEdge + + if (includeHalo) then + nEdgesCompute = grid % nEdges + else + nEdgesCompute = grid % nEdgesSolve + endif + nBuoyLayers = grid % nBuoyancyLayers + nCells = grid % nCells + + cellsOnEdge => grid % cellsOnEdge % array + + ! error check that index 1 of matrixEdge and matrixCell are same length? + + do iEdge=1,nEdgesCompute + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + do k=1,nBuoyLayers + do q = 1, 3 + do p = 1, 3 + matrixEdge(p,q,k,iEdge) = & + 0.5*(matrixCell(p,q,k,cell1) + matrixCell(p,q,k,cell2)) + end do + end do + enddo + enddo + + end subroutine mpas_tensor_cell_to_edge_BuoyCoor!}}} + + +!*********************************************************************** +! +! subroutine calculateErtelPVTendencyFromPVFlux +! +!> \brief Calculate the Ertel PV tendency from Ertel PV flux +!> \author Juan A. Saenz +!> \date January 2014 +!> \details +!> This subroutine calculates the Ertel PV tendency as the divergence of +!> the Ertel PV flux +! +!----------------------------------------------------------------------- + + subroutine calculateErtelPVTendencyFromPVFlux(nLayers, nCells, nEdges, & + mesh, sigmaEA, vectorCell, divVectorCell)!{{{ + + use mpas_vector_operations + + integer, intent(in) :: nLayers, nCells, nEdges + type (mesh_type), intent(in) :: mesh + real (kind=RKIND), dimension(:,:), intent(in) :: sigmaEA + real (kind=RKIND), dimension(:,:,:), intent(in) :: vectorCell + real (kind=RKIND), dimension(:,:), intent(out) :: divVectorCell + + ! local variables + logical :: includeHalo, on_a_sphere + integer :: i, k, iComponent + real (kind=RKIND) :: sigma + real (kind=RKIND), dimension(:), pointer :: latCell + real (kind=RKIND), dimension(:), pointer :: lonCell + integer, dimension(:,:), pointer :: edgeSignOnCell + real (kind=RKIND), dimension(:,:,:), allocatable :: vectorCellWrk1 + real (kind=RKIND), dimension(:,:,:), allocatable :: vectorCellWrk2 + real (kind=RKIND), dimension(:,:,:), allocatable :: vectorEdgeWrk1 + + ! test variables + real (kind=RKIND) :: wrk + real (kind=RKIND), dimension(:), allocatable :: divExact + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + xCell => mesh % xCell % array + yCell => mesh % yCell % array + zCell => mesh % zCell % array + + if (config_oac_epft_debug) then + allocate(divExact(nCells+1)) + end if + + + allocate(vectorCellWrk1(3,nLayers,nCells+1)) + allocate(vectorCellWrk2(3,nLayers,nCells+1)) + allocate(vectorEdgeWrk1(3,nLayers,nEdges)) + + on_a_sphere = mesh % on_a_sphere + edgeSignOnCell => mesh % edgeSignOnCell % array + latCell => mesh % latCell % array + lonCell => mesh % lonCell % array + + includeHalo = .true. + + vectorCellWrk1 = vectorCell + + ! weight the vector with sigmaEA(:,:) + do iComponent = 1,3 + vectorCellWrk1(iComponent,:,:) = sigmaEA(:,:)*vectorCellWrk1(iComponent,:,:) + enddo + + + if (config_oac_epft_debug) then + do i= 1,nCells + vectorCellWrk1(1,:,i) = xCell(i) + vectorCellWrk1(2,:,i) = yCell(i) + vectorCellWrk1(3,:,i) = zCell(i) + ! the analytical divergence: + divExact(i) = -1.0*sin(lonCell(i)) * & + (1.0 + 2.0*sin(latCell(i))) !+ 3.0*sin(latCell(i)) + enddo + endif + + + if (on_a_sphere) then + + do i = 1,nCells + do k = 1,nLayers + call mpas_vector_LonLatR_to_R3(vectorCellWrk1(:,k,i), & + lonCell(i), latCell(i), vectorCellWrk2(:,k,i)) + end do + end do + + vectorCellWrk1 = vectorCellWrk2 + + end if + + call mpas_vector_R3Cell_to_Edge(vectorCellWrk1, mesh, & + vectorEdgeWrk1) + + call mpas_divergence_in_r3_buoyancy(vectorEdgeWrk1, mesh, edgeSignOnCell, & + includeHalo, divVectorCell) + + + if (config_oac_epft_debug) then + print *, ' ' + do k= 1,nLayers + wrk = sqrt( & + sum( & + ( & + (divExact(:)-divVectorCell(k,:))/ max(abs(divExact(:)),1.0e-15) & + )**2 * & + (1.0 - mesh % boundaryCell % array(1,:)) & + ) / nCells ) + print *, 'div RMS relative error on layer:', wrk + enddo + endif + + + if (.not. config_oac_epft_debug) then + do i = 1,nCells + do k = 1,nLayers + sigma = max(sigmaEA(k,i), 1.0e-15) + !sigma = 1.0 + divVectorCell(k,i) = divVectorCell(k,i) / sigma + end do + end do + end if + + + deallocate(vectorCellWrk1) + deallocate(vectorEdgeWrk1) + + + end subroutine calculateErtelPVTendencyFromPVFlux!}}} + + + +!*********************************************************************** +! +! subroutine computeErtelPV +! +!> \brief Calculate Ertel potential vorticity on buoyancy surfaces +!> \author Juan A. Saenz +!> \date January 2014 +!> \details +!> This subroutine calculates Ertel potential voriticity in buoyancy surfaces +! +!----------------------------------------------------------------------- + + subroutine computeErtelPV(nCells, nLayers, nEdges, mesh, & + fCell, uCell, vCell, sigma, ErtelPV) + + use mpas_vector_reconstruction + + integer, intent(in) :: nCells, nLayers, nEdges + type (mesh_type), intent(in) :: mesh + real (kind=RKIND), dimension(:), intent(in) :: fCell + real (kind=RKIND), dimension(:,:), intent(in) :: uCell, vCell + real (kind=RKIND), dimension(:,:), intent(in) :: sigma + real (kind=RKIND), dimension(:,:), intent(out) :: ErtelPV + + ! local variables + integer :: i, k + real (kind=RKIND), dimension(:,:), allocatable :: velNormalGradOnEdge + real (kind=RKIND), dimension(:,:), allocatable :: velGradX, velGradY, velGradZ + real (kind=RKIND), dimension(:,:), allocatable :: velGradZonal, velGradMerid + real (kind=RKIND), dimension(:,:), allocatable :: vGradZonal, uGradMerid + + allocate(velNormalGradOnEdge(nLayers, nEdges)) + allocate(velGradX(nLayers, nCells)) + allocate(velGradY(nLayers, nCells)) + allocate(velGradZ(nLayers, nCells)) + allocate(velGradZonal(nLayers, nCells)) + allocate(velGradMerid(nLayers, nCells)) + allocate(vGradZonal(nLayers, nCells)) + allocate(uGradMerid(nLayers, nCells)) + + ! calculate derivative of uTWA with respect to y + call computeNormalGradientOnEdge(nLayers, nCells, nEdges, & + mesh, & + uCell, velNormalGradOnEdge) + call mpas_reconstruct(mesh, velNormalGradOnEdge, & + velGradX, velGradY, velGradZ, & + velGradZonal, velGradMerid) + uGradMerid = velGradMerid + + ! calculate derivative of vTWA with respect to x + call computeNormalGradientOnEdge(nLayers, nCells, nEdges, & + mesh, & + vCell, velNormalGradOnEdge) + call mpas_reconstruct(mesh, velNormalGradOnEdge, & + velGradX, velGradY, velGradZ, & + velGradZonal, velGradMerid) + vGradZonal = velGradZonal + + do i = 1, nCells + do k = 1,nLayers + ErtelPV(k,i) = (fCell(i) + vGradZonal(k,i) - uGradMerid(k,i))/max(sigma(k,i),1.0e-15) + end do + end do + + end subroutine computeErtelPV + + +!*********************************************************************** +! +! subroutine eddyGeomDecompEPFT +! +!> \brief Calculate the eddy geometric decomposition from EPFT +!> \author Juan A. Saenz +!> \date January 2014 +!> \details +!> This subroutine calculates the eddy geometric decomposition from EPFT +! +!----------------------------------------------------------------------- + + subroutine eddyGeomDecompEPFT()!sigmaRef, ErtelPVFlux, ErtelPVTendency)!{{{ + ! Compute the geometric decomposition in terms of angles and eccentricities using + ! the entries of EPFT. + + end subroutine eddyGeomDecompEPFT!}}} + + +!*********************************************************************** +! +! routine mpas_divergence_in_r3_buoyancy +! +!> \brief MPAS 3D divergence routine +!> \author Todd Ringler +!> \date 02/07/14 +!> \details +!> This routine computes the of an input vector. +!----------------------------------------------------------------------- + subroutine mpas_divergence_in_r3_buoyancy(vectorR3Edge, grid, & + edgeSignOnCell, includeHalo, divCell)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + vectorR3Edge !< Input: vector at edge, R3, indices (direction,verticalIndex,edgeIndex) + + type (mesh_type), intent(in) :: & + grid !< Input: grid information + + integer, dimension(:,:), intent(in) :: & + edgeSignOnCell !< Input: Direction of vector connecting cells + + logical, intent(in) :: & + includeHalo !< Input: If true, halo cells and edges are included in computation + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:), intent(out) :: & + divCell !< Output: scalar divergence, indices (verticalIndex,edgeIndex) + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iEdge, iCell, nCellsCompute, i, k, p, nVertLevels + + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnCell + + real (kind=RKIND) :: invAreaCell + real (kind=RKIND) :: edgeNormalDotVector + real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell + real (kind=RKIND), dimension(:,:), pointer :: edgeNormalVectors + + if (includeHalo) then + nCellsCompute = grid % nCells + else + nCellsCompute = grid % nCellsSolve + endif + nVertLevels = grid % nBuoyancyLayers + + edgesOnCell => grid % edgesOnCell % array + nEdgesOnCell => grid % nEdgesOnCell % array + dvEdge => grid % dvEdge % array + areaCell => grid % areaCell % array + edgeNormalVectors => grid % edgeNormalVectors % array + + divCell(:,:) = 0.0 + do iCell = 1, nCellsCompute + invAreaCell = 1.0 / areaCell(iCell) + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + do k = 1, nVertLevels + edgeNormalDotVector = 0.0 + do p=1,3 + edgeNormalDotVector = edgeNormalDotVector + & + edgeNormalVectors(p,iEdge)*vectorR3Edge(p,k,iEdge) + enddo + divCell(k,iCell) = divCell(k,iCell) - & + edgeSignOnCell(i,iCell) * dvEdge(iEdge) * invAreaCell * & + edgeNormalDotVector + end do + end do + end do + + end subroutine mpas_divergence_in_r3_buoyancy!}}} + + +!*********************************************************************** +! +! routine mpas_vector_R3Cell_to_Edge +! +!> \brief MPAS 3D divergence routine +!> \author Todd Ringler +!> \date 02/07/14 +!> \details +!> This routine averages a vector field from cells to edges +!----------------------------------------------------------------------- + subroutine mpas_vector_R3Cell_to_Edge(vectorCell, mesh, & + vectorEdge) + + real, dimension(:,:,:), intent(in) :: vectorCell + type (mesh_type), intent(in) :: mesh !< Input: mesh information + real (kind=RKIND), dimension(:,:,:), intent(out) :: vectorEdge + + !local variables + integer :: nEdges, iEdge, k, cell1, cell2 + integer, dimension(:,:), pointer :: cellsOnEdge, boundaryEdge + + cellsOnEdge => mesh % cellsOnEdge % array + boundaryEdge => mesh % boundaryEdge % array + + vectorEdge = 0.0 + + do iEdge = 1, mesh % nEdges + ! Enforce vector value of zero on boundary edges, e.g. no slip for velocities + if (boundaryEdge(1,iEdge) == 1) then + vectorEdge(:,:,iEdge) = 0.0 + else + cell1 = cellsOnEdge(1, iEdge) + cell2 = cellsOnEdge(2, iEdge) + do k = 1, mesh % nBuoyancyLayers + vectorEdge(:,k,iEdge) = 0.5*( vectorCell(:,k,cell2) + vectorCell(:,k,cell1) ) + enddo + end if + enddo + + end subroutine mpas_vector_R3Cell_to_Edge!}}} + + end module ocn_eliassen_palm_flux_tensor ! vim: foldmethod=marker From e258fd0c596ce93c2df84a8b2ab0fb24875fc3b3 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Fri, 29 May 2015 19:39:21 -0600 Subject: [PATCH 0071/1724] ported Todd's changes from his branch ported and adapted Todd's changes from his branch epftDiagPools --- .../mpas_ocn_eliassen_palm_flux_tensor.F | 1023 +++++++++++------ 1 file changed, 650 insertions(+), 373 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F index 0375ca04bd..e1756e22d5 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F @@ -11,7 +11,7 @@ ! !> \brief MPAS ocean analysis core member: epft !> \author Juan A. Saenz, Todd Ringler -!> \date May, 2015 +!> \date May 2015 !> \details !> This module contains the routines for computing the Eliassen and Palm Flux Tensor !> in buoyancy coordinates, and related quantities. @@ -93,7 +93,7 @@ subroutine ocn_setup_packages_eliassen_palm_flux_tensor(configPool, packagePool, !----------------------------------------------------------------- ! - ! input/output variables + ! input variables ! !----------------------------------------------------------------- @@ -110,6 +110,7 @@ subroutine ocn_setup_packages_eliassen_palm_flux_tensor(configPool, packagePool, ! local variables ! !----------------------------------------------------------------- + logical, pointer :: am_eliassen_palm_flux_tensor_Active err = 0 @@ -118,8 +119,10 @@ subroutine ocn_setup_packages_eliassen_palm_flux_tensor(configPool, packagePool, call mpas_pool_get_package(packagePool, & 'am_eliassen_palm_flux_tensor_Active', am_eliassen_palm_flux_tensor_Active) - ! turn on package for this analysis member - am_eliassen_palm_flux_tensor_Active = .true. + ! turn on package for this analysis member based on configure option + ! (at present, this routine is only called when true) + amEPFTACtive = .false. + if (config_use_epft) amEPFTACtive = .true. end subroutine ocn_setup_packages_eliassen_palm_flux_tensor!}}} @@ -155,7 +158,6 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ ! input/output variables ! !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain !----------------------------------------------------------------- @@ -163,7 +165,6 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ ! output variables ! !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag !----------------------------------------------------------------- @@ -178,53 +179,130 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ type (block_type), pointer :: block type (amEPFT_type), pointer :: amEPFT - real(KIND=RKIND), dimension(:), pointer :: potentialDensityMidRef - real(KIND=RKIND), dimension(:), pointer :: potentialDensityTopRef - real(KIND=RKIND), dimension(:,:), pointer :: buoyMaskEA - - + integer :: nBuoyancyLayers + real (kind=RKIND), dimension(:), pointer :: potentialDensityMidRef + real (kind=RKIND), dimension(:), pointer :: potentialDensityTopRef + real (kind=RKIND), dimension(:), pointer :: buoyancyMidRef + real (kind=RKIND), dimension(:), pointer :: buoyancyInterfaceRef + + logical, pointer :: amEPFTActive, config_do_restart, config_epft_reset + integer, pointer :: config_epft_nBuoyancyLayers + real (kind=RKIND), pointer :: config_epft_rhomax_buoycoor + real (kind=RKIND), pointer :: config_epft_rhomin_buoycoor + real (kind=RKIND), pointer :: config_density0 + + integer, pointer :: nSamplesEA + + real (kind=RKIND), dimension(:,:), pointer :: buoyancyMaskEA + real (kind=RKIND), dimension(:,:), pointer :: sigmaEA + real (kind=RKIND), dimension(:,:), pointer :: heightMidBuoyCoorEA + real (kind=RKIND), dimension(:,:), pointer :: montgPotBuoyCoorEA + real (kind=RKIND), dimension(:,:), pointer :: montgPotGradZonalEA + real (kind=RKIND), dimension(:,:), pointer :: montgPotGradMeridEA + real (kind=RKIND), dimension(:,:), pointer :: heightMidBuoyCoorSqEA + real (kind=RKIND), dimension(:,:), pointer :: heightMGradZonalEA + real (kind=RKIND), dimension(:,:), pointer :: heightMGradMeridEA + real (kind=RKIND), dimension(:,:), pointer :: usigmaEA + real (kind=RKIND), dimension(:,:), pointer :: vsigmaEA + real (kind=RKIND), dimension(:,:), pointer :: uusigmaEA + real (kind=RKIND), dimension(:,:), pointer :: vvsigmaEA + real (kind=RKIND), dimension(:,:), pointer :: uvsigmaEA + real (kind=RKIND), dimension(:,:), pointer :: uwsigmaEA + real (kind=RKIND), dimension(:,:), pointer :: vwsigmaEA err = 0 - block => domain % blocklist - do while (associated(block)) + call mpas_pool_get_package(domain % packages, 'amEPFTActive', amEPFTActive) - amEPFT => block % amEPFT + if(.not.amEPFTActive) return - ! Calculate target values - potentialDensityMidRef => amEPFT % potentialDensityMidRef % array - potentialDensityTopRef => amEPFT % potentialDensityTopRef % array + call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) + call mpas_pool_get_config(domain % configs, 'config_epft_reset', config_epft_reset) + call mpas_pool_get_config(domain % configs, 'config_epft_nBuoyancyLayers', config_epft_nBuoyancyLayers) + call mpas_pool_get_config(domain % configs, 'config_epft_rhomax_buoycoor', config_epft_rhomax_buoycoor) + call mpas_pool_get_config(domain % configs, 'config_epft_rhomin_buoycoor', config_epft_rhomin_buoycoor) + call mpas_pool_get_config(domain % configs, 'config_density0', config_density0) - do k = 1, config_nBuoyancyLayers - potentialDensityTopRef(k) = config_rhomin_buoycoor + & - (config_rhomax_buoycoor - config_rhomin_buoycoor) / & - (config_nBuoyancyLayers) * (k-1) + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'amEPFT', amEPFTPool) + + !----------------------------------------------------------------- + ! set up pointers + !----------------------------------------------------------------- + call mpas_pool_get_array(amEPFTPool, 'potentialDensityMidRef', potentialDensityMidRef) + call mpas_pool_get_array(amEPFTPool, 'potentialDensityTopRef', potentialDensityTopRef) + call mpas_pool_get_array(amEPFTPool, 'buoyancyMidRef', buoyancyMidRef) + call mpas_pool_get_array(amEPFTPool, 'buoyancyInterfaceRef', buoyancyInterfaceRef) + + !----------------------------------------------------------------- + ! compute buoyancy and density increment of each layer + ! at present we use layer interfaces that are evenly-spaced in buoyancy space + !----------------------------------------------------------------- + nBuoyancyLayers = config_epft_nBuoyancyLayers + deltaDensity = (config_epft_rhomax_buoycoor - config_epft_rhomin_buoycoor) / config_epft_nBuoyancyLayers + deltaBuoyancy = -gravity * deltaDensity / config_density0 + + !----------------------------------------------------------------- + ! compute density/bouyancy at top of each layer + !----------------------------------------------------------------- + do k = 1, nBuoyancyLayers + potentialDensityTopRef(k) = config_epft_rhomin_buoycoor + deltaDensity * (k-1) + buoyancyInterfaceRef(k) = -gravity * (config_epft_rhomin_buoycoor - config_density0) / config_density0 + deltaBuoyancy * (k-1) end do - do k = 1, config_nBuoyancyLayers-1 - potentialDensityMidRef(k) = & - 0.5*(potentialDensityTopRef(k) + potentialDensityTopRef(k+1)) + k=nBuoyancyLayers + buoyancyInterfaceRef(k+1) = buoyancyInterfaceRef(k) + deltaBuoyancy + + !----------------------------------------------------------------- + ! compute density/bouyancy for each layer + !----------------------------------------------------------------- + do k = 1, nBuoyancyLayers-1 + potentialDensityMidRef(k) = 0.5*(potentialDensityTopRef(k) + potentialDensityTopRef(k+1)) + buoyancyMidRef(k) = 0.5*(buoyancyInterfaceRef(k) + buoyancyInterfaceRef(k+1)) end do - potentialDensityMidRef(config_nBuoyancyLayers) = & - 0.5*(potentialDensityTopRef(config_nBuoyancyLayers) + config_rhomax_buoycoor) - - if (.not. config_do_restart .or. config_oac_epft_reset) then - amEPFT % buoyMaskEA % array = 0.0 - amEPFT % sigmaEA % array = 0.0 - amEPFT % nSamplesEA % scalar = 0.0 - amEPFT % heightMidBuoyCoorEA % array = 0.0 - amEPFT % montgPotBuoyCoorEA % array = 0.0 - amEPFT % montgPotGradZonalEA % array = 0.0 - amEPFT % montgPotGradMeridEA % array = 0.0 - amEPFT % heightMidBuoyCoorSqEA % array = 0.0 - amEPFT % HeightMGradZonalEA % array = 0.0 - amEPFT % HeightMGradMeridEA % array = 0.0 - amEPFT % usigmaEA % array = 0.0 - amEPFT % vsigmaEA % array = 0.0 - amEPFT % uusigmaEA % array = 0.0 - amEPFT % vvsigmaEA % array = 0.0 - amEPFT % uvsigmaEA % array = 0.0 - amEPFT % uwsigmaEA % array = 0.0 - amEPFT % vwsigmaEA % array = 0.0 + k=nBuoyancyLayers + potentialDensityMidRef(k) = 0.5*(potentialDensityTopRef(k-1) + config_epft_rhomax_buoycoor) + buoyancyMidRef(k) = 0.5*(buoyancyInterfaceRef(k) + buoyancyInterfaceRef(k+1)) + + !----------------------------------------------------------------- + ! initialize ensemble averages when it is not a restart or when a reset is specified + !----------------------------------------------------------------- + if (.not. config_do_restart .or. config_epft_reset) then + call mpas_pool_get_array(amEPFTPool, 'buoyancyMaskEA', buoyancyMaskEA) + call mpas_pool_get_array(amEPFTPool, 'sigmaEA', sigmaEA) + call mpas_pool_get_array(amEPFTPool, 'nSamplesEA', nSamplesEA) + call mpas_pool_get_array(amEPFTPool, 'heightMidBuoyCoorEA', heightMidBuoyCoorEA) + call mpas_pool_get_array(amEPFTPool, 'montgPotBuoyCoorEA', montgPotBuoyCoorEA) + call mpas_pool_get_array(amEPFTPool, 'montgPotGradZonalEA', montgPotGradZonalEA) + call mpas_pool_get_array(amEPFTPool, 'montgPotGradMeridEA', montgPotGradMeridEA) + call mpas_pool_get_array(amEPFTPool, 'heightMidBuoyCoorSqEA', heightMidBuoyCoorSqEA) + call mpas_pool_get_array(amEPFTPool, 'heightMGradZonalEA', heightMGradZonalEA) + call mpas_pool_get_array(amEPFTPool, 'heightMGradMeridEA', heightMGradMeridEA) + call mpas_pool_get_array(amEPFTPool, 'usigmaEA', usigmaEA) + call mpas_pool_get_array(amEPFTPool, 'vsigmaEA', vsigmaEA) + call mpas_pool_get_array(amEPFTPool, 'uusigmaEA', uusigmaEA) + call mpas_pool_get_array(amEPFTPool, 'vvsigmaEA', vvsigmaEA) + call mpas_pool_get_array(amEPFTPool, 'uvsigmaEA', uvsigmaEA) + call mpas_pool_get_array(amEPFTPool, 'uwsigmaEA', uwsigmaEA) + call mpas_pool_get_array(amEPFTPool, 'vwsigmaEA', vwsigmaEA) + + buoyancyMaskEA = 0.0 + sigmaEA = 0.0 + nSamplesEA = 0.0 + heightMidBuoyCoorEA = 0.0 + montgPotBuoyCoorEA = 0.0 + montgPotGradZonalEA = 0.0 + montgPotGradMeridEA = 0.0 + heightMidBuoyCoorSqEA = 0.0 + heightMGradZonalEA = 0.0 + heightMGradMeridEA = 0.0 + usigmaEA = 0.0 + vsigmaEA = 0.0 + uusigmaEA = 0.0 + vvsigmaEA = 0.0 + uvsigmaEA = 0.0 + uwsigmaEA = 0.0 + vwsigmaEA = 0.0 end if block => block % next @@ -303,14 +381,14 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !----------------------------------------------------------------- ! define local scalars holding length of dimensions !----------------------------------------------------------------- - integer, pointer :: nVertLevels, nBuoyLayers, nBuoyLayersP1 + integer, pointer :: nVertLevels, nBuoyancyLayers, nBuoyLayersP1 integer, pointer :: nEdges, nCells, nCellsSolve ! nCellsSolve includes halos integer, dimension(:), pointer :: maxLevelCell integer, dimension(:), pointer :: firstLayerBuoyCoor integer, dimension(:), pointer :: lastLayerBuoyCoor - real(KIND=RKIND), dimension(:,:), pointer :: buoyMask + real(KIND=RKIND), dimension(:,:), pointer :: buoyancyMask integer :: nSamplesEA @@ -318,15 +396,15 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:), pointer :: potentialDensityTopRef real(KIND=RKIND), dimension(:), pointer :: buoyancyMidRef real(KIND=RKIND), dimension(:), pointer :: buoyancyInterfaceRef - real(KIND=RKIND), dimension(:,:), pointer :: buoyMaskEA + real(KIND=RKIND), dimension(:,:), pointer :: buoyancyMaskEA real(KIND=RKIND), dimension(:,:), pointer :: sigmaEA real(KIND=RKIND), dimension(:,:), pointer :: heightMidBuoyCoorEA real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradZonalEA real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradMeridEA real(KIND=RKIND), dimension(:,:), pointer :: heightMidBuoyCoorSqEA real(KIND=RKIND), dimension(:,:), pointer :: montgPotBuoyCoorEA - real(KIND=RKIND), dimension(:,:), pointer :: HeightMGradZonalEA - real(KIND=RKIND), dimension(:,:), pointer :: HeightMGradMeridEA + real(KIND=RKIND), dimension(:,:), pointer :: heightMGradZonalEA + real(KIND=RKIND), dimension(:,:), pointer :: heightMGradMeridEA real(KIND=RKIND), dimension(:,:), pointer :: usigmaEA real(KIND=RKIND), dimension(:,:), pointer :: vsigmaEA !real(KIND=RKIND), dimension(:,:), pointer :: wsigmaEA @@ -417,13 +495,15 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_pool_get_subpool(block % structs, 'amEliassenPalmFluxTensor', am_epftPool) call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(block % dimensions, 'nBuoyLayers', nBuoyLayers) - !call mpas_pool_get_dimension(block % dimensions, 'nBuoyLayersP1', nBuoyLayersP1) + call mpas_pool_get_dimension(block % dimensions, 'nBuoyancyLayers', nBuoyLayers) + !call mpas_pool_get_dimension(block % dimensions, 'nBuoyancyLayersP1', nBuoyLayersP1) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'fCell', fCell) + call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', surfacePressure) @@ -439,7 +519,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_pool_get_field(scratchPool, 'montgPotNormalGradOnEdge', montgPotNormalGradOnEdge) call mpas_pool_get_field(scratchPool, 'firstLayerBuoyCoor', firstLayerBuoyCoor) call mpas_pool_get_field(scratchPool, 'lastLayerBuoyCoor', lastLayerBuoyCoor) - call mpas_pool_get_field(scratchPool, 'buoyMask', buoyMask) + call mpas_pool_get_field(scratchPool, 'buoyancyMask', buoyancyMask) call mpas_pool_get_field(scratchPool, 'montgPotGradX', montgPotGradX) call mpas_pool_get_field(scratchPool, 'montgPotGradY', montgPotGradY) call mpas_pool_get_field(scratchPool, 'montgPotGradZ', montgPotGradZ) @@ -461,7 +541,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_allocate_scratch_field(montgPotNormalGradOnEdge, .true.) call mpas_allocate_scratch_field(firstLayerBuoyCoor, .true.) call mpas_allocate_scratch_field(lastLayerBuoyCoor, .true.) - call mpas_allocate_scratch_field(buoyMask, .true.) + call mpas_allocate_scratch_field(buoyancyMask, .true.) call mpas_allocate_scratch_field(montgPotGradX, .true.) call mpas_allocate_scratch_field(montgPotGradY, .true.) call mpas_allocate_scratch_field(montgPotGradZ, .true.) @@ -512,15 +592,15 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_pool_get_array(am_epftPool, 'potentialDensityTopRef', potentialDensityTopRef) call mpas_pool_get_array(am_epftPool, 'buoyancyMidRef', buoyancyMidRef) call mpas_pool_get_array(am_epftPool, 'buoyancyInterfaceRef', buoyancyInterfaceRef) - call mpas_pool_get_array(am_epftPool, 'buoyMaskEA', buoyMaskEA) + call mpas_pool_get_array(am_epftPool, 'buoyancyMaskEA', buoyancyMaskEA) call mpas_pool_get_array(am_epftPool, 'sigmaEA', sigmaEA) call mpas_pool_get_array(am_epftPool, 'heightMidBuoyCoorEA', heightMidBuoyCoorEA) call mpas_pool_get_array(am_epftPool, 'montgPotGradZonalEA', montgPotGradZonalEA) call mpas_pool_get_array(am_epftPool, 'montgPotGradMeridEA', montgPotGradMeridEA) call mpas_pool_get_array(am_epftPool, 'heightMidBuoyCoorSqEA', heightMidBuoyCoorSqEA) call mpas_pool_get_array(am_epftPool, 'montgPotBuoyCoorEA', montgPotBuoyCoorEA) - call mpas_pool_get_array(am_epftPool, 'HeightMGradZonalEA', HeightMGradZonalEA) - call mpas_pool_get_array(am_epftPool, 'HeightMGradMeridEA', HeightMGradMeridEA) + call mpas_pool_get_array(am_epftPool, 'heightMGradZonalEA', HeightMGradZonalEA) + call mpas_pool_get_array(am_epftPool, 'heightMGradMeridEA', HeightMGradMeridEA) call mpas_pool_get_array(am_epftPool, 'usigmaEA', usigmaEA) call mpas_pool_get_array(am_epftPool, 'vsigmaEA', vsigmaEA) call mpas_pool_get_array(am_epftPool, 'uusigmaEA', uusigmaEA) @@ -555,7 +635,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ montgPotNormalGradOnEdge=> montgPotNormalGradOnEdge % array firstLayerBuoyCoor => firstLayerBuoyCoor % array lastLayerBuoyCoor => lastLayerBuoyCoor % array - buoyMask => buoyMask % array + buoyancyMask => buoyancyMask % array montgPotGradX => montgPotGradX % array montgPotGradY => montgPotGradY % array montgPotGradZ => montgPotGradZ % array @@ -580,7 +660,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ PVFluxTest => PVFluxTest % array - nBuoyLayersP1 = nBuoyLayers+1 + nBuoyancyLayersP1 = nBuoyLayers+1 ! jas diabatic terms @@ -596,9 +676,9 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! begin computation !------------------------------------------------------------- - call get_masks_in_buoyancy_coordinates(nVertLevels, nCells, nBuoyLayers, & + call get_masks_in_buoyancy_coordinates(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, potentialDensity, potentialDensityMidRef, & - firstLayerBuoyCoor, lastLayerBuoyCoor, buoyMask) + firstLayerBuoyCoor, lastLayerBuoyCoor, buoyancyMask) if(config_oac_epft_debug) then print *, ' ' @@ -608,8 +688,8 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ print *, potentialDensityTopRef print *, 'potentialDensityMidRef' print *, potentialDensityMidRef - print *, 'nCells*nBuoyLayers', nCells*nBuoyLayers - print *, 'sum(buoyMask)', sum(buoyMask) + print *, 'nCells*nBuoyancyLayers', nCells*nBuoyLayers + print *, 'sum(buoyancyMask)', sum(buoyancyMask) print *, 'nCells*nVertLevels', nCells*nVertLevels print *, 'sum(mesh%cellMask%array)', sum(mesh%cellMask%array) print *, 'minval(potentialDensity), maxval(potentialDensity)' @@ -679,11 +759,11 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ (zMid(nVertLevels,i) - zMid(1,i)) end do end do - call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, array1_3D, zMid, potentialDensityMidRef, array1_3Dbuoy) do i = 1,nCells - do k = 1, nBuoyLayers + do k = 1, nBuoyancyLayers array2_3Dbuoy(k,i) = zMid(1,i) + & (potentialDensityMidRef(k) - config_rhomin_buoycoor*1.02) * & (zMid(nVertLevels,i) - zMid(1,i)) / & @@ -691,7 +771,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ end do end do do i = 1,nCells - do k = 1, nBuoyLayers + do k = 1, nBuoyancyLayers RMSlocal2 = RMSlocal2 + & ((array1_3Dbuoy(k,i) - array2_3Dbuoy(k,i))/array2_3Dbuoy(k,i))**2 end do @@ -711,170 +791,224 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! call check_potentialDensityRef_range(nVertLevels, nCells, maxLevelCell, potentialDensity) - call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, -potentialDensity, zMid, & -potentialDensityMidRef, heightMidBuoyCoor) - call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, -potentialDensity, zMid, & -potentialDensityTopRef, heightTopBuoyCoor) - do i=1,nCells - !correct the top of heightTopBuoyCoor - do k=1,firstLayerBuoyCoor(i) - heightTopBuoyCoor(k,i)=zTop(1,i) - enddo - ! correct the bottom of heightTopBuoyCoor - do k=lastLayerBuoyCoor(i)+1,nBuoyLayers - heightTopBuoyCoor(k,i)=-bottomDepth(i) - enddo - ! copy into interface variable - heightInterfaceBuoyCoor(1:nBuoyLayers,i)=heightTopBuoyCoor(1:nBuoyLayers,i) - heightInterfaceBuoyCoor(nBuoyLayers+1,i)=-bottomDepth(i) - enddo - call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, -potentialDensity, uCellCenter, & -potentialDensityMidRef, uMidBuoyCoor) - call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, -potentialDensity, vCellCenter, & -potentialDensityMidRef, vMidBuoyCoor) - call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, -potentialDensity, density, & -potentialDensityMidRef, densityMidBuoyCoor) - call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, -potentialDensity, density, & -potentialDensityTopRef, densityTopBuoyCoor) - !call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + !call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & ! maxLevelCell, -potentialDensity, Q, potentialDensityTopRef, QMidRef) - call computeBuoyancyColumn(nBuoyLayers, potentialDensityMidRef, buoyancyMidRef) - call computeBuoyancyColumnP1(nBuoyLayersP1, potentialDensityTopRef, & + ! JAS this can be moved to init ? + call computeBuoyancyColumn(nBuoyancyLayers, potentialDensityMidRef, buoyancyMidRef) + call computeBuoyancyColumnP1(nBuoyancyLayersP1, potentialDensityTopRef, & buoyancyInterfaceRef) + !------------------------------------------------------------- + ! fill in data above firstLayerBuoyCoor and below lastLayerBuoyCoor + !------------------------------------------------------------- + do i = 1, nCells + do k = 1, firstLayerBuoyCoor(i)-1 + heightMidBuoyCoor(k,i) = zTop(1,i) + heightTopBuoyCoor(k,i) = zTop(1,i) + uMidBuoyCoor(k,i) = normalVelocityZonal(1,i) + vMidBuoyCoor(k,i) = normalVelocityMeridional(1,i) + densityMidBuoyCoor(k,i) = density(1,i) + densityTopBuoyCoor(k,i) = density(1,i) + ! TDR: diabatic + !wMidBuoyCoor(k,i) = wCellCenter(1,i) + end do + do k = lastLayerBuoyCoor(i) + 1, nBuoyancyLayers + heightMidBuoyCoor(k,i) = -bottomDepth(i) + heightTopBuoyCoor(k,i) = -bottomDepth(i) + uMidBuoyCoor(k,i) = normalVelocityZonal(maxLevelCell(i),i) + vMidBuoyCoor(k,i) = normalVelocityMeridional(maxLevelCell(i),i) + densityMidBuoyCoor(k,i) = density(maxLevelCell(i),i) + densityTopBuoyCoor(k,i) = density(maxLevelCell(i),i) + ! TDR: diabatic + !wMidBuoyCoor(k,i) = wCellCenter(maxLevelCell(i),i) + end do + heightInterfaceBuoyCoor(1:nBuoyancyLayers,i) = heightTopBuoyCoor(1:nBuoyancyLayers,i) + heightInterfaceBuoyCoor(nBuoyancyLayers+1,i) = -bottomDepth(i) + end do - call computeSigma(nCells, nBuoyLayers, firstLayerBuoyCoor, lastLayerBuoyCoor, & + !------------------------------------------------------------- + ! compute sigma, aka "layer thickness", units of s^2 + !------------------------------------------------------------- + call computeSigma(nCells, nBuoyancyLayers, & heightInterfaceBuoyCoor, buoyancyInterfaceRef, sigma) - - call computeMontgomeryPotential(nBuoyLayers, nCells, surfacePressure, & + !------------------------------------------------------------- + ! using data interpolated to buoyancy space, compute Montgomery potential + !------------------------------------------------------------- + call computeMontgomeryPotential(nBuoyancyLayers, nCells, surfacePressure, & firstLayerBuoyCoor, lastLayerBuoyCoor, SSH, densityMidBuoyCoor, & potentialDensityMidRef, heightInterfaceBuoyCoor, montgPotBuoyCoor) - call computeNormalGradientOnEdge(nBuoyLayers, nCells, nEdges, & + + !------------------------------------------------------------- + ! compute the normal derivative of Montgomery potential at cell edges + !------------------------------------------------------------- + call computeNormalGradientOnEdge(nBuoyancyLayers, nCells, nEdges, & mesh, & montgPotBuoyCoor, montgPotNormalGradOnEdge) - call mpas_reconstruct(mesh, montgPotNormalGradOnEdge, & + + !------------------------------------------------------------- + ! reconstruct full gradient vector at cell centers + !------------------------------------------------------------- + call mpas_reconstruct(mesh, montgPotNormalGradOnEdge, & montgPotGradX, montgPotGradY, montgPotGradZ, & montgPotGradZonal, montgPotGradMerid) -! jas issue: in some cases it might be cleaner to pass mesh instead of -! nBuoyLayers, nCells, maxLevelCell... - - ! Increment first-order running mean fields: - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & - buoyMask, buoyMaskEA) - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + !------------------------------------------------------------- + ! Increment first-order running mean fields + !------------------------------------------------------------- + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & + buoyancyMask, buoyancyMaskEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & sigma, sigmaEA) - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & heightMidBuoyCoor, heightMidBuoyCoorEA) - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & montgPotBuoyCoor, montgPotBuoyCoorEA) - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & montgPotGradZonal, montgPotGradZonalEA) - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & montgPotGradMerid, montgPotGradMeridEA) - + !------------------------------------------------------------- ! Increment second-order running mean fields + !------------------------------------------------------------- wrk3DBuoyCoor = heightMidBuoyCoor * heightMidBuoyCoor - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & wrk3DBuoyCoor, heightMidBuoyCoorSqEA) wrk3DBuoyCoor = heightMidBuoyCoor * montgPotGradZonal - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & - wrk3DBuoyCoor, HeightMGradZonalEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & + wrk3DBuoyCoor, heightMGradZonalEA) wrk3DBuoyCoor = heightMidBuoyCoor * montgPotGradMerid - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & - wrk3DBuoyCoor, HeightMGradMeridEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & + wrk3DBuoyCoor, heightMGradMeridEA) wrk3DBuoyCoor = uMidBuoyCoor * sigma - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & wrk3DBuoyCoor, usigmaEA) wrk3DBuoyCoor = vMidBuoyCoor * sigma - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & wrk3DBuoyCoor, vsigmaEA) + ! Diabatic terms !wrk3DBuoyCoor = wMidBuoyCoor * sigma - !call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & ! wrk3DBuoyCoor, wsigmaEA) - ! Increment third-order running mean fields + !------------------------------------------------------------- + ! Increment third-order running mean fields + !------------------------------------------------------------- wrk3DBuoyCoor = uMidBuoyCoor * uMidBuoyCoor * sigma - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & wrk3DBuoyCoor, uusigmaEA) wrk3DBuoyCoor = vMidBuoyCoor * vMidBuoyCoor * sigma - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & wrk3DBuoyCoor, vvsigmaEA) wrk3DBuoyCoor = uMidBuoyCoor * vMidBuoyCoor * sigma - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & wrk3DBuoyCoor, uvsigmaEA) + ! Diabatic terms !wrk3DBuoyCoor = uMidBuoyCoor * wMidBuoyCoor * sigma - !call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & ! wrk3DBuoyCoor, uwsigmaEA) uwsigmaEA = 0.0 + ! Diabatic terms !wrk3DBuoyCoor = vMidBuoyCoor * wMidBuoyCoor* sigma - !call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & ! wrk3DBuoyCoor, vwsigmaEA) vwsigmaEA = 0.0 + !------------------------------------------------------------- ! update number of samples in ensemble average - amEPFT % nSamplesEA % scalar = amEPFT % nSamplesEA % scalar + 1 - - + !------------------------------------------------------------- + nSamplesEA = nSamplesEA + 1 - ! Calculate the thickness weighted averages - call calculateTWA(nBuoyLayers, nCells, nBuoyLayers, & + !------------------------------------------------------------- + ! based on current estimate of ensemble-average state, + ! compute the thickness-weighted average velocity + !------------------------------------------------------------- + call calculateTWA(nBuoyancyLayers, nCells, nBuoyLayers, & sigmaEA, usigmaEA, uTWA) - call calculateTWA(nBuoyLayers, nCells, nBuoyLayers, & + call calculateTWA(nBuoyancyLayers, nCells, nBuoyLayers, & sigmaEA, vsigmaEA, vTWA) - !call calculateTWA(nBuoyLayers, nCells, nBuoyLayers, & + ! Diabatic terms + !call calculateTWA(nBuoyancyLayers, nCells, nBuoyLayers, & ! sigmaEA, wsigmaEA, wTWA) wTWA = 0.0 - - call calculateEPFTfromTWA(nBuoyLayers, nCells, & + !------------------------------------------------------------- + ! based on current estimate of ensemble-average state, + ! compute the Eliassen-Palm flux tensor + !------------------------------------------------------------- + call calculateEPFTfromTWA(nBuoyancyLayers, nCells, & sigmaEA, heightMidBuoyCoorEA, & heightMidBuoyCoorSqEA, montgPotGradZonalEA, montgPotGradMeridEA, & - HeightMGradZonalEA, HeightMGradMeridEA, uTWA, vTWA, wTWA, & + heightMGradZonalEA, heightMGradMeridEA, uTWA, vTWA, wTWA, & uusigmaEA, vvsigmaEA, uvsigmaEA, uwsigmaEA, vwsigmaEA, EPFT) - call calculateDivEPFT(nBuoyLayers, nCells, nEdges, & - mesh, buoyancyInterfaceRef, sigmaEA, buoyMaskEA, EPFT, divEPFT) + !------------------------------------------------------------- + ! compute the force applied to the momentum equation as div(EPFT) + !------------------------------------------------------------- + call calculateDivEPFT(nBuoyancyLayers, nCells, nEdges, & + mesh, buoyancyInterfaceRef, sigmaEA, buoyancyMaskEA, EPFT, divEPFT) - call calculateErtelPVFlux(nCells, nBuoyLayers, & + !------------------------------------------------------------- + ! transform div(EPFT) into a flux of Ertel's PV + !------------------------------------------------------------- + call calculateErtelPVFlux(nCells, nBuoyancyLayers, & sigmaEA, divEPFT, ErtelPVFlux) - call calculateErtelPVTendencyFromPVFlux(nBuoyLayers, nCells, nEdges, & + !------------------------------------------------------------- + ! compute div(ErtelPVFlux) to obtain tendency of Ertel's PV + !------------------------------------------------------------- + call calculateErtelPVTendencyFromPVFlux(nBuoyancyLayers, nCells, nEdges, & mesh, sigmaEA, ErtelPVFlux, ErtelPVTendency) - fCell => mesh % fCell % array - call computeErtelPV(nCells, nBuoyLayers, nEdges, mesh, & + !------------------------------------------------------------- + ! compute Ertel PV based on EA/TWA fields + !------------------------------------------------------------- + call computeErtelPV(nCells, nBuoyancyLayers, nEdges, mesh, & fCell, uTWA, vTWA, sigmaEA, ErtelPV) + !------------------------------------------------------------- ! Compute the geometric decomposition in terms of angles and ! eccentricities using the entries of EPFT. + ! (not yet implemented) + !------------------------------------------------------------- !call eddyGeomDecompEPFT(EPFT, ...) @@ -886,7 +1020,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ relativeVorticityCell => diagnostics % relativeVorticityCell % array ! store relVortMidBuoyCoor in array1_3Dbuoy - call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, -potentialDensity, relativeVorticityCell, & -potentialDensityMidRef, array1_3Dbuoy) @@ -896,21 +1030,21 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ end do end do - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & uMidBuoyCoor, uMidBuoyCoorEA) - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & vMidBuoyCoor, vMidBuoyCoorEA) - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & PVMidBuoyCoor, PVMidBuoyCoorEA) wrk3DBuoyCoor = uMidBuoyCoor * PVMidBuoyCoor - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & wrk3DBuoyCoor, uPVMidBuoyCoorEA) wrk3DBuoyCoor = vMidBuoyCoor * PVMidBuoyCoor - call updateEnsembleAverage(nBuoyLayers, nCells, nSamplesEA, & + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & wrk3DBuoyCoor, vPVMidBuoyCoorEA) PVFluxTest(1,:,:) = uPVMidBuoyCoorEA - uMidBuoyCoorEA * PVMidBuoyCoorEA @@ -928,42 +1062,49 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ end if + !------------------------------------------------------------- + ! deallocate scratch space + !------------------------------------------------------------- + call mpas_deallocate_scratch_field(firstLayerBuoyCoorField, .true.) + call mpas_deallocate_scratch_field(lastLayerBuoyCoorField, .true.) + call mpas_deallocate_scratch_field(buoyancyMaskField, .true.) + call mpas_deallocate_scratch_field(sigmaField, .true.) + call mpas_deallocate_scratch_field(heightMidBuoyCoorField, .true.) + call mpas_deallocate_scratch_field(heightTopBuoyCoorField, .true.) + call mpas_deallocate_scratch_field(heightInterfaceBuoyCoorField, .true.) + call mpas_deallocate_scratch_field(uMidBuoyCoorField, .true.) + call mpas_deallocate_scratch_field(vMidBuoyCoorField, .true.) + call mpas_deallocate_scratch_field(densityMidBuoyCoorField, .true.) + call mpas_deallocate_scratch_field(densityTopBuoyCoorField, .true.) + call mpas_deallocate_scratch_field(montgPotBuoyCoorField, .true.) + call mpas_deallocate_scratch_field(montgPotNormalGradOnEdgeField, .true.) + call mpas_deallocate_scratch_field(montgPotGradXField, .true.) + call mpas_deallocate_scratch_field(montgPotGradYField, .true.) + call mpas_deallocate_scratch_field(montgPotGradZField, .true.) + call mpas_deallocate_scratch_field(montgPotGradZonalField, .true.) + call mpas_deallocate_scratch_field(montgPotGradMeridField, .true.) + call mpas_deallocate_scratch_field(wrk3DnVertLevelsField, .true.) + call mpas_deallocate_scratch_field(wrk3DBuoyCoorField, .true.) + + call mpas_deallocate_scratch_field(array1_3D, .true.) + call mpas_deallocate_scratch_field(array2_3D, .true.) + call mpas_deallocate_scratch_field(array3_3D, .true.) + call mpas_deallocate_scratch_field(array1_3Dbuoy, .true.) + call mpas_deallocate_scratch_field(array2_3Dbuoy, .true.) - ! Clean up - ! jas issue: make sure I deallocate everything - call mpas_deallocate_scratch_field(amEPFT % firstLayerBuoyCoor, .true.) - call mpas_deallocate_scratch_field(amEPFT % lastLayerBuoyCoor, .true.) - call mpas_deallocate_scratch_field(amEPFT % buoyMask, .true.) - call mpas_deallocate_scratch_field(amEPFT % heightMidBuoyCoor, .true.) - call mpas_deallocate_scratch_field(amEPFT % heightTopBuoyCoor, .true.) - call mpas_deallocate_scratch_field(amEPFT % heightInterfaceBuoyCoor, .true.) - call mpas_deallocate_scratch_field(amEPFT % uMidBuoyCoor, .true.) - call mpas_deallocate_scratch_field(amEPFT % vMidBuoyCoor, .true.) - call mpas_deallocate_scratch_field(amEPFT % densityMidBuoyCoor, .true.) - call mpas_deallocate_scratch_field(amEPFT % densityTopBuoyCoor, .true.) - call mpas_deallocate_scratch_field(amEPFT % buoyancyMidRef, .true.) - call mpas_deallocate_scratch_field(amEPFT % buoyancyInterfaceRef, .true.) - call mpas_deallocate_scratch_field(amEPFT % sigma, .true.) - call mpas_deallocate_scratch_field(amEPFT % montgPotBuoyCoor, .true.) - call mpas_deallocate_scratch_field(amEPFT % montgPotNormalGradOnEdge, .true.) - call mpas_deallocate_scratch_field(amEPFT % wrk3DnVertLevels, .true.) - call mpas_deallocate_scratch_field(amEPFT % wrk3DBuoyCoor, .true.) - - call mpas_deallocate_scratch_field(amEPFT % array1_3D, .true.) - call mpas_deallocate_scratch_field(amEPFT % array2_3D, .true.) - call mpas_deallocate_scratch_field(amEPFT % array3_3D, .true.) - call mpas_deallocate_scratch_field(amEPFT % array1_3Dbuoy, .true.) - call mpas_deallocate_scratch_field(amEPFT % array2_3Dbuoy, .true.) - - call mpas_deallocate_scratch_field(amEPFT % PVMidBuoyCoor, .true.) - call mpas_deallocate_scratch_field(amEPFT % PVMidBuoyCoorEA, .true.) - call mpas_deallocate_scratch_field(amEPFT % uPVMidBuoyCoorEA , .true.) - call mpas_deallocate_scratch_field(amEPFT % vPVMidBuoyCoorEA, .true.) - call mpas_deallocate_scratch_field(amEPFT % PVFluxTest, .true.) + call mpas_deallocate_scratch_field(PVMidBuoyCoor, .true.) + call mpas_deallocate_scratch_field(PVMidBuoyCoorEA, .true.) + call mpas_deallocate_scratch_field(uPVMidBuoyCoorEA , .true.) + call mpas_deallocate_scratch_field(vPVMidBuoyCoorEA, .true.) + call mpas_deallocate_scratch_field(PVFluxTest, .true.) nCellsCum = nCellsCum + nCells + !------------------------------------------------------------- + ! move to the next block + !------------------------------------------------------------- + block => block % next end do @@ -1083,8 +1224,8 @@ end subroutine ocn_restart_eliassen_palm_flux_tensor!}}} ! routine ocn_finalize_eliassen_palm_flux_tensor ! !> \brief Finalize MPAS-Ocean analysis member -!> \author FILL_IN_AUTHOR -!> \date FILL_IN_DATE +!> \author Juan A. Saenz +!> \date May 2015 !> \details !> This routine conducts all finalizations required for this !> MPAS-Ocean analysis member. @@ -1131,8 +1272,8 @@ end subroutine ocn_finalize_eliassen_palm_flux_tensor!}}} ! subroutine get_masks_in_buoyancy_coordinates ! !> \brief Get masks in buoyancy coordinates -!> \author Juan A. Saenz -!> \date Jan 2014 +!> \author Juan A. Saenz, Todd Ringler +!> \date May 2015 !> \details !> firstLayerBuoyCoor(iCell): the index of the smallest reference density that !> is >= the smallest actual density in a column. @@ -1144,38 +1285,59 @@ end subroutine ocn_finalize_eliassen_palm_flux_tensor!}}} !> Required: potentialDensityMidRef monotonically increases with index value ! !----------------------------------------------------------------------- - subroutine get_masks_in_buoyancy_coordinates(nVertLevels, nCells, nBuoyLayers, & + subroutine get_masks_in_buoyancy_coordinates(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, potentialDensity, potentialDensityMidRef, & - firstLayerBuoyCoor, lastLayerBuoyCoor, buoyMask)!{{{ - - integer, intent(in) :: nVertLevels, nCells, nBuoyLayers + firstLayerBuoyCoor, lastLayerBuoyCoor, buoyancyMask)!{{{ + + !----------------------------------------------------------------- + ! intent(in) + !----------------------------------------------------------------- + integer, intent(in) :: nVertLevels, nCells, nBuoyancyLayers integer, dimension(nCells), intent(in) :: maxLevelCell + real (kind=RKIND), dimension(nVertLevels, nCells), intent(in) :: potentialDensity + real (kind=RKIND), dimension(nBuoyancyLayers), intent(in) :: potentialDensityMidRef + + !----------------------------------------------------------------- + ! intent(out) + !----------------------------------------------------------------- integer, dimension(nCells), intent(out) :: firstLayerBuoyCoor integer, dimension(nCells), intent(out) :: lastLayerBuoyCoor - real (kind=RKIND), dimension(nBuoyLayers, nCells), intent(out) :: buoyMask - real (kind=RKIND), dimension(nVertLevels, nCells), intent(in) :: potentialDensity - real (kind=RKIND), dimension(nBuoyLayers), intent(in) :: potentialDensityMidRef + real (kind=RKIND), dimension(nBuoyancyLayers, nCells), intent(out) :: buoyancyMask + !----------------------------------------------------------------- ! Local variables + !----------------------------------------------------------------- integer :: iCell, maxLevel, kB, kBBottom, kBTop - firstLayerBuoyCoor = 1 - lastLayerBuoyCoor = nBuoyLayers - buoyMask = 0.0 - + !----------------------------------------------------------------- + ! initialize fields assuming no density layers exist + !----------------------------------------------------------------- + firstLayerBuoyCoor = nBuoyancyLayers + lastLayerBuoyCoor = 1 + buoyancyMask = 0.0 + !----------------------------------------------------------------- + ! loop over all cells + ! when searching from the top down + ! find first target density greater than density in top model layer + ! when searching from the bottom up + ! find first target density less than density in bottom model layer + !----------------------------------------------------------------- do iCell = 1, nCells + ! find the bottom model layer for this cell maxLevel = maxLevelCell(iCell) - do kB = 1, nBuoyLayers + ! search top down + do kB = 1, nBuoyancyLayers if (potentialDensityMidRef(kB) >= potentialDensity(1,iCell) ) then firstLayerBuoyCoor(iCell) = kB exit endif enddo - do kB = nBuoyLayers, 1, -1 + ! search bottom up + do kB = nBuoyancyLayers, 1, -1 if (potentialDensityMidRef(kB) <= potentialDensity(maxLevel,iCell) ) then lastLayerBuoyCoor(iCell) = kB exit @@ -1184,7 +1346,7 @@ subroutine get_masks_in_buoyancy_coordinates(nVertLevels, nCells, nBuoyLayers, & ! set mask to 1 inside the range do kB = firstLayerBuoyCoor(iCell), lastLayerBuoyCoor(iCell) - buoyMask(kB,iCell) = 1.0 + buoyancyMask(kB,iCell) = 1.0 enddo enddo @@ -1192,54 +1354,69 @@ subroutine get_masks_in_buoyancy_coordinates(nVertLevels, nCells, nBuoyLayers, & end subroutine get_masks_in_buoyancy_coordinates!}}} - !*********************************************************************** ! ! subroutine check_potentialDensityRef_range ! !> \brief Check if the range of values in potentialDensityTopRef contains current state -!> \author Juan A. Saenz -!> \date Jan 2014 +!> \author Juan A. Saenz, Todd Ringler +!> \date May 2015 !> \details -!> Check if the range of values in potentialDesnityTopRef contains all values in +!> Check if the range of values in potentialDensityTopRef contains all values in !> potentialDensity of the current state. !> If not, print a warning. ! !----------------------------------------------------------------------- subroutine check_potentialDensityRef_range(nVertLevels, nCells, maxLevelCell, & potentialDensity)!{{{ + !----------------------------------------------------------------- + ! intent(in) + !----------------------------------------------------------------- integer, intent(in) :: nVertLevels, nCells integer, dimension(nCells), intent(in) :: maxLevelCell real (kind=RKIND), dimension(nVertLevels, nCells), intent(in) :: potentialDensity + !----------------------------------------------------------------- ! Local variables - integer :: k, i + !----------------------------------------------------------------- + integer :: k, iCell, iCellMinBound, iCellMaxBound logical :: printWarning - + + real (kind=RKIND), pointer :: config_epft_rhomin_buoycoor, config_epft_rhomax_buoycoor + + call mpas_pool_get_config(ocnConfigs, 'config_epft_rhomin_buoycoor', config_epft_rhomin_buoycoor) + call mpas_pool_get_config(ocnConfigs, 'config_epft_rhomax_buoycoor', config_epft_rhomax_buoycoor) + printWarning = .false. - - do i = 1, nCells - if (potentialDensity(1,i) < config_rhomin_buoycoor) then + iCellMinBound = -1 + iCellMaxBound = -1 + + do iCell = 1, nCells + if (potentialDensity(1,iCell) < config_epft_rhomin_buoycoor) then printWarning = .true. + iCellMinBound = iCell exit end if - if (potentialDensity(maxLevelCell(i),i) > config_rhomax_buoycoor) then + if (potentialDensity(maxLevelCell(iCell),iCell) > config_epft_rhomax_buoycoor) then printWarning = .true. + iCellMaxBound = iCell exit end if enddo - !jas issue: do we want to print a warning once, or at every i,k out of range? if (printWarning) then - write(stderrUnit,*) 'Warning: in EPFT package, reference potential density does & - not span the values of potentialDensity in the current state' + write(stderrUnit,*) + write(stderrUnit,*) 'Warning: in EPFT package, subroutine check_potentialDensityRef_range' + write(stderrUnit,*) 'One or more columns in the ocean doman have densities that are not' + write(stderrUnit,*) 'contained in the defined buoyancy space of the EPFT module' + if (iCellMinBound.gt.0) write(stderrUnit,*) 'fluid is lighter than min buoyancy at cell: ',iCellMinBound + if (iCellMaxBound.gt.0) write(stderrUnit,*) 'fluid is lighter than max buoyancy at cell: ',iCellMaxBound + write(stderrUnit,*) end if end subroutine check_potentialDensityRef_range!}}} - - !*********************************************************************** ! ! subroutine linear_interp_1d_field_along_column @@ -1255,22 +1432,37 @@ end subroutine check_potentialDensityRef_range!}}} ! !----------------------------------------------------------------------- - subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, & + subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, xFieldIn, yFieldIn, xColumnOut, yFieldOut)!{{{ - integer, intent(in) :: nVertLevels, nCells, nBuoyLayers + !----------------------------------------------------------------- + ! intent(in) + !----------------------------------------------------------------- + integer, intent(in) :: nVertLevels, nCells, nBuoyancyLayers integer, dimension(nCells), intent(in) :: maxLevelCell real (kind=RKIND), dimension(nVertLevels, nCells), intent(in) :: xFieldIn real (kind=RKIND), dimension(nVertLevels, nCells), intent(in) :: yFieldIn - real (kind=RKIND), dimension(nBuoyLayers), intent(in) :: xColumnOut - real (kind=RKIND), dimension(nBuoyLayers, nCells), intent(out) :: yFieldOut + real (kind=RKIND), dimension(nBuoyancyLayers), intent(in) :: xColumnOut + + !----------------------------------------------------------------- + ! intent(out) + !----------------------------------------------------------------- + real (kind=RKIND), dimension(nBuoyancyLayers, nCells), intent(out) :: yFieldOut + !----------------------------------------------------------------- ! Local variables + !----------------------------------------------------------------- integer :: iCell, maxLevel, kB, kBBottom, kBTop, kDataAbove, kDataBelow, kData real (kind=RKIND) :: dx, dy + !----------------------------------------------------------------- + ! initialize intent(out) + !----------------------------------------------------------------- yFieldOut = 0.0 + !----------------------------------------------------------------- + ! loop over all columns + !----------------------------------------------------------------- do iCell = 1, nCells ! find the index of the bottom level of a column @@ -1279,9 +1471,9 @@ subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, ! Monotonically decreasing xFieldIn required ! Find index of first element in xColumnOut that is inside xFieldIn(:,iCell) kBTop = 1 - do kB = 1, nBuoyLayers + do kB = 1, nBuoyancyLayers ! the following line ensures that - ! if all xColumnOut > xFieldIn(1,iCell) then kBTop = nBuoyLayers + ! if all xColumnOut > xFieldIn(1,iCell) then kBTop = nBuoyancyLayers kBTop = kB if (xColumnOut(kB) <= xFieldIn(1,iCell) ) then exit @@ -1289,8 +1481,8 @@ subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, enddo !find last target buoyancy level inside column - kBBottom = nBuoyLayers - do kB = nBuoyLayers, 1, -1 + kBBottom = nBuoyancyLayers + do kB = nBuoyancyLayers, 1, -1 ! the following line ensures that ! if all xColumnOut < xFieldIn(1,iCell) then kBBottom = 1 kBBottom = kB @@ -1299,21 +1491,18 @@ subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyLayers, endif enddo - ! For the target x levels outside the x range in a column: ! set data from 1:kBTop-1 to surface values do kB = 1, kBTop-1 yFieldOut(kB,iCell) = yFieldIn(1,iCell) enddo - !set data from kBBottom+1:nBuoyLayers to bottom values - do kB = kBBottom+1, nBuoyLayers + !set data from kBBottom+1:nBuoyancyLayers to bottom values + do kB = kBBottom+1, nBuoyancyLayers yFieldOut(kB,iCell) = yFieldIn(maxLevel,iCell) enddo ! The interpolation: ! for the target buoyancy levels within the buoyancy range in a column: - ! jas issue: this can be replaced by a call to - ! src/operators/mpas_spline_interpolatoin.F:mpas_interpolate_linear() kDataAbove = 1 kDataBelow = kDataAbove + 1 do kB = kBTop, kBBottom @@ -1413,32 +1602,45 @@ end subroutine computeBuoyancyColumnP1!}}} ! subroutine computeSigma ! !> \brief Calculate the inverse of the derivative of buoy wrt z -!> \author Juan A. Saenz -!> \date December 2013 +!> \author Juan A. Saenz, Todd Ringler +!> \date May 2015 !> \details !> This subroutine calculates the inverse of the derivative of buoy wrt z. ! !----------------------------------------------------------------------- - subroutine computeSigma(nCells, nLayers, firstLayerBuoyCoor, & - lastLayerBuoyCoor, heightInterface, buoyInterface, sigma)!{{{ + subroutine computeSigma(nCells, nLayers, & + heightInterface, buoyInterface, sigma)!{{{ + !----------------------------------------------------------------- + ! intent(in) + !----------------------------------------------------------------- integer, intent(in) :: nCells, nLayers - integer, dimension(:), intent(in) :: firstLayerBuoyCoor - integer, dimension(:), intent(in) :: lastLayerBuoyCoor real (kind=RKIND), dimension(:,:), intent(in) :: heightInterface real (kind=RKIND), dimension(:), intent(in) :: buoyInterface + + !----------------------------------------------------------------- + ! intent(out) + !----------------------------------------------------------------- real (kind=RKIND), dimension(:,:), intent(out) :: sigma ! local variables - integer :: i, k + integer :: iCell, k + !----------------------------------------------------------------- + ! initialize sigma assuming zero thickness layers everywhere + !----------------------------------------------------------------- sigma = 0.0 - do i = 1, nCells + !----------------------------------------------------------------- + ! loop over all column, sigam = delta z / delta b + ! note: positive z points "up", i.e. from k+1 to k + ! note: positive b points "up", i.e. from k+1 to k + !----------------------------------------------------------------- + do iCell = 1, nCells do k = 1,nLayers - sigma(k,i) = (heightInterface(k,i) - heightInterface(k+1,i)) / & - (buoyInterface(k) - buoyInterface(k+1)) + sigma(k,iCell) = (heightInterface(k+1,iCell) - heightInterface(k,iCell)) / & + (buoyInterface(k+1) - buoyInterface(k)) enddo enddo @@ -1451,8 +1653,8 @@ end subroutine computeSigma!}}} ! subroutine computeMontgomeryPotential ! !> \brief Compute the Montgomery potential -!> \author Juan A. Saenz -!> \date 17 December 2013 +!> \author Juan A. Saenz, Todd Ringler +!> \date May 20015 !> \details !> This subroutine computes the Montgomery potential using eqn 2.10 in !> R.L. Higdon and R.A. Szoeke (1997), J. Comp. Phys. 135, 30–53, Article No. CP975733 @@ -1464,36 +1666,54 @@ end subroutine computeSigma!}}} !> Montgomery potential of a layer is constant across layer !----------------------------------------------------------------------- - subroutine computeMontgomeryPotential(nLayers, nCells, pSurface, firstLayer, & - lastLayer, SSH, density, potDens, heightInterface, MontgomeryPotential)!{{{ + subroutine computeMontgomeryPotential(nLayers, nCells, pSurface, & + density, potDens, heightInterface, MontgomeryPotential)!{{{ + !----------------------------------------------------------------- + ! intent(in) + !----------------------------------------------------------------- integer, intent(in) :: nLayers, nCells - integer, dimension(nCells), intent(in) :: firstLayer - integer, dimension(nCells), intent(in) :: lastLayer real (kind=RKIND), dimension(nCells), intent(in) :: pSurface - real (kind=RKIND), dimension(nCells), intent(in) :: SSH real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: density real (kind=RKIND), dimension(nLayers), intent(in) :: potDens real (kind=RKIND), dimension(nLayers+1, nCells), intent(in) :: heightInterface + + !----------------------------------------------------------------- + ! intent(out) + !----------------------------------------------------------------- real (kind=RKIND), dimension(nLayers, nCells), intent(out) :: MontgomeryPotential + !----------------------------------------------------------------- ! local variables - integer :: i, k + !----------------------------------------------------------------- + integer :: iCell, k real (kind=RKIND) :: pInterfacek ! pressure at interface k, i.e. at top of layer k + !----------------------------------------------------------------- + ! initialize intent(out) + !----------------------------------------------------------------- MontgomeryPotential = 0.0 - - do i = 1, nCells + !----------------------------------------------------------------- + ! loop over all columns + !----------------------------------------------------------------- + do iCell = 1, nCells - !pInterfacek = pSurface(i) + !----------------------------------------------------------------- + ! compute Montgomery potential in top buoyancy layer + ! at present, assume atmosphere surface pressure is zero (or a constant) + !----------------------------------------------------------------- pInterfacek = 0.0 k = 1 - MontgomeryPotential(k,i) = pInterfacek/potDens(k) + gravity*heightInterface(k,i) + MontgomeryPotential(k,iCell) = pInterfacek/potDens(k) + gravity*heightInterface(k,iCell) + !----------------------------------------------------------------- + ! compute Montgomery potential by accumulating jump across each layer interace + ! Jump == pressure at interface * (alpha (below interface) - alpha (above interface)) + !----------------------------------------------------------------- do k = 2, nLayers pInterfacek = pInterfacek + & - gravity * ( heightInterface(k-1,i)-heightInterface(k,i) ) * density(k-1,i) - MontgomeryPotential(k,i) = MontgomeryPotential(k-1,i) + & + gravity * ( heightInterface(k-1,iCell)-heightInterface(k,iCell) ) * density(k-1,iCell) + MontgomeryPotential(k,iCell) = MontgomeryPotential(k-1,iCell) + & pInterfacek * ( 1/potDens(k) - 1/potDens(k-1) ) enddo @@ -1508,44 +1728,67 @@ end subroutine computeMontgomeryPotential!}}} ! subroutine computeNormalGradientOnEdge ! !> \brief Compute the gradient of a quantity that exists on cell centers -!> \author Juan A. Saenz -!> \date December 2013 +!> \author Juan A. Saenz, Todd Ringler +!> \date May 2015 !> \details -!> This subroutine computes the gradient of a quantity that exists on cell centers +!> This subroutine computes the normal derivative of a scalar +!> quantity that exists on cell centers. Routine assumes that +!> data is valid throughout the entire column, as is the case +!> when working in buoyancy coordinates ! !----------------------------------------------------------------------- subroutine computeNormalGradientOnEdge(nBLayers, nCells, nEdges, & - mesh, field, normalGradOnEdge)!{{{ + meshPool, field, normalGradOnEdge)!{{{ + + !----------------------------------------------------------------- + ! intent(in) + !----------------------------------------------------------------- integer, intent(in) :: nBLayers, nCells, nEdges - type (mesh_type), intent(in) :: mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:), intent(in) :: field + + !----------------------------------------------------------------- + ! intent(out) + !----------------------------------------------------------------- real (kind=RKIND), dimension(:,:), intent(out) :: normalGradOnEdge + !----------------------------------------------------------------- !local variables - integer :: nEdgesSolve, iEdge, k, cell1, cell2, kMin, kMax - integer, dimension(:), pointer :: maxLevelEdgeTop + !----------------------------------------------------------------- + integer :: iEdge, k, cell1, cell2, kMin, kMax + integer, pointer :: nBuoyancyLayers integer, dimension(:,:), pointer :: cellsOnEdge integer, dimension(:,:), pointer :: boundaryEdge real (kind=RKIND), dimension(:), pointer :: dcEdge real (kind=RKIND) :: invLength - cellsOnEdge => mesh % cellsOnEdge % array - dcEdge => mesh % dcEdge % array - maxLevelEdgeTop => mesh % maxLevelEdgeTop % array - boundaryEdge => mesh % boundaryEdge % array + !----------------------------------------------------------------- + ! assign pointers + !----------------------------------------------------------------- + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'boundaryEdge', boundaryEdge) + call mpas_pool_get_dimension(meshPool, 'nBuoyancyLayers', nBuoyancyLayers) + + !----------------------------------------------------------------- + ! initialize intent(out) + !----------------------------------------------------------------- normalGradOnEdge = 0.0 + !----------------------------------------------------------------- + ! loop over edges, compute derivative as (cell2 - cell1) / dc + !----------------------------------------------------------------- do iEdge = 1, nEdges - ! enforce enforce zero gradient on boundary edges + ! do not compute the normal derivative at land/sea interface if (boundaryEdge(1,iEdge) == 1) then normalGradOnEdge(:,iEdge) = 0.0 else cell1 = cellsOnEdge(1, iEdge) cell2 = cellsOnEdge(2, iEdge) invLength = 1.0 / dcEdge(iEdge) - do k = 1, mesh % nBuoyancyLayers + do k = 1, nBuoyancyLayers normalGradOnEdge(k,iEdge) = ( field(k,cell2) - field(k,cell1) )*invLength enddo end if @@ -1560,24 +1803,40 @@ end subroutine computeNormalGradientOnEdge!}}} ! subroutine updateEnsembleAverage ! !> \brief Update ensemble average -!> \author Juan A. Saenz -!> \date 17 December 2013 +!> \author Juan A. Saenz, Todd Ringler +!> \date May 2015 !> \details !> This subroutine updates the ensemble average ! !----------------------------------------------------------------------- - subroutine updateEnsembleAverage(nLayers, nCells, nSamples, A, Abar)!{{{ + subroutine updateEnsembleAverage(nLayers, nCells, nSamples, A, Abar)!{{{ + + !----------------------------------------------------------------- + ! intent(in) + !----------------------------------------------------------------- integer, intent(in) :: nLayers, nCells, nSamples real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: A + + !----------------------------------------------------------------- + ! intent(inout) + !----------------------------------------------------------------- real (kind=RKIND), dimension(nLayers, nCells), intent(inout) :: Abar - !test - integer :: i, k + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + integer :: iCell, k - do i = 1, nCells + !----------------------------------------------------------------- + ! Abar is the current estimate of the ensemble average + ! on input, Abar was built using nSamples of A + ! To update Abar, we multiple Abar times nSamples, add in the + ! current value (A), then normalize by (nSamples + 1) + !----------------------------------------------------------------- + do iCell = 1, nCells do k = 1, nLayers - Abar(k,i) = (nSamples * Abar(k,i) + A(k,i)) / (nSamples + 1.0) + Abar(k,iCell) = (nSamples * Abar(k,iCell) + A(k,iCell)) / (nSamples + 1.0) enddo enddo @@ -1589,27 +1848,40 @@ end subroutine updateEnsembleAverage!}}} ! subroutine calculateTWA ! !> \brief Calculate the thickness weighted average -!> \author Juan A. Saenz -!> \date January 2014 +!> \author Juan A. Saenz, Todd Ringler +!> \date May 2015 !> \details !> This subroutine calculates the thickness weighted average ! !----------------------------------------------------------------------- - subroutine calculateTWA(nLayers, nCells, nBuoyancyLayers, sigmaEA, & - varSigmaEA, varTWA)!{{{ + subroutine calculateTWA(nLayers, nCells, nBuoyancyLayers, sigmaEA, & + varSigmaEA, varTWA)!{{{ + + !----------------------------------------------------------------- + ! intent(in) + !----------------------------------------------------------------- integer, intent(in) :: nLayers, nCells, nBuoyancyLayers real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: sigmaEA real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: varSigmaEA + + !----------------------------------------------------------------- + ! intent(inout) + !----------------------------------------------------------------- real (kind=RKIND), dimension(nLayers, nCells), intent(out) :: varTWA + !----------------------------------------------------------------- ! local variables - integer :: i, k + !----------------------------------------------------------------- + integer :: iCell, k + !----------------------------------------------------------------- + ! initialize intent(out) + !----------------------------------------------------------------- varTWA = 0.0 - do i = 1, nCells + do iCell = 1, nCells do k = 1,nBuoyancyLayers - varTWA(k,i) = varSigmaEA(k,i) / max(1.0e-15,sigmaEA(k,i)) + varTWA(k,iCell) = varSigmaEA(k,iCell) / max(epsilonEPFT,sigmaEA(k,iCell)) enddo enddo @@ -1661,7 +1933,7 @@ subroutine calculateEPFTfromTWA(nLayers, nCells, & do iCell = 1, nCells do kLayer = 1,nLayers - sigma = max(sigmaEA(kLayer,iCell), 1.0e-15) + sigma = max(sigmaEA(kLayer,iCell), epsilonEPFT) uppupp = uuSigmaEA(kLayer,iCell) / sigma - uTWA(kLayer,iCell)*uTWA(kLayer,iCell) vppvpp = vvSigmaEA(kLayer,iCell) / sigma - vTWA(kLayer,iCell)*vTWA(kLayer,iCell) @@ -1699,28 +1971,29 @@ end subroutine calculateEPFTfromTWA!}}} ! subroutine calculateDivEPFT ! !> \brief Calculate the divergence of EPFT -!> \author Juan A. Saenz -!> \date January 2014 +!> \author Juan A. Saenz, Todd Ringler +!> \date May 2015 !> \details -!> This subroutine calculates the divergence of the Elliassen-Palm flux tensor +!> This subroutine calculates the divergence of the Eliassen-Palm flux tensor ! !----------------------------------------------------------------------- - subroutine calculateDivEPFT(nLayers, nCells, nEdges, & - mesh, buoyancyInterfaceRef, sigmaEA, buoyMaskEA, tensorCellIn, vectorCellOut)!{{{ + subroutine calculateDivEPFT(onASphere, nLayers, nCells, nEdges, & + meshPool, buoyancyMidRef, sigmaEA, buoyancyMaskEA, tensorCellIn, vectorCellOut)!{{{ use mpas_vector_operations + logical, intent(in) :: onASphere integer, intent(in) :: nLayers, nCells, nEdges - type (mesh_type), intent(in) :: mesh - real (kind=RKIND), dimension(:), intent(in) :: buoyancyInterfaceRef + type (mpas_pool_type), intent(in) :: meshPool + real (kind=RKIND), dimension(:), intent(in) :: buoyancyMidRef real (kind=RKIND), dimension(:,:), intent(in) :: sigmaEA - real (kind=RKIND), dimension(:,:), intent(in) :: buoyMaskEA + real (kind=RKIND), dimension(:,:), intent(in) :: buoyancyMaskEA real (kind=RKIND), dimension(:,:,:,:), intent(in) :: tensorCellIn real (kind=RKIND), dimension(:,:,:), intent(out) :: vectorCellOut ! local variables - logical :: includeHalo, on_a_sphere + logical :: includeHalo integer :: q, iCell, kLayer, iComponent real (kind=RKIND) :: wrk, wrkAbove, wrkBelow, sigma, db real (kind=RKIND), dimension(:), pointer :: latCell @@ -1750,17 +2023,15 @@ subroutine calculateDivEPFT(nLayers, nCells, nEdges, & allocate(scalarWrk1(nLayers,nCells+1)) allocate(vectorCellWrk1(3,nLayers,nCells+1)) allocate(vectorCellWrk2(3,nLayers,nCells+1)) - allocate(vectorEdgeWrk1(3,nLayers,nEdges)) + allocate(vectorEdgeWrk1(3,nLayers,nEdges+1)) allocate(vertVector(nLayers)) - on_a_sphere = mesh % on_a_sphere - edgeSignOnCell => mesh % edgeSignOnCell % array - latCell => mesh % latCell % array - lonCell => mesh % lonCell % array + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) includeHalo = .true. - ! initialize work and intent(out) vectorCellOut = 0.0 @@ -1794,8 +2065,9 @@ subroutine calculateDivEPFT(nLayers, nCells, nEdges, & ! the vertical will be treated seperately below vectorCellWrk1(3,:,:) = 0.0 - if (on_a_sphere) then + if (onASphere) then + ! convert from lat/lon to Cartesian (x,y,z) do iCell = 1,nCells do kLayer = 1,nLayers call mpas_vector_LonLatR_to_R3(vectorCellWrk1(:,kLayer,iCell), & @@ -1803,14 +2075,17 @@ subroutine calculateDivEPFT(nLayers, nCells, nEdges, & end do end do + ! copy vector measured in x,y,z back into Wrk1 vectorCellWrk1 = vectorCellWrk2 end if - call mpas_vector_R3Cell_to_Edge(vectorCellWrk1, mesh, & + ! average the vector from cell centers to cell edges + call mpas_vector_R3Cell_to_Edge(vectorCellWrk1, meshPool, & vectorEdgeWrk1) - call mpas_divergence_in_r3_buoyancy(vectorEdgeWrk1, mesh, & + ! computed the divergence via the weak, line-integral form + call mpas_divergence_in_r3_buoyancy(vectorEdgeWrk1, meshPool, & edgeSignOnCell, includeHalo, scalarWrk1) ! use q=3 as a test vector @@ -1832,7 +2107,7 @@ subroutine calculateDivEPFT(nLayers, nCells, nEdges, & if (q < 3 .or. .not. config_oac_epft_debug) then do iCell = 1,nCells do kLayer = 1,nLayers - sigma = max(sigmaEA(kLayer,iCell), 1.0e-15) + sigma = max(sigmaEA(kLayer,iCell), epsilonEPFT) scalarWrk1(kLayer,iCell) = scalarWrk1(kLayer,iCell) / sigma end do end do @@ -1855,46 +2130,39 @@ subroutine calculateDivEPFT(nLayers, nCells, nEdges, & wrk = 0.0 - ! jas issue: change buoyancyInterfaceRef to buoyancyMidRef and generalize if(kLayer.eq.1) then wrkAbove=sigmaEA(kLayer,iCell)*vertVector(kLayer) wrkBelow=sigmaEA(kLayer+1,iCell)*vertVector(kLayer+1) - db = buoyancyInterfaceRef(kLayer)-buoyancyInterfaceRef(kLayer+1) + db = buoyancyMidRef(kLayer)-buoyancyMidRef(kLayer+1) else if (kLayer.eq.nLayers) then wrkAbove=sigmaEA(kLayer-1,iCell)*vertVector(kLayer-1) wrkBelow=sigmaEA(kLayer,iCell)*vertVector(kLayer) - db = buoyancyInterfaceRef(kLayer)-buoyancyInterfaceRef(kLayer+1) + db = buoyancyMidRef(kLayer-1)-buoyancyMidRef(kLayer) else wrkAbove=sigmaEA(kLayer-1,iCell)*vertVector(kLayer-1) wrkBelow=sigmaEA(kLayer+1,iCell)*vertVector(kLayer+1) - db = 2.0*(buoyancyInterfaceRef(kLayer)-buoyancyInterfaceRef(kLayer+1)) + db = buoyancyMidRef(kLayer-1)-buoyancyMidRef(kLayer+1) endif - ! jas issue: should sigma also be clipped like this for k-1 and k+1? - sigma = max(sigmaEA(kLayer,iCell), 1.0e-15) + sigma = max(sigmaEA(kLayer,iCell), epsilonEPFT) wrk = (wrkAbove - wrkBelow) / db / sigma scalarWrk1(kLayer,iCell) = scalarWrk1(kLayer,iCell) + wrk - ! temporarily mask divEPFT to add in visualization - !if(buoyMaskEA(kLayer,iCell).lt.0.5) scalarWrk1(kLayer,iCell) = 0.0 - - end do + end do ! do iCell=1,nCells - end do + end do ! do q=1,3 vectorCellOut(q,:,:) = scalarWrk1 end do - deallocate(scalarWrk1) deallocate(vectorCellWrk1) deallocate(vectorCellWrk2) deallocate(vectorEdgeWrk1) deallocate(vertVector) - end subroutine calculateDivEPFT!}}} @@ -1929,7 +2197,7 @@ subroutine calculateErtelPVFlux(nCells, nBuoyancyLayers, & do i = 1, nCells do k = 1,nBuoyancyLayers - ErtelPVFlux(:,k,i) = ErtelPVFlux(:,k,i) / max(sigma(k,i),1.0e-15) + ErtelPVFlux(:,k,i) = ErtelPVFlux(:,k,i) / max(sigma(k,i),epsilonEPFT) end do end do @@ -1984,7 +2252,7 @@ subroutine mpas_tensor_cell_to_edge_BuoyCoor(matrixCell, grid, & !----------------------------------------------------------------- integer :: iEdge, cell1, cell2, p, q, k - integer :: nEdgesCompute, nBuoyLayers, nCells + integer :: nEdgesCompute, nBuoyancyLayers, nCells integer, dimension(:,:), pointer :: cellsOnEdge if (includeHalo) then @@ -1992,7 +2260,7 @@ subroutine mpas_tensor_cell_to_edge_BuoyCoor(matrixCell, grid, & else nEdgesCompute = grid % nEdgesSolve endif - nBuoyLayers = grid % nBuoyancyLayers + nBuoyancyLayers = grid % nBuoyancyLayers nCells = grid % nCells cellsOnEdge => grid % cellsOnEdge % array @@ -2002,7 +2270,7 @@ subroutine mpas_tensor_cell_to_edge_BuoyCoor(matrixCell, grid, & do iEdge=1,nEdgesCompute cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - do k=1,nBuoyLayers + do k=1,nBuoyancyLayers do q = 1, 3 do p = 1, 3 matrixEdge(p,q,k,iEdge) = & @@ -2020,32 +2288,32 @@ end subroutine mpas_tensor_cell_to_edge_BuoyCoor!}}} ! subroutine calculateErtelPVTendencyFromPVFlux ! !> \brief Calculate the Ertel PV tendency from Ertel PV flux -!> \author Juan A. Saenz -!> \date January 2014 +!> \author Juan A. Saenz, Todd Ringler +!> \date May 2015 !> \details !> This subroutine calculates the Ertel PV tendency as the divergence of !> the Ertel PV flux ! !----------------------------------------------------------------------- - subroutine calculateErtelPVTendencyFromPVFlux(nLayers, nCells, nEdges, & - mesh, sigmaEA, vectorCell, divVectorCell)!{{{ + subroutine calculateErtelPVTendencyFromPVFlux(onASphere, nLayers, nCells, nEdges, & + meshPool, sigma, vectorCell, divVectorCell)!{{{ use mpas_vector_operations + logical, intent(in) :: onASphere integer, intent(in) :: nLayers, nCells, nEdges - type (mesh_type), intent(in) :: mesh - real (kind=RKIND), dimension(:,:), intent(in) :: sigmaEA + type (mpas_pool_type), intent(in) :: meshPool + real (kind=RKIND), dimension(:,:), intent(in) :: sigma real (kind=RKIND), dimension(:,:,:), intent(in) :: vectorCell real (kind=RKIND), dimension(:,:), intent(out) :: divVectorCell ! local variables - logical :: includeHalo, on_a_sphere + logical :: includeHalo integer :: i, k, iComponent - real (kind=RKIND) :: sigma real (kind=RKIND), dimension(:), pointer :: latCell real (kind=RKIND), dimension(:), pointer :: lonCell - integer, dimension(:,:), pointer :: edgeSignOnCell + integer, dimension(:,:), pointer :: edgeSignOnCell, boundaryCell real (kind=RKIND), dimension(:,:,:), allocatable :: vectorCellWrk1 real (kind=RKIND), dimension(:,:,:), allocatable :: vectorCellWrk2 real (kind=RKIND), dimension(:,:,:), allocatable :: vectorEdgeWrk1 @@ -2065,20 +2333,21 @@ subroutine calculateErtelPVTendencyFromPVFlux(nLayers, nCells, nEdges, & allocate(vectorCellWrk1(3,nLayers,nCells+1)) allocate(vectorCellWrk2(3,nLayers,nCells+1)) - allocate(vectorEdgeWrk1(3,nLayers,nEdges)) + allocate(vectorEdgeWrk1(3,nLayers,nEdges+1)) !jas issua check that this is +1 - on_a_sphere = mesh % on_a_sphere - edgeSignOnCell => mesh % edgeSignOnCell % array - latCell => mesh % latCell % array - lonCell => mesh % lonCell % array + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshPool, 'boundaryCell', boundaryCell) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) includeHalo = .true. + ! copy vector into work array vectorCellWrk1 = vectorCell - ! weight the vector with sigmaEA(:,:) + ! weight the vector with sigma(:,:) do iComponent = 1,3 - vectorCellWrk1(iComponent,:,:) = sigmaEA(:,:)*vectorCellWrk1(iComponent,:,:) + vectorCellWrk1(iComponent,:,:) = sigma(:,:)*vectorCellWrk1(iComponent,:,:) enddo @@ -2095,7 +2364,7 @@ subroutine calculateErtelPVTendencyFromPVFlux(nLayers, nCells, nEdges, & if (on_a_sphere) then - + ! copy vector into work array do i = 1,nCells do k = 1,nLayers call mpas_vector_LonLatR_to_R3(vectorCellWrk1(:,k,i), & @@ -2103,14 +2372,16 @@ subroutine calculateErtelPVTendencyFromPVFlux(nLayers, nCells, nEdges, & end do end do + ! copy transformed vector back to Wrk1 vectorCellWrk1 = vectorCellWrk2 - end if - call mpas_vector_R3Cell_to_Edge(vectorCellWrk1, mesh, & + ! average vector from cell centers to cell edges + call mpas_vector_R3Cell_to_Edge(vectorCellWrk1, meshPool, & vectorEdgeWrk1) - call mpas_divergence_in_r3_buoyancy(vectorEdgeWrk1, mesh, edgeSignOnCell, & + ! computed divergence via weak-form, line integral + call mpas_divergence_in_r3_buoyancy(vectorEdgeWrk1, meshPool, edgeSignOnCell, & includeHalo, divVectorCell) @@ -2132,18 +2403,15 @@ subroutine calculateErtelPVTendencyFromPVFlux(nLayers, nCells, nEdges, & if (.not. config_oac_epft_debug) then do i = 1,nCells do k = 1,nLayers - sigma = max(sigmaEA(k,i), 1.0e-15) - !sigma = 1.0 - divVectorCell(k,i) = divVectorCell(k,i) / sigma + divVectorCell(k,i) = divVectorCell(k,i) / max(sigma(k,i), epsilonEPFT) end do end do end if - deallocate(vectorCellWrk1) + deallocate(vectorCellWrk2) deallocate(vectorEdgeWrk1) - end subroutine calculateErtelPVTendencyFromPVFlux!}}} @@ -2160,13 +2428,13 @@ end subroutine calculateErtelPVTendencyFromPVFlux!}}} ! !----------------------------------------------------------------------- - subroutine computeErtelPV(nCells, nLayers, nEdges, mesh, & + subroutine computeErtelPV(nCells, nLayers, nEdges, meshPool, & fCell, uCell, vCell, sigma, ErtelPV) use mpas_vector_reconstruction integer, intent(in) :: nCells, nLayers, nEdges - type (mesh_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: meshPool real (kind=RKIND), dimension(:), intent(in) :: fCell real (kind=RKIND), dimension(:,:), intent(in) :: uCell, vCell real (kind=RKIND), dimension(:,:), intent(in) :: sigma @@ -2179,39 +2447,47 @@ subroutine computeErtelPV(nCells, nLayers, nEdges, mesh, & real (kind=RKIND), dimension(:,:), allocatable :: velGradZonal, velGradMerid real (kind=RKIND), dimension(:,:), allocatable :: vGradZonal, uGradMerid - allocate(velNormalGradOnEdge(nLayers, nEdges)) - allocate(velGradX(nLayers, nCells)) - allocate(velGradY(nLayers, nCells)) - allocate(velGradZ(nLayers, nCells)) - allocate(velGradZonal(nLayers, nCells)) - allocate(velGradMerid(nLayers, nCells)) - allocate(vGradZonal(nLayers, nCells)) - allocate(uGradMerid(nLayers, nCells)) + allocate(velNormalGradOnEdge(nLayers, nEdges+1)) ! jas issue check all these are +1 + allocate(velGradX(nLayers, nCells+1)) + allocate(velGradY(nLayers, nCells+1)) + allocate(velGradZ(nLayers, nCells+1)) + allocate(velGradZonal(nLayers, nCells+1)) + allocate(velGradMerid(nLayers, nCells+1)) + allocate(vGradZonal(nLayers, nCells+1)) + allocate(uGradMerid(nLayers, nCells+1)) - ! calculate derivative of uTWA with respect to y + ! calculate derivative of uTWA with respect to the meridional direction call computeNormalGradientOnEdge(nLayers, nCells, nEdges, & - mesh, & - uCell, velNormalGradOnEdge) - call mpas_reconstruct(mesh, velNormalGradOnEdge, & + meshPool, uCell, velNormalGradOnEdge) + call mpas_reconstruct(meshPool, velNormalGradOnEdge, & velGradX, velGradY, velGradZ, & velGradZonal, velGradMerid) uGradMerid = velGradMerid - ! calculate derivative of vTWA with respect to x + ! calculate derivative of vTWA with respect to the zonal direction call computeNormalGradientOnEdge(nLayers, nCells, nEdges, & - mesh, & - vCell, velNormalGradOnEdge) - call mpas_reconstruct(mesh, velNormalGradOnEdge, & + meshPool, vCell, velNormalGradOnEdge) + call mpas_reconstruct(meshPool, velNormalGradOnEdge, & velGradX, velGradY, velGradZ, & velGradZonal, velGradMerid) vGradZonal = velGradZonal do i = 1, nCells do k = 1,nLayers - ErtelPV(k,i) = (fCell(i) + vGradZonal(k,i) - uGradMerid(k,i))/max(sigma(k,i),1.0e-15) + ErtelPV(k,i) = (fCell(i) + vGradZonal(k,i) - uGradMerid(k,i))/max(sigma(k,i),epsilonEPFT) end do end do + deallocate(velNormalGradOnEdge) + deallocate(velGradX) + deallocate(velGradY) + deallocate(velGradZ) + deallocate(velGradZonal) + deallocate(velGradMerid) + deallocate(vGradZonal) + deallocate(uGradMerid) + + end subroutine computeErtelPV @@ -2244,7 +2520,7 @@ end subroutine eddyGeomDecompEPFT!}}} !> \details !> This routine computes the of an input vector. !----------------------------------------------------------------------- - subroutine mpas_divergence_in_r3_buoyancy(vectorR3Edge, grid, & + subroutine mpas_divergence_in_r3_buoyancy(vectorR3Edge, meshPool, & edgeSignOnCell, includeHalo, divCell)!{{{ !----------------------------------------------------------------- @@ -2256,8 +2532,8 @@ subroutine mpas_divergence_in_r3_buoyancy(vectorR3Edge, grid, & real (kind=RKIND), dimension(:,:,:), intent(in) :: & vectorR3Edge !< Input: vector at edge, R3, indices (direction,verticalIndex,edgeIndex) - type (mesh_type), intent(in) :: & - grid !< Input: grid information + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information integer, dimension(:,:), intent(in) :: & edgeSignOnCell !< Input: Direction of vector connecting cells @@ -2280,7 +2556,8 @@ subroutine mpas_divergence_in_r3_buoyancy(vectorR3Edge, grid, & ! !----------------------------------------------------------------- - integer :: iEdge, iCell, nCellsCompute, i, k, p, nVertLevels + integer :: iEdge, iCell, i, k, p + integer, pointer :: nVertLevels, nCells integer, dimension(:), pointer :: nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnCell @@ -2290,21 +2567,17 @@ subroutine mpas_divergence_in_r3_buoyancy(vectorR3Edge, grid, & real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell real (kind=RKIND), dimension(:,:), pointer :: edgeNormalVectors - if (includeHalo) then - nCellsCompute = grid % nCells - else - nCellsCompute = grid % nCellsSolve - endif - nVertLevels = grid % nBuoyancyLayers + call mpas_pool_get_dimension(meshPool, 'nBuoyancyLayers', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - edgesOnCell => grid % edgesOnCell % array - nEdgesOnCell => grid % nEdgesOnCell % array - dvEdge => grid % dvEdge % array - areaCell => grid % areaCell % array - edgeNormalVectors => grid % edgeNormalVectors % array + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'edgeNormalVectors', edgeNormalVectors) divCell(:,:) = 0.0 - do iCell = 1, nCellsCompute + do iCell = 1, nCells invAreaCell = 1.0 / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) iEdge = edgesOnCell(i, iCell) @@ -2334,30 +2607,34 @@ end subroutine mpas_divergence_in_r3_buoyancy!}}} !> \details !> This routine averages a vector field from cells to edges !----------------------------------------------------------------------- - subroutine mpas_vector_R3Cell_to_Edge(vectorCell, mesh, & + subroutine mpas_vector_R3Cell_to_Edge(vectorCell, meshPool, & vectorEdge) real, dimension(:,:,:), intent(in) :: vectorCell - type (mesh_type), intent(in) :: mesh !< Input: mesh information + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:,:), intent(out) :: vectorEdge !local variables - integer :: nEdges, iEdge, k, cell1, cell2 + integer :: iEdge, k, cell1, cell2 + integer, pointer :: nEdges, nBuoyancyLayers integer, dimension(:,:), pointer :: cellsOnEdge, boundaryEdge - cellsOnEdge => mesh % cellsOnEdge % array - boundaryEdge => mesh % boundaryEdge % array + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'boundaryEdge', boundaryEdge) + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nBuoyancyLayers', nBuoyancyLayers) vectorEdge = 0.0 - do iEdge = 1, mesh % nEdges + do iEdge = 1, nEdges ! Enforce vector value of zero on boundary edges, e.g. no slip for velocities if (boundaryEdge(1,iEdge) == 1) then vectorEdge(:,:,iEdge) = 0.0 else cell1 = cellsOnEdge(1, iEdge) cell2 = cellsOnEdge(2, iEdge) - do k = 1, mesh % nBuoyancyLayers + do k = 1, nBuoyancyLayers vectorEdge(:,k,iEdge) = 0.5*( vectorCell(:,k,cell2) + vectorCell(:,k,cell1) ) enddo end if From d8fd0306e5c0020a8343c90ad995201c11b7b21c Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Mon, 1 Jun 2015 14:18:40 -0600 Subject: [PATCH 0072/1724] finished porting EPFT module. Compiles. Haven't tried to run it. --- .../Registry_eliassen_palm_flux_tensor.xml | 126 ++++---- .../mpas_ocn_eliassen_palm_flux_tensor.F | 294 ++++++++++-------- 2 files changed, 227 insertions(+), 193 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml index 4f48cb2b31..3d0ecd8939 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml @@ -6,6 +6,13 @@ description="If true, ocean analysis member eliassen_palm_flux_tensor is called." possible_values=".true. or .false." /> + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + - - + - - - - + + + + @@ -185,6 +131,37 @@ + + + + + + + + + + + + + + + + + + + + + + + - - + domain % blocklist do while (associated(block)) + + !-------------------------------------------------- + ! assign pointers for each block + !-------------------------------------------------- + call mpas_pool_get_subpool(block % structs, 'amEliassenPalmFluxTensor', am_epftPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'eliassenPalmFluxTensorScratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) - call mpas_pool_get_subpool(block % structs, 'amEliassenPalmFluxTensor', am_epftPool) + !-------------------------------------------------- + ! assign pointers for mesh-related variables + !-------------------------------------------------- call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(block % dimensions, 'nBuoyancyLayers', nBuoyLayers) - !call mpas_pool_get_dimension(block % dimensions, 'nBuoyancyLayersP1', nBuoyLayersP1) + call mpas_pool_get_dimension(block % dimensions, 'nBuoyancyLayers', nBuoyancyLayers) + call mpas_pool_get_dimension(block % dimensions, 'nBuoyancyLayersP1', nBuoyancyLayersP1) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) call mpas_pool_get_array(meshPool, 'fCell', fCell) - - call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', surfacePressure) - + !-------------------------------------------------- + ! allocate scratch variables that will hold current state + !-------------------------------------------------- call mpas_pool_get_field(scratchPool, 'heightMidBuoyCoor', heightMidBuoyCoor) call mpas_pool_get_field(scratchPool, 'heightTopBuoyCoor', heightTopBuoyCoor) call mpas_pool_get_field(scratchPool, 'heightInterfaceBuoyCoor', heightInterfaceBuoyCoor) @@ -585,13 +613,21 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_pool_get_array(diagnosticsPool, 'density', density) call mpas_pool_get_array(diagnosticsPool, 'potentialdensity', potentialDensity) call mpas_pool_get_array(diagnosticsPool, 'pressure', pressure) - call mpas_pool_get_array(diagnosticsPool, 'normalVelocityZonal', uCellCenter) - call mpas_pool_get_array(diagnosticsPool, 'normalVelocityMeridional', vCellCenter) + call mpas_pool_get_array(diagnosticsPool, 'normalVelocityZonal', normalVelocityZonal) + call mpas_pool_get_array(diagnosticsPool, 'normalVelocityMeridional', normalVelocityMeridional) + !-------------------------------------------------- + ! define the vertical coordinate system in density/buoyancy space + !-------------------------------------------------- call mpas_pool_get_array(am_epftPool, 'potentialDensityMidRef', potentialDensityMidRef) call mpas_pool_get_array(am_epftPool, 'potentialDensityTopRef', potentialDensityTopRef) call mpas_pool_get_array(am_epftPool, 'buoyancyMidRef', buoyancyMidRef) call mpas_pool_get_array(am_epftPool, 'buoyancyInterfaceRef', buoyancyInterfaceRef) + + !-------------------------------------------------- + ! assign pointers for EA / TWA state + !-------------------------------------------------- + call mpas_pool_get_array(am_epftPool, 'nSamplesEA', nSamplesEA) call mpas_pool_get_array(am_epftPool, 'buoyancyMaskEA', buoyancyMaskEA) call mpas_pool_get_array(am_epftPool, 'sigmaEA', sigmaEA) call mpas_pool_get_array(am_epftPool, 'heightMidBuoyCoorEA', heightMidBuoyCoorEA) @@ -603,6 +639,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_pool_get_array(am_epftPool, 'heightMGradMeridEA', HeightMGradMeridEA) call mpas_pool_get_array(am_epftPool, 'usigmaEA', usigmaEA) call mpas_pool_get_array(am_epftPool, 'vsigmaEA', vsigmaEA) + call mpas_pool_get_array(am_epftPool, 'wsigmaEA', wsigmaEA) call mpas_pool_get_array(am_epftPool, 'uusigmaEA', uusigmaEA) call mpas_pool_get_array(am_epftPool, 'vvsigmaEA', vvsigmaEA) call mpas_pool_get_array(am_epftPool, 'uvsigmaEA', uvsigmaEA) @@ -617,12 +654,16 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_pool_get_array(am_epftPool, 'ErtelPVTendency', ErtelPVTendency) call mpas_pool_get_array(am_epftPool, 'ErtelPV', ErtelPV) - call mpas_pool_get_array(statePool, 'SSH', SSH) - - call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + !-------------------------------------------------- + ! assign pointers used from forcing pool + !-------------------------------------------------- + call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) - nSamplesEA = nSamplesEA % scalar + + !-------------------------------------------------- + ! assign pointers for instantaneous state + !-------------------------------------------------- heightMidBuoyCoor => heightMidBuoyCoor % array heightTopBuoyCoor => heightTopBuoyCoor % array heightInterfaceBuoyCoor => heightInterfaceBuoyCoor % array @@ -635,7 +676,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ montgPotNormalGradOnEdge=> montgPotNormalGradOnEdge % array firstLayerBuoyCoor => firstLayerBuoyCoor % array lastLayerBuoyCoor => lastLayerBuoyCoor % array - buoyancyMask => buoyancyMask % array + buoyancyMask => buoyancyMask % array montgPotGradX => montgPotGradX % array montgPotGradY => montgPotGradY % array montgPotGradZ => montgPotGradZ % array @@ -645,6 +686,9 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ wrk3DnVertLevels => wrk3DnVertLevels % array wrk3DBuoyCoor => wrk3DBuoyCoor % array + !-------------------------------------------------- + ! assign pointers for scratch and test variables + !-------------------------------------------------- array1_3D => array1_3D % array array2_3D => array2_3D % array array3_3D => array3_3D % array @@ -660,14 +704,11 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ PVFluxTest => PVFluxTest % array - nBuoyancyLayersP1 = nBuoyLayers+1 - - - ! jas diabatic terms + ! jas issue diabatic terms !diabaticHeating(nVertLevels,nCells)! "vertical velocity" in buoyancy space !wCellCenter = 0.0 - !jas issue + !jas issue diabatic terms ! Get diabaticTimeTendency of a buoyancy surface, omega with funny hat, if any. !call any existing MPAS-O subroutines for this @@ -676,6 +717,11 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! begin computation !------------------------------------------------------------- + !------------------------------------------------------------- + ! compute firstLayerBuoyCoor and lastLayerBuoyCoor + ! firstLayerBuoyCoor == top buoyancy coordinate to exist in each column + ! lastLayerBuoyCoor == bottom buoyancy coordinate to exist in each column + !------------------------------------------------------------- call get_masks_in_buoyancy_coordinates(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, potentialDensity, potentialDensityMidRef, & firstLayerBuoyCoor, lastLayerBuoyCoor, buoyancyMask) @@ -688,7 +734,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ print *, potentialDensityTopRef print *, 'potentialDensityMidRef' print *, potentialDensityMidRef - print *, 'nCells*nBuoyancyLayers', nCells*nBuoyLayers + print *, 'nCells*nBuoyancyLayers', nCells*nBuoyancyLayers print *, 'sum(buoyancyMask)', sum(buoyancyMask) print *, 'nCells*nVertLevels', nCells*nVertLevels print *, 'sum(mesh%cellMask%array)', sum(mesh%cellMask%array) @@ -699,9 +745,11 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ endif -! INTERPOLATION TEST 1 -! stratified, horizontally uniform -! Interpolating from z, rho to z, rho + !------------------------------------------------------------- + ! INTERPOLATION TEST 1 + ! stratified, horizontally uniform + ! Interpolating from z, rho to z, rho + !------------------------------------------------------------- if(config_oac_epft_debug) then do i = 1, nCells array1_3D(:,i) = -zMid(:,nCells/2) @@ -741,11 +789,13 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ endif -! INTERPOLATION TEST 2 -! Define a stratification where potential density varies linearly with depth -! Using reference potential density that varies linearly with index -! Interpolate z from that potential density to reference potential density -! compare to expected values + !------------------------------------------------------------- + ! INTERPOLATION TEST 2 + ! Define a stratification where potential density varies linearly with depth + ! Using reference potential density that varies linearly with index + ! Interpolate z from that potential density to reference potential density + ! compare to expected values + !------------------------------------------------------------- if(config_oac_epft_debug) then do i = 1,nCells do k = 1, nVertLevels @@ -779,18 +829,17 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ endif - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!! end chunk for testing -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!! start chunk commented during testing -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !------------------------------------------------------------- + ! check to see if at any point in the domain: + ! potentialDensity < potentialDensityTopRef(1) + ! potentialDensity > potentialDensityTopRef(nBuoyancyLayersP1) + ! either case means that buoyancy coordinate does not span the fluid domain + !------------------------------------------------------------- call check_potentialDensityRef_range(nVertLevels, nCells, maxLevelCell, potentialDensity) + !------------------------------------------------------------- + ! interpolate state variable from z-space into buoyancy-space + !------------------------------------------------------------- call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, -potentialDensity, zMid, & -potentialDensityMidRef, heightMidBuoyCoor) @@ -800,11 +849,11 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ -potentialDensityTopRef, heightTopBuoyCoor) call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & - maxLevelCell, -potentialDensity, uCellCenter, & + maxLevelCell, -potentialDensity, normalVelocityZonal, & -potentialDensityMidRef, uMidBuoyCoor) call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & - maxLevelCell, -potentialDensity, vCellCenter, & + maxLevelCell, -potentialDensity, normalVelocityMeridional, & -potentialDensityMidRef, vMidBuoyCoor) call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & @@ -815,14 +864,9 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ maxLevelCell, -potentialDensity, density, & -potentialDensityTopRef, densityTopBuoyCoor) + ! Diabatic terms !call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & - ! maxLevelCell, -potentialDensity, Q, potentialDensityTopRef, QMidRef) - - - ! JAS this can be moved to init ? - call computeBuoyancyColumn(nBuoyancyLayers, potentialDensityMidRef, buoyancyMidRef) - call computeBuoyancyColumnP1(nBuoyancyLayersP1, potentialDensityTopRef, & - buoyancyInterfaceRef) + ! maxLevelCell, -potentialDensity, wCellCenter, potentialDensityTopRef, wMidBuoyCoor) !------------------------------------------------------------- ! fill in data above firstLayerBuoyCoor and below lastLayerBuoyCoor @@ -861,21 +905,19 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !------------------------------------------------------------- ! using data interpolated to buoyancy space, compute Montgomery potential !------------------------------------------------------------- - call computeMontgomeryPotential(nBuoyancyLayers, nCells, surfacePressure, & - firstLayerBuoyCoor, lastLayerBuoyCoor, SSH, densityMidBuoyCoor, & - potentialDensityMidRef, heightInterfaceBuoyCoor, montgPotBuoyCoor) + call computeMontgomeryPotential(nBuoyancyLayers, nCells, seaSurfacePressure, & + densityMidBuoyCoor, potentialDensityMidRef, heightInterfaceBuoyCoor, montgPotBuoyCoor) !------------------------------------------------------------- ! compute the normal derivative of Montgomery potential at cell edges !------------------------------------------------------------- call computeNormalGradientOnEdge(nBuoyancyLayers, nCells, nEdges, & - mesh, & - montgPotBuoyCoor, montgPotNormalGradOnEdge) + meshPool, montgPotBuoyCoor, montgPotNormalGradOnEdge) !------------------------------------------------------------- ! reconstruct full gradient vector at cell centers !------------------------------------------------------------- - call mpas_reconstruct(mesh, montgPotNormalGradOnEdge, & + call mpas_reconstruct(meshPool, montgPotNormalGradOnEdge, & montgPotGradX, montgPotGradY, montgPotGradZ, & montgPotGradZonal, montgPotGradMerid) @@ -960,12 +1002,12 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! based on current estimate of ensemble-average state, ! compute the thickness-weighted average velocity !------------------------------------------------------------- - call calculateTWA(nBuoyancyLayers, nCells, nBuoyLayers, & + call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, & sigmaEA, usigmaEA, uTWA) - call calculateTWA(nBuoyancyLayers, nCells, nBuoyLayers, & + call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, & sigmaEA, vsigmaEA, vTWA) ! Diabatic terms - !call calculateTWA(nBuoyancyLayers, nCells, nBuoyLayers, & + !call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, & ! sigmaEA, wsigmaEA, wTWA) wTWA = 0.0 @@ -982,8 +1024,8 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !------------------------------------------------------------- ! compute the force applied to the momentum equation as div(EPFT) !------------------------------------------------------------- - call calculateDivEPFT(nBuoyancyLayers, nCells, nEdges, & - mesh, buoyancyInterfaceRef, sigmaEA, buoyancyMaskEA, EPFT, divEPFT) + call calculateDivEPFT(domain % on_a_sphere, nBuoyancyLayers, nCells, nEdges, & + meshPool, buoyancyMidRef, sigmaEA, buoyancyMaskEA, EPFT, divEPFT) !------------------------------------------------------------- ! transform div(EPFT) into a flux of Ertel's PV @@ -994,14 +1036,14 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !------------------------------------------------------------- ! compute div(ErtelPVFlux) to obtain tendency of Ertel's PV !------------------------------------------------------------- - call calculateErtelPVTendencyFromPVFlux(nBuoyancyLayers, nCells, nEdges, & - mesh, sigmaEA, ErtelPVFlux, ErtelPVTendency) + call calculateErtelPVTendencyFromPVFlux(domain % on_a_sphere, nBuoyancyLayers, nCells, nEdges, & + meshPool, sigmaEA, ErtelPVFlux, ErtelPVTendency) !------------------------------------------------------------- ! compute Ertel PV based on EA/TWA fields !------------------------------------------------------------- - call computeErtelPV(nCells, nBuoyancyLayers, nEdges, mesh, & + call computeErtelPV(nCells, nBuoyancyLayers, nEdges, meshPool, & fCell, uTWA, vTWA, sigmaEA, ErtelPV) !------------------------------------------------------------- @@ -1013,8 +1055,10 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ - + !------------------------------------------------------------- + ! Test: ! calculate potential vorticity fluxes using curl of u + !------------------------------------------------------------- if(config_oac_epft_debug) then relativeVorticityCell => diagnostics % relativeVorticityCell % array @@ -1063,7 +1107,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !------------------------------------------------------------- - ! deallocate scratch space + ! deallocate scratch space and test space variables !------------------------------------------------------------- call mpas_deallocate_scratch_field(firstLayerBuoyCoorField, .true.) call mpas_deallocate_scratch_field(lastLayerBuoyCoorField, .true.) @@ -1098,17 +1142,22 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_deallocate_scratch_field(vPVMidBuoyCoorEA, .true.) call mpas_deallocate_scratch_field(PVFluxTest, .true.) - + !------------------------------------------------------------- + ! update test variables + !------------------------------------------------------------- nCellsCum = nCellsCum + nCells !------------------------------------------------------------- ! move to the next block !------------------------------------------------------------- - block => block % next + end do + !------------------------------------------------------------- + ! TESTS: ! mpi gather/scatter calls may be placed here. + !------------------------------------------------------------- if(config_oac_epft_debug) then RMSglobal1 = 1.0D36 call mpas_dmpar_sum_int(dminfo, nCellsCum, nCellsGlobal) @@ -1158,19 +1207,16 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ endif - - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'am_eliassen_palm_flux_tensor', am_epftPool) - - ! assignment of final am_eliassen_palm_flux_tensor variables could occur here. - - block => block % next - end do call mpas_timer_stop("eliassen_palm_flux_tensor", am_eliassen_palm_flux_tensorTimer) - end subroutine ocn_compute_eliassen_palm_flux_tensor!}}} + if(config_epft_debug) then + write(stderrUnit, *) ' ' + write(stderrUnit, *) 'exiting ocn_compute_epft' + write(stderrUnit, *) ' ' + end if + + end subroutine ocn_compute_eliassen_palm_flux_tensor!}}} !*********************************************************************** ! @@ -1193,14 +1239,14 @@ subroutine ocn_restart_eliassen_palm_flux_tensor(domain, err)!{{{ ! !----------------------------------------------------------------- + type (domain_type), intent(in) :: domain + !----------------------------------------------------------------- ! ! input/output variables ! !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain - !----------------------------------------------------------------- ! ! output variables @@ -1240,14 +1286,14 @@ subroutine ocn_finalize_eliassen_palm_flux_tensor(domain, err)!{{{ ! !----------------------------------------------------------------- + type (domain_type), intent(in) :: domain + !----------------------------------------------------------------- ! ! input/output variables ! !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain - !----------------------------------------------------------------- ! ! output variables @@ -1264,6 +1310,8 @@ subroutine ocn_finalize_eliassen_palm_flux_tensor(domain, err)!{{{ err = 0 + write(stderrUnit,*) 'ocn_finalize_eliassen_palm_flux_tensor' + end subroutine ocn_finalize_eliassen_palm_flux_tensor!}}} @@ -1623,8 +1671,9 @@ subroutine computeSigma(nCells, nLayers, & !----------------------------------------------------------------- real (kind=RKIND), dimension(:,:), intent(out) :: sigma - + !----------------------------------------------------------------- ! local variables + !----------------------------------------------------------------- integer :: iCell, k !----------------------------------------------------------------- @@ -1668,6 +1717,7 @@ end subroutine computeSigma!}}} subroutine computeMontgomeryPotential(nLayers, nCells, pSurface, & density, potDens, heightInterface, MontgomeryPotential)!{{{ + !----------------------------------------------------------------- ! intent(in) !----------------------------------------------------------------- @@ -2333,7 +2383,7 @@ subroutine calculateErtelPVTendencyFromPVFlux(onASphere, nLayers, nCells, nEdges allocate(vectorCellWrk1(3,nLayers,nCells+1)) allocate(vectorCellWrk2(3,nLayers,nCells+1)) - allocate(vectorEdgeWrk1(3,nLayers,nEdges+1)) !jas issua check that this is +1 + allocate(vectorEdgeWrk1(3,nLayers,nEdges)) !jas issue Todd had set this to nEdges+1 call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) call mpas_pool_get_array(meshPool, 'boundaryCell', boundaryCell) @@ -2363,7 +2413,7 @@ subroutine calculateErtelPVTendencyFromPVFlux(onASphere, nLayers, nCells, nEdges endif - if (on_a_sphere) then + if (onASphere) then ! copy vector into work array do i = 1,nCells do k = 1,nLayers @@ -2447,14 +2497,14 @@ subroutine computeErtelPV(nCells, nLayers, nEdges, meshPool, & real (kind=RKIND), dimension(:,:), allocatable :: velGradZonal, velGradMerid real (kind=RKIND), dimension(:,:), allocatable :: vGradZonal, uGradMerid - allocate(velNormalGradOnEdge(nLayers, nEdges+1)) ! jas issue check all these are +1 - allocate(velGradX(nLayers, nCells+1)) - allocate(velGradY(nLayers, nCells+1)) - allocate(velGradZ(nLayers, nCells+1)) - allocate(velGradZonal(nLayers, nCells+1)) - allocate(velGradMerid(nLayers, nCells+1)) - allocate(vGradZonal(nLayers, nCells+1)) - allocate(uGradMerid(nLayers, nCells+1)) + allocate(velNormalGradOnEdge(nLayers, nEdges)) ! jas issue this one seems correct + allocate(velGradX(nLayers, nCells)) ! jas issue gets sent to routine where looping over nCellsSolve + allocate(velGradY(nLayers, nCells)) ! jas issue gets sent to routine where looping over nCellsSolve + allocate(velGradZ(nLayers, nCells)) ! jas issue gets sent to routine where looping over nCellsSolve + allocate(velGradZonal(nLayers, nCells)) ! jas issue gets sent to routine where looping over nCellsSolve + allocate(velGradMerid(nLayers, nCells)) ! jas issue gets sent to routine where looping over nCellsSolve + allocate(uGradMerid(nLayers, nCells)) ! jas issue gets assigned array of size is nCells + allocate(vGradZonal(nLayers, nCells)) ! jas issue gets assigned array of size is nCells ! calculate derivative of uTWA with respect to the meridional direction call computeNormalGradientOnEdge(nLayers, nCells, nEdges, & From b9e44ba2b33c395aac7fc1955e3258a8b47d0862 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Tue, 2 Jun 2015 12:09:53 -0600 Subject: [PATCH 0073/1724] changed package name changed package name to distinguish it from varstruct name --- .../Registry_eliassen_palm_flux_tensor.xml | 44 +++++++------------ 1 file changed, 16 insertions(+), 28 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml index 3d0ecd8939..3bf539ac23 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml @@ -73,7 +73,7 @@ - @@ -85,7 +85,7 @@ filename_template="eliassen_palm_flux_tensor_input.$Y-$M-$D.nc" filename_interval="01-00-00_00:00:00" output_interval="00-00-01_00:00:00" - packages="amEliassenPalmFluxTensor" + packages="amEliassenPalmFluxTensorPkg" clobber_mode="truncate" runtime_format="single_file"> @@ -93,14 +93,14 @@ + type="output" + mode="forward;analysis" + filename_template="analysis_members/eliassen_palm_flux_tensor_output.$Y-$M-$D.nc" + filename_interval="01-00-00_00:00:00" + output_interval="00-00-01_00:00:00" + packages="amEliassenPalmFluxTensorPkg" + clobber_mode="truncate" + runtime_format="single_file"> @@ -129,15 +129,14 @@ - - @@ -160,7 +159,8 @@ - + + - + packages="amEliassenPalmFluxTensorPkg"> - - - - - - - - - - - - From a672010d4bd0203b4045fc068e7b7fe4e7caf63e Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Mon, 8 Jun 2015 14:27:58 -0600 Subject: [PATCH 0074/1724] changed Makefile in AM and epft registry added epft module object file to Makefile in AM directory cleaned epft registry --- src/core_ocean/analysis_members/Makefile | 5 ++++- .../Registry_eliassen_palm_flux_tensor.xml | 10 +++++++--- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/src/core_ocean/analysis_members/Makefile b/src/core_ocean/analysis_members/Makefile index 4ead700523..2b55b3d780 100644 --- a/src/core_ocean/analysis_members/Makefile +++ b/src/core_ocean/analysis_members/Makefile @@ -6,7 +6,8 @@ OBJS = mpas_ocn_analysis_driver.o \ mpas_ocn_okubo_weiss_eigenvalues.o \ mpas_ocn_surface_area_weighted_averages.o \ mpas_ocn_water_mass_census.o \ - mpas_ocn_zonal_mean.o + mpas_ocn_zonal_mean.o \ + mpas_ocn_eliassen_palm_flux_tensor.o all: $(OBJS) @@ -22,6 +23,8 @@ mpas_ocn_water_mass_census.o: mpas_ocn_layer_volume_weighted_averages.o: +mpas_ocn_eliassen_palm_flux_tensor.o: + clean: $(RM) *.o *.i *.mod *.f90 diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml index 3bf539ac23..9568468f96 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml @@ -41,6 +41,13 @@ description="If true, debugging code is turned on." possible_values=".true. or .false." /> + - - - Date: Tue, 9 Jun 2015 15:34:48 -0600 Subject: [PATCH 0075/1724] implemented epft in AM makefile, registry, driver and fixed some bugs --- src/core_ocean/analysis_members/Makefile | 2 +- .../Registry_analysis_members.xml | 1 + .../Registry_eliassen_palm_flux_tensor.xml | 116 +-- .../mpas_ocn_analysis_driver.F | 1 + .../mpas_ocn_eliassen_palm_flux_tensor.F | 682 ++++++++++-------- 5 files changed, 410 insertions(+), 392 deletions(-) diff --git a/src/core_ocean/analysis_members/Makefile b/src/core_ocean/analysis_members/Makefile index 2b55b3d780..b61d1f1696 100644 --- a/src/core_ocean/analysis_members/Makefile +++ b/src/core_ocean/analysis_members/Makefile @@ -11,7 +11,7 @@ OBJS = mpas_ocn_analysis_driver.o \ all: $(OBJS) -mpas_ocn_analysis_driver.o: mpas_ocn_global_stats.o mpas_ocn_okubo_weiss.o mpas_ocn_zonal_mean.o mpas_ocn_okubo_weiss_eigenvalues.o mpas_ocn_surface_area_weighted_averages.o mpas_ocn_water_mass_census.o mpas_ocn_layer_volume_weighted_averages.o +mpas_ocn_analysis_driver.o: mpas_ocn_global_stats.o mpas_ocn_okubo_weiss.o mpas_ocn_zonal_mean.o mpas_ocn_okubo_weiss_eigenvalues.o mpas_ocn_surface_area_weighted_averages.o mpas_ocn_water_mass_census.o mpas_ocn_layer_volume_weighted_averages.o mpas_ocn_eliassen_palm_flux_tensor.o mpas_ocn_global_stats.o: diff --git a/src/core_ocean/analysis_members/Registry_analysis_members.xml b/src/core_ocean/analysis_members/Registry_analysis_members.xml index e1b22d4832..da2a3617cd 100644 --- a/src/core_ocean/analysis_members/Registry_analysis_members.xml +++ b/src/core_ocean/analysis_members/Registry_analysis_members.xml @@ -4,3 +4,4 @@ #include "Registry_layer_volume_weighted_averages.xml" #include "Registry_zonal_mean.xml" #include "Registry_okubo_weiss.xml" +#include "Registry_eliassen_palm_flux_tensor.xml" diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml index 9568468f96..816b883f93 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml @@ -1,12 +1,12 @@ - - - - - + - + + + - - @@ -406,34 +376,29 @@ - - diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F index 6ff3b2faf7..9ba89c772c 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -119,6 +119,7 @@ subroutine ocn_analysis_setup_packages(configPool, packagePool, err)!{{{ logical, pointer :: config_use_AM_sfc_area_weighted_avg logical, pointer :: config_use_AM_water_mass_census logical, pointer :: config_use_AM_layer_volume_weighted_avg + logical, pointer :: config_use_AM_eliassen_palm_flux_tensor ! logical, pointer :: config_use_TEMPLATE err = 0 diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F index 5de0121069..f765f10547 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F @@ -27,6 +27,7 @@ module ocn_eliassen_palm_flux_tensor use mpas_stream_manager use mpas_configure + use mpas_constants use ocn_constants use ocn_diagnostics_routines @@ -59,7 +60,6 @@ module ocn_eliassen_palm_flux_tensor !-------------------------------------------------------------------- type (timer_node), pointer :: am_eliassen_palm_flux_tensorTimer - logical :: amEPFTOn real (kind=RKIND), parameter :: epsilonEPFT=1.0e-15 !*********************************************************************** @@ -115,14 +115,10 @@ subroutine ocn_setup_packages_eliassen_palm_flux_tensor(configPool, packagePool, err = 0 - call mpas_pool_get_config(configPool, "config_use_epft", config_use_epft) call mpas_pool_get_package(packagePool, & 'am_eliassen_palm_flux_tensor_Active', am_eliassen_palm_flux_tensor_Active) - ! turn on package for this analysis member based on configure option - ! (at present, this routine is only called when true) - amEPFTACtive = .false. - if (config_use_epft) amEPFTACtive = .true. + am_eliassen_palm_flux_tensor_Active = .true. end subroutine ocn_setup_packages_eliassen_palm_flux_tensor!}}} @@ -182,10 +178,10 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ real (kind=RKIND), dimension(:), pointer :: buoyancyMidRef real (kind=RKIND), dimension(:), pointer :: buoyancyInterfaceRef - logical, pointer :: amEPFTActive, config_do_restart, config_epft_reset - integer, pointer :: config_epft_nBuoyancyLayers - real (kind=RKIND), pointer :: config_epft_rhomax_buoycoor - real (kind=RKIND), pointer :: config_epft_rhomin_buoycoor + logical, pointer :: amEPFTActive, config_eliassen_palm_flux_tensor_do_restart, config_eliassen_palm_flux_tensor_reset + integer, pointer :: config_eliassen_palm_flux_tensor_nBuoyancyLayers + real (kind=RKIND), pointer :: config_eliassen_palm_flux_tensor_rhomax_buoycoor + real (kind=RKIND), pointer :: config_eliassen_palm_flux_tensor_rhomin_buoycoor real (kind=RKIND), pointer :: config_density0 integer, pointer :: nSamplesEA @@ -213,11 +209,16 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ if(.not.amEPFTActive) return - call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) - call mpas_pool_get_config(domain % configs, 'config_epft_reset', config_epft_reset) - call mpas_pool_get_config(domain % configs, 'config_epft_nBuoyancyLayers', config_epft_nBuoyancyLayers) - call mpas_pool_get_config(domain % configs, 'config_epft_rhomax_buoycoor', config_epft_rhomax_buoycoor) - call mpas_pool_get_config(domain % configs, 'config_epft_rhomin_buoycoor', config_epft_rhomin_buoycoor) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_do_restart', & + config_eliassen_palm_flux_tensor_do_restart) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_reset', & + config_eliassen_palm_flux_tensor_reset) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_nBuoyancyLayers', & + config_eliassen_palm_flux_tensor_nBuoyancyLayers) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_rhomax_buoycoor', & + config_eliassen_palm_flux_tensor_rhomax_buoycoor) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_rhomin_buoycoor', & + config_eliassen_palm_flux_tensor_rhomin_buoycoor) call mpas_pool_get_config(domain % configs, 'config_density0', config_density0) block => domain % blocklist @@ -236,16 +237,16 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ ! compute buoyancy and density increment of each layer ! at present we use layer interfaces that are evenly-spaced in buoyancy space !----------------------------------------------------------------- - nBuoyancyLayers = config_epft_nBuoyancyLayers - deltaDensity = (config_epft_rhomax_buoycoor - config_epft_rhomin_buoycoor) / config_epft_nBuoyancyLayers + nBuoyancyLayers = config_eliassen_palm_flux_tensor_nBuoyancyLayers + deltaDensity = (config_eliassen_palm_flux_tensor_rhomax_buoycoor - config_eliassen_palm_flux_tensor_rhomin_buoycoor) / config_eliassen_palm_flux_tensor_nBuoyancyLayers deltaBuoyancy = -gravity * deltaDensity / config_density0 !----------------------------------------------------------------- ! compute density/bouyancy at top of each layer !----------------------------------------------------------------- do k = 1, nBuoyancyLayers - potentialDensityTopRef(k) = config_epft_rhomin_buoycoor + deltaDensity * (k-1) - buoyancyInterfaceRef(k) = -gravity * (config_epft_rhomin_buoycoor - config_density0) / config_density0 + deltaBuoyancy * (k-1) + potentialDensityTopRef(k) = config_eliassen_palm_flux_tensor_rhomin_buoycoor + deltaDensity * (k-1) + buoyancyInterfaceRef(k) = -gravity * (config_eliassen_palm_flux_tensor_rhomin_buoycoor - config_density0) / config_density0 + deltaBuoyancy * (k-1) end do k=nBuoyancyLayers buoyancyInterfaceRef(k+1) = buoyancyInterfaceRef(k) + deltaBuoyancy @@ -258,13 +259,13 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ buoyancyMidRef(k) = 0.5*(buoyancyInterfaceRef(k) + buoyancyInterfaceRef(k+1)) end do k=nBuoyancyLayers - potentialDensityMidRef(k) = 0.5*(potentialDensityTopRef(k-1) + config_epft_rhomax_buoycoor) + potentialDensityMidRef(k) = 0.5*(potentialDensityTopRef(k-1) + config_eliassen_palm_flux_tensor_rhomax_buoycoor) buoyancyMidRef(k) = 0.5*(buoyancyInterfaceRef(k) + buoyancyInterfaceRef(k+1)) !----------------------------------------------------------------- ! initialize ensemble averages when it is not a restart or when a reset is specified !----------------------------------------------------------------- - if (.not. config_do_restart .or. config_epft_reset) then + if (.not. config_eliassen_palm_flux_tensor_do_restart .or. config_eliassen_palm_flux_tensor_reset) then call mpas_pool_get_array(amEPFTPool, 'buoyancyMaskEA', buoyancyMaskEA) call mpas_pool_get_array(amEPFTPool, 'sigmaEA', sigmaEA) call mpas_pool_get_array(amEPFTPool, 'nSamplesEA', nSamplesEA) @@ -372,7 +373,15 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ type (mpas_pool_type), pointer :: forcingPool type (mpas_pool_type), pointer :: diagnosticsPool - logical, pointer :: config_epft_debug + real (kind=RKIND), pointer :: config_density0 + + + !----------------------------------------------------------------- + ! define namelist config variables local to the EPFT module + !----------------------------------------------------------------- + logical, pointer :: config_eliassen_palm_flux_tensor_debug + real (kind=RKIND), pointer :: config_eliassen_palm_flux_tensor_rhomin_buoycoor + real (kind=RKIND), pointer :: config_eliassen_palm_flux_tensor_rhomax_buoycoor !----------------------------------------------------------------- ! define local scalars holding length of dimensions @@ -384,8 +393,6 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! define buoyancy coordinate and field related to the vertical direction !----------------------------------------------------------------- integer, dimension(:), pointer :: maxLevelCell - integer, dimension(:), pointer :: firstLayerBuoyCoor - integer, dimension(:), pointer :: lastLayerBuoyCoor real(KIND=RKIND), dimension(:), pointer :: potentialDensityMidRef real(KIND=RKIND), dimension(:), pointer :: potentialDensityTopRef real(KIND=RKIND), dimension(:), pointer :: buoyancyMidRef @@ -396,11 +403,12 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! define mesh variables !----------------------------------------------------------------- real(KIND=RKIND), dimension(:), pointer :: fCell + real(KIND=RKIND), dimension(:,:), pointer :: cellMask !----------------------------------------------------------------- ! define fields related to the Ensemble Average (EA) !----------------------------------------------------------------- - integer :: nSamplesEA + integer, pointer :: nSamplesEA real(KIND=RKIND), dimension(:,:), pointer :: buoyancyMaskEA real(KIND=RKIND), dimension(:,:), pointer :: sigmaEA real(KIND=RKIND), dimension(:,:), pointer :: heightMidBuoyCoorEA @@ -412,7 +420,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: heightMGradMeridEA real(KIND=RKIND), dimension(:,:), pointer :: usigmaEA real(KIND=RKIND), dimension(:,:), pointer :: vsigmaEA - !real(KIND=RKIND), dimension(:,:), pointer :: wsigmaEA + real(KIND=RKIND), dimension(:,:), pointer :: wsigmaEA real(KIND=RKIND), dimension(:,:), pointer :: uusigmaEA real(KIND=RKIND), dimension(:,:), pointer :: vvsigmaEA real(KIND=RKIND), dimension(:,:), pointer :: uvsigmaEA @@ -440,24 +448,80 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:,:), pointer :: divEPFT !----------------------------------------------------------------- - ! define arrays holding instantaneous state in buoyancy coordinates + ! define scratch fields + !----------------------------------------------------------------- + type(field1DInteger), pointer :: firstLayerBuoyCoorField + type(field1DInteger), pointer :: lastLayerBuoyCoorField + type(field2DReal), pointer :: heightMidBuoyCoorField + type(field2DReal), pointer :: heightTopBuoyCoorField + type(field2DReal), pointer :: heightInterfaceBuoyCoorField + type(field2DReal), pointer :: sigmaField + type(field2DReal), pointer :: montgPotBuoyCoorField + type(field2DReal), pointer :: montgPotNormalGradOnEdgeField + type(field2DReal), pointer :: uMidBuoyCoorField + type(field2DReal), pointer :: vMidBuoyCoorField + type(field2DReal), pointer :: densityMidBuoyCoorField + type(field2DReal), pointer :: densityTopBuoyCoorField + type(field2DReal), pointer :: buoyancyMaskField + type(field2DReal), pointer :: montgPotGradXField + type(field2DReal), pointer :: montgPotGradYField + type(field2DReal), pointer :: montgPotGradZField + type(field2DReal), pointer :: montgPotGradZonalField + type(field2DReal), pointer :: montgPotGradMeridField + type(field2DReal), pointer :: wrk3DnVertLevelsP1Field + type(field2DReal), pointer :: wrk3DnVertLevelsField + type(field2DReal), pointer :: wrk3DBuoyCoorField + + type(field2DReal), pointer :: array1_3DField + type(field2DReal), pointer :: array2_3DField + type(field2DReal), pointer :: array3_3DField + type(field2DReal), pointer :: array1_3DbuoyField + type(field2DReal), pointer :: array2_3DbuoyField + type(field2DReal), pointer :: PVMidBuoyCoorField + type(field2DReal), pointer :: PVMidBuoyCoorEAField + type(field2DReal), pointer :: uMidBuoyCoorEAField + type(field2DReal), pointer :: vMidBuoyCoorEAField + type(field2DReal), pointer :: uPVMidBuoyCoorEAField + type(field2DReal), pointer :: vPVMidBuoyCoorEAField + type(field3DReal), pointer :: PVFluxTestField + + !----------------------------------------------------------------- + ! define pointers to scratch fields !----------------------------------------------------------------- - real(KIND=RKIND), dimension(:,:), pointer :: buoyancyMask - real(KIND=RKIND), dimension(:,:), pointer :: heightMidBuoyCoor + integer, dimension(:), pointer :: firstLayerBuoyCoor + integer, dimension(:), pointer :: lastLayerBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: heightMidBuoyCoor real(KIND=RKIND), dimension(:,:), pointer :: heightTopBuoyCoor real(KIND=RKIND), dimension(:,:), pointer :: heightInterfaceBuoyCoor - real(KIND=RKIND), dimension(:,:), pointer :: uMidBuoyCoor - real(KIND=RKIND), dimension(:,:), pointer :: vMidBuoyCoor - real(KIND=RKIND), dimension(:,:), pointer :: densityMidBuoyCoor - real(KIND=RKIND), dimension(:,:), pointer :: densityTopBuoyCoor real(KIND=RKIND), dimension(:,:), pointer :: sigma real(KIND=RKIND), dimension(:,:), pointer :: montgPotBuoyCoor real(KIND=RKIND), dimension(:,:), pointer :: montgPotNormalGradOnEdge - real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradX - real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradY - real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradZ - real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradZonal + real(KIND=RKIND), dimension(:,:), pointer :: uMidBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: vMidBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: densityMidBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: densityTopBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: buoyancyMask + real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradX + real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradY + real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradZ + real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradZonal real(KIND=RKIND), dimension(:,:), pointer :: montgPotGradMerid + real(KIND=RKIND), dimension(:,:), pointer :: wrk3DnVertLevelsP1 + real(KIND=RKIND), dimension(:,:), pointer :: wrk3DnVertLevels + real(KIND=RKIND), dimension(:,:), pointer :: wrk3DBuoyCoor + + real(KIND=RKIND), dimension(:,:), pointer :: array1_3D + real(KIND=RKIND), dimension(:,:), pointer :: array2_3D + real(KIND=RKIND), dimension(:,:), pointer :: array3_3D + real(KIND=RKIND), dimension(:,:), pointer :: array1_3Dbuoy + real(KIND=RKIND), dimension(:,:), pointer :: array2_3Dbuoy + real(KIND=RKIND), dimension(:,:), pointer :: PVMidBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: PVMidBuoyCoorEA + real(KIND=RKIND), dimension(:,:), pointer :: uMidBuoyCoorEA + real(KIND=RKIND), dimension(:,:), pointer :: vMidBuoyCoorEA + real(KIND=RKIND), dimension(:,:), pointer :: uPVMidBuoyCoorEA + real(KIND=RKIND), dimension(:,:), pointer :: vPVMidBuoyCoorEA + real(KIND=RKIND), dimension(:,:,:), pointer :: PVFluxTest !----------------------------------------------------------------- ! define arrays holding instantaneous state in z-coordinates @@ -470,41 +534,50 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: pressure real(KIND=RKIND), dimension(:,:), pointer :: normalVelocityZonal real(KIND=RKIND), dimension(:,:), pointer :: normalVelocityMeridional - real(KIND=RKIND), dimension(:,:), pointer :: wCellCenter + !real(KIND=RKIND), dimension(:,:), pointer :: wCellCenter + real(KIND=RKIND), dimension(:,:), pointer :: relativeVorticityCell ! jas used for testing !----------------------------------------------------------------- - ! define local workspace fields + ! define local test variables !----------------------------------------------------------------- - integer :: k - real(KIND=RKIND), dimension(:,:), pointer :: wrk3DnVertLevels - real(KIND=RKIND), dimension(:,:), pointer :: wrk3DBuoyCoor + ! jas to do : move these to Registry + integer :: nCellsCum + real(KIND=RKIND) :: RMSlocal1, RMSglobal1 + real(KIND=RKIND) :: RMSlocal2, RMSglobal2 + real(KIND=RKIND) :: RMSPVFlux1local, RMSPVFlux1global + real(KIND=RKIND) :: RMSPVFlux2local, RMSPVFlux2global !----------------------------------------------------------------- - ! define local test variables + ! define local work variables !----------------------------------------------------------------- - integer :: nCellsGlobal, i - real(KIND=RKIND), dimension(:,:), pointer :: array1_3D - real(KIND=RKIND), dimension(:,:), pointer :: array2_3D - real(KIND=RKIND), dimension(:,:), pointer :: array3_3D - real(KIND=RKIND), dimension(:,:), pointer :: array1_3Dbuoy - real(KIND=RKIND), dimension(:,:), pointer :: array2_3Dbuoy - real(KIND=RKIND), dimension(:,:), pointer :: PVMidBuoyCoor - real(KIND=RKIND), dimension(:,:), pointer :: PVMidBuoyCoorEA - real(KIND=RKIND), dimension(:,:), pointer :: uMidBuoyCoorEA - real(KIND=RKIND), dimension(:,:), pointer :: vMidBuoyCoorEA - real(KIND=RKIND), dimension(:,:), pointer :: uPVMidBuoyCoorEA - real(KIND=RKIND), dimension(:,:), pointer :: vPVMidBuoyCoorEA - real(KIND=RKIND), dimension(:,:,:), pointer :: PVFluxTest - real(KIND=RKIND), dimension(:,:), pointer :: relativeVorticityCell + integer :: nCellsGlobal, k, i + real(KIND=RKIND) :: rho0 err = 0 dminfo = domain % dminfo - - call mpas_timer_start("compute_eliassen_palm_flux_tensor", .false., am_eliassen_palm_flux_tensorTimer) - call mpas_pool_get_config(domain % configs, 'config_epft_debug', config_epft_debug) + RMSlocal1 = 0.0 + RMSlocal2 = 0.0 + RMSglobal1 = 0.0 + RMSglobal2 = 0.0 + RMSPVFlux1local = 0.0 + RMSPVFlux2local = 0.0 + RMSPVFlux1global = 0.0 + RMSPVFlux2global = 0.0 + + call mpas_timer_start("compute_eliassen_palm_flux_tensor", .false., & + am_eliassen_palm_flux_tensorTimer) + + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_debug', & + config_eliassen_palm_flux_tensor_debug) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_rhomin_buoycoor', & + config_eliassen_palm_flux_tensor_rhomin_buoycoor) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_rhomax_buoycoor', & + config_eliassen_palm_flux_tensor_rhomax_buoycoor) + call mpas_pool_get_config(domain % configs, 'config_density0', config_density0) + rho0 = config_density0 block => domain % blocklist do while (associated(block)) @@ -531,83 +604,126 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) call mpas_pool_get_array(meshPool, 'fCell', fCell) + call mpas_pool_get_array(meshPool, 'cellMask', cellMask) ! used for tests + !-------------------------------------------------- - ! allocate scratch variables that will hold current state + ! get scratch field pointers !-------------------------------------------------- - call mpas_pool_get_field(scratchPool, 'heightMidBuoyCoor', heightMidBuoyCoor) - call mpas_pool_get_field(scratchPool, 'heightTopBuoyCoor', heightTopBuoyCoor) - call mpas_pool_get_field(scratchPool, 'heightInterfaceBuoyCoor', heightInterfaceBuoyCoor) - call mpas_pool_get_field(scratchPool, 'uMidBuoyCoor', uMidBuoyCoor) - call mpas_pool_get_field(scratchPool, 'vMidBuoyCoor', vMidBuoyCoor) - call mpas_pool_get_field(scratchPool, 'densityMidBuoyCoor', densityMidBuoyCoor) - call mpas_pool_get_field(scratchPool, 'densityTopBuoyCoor', densityTopBuoyCoor) - call mpas_pool_get_field(scratchPool, 'sigma', sigma) - call mpas_pool_get_field(scratchPool, 'montgPotBuoyCoor', montgPotBuoyCoor) - call mpas_pool_get_field(scratchPool, 'montgPotNormalGradOnEdge', montgPotNormalGradOnEdge) - call mpas_pool_get_field(scratchPool, 'firstLayerBuoyCoor', firstLayerBuoyCoor) - call mpas_pool_get_field(scratchPool, 'lastLayerBuoyCoor', lastLayerBuoyCoor) - call mpas_pool_get_field(scratchPool, 'buoyancyMask', buoyancyMask) - call mpas_pool_get_field(scratchPool, 'montgPotGradX', montgPotGradX) - call mpas_pool_get_field(scratchPool, 'montgPotGradY', montgPotGradY) - call mpas_pool_get_field(scratchPool, 'montgPotGradZ', montgPotGradZ) - call mpas_pool_get_field(scratchPool, 'montgPotGradZonal', montgPotGradZonal) - call mpas_pool_get_field(scratchPool, 'montgPotGradMerid', montgPotGradMerid) - call mpas_pool_get_field(scratchPool, 'wrk3DnVertLevelsP1', wrk3DnVertLevelsP1) - call mpas_pool_get_field(scratchPool, 'wrk3DnVertLevels', wrk3DnVertLevels) - call mpas_pool_get_field(scratchPool, 'wrk3DBuoyCoor', wrk3DBuoyCoor) + call mpas_pool_get_field(scratchPool, 'firstLayerBuoyCoor', firstLayerBuoyCoorField) + call mpas_pool_get_field(scratchPool, 'lastLayerBuoyCoor', lastLayerBuoyCoorField) + call mpas_pool_get_field(scratchPool, 'heightMidBuoyCoor', heightMidBuoyCoorField) + call mpas_pool_get_field(scratchPool, 'heightTopBuoyCoor', heightTopBuoyCoorField) + call mpas_pool_get_field(scratchPool, 'heightInterfaceBuoyCoor', heightInterfaceBuoyCoorField) + call mpas_pool_get_field(scratchPool, 'sigma', sigmaField) + call mpas_pool_get_field(scratchPool, 'montgPotBuoyCoor', montgPotBuoyCoorField) + call mpas_pool_get_field(scratchPool, 'montgPotNormalGradOnEdge', montgPotNormalGradOnEdgeField) + call mpas_pool_get_field(scratchPool, 'uMidBuoyCoor', uMidBuoyCoorField) + call mpas_pool_get_field(scratchPool, 'vMidBuoyCoor', vMidBuoyCoorField) + call mpas_pool_get_field(scratchPool, 'densityMidBuoyCoor', densityMidBuoyCoorField) + call mpas_pool_get_field(scratchPool, 'densityTopBuoyCoor', densityTopBuoyCoorField) + call mpas_pool_get_field(scratchPool, 'buoyancyMask', buoyancyMaskField) + call mpas_pool_get_field(scratchPool, 'montgPotGradX', montgPotGradXField) + call mpas_pool_get_field(scratchPool, 'montgPotGradY', montgPotGradYField) + call mpas_pool_get_field(scratchPool, 'montgPotGradZ', montgPotGradZField) + call mpas_pool_get_field(scratchPool, 'montgPotGradZonal', montgPotGradZonalField) + call mpas_pool_get_field(scratchPool, 'montgPotGradMerid', montgPotGradMeridField) + call mpas_pool_get_field(scratchPool, 'wrk3DnVertLevelsP1', wrk3DnVertLevelsP1Field) + call mpas_pool_get_field(scratchPool, 'wrk3DnVertLevels', wrk3DnVertLevelsField) + call mpas_pool_get_field(scratchPool, 'wrk3DBuoyCoor', wrk3DBuoyCoorField) - call mpas_allocate_scratch_field(heightMidBuoyCoor, .true.) - call mpas_allocate_scratch_field(heightTopBuoyCoor, .true.) - call mpas_allocate_scratch_field(heightInterfaceBuoyCoor, .true.) - call mpas_allocate_scratch_field(uMidBuoyCoor, .true.) - call mpas_allocate_scratch_field(vMidBuoyCoor, .true.) - call mpas_allocate_scratch_field(densityMidBuoyCoor, .true.) - call mpas_allocate_scratch_field(densityTopBuoyCoor, .true.) - call mpas_allocate_scratch_field(sigma, .true.) - call mpas_allocate_scratch_field(montgPotBuoyCoor, .true.) - call mpas_allocate_scratch_field(montgPotNormalGradOnEdge, .true.) - call mpas_allocate_scratch_field(firstLayerBuoyCoor, .true.) - call mpas_allocate_scratch_field(lastLayerBuoyCoor, .true.) - call mpas_allocate_scratch_field(buoyancyMask, .true.) - call mpas_allocate_scratch_field(montgPotGradX, .true.) - call mpas_allocate_scratch_field(montgPotGradY, .true.) - call mpas_allocate_scratch_field(montgPotGradZ, .true.) - call mpas_allocate_scratch_field(montgPotGradZonal, .true.) - call mpas_allocate_scratch_field(montgPotGradMerid, .true.) - call mpas_allocate_scratch_field(wrk3DnVertLevelsP1, .true.) - call mpas_allocate_scratch_field(wrk3DnVertLevels, .true.) - call mpas_allocate_scratch_field(wrk3DBuoyCoor, .true.) - - ! test variables - call mpas_pool_get_field(scratchPool, 'array1_3D', array1_3D) - call mpas_pool_get_field(scratchPool, 'array2_3D', array2_3D) - call mpas_pool_get_field(scratchPool, 'array3_3D', array3_3D) - call mpas_pool_get_field(scratchPool, 'array1_3Dbuoy', array1_3Dbuoy) - call mpas_pool_get_field(scratchPool, 'array2_3Dbuoy', array2_3Dbuoy) - - call mpas_allocate_scratch_field(array1_3D, .true.) - call mpas_allocate_scratch_field(array2_3D, .true.) - call mpas_allocate_scratch_field(array3_3D, .true.) - call mpas_allocate_scratch_field(array1_3Dbuoy, .true.) - call mpas_allocate_scratch_field(array2_3Dbuoy, .true.) - - call mpas_pool_get_field('PVMidBuoyCoor', PVMidBuoyCoor) - call mpas_pool_get_field('PVMidBuoyCoorEA', PVMidBuoyCoorEA) - call mpas_pool_get_field('uMidBuoyCoorEA', uMidBuoyCoorEA) - call mpas_pool_get_field('vMidBuoyCoorEA', vMidBuoyCoorEA) - call mpas_pool_get_field('uPVMidBuoyCoorEA', uPVMidBuoyCoorEA) - call mpas_pool_get_field('vPVMidBuoyCoorEA', vPVMidBuoyCoorEA) - call mpas_pool_get_field('PVFluxTest', PVFluxTest) - - call mpas_allocate_scratch_field(PVMidBuoyCoor, .true.) - call mpas_allocate_scratch_field(PVMidBuoyCoorEA, .true.) - call mpas_allocate_scratch_field(uMidBuoyCoorEA , .true.) - call mpas_allocate_scratch_field(vMidBuoyCoorEA , .true.) - call mpas_allocate_scratch_field(uPVMidBuoyCoorEA , .true.) - call mpas_allocate_scratch_field(vPVMidBuoyCoorEA, .true.) - call mpas_allocate_scratch_field(PVFluxTest, .true.) + call mpas_pool_get_field(scratchPool, 'array1_3D', array1_3DField) + call mpas_pool_get_field(scratchPool, 'array2_3D', array2_3DField) + call mpas_pool_get_field(scratchPool, 'array3_3D', array3_3DField) + call mpas_pool_get_field(scratchPool, 'array1_3Dbuoy', array1_3DbuoyField) + call mpas_pool_get_field(scratchPool, 'array2_3Dbuoy', array2_3DbuoyField) + call mpas_pool_get_field(scratchPool, 'PVMidBuoyCoor', PVMidBuoyCoorField) + call mpas_pool_get_field(scratchPool, 'PVMidBuoyCoorEA', PVMidBuoyCoorEAField) + call mpas_pool_get_field(scratchPool, 'uMidBuoyCoorEA', uMidBuoyCoorEAField) + call mpas_pool_get_field(scratchPool, 'vMidBuoyCoorEA', vMidBuoyCoorEAField) + call mpas_pool_get_field(scratchPool, 'uPVMidBuoyCoorEA', uPVMidBuoyCoorEAField) + call mpas_pool_get_field(scratchPool, 'vPVMidBuoyCoorEA', vPVMidBuoyCoorEAField) + call mpas_pool_get_field(scratchPool, 'PVFluxTest', PVFluxTestField) + + !-------------------------------------------------- + ! allocate scratch field variables + !-------------------------------------------------- + call mpas_allocate_scratch_field(firstLayerBuoyCoorField, .true.) + call mpas_allocate_scratch_field(lastLayerBuoyCoorField, .true.) + call mpas_allocate_scratch_field(heightMidBuoyCoorField, .true.) + call mpas_allocate_scratch_field(heightTopBuoyCoorField, .true.) + call mpas_allocate_scratch_field(heightInterfaceBuoyCoorField, .true.) + call mpas_allocate_scratch_field(sigmaField, .true.) + call mpas_allocate_scratch_field(montgPotBuoyCoorField, .true.) + call mpas_allocate_scratch_field(montgPotNormalGradOnEdgeField, .true.) + call mpas_allocate_scratch_field(uMidBuoyCoorField, .true.) + call mpas_allocate_scratch_field(vMidBuoyCoorField, .true.) + call mpas_allocate_scratch_field(densityMidBuoyCoorField, .true.) + call mpas_allocate_scratch_field(densityTopBuoyCoorField, .true.) + call mpas_allocate_scratch_field(buoyancyMaskField, .true.) + call mpas_allocate_scratch_field(montgPotGradXField, .true.) + call mpas_allocate_scratch_field(montgPotGradYField, .true.) + call mpas_allocate_scratch_field(montgPotGradZField, .true.) + call mpas_allocate_scratch_field(montgPotGradZonalField, .true.) + call mpas_allocate_scratch_field(montgPotGradMeridField, .true.) + call mpas_allocate_scratch_field(wrk3DnVertLevelsP1Field, .true.) + call mpas_allocate_scratch_field(wrk3DnVertLevelsField, .true.) + call mpas_allocate_scratch_field(wrk3DBuoyCoorField, .true.) + + call mpas_allocate_scratch_field(array1_3DField, .true.) + call mpas_allocate_scratch_field(array2_3DField, .true.) + call mpas_allocate_scratch_field(array3_3DField, .true.) + call mpas_allocate_scratch_field(array1_3DbuoyField, .true.) + call mpas_allocate_scratch_field(array2_3DbuoyField, .true.) + call mpas_allocate_scratch_field(PVMidBuoyCoorField, .true.) + call mpas_allocate_scratch_field(PVMidBuoyCoorEAField, .true.) + call mpas_allocate_scratch_field(uMidBuoyCoorEAField, .true.) + call mpas_allocate_scratch_field(vMidBuoyCoorEAField, .true.) + call mpas_allocate_scratch_field(uPVMidBuoyCoorEAField, .true.) + call mpas_allocate_scratch_field(vPVMidBuoyCoorEAField, .true.) + call mpas_allocate_scratch_field(PVFluxTestField, .true.) + + !-------------------------------------------------- + ! assign pointers for scratch and test variables + !-------------------------------------------------- + firstLayerBuoyCoor => firstLayerBuoyCoorField % array + lastLayerBuoyCoor => lastLayerBuoyCoorField % array + heightMidBuoyCoor => heightMidBuoyCoorField % array + heightTopBuoyCoor => heightTopBuoyCoorField % array + heightInterfaceBuoyCoor => heightInterfaceBuoyCoorField % array + sigma => sigmaField % array + montgPotBuoyCoor => montgPotBuoyCoorField % array + montgPotNormalGradOnEdge=> montgPotNormalGradOnEdgeField % array + uMidBuoyCoor => uMidBuoyCoorField % array + vMidBuoyCoor => vMidBuoyCoorField % array + densityMidBuoyCoor => densityMidBuoyCoorField % array + densityTopBuoyCoor => densityTopBuoyCoorField % array + buoyancyMask => buoyancyMaskField % array + montgPotGradX => montgPotGradXField % array + montgPotGradY => montgPotGradYField % array + montgPotGradZ => montgPotGradZField % array + montgPotGradZonal => montgPotGradZonalField % array + montgPotGradMerid => montgPotGradMeridField % array + wrk3DnVertLevelsP1 => wrk3DnVertLevelsP1Field % array + wrk3DnVertLevels => wrk3DnVertLevelsField % array + wrk3DBuoyCoor => wrk3DBuoyCoorField % array + + array1_3D => array1_3DField % array + array2_3D => array2_3DField % array + array3_3D => array3_3DField % array + array1_3Dbuoy => array1_3DbuoyField % array + array2_3Dbuoy => array2_3DbuoyField % array + PVMidBuoyCoor => PVMidBuoyCoorField % array + PVMidBuoyCoorEA => PVMidBuoyCoorEAField % array + uMidBuoyCoorEA => uMidBuoyCoorEAField % array + vMidBuoyCoorEA => vMidBuoyCoorEAField % array + uPVMidBuoyCoorEA => uPVMidBuoyCoorEAField % array + vPVMidBuoyCoorEA => vPVMidBuoyCoorEAField % array + PVFluxTest => PVFluxTestField % array + !-------------------------------------------------- + ! get diagnostic variables + !-------------------------------------------------- call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) call mpas_pool_get_array(diagnosticsPool, 'zTop', zTop) call mpas_pool_get_array(diagnosticsPool, 'density', density) @@ -661,48 +777,6 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ - !-------------------------------------------------- - ! assign pointers for instantaneous state - !-------------------------------------------------- - heightMidBuoyCoor => heightMidBuoyCoor % array - heightTopBuoyCoor => heightTopBuoyCoor % array - heightInterfaceBuoyCoor => heightInterfaceBuoyCoor % array - uMidBuoyCoor => uMidBuoyCoor % array - vMidBuoyCoor => vMidBuoyCoor % array - densityMidBuoyCoor => densityMidBuoyCoor % array - densityTopBuoyCoor => densityTopBuoyCoor % array - sigma => sigma % array - montgPotBuoyCoor => montgPotBuoyCoor % array - montgPotNormalGradOnEdge=> montgPotNormalGradOnEdge % array - firstLayerBuoyCoor => firstLayerBuoyCoor % array - lastLayerBuoyCoor => lastLayerBuoyCoor % array - buoyancyMask => buoyancyMask % array - montgPotGradX => montgPotGradX % array - montgPotGradY => montgPotGradY % array - montgPotGradZ => montgPotGradZ % array - montgPotGradZonal => montgPotGradZonal % array - montgPotGradMerid => montgPotGradMerid % array - wrk3DnVertLevelsP1 => wrk3DnVertLevelsP1 % array - wrk3DnVertLevels => wrk3DnVertLevels % array - wrk3DBuoyCoor => wrk3DBuoyCoor % array - - !-------------------------------------------------- - ! assign pointers for scratch and test variables - !-------------------------------------------------- - array1_3D => array1_3D % array - array2_3D => array2_3D % array - array3_3D => array3_3D % array - array1_3Dbuoy => array1_3Dbuoy % array - array2_3Dbuoy => array2_3Dbuoy % array - - PVMidBuoyCoor => PVMidBuoyCoor % array - PVMidBuoyCoorEA => PVMidBuoyCoorEA % array - uMidBuoyCoorEA => uMidBuoyCoorEA % array - vMidBuoyCoorEA => vMidBuoyCoorEA % array - uPVMidBuoyCoorEA => uPVMidBuoyCoorEA % array - vPVMidBuoyCoorEA => vPVMidBuoyCoorEA % array - PVFluxTest => PVFluxTest % array - ! jas issue diabatic terms !diabaticHeating(nVertLevels,nCells)! "vertical velocity" in buoyancy space @@ -726,7 +800,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ maxLevelCell, potentialDensity, potentialDensityMidRef, & firstLayerBuoyCoor, lastLayerBuoyCoor, buoyancyMask) - if(config_oac_epft_debug) then + if(config_eliassen_palm_flux_tensor_debug) then print *, ' ' print *, 'timeLevel:', timeLevel print *, ' ' @@ -737,7 +811,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ print *, 'nCells*nBuoyancyLayers', nCells*nBuoyancyLayers print *, 'sum(buoyancyMask)', sum(buoyancyMask) print *, 'nCells*nVertLevels', nCells*nVertLevels - print *, 'sum(mesh%cellMask%array)', sum(mesh%cellMask%array) + print *, 'sum(cellMask)', sum(cellMask) print *, 'minval(potentialDensity), maxval(potentialDensity)' print *, minval(potentialDensity), maxval(potentialDensity) print *, 'minval(density), maxval(density)' @@ -750,7 +824,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! stratified, horizontally uniform ! Interpolating from z, rho to z, rho !------------------------------------------------------------- - if(config_oac_epft_debug) then + if(config_eliassen_palm_flux_tensor_debug) then do i = 1, nCells array1_3D(:,i) = -zMid(:,nCells/2) array2_3D(:,i) = potentialDensity(:,nCells/2) @@ -796,16 +870,16 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! Interpolate z from that potential density to reference potential density ! compare to expected values !------------------------------------------------------------- - if(config_oac_epft_debug) then + if(config_eliassen_palm_flux_tensor_debug) then do i = 1,nCells do k = 1, nVertLevels - array1_3D(k,i) = config_rhomin_buoycoor*1.02 + & + array1_3D(k,i) = config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02 + & (zMid(k,i)-zMid(1,i)) * & - (config_rhomax_buoycoor*0.98 - config_rhomin_buoycoor*1.02) / & + (config_eliassen_palm_flux_tensor_rhomax_buoycoor*0.98 - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) / & (zMid(nVertLevels,i) - zMid(1,i)) - array2_3D(k,i) = config_rhomin_buoycoor*1.02 + & + array2_3D(k,i) = config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02 + & (zTop(k,i)-zMid(1,i)) * & - (config_rhomax_buoycoor*0.98 - config_rhomin_buoycoor*1.02) / & + (config_eliassen_palm_flux_tensor_rhomax_buoycoor*0.98 - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) / & (zMid(nVertLevels,i) - zMid(1,i)) end do end do @@ -815,9 +889,9 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ do i = 1,nCells do k = 1, nBuoyancyLayers array2_3Dbuoy(k,i) = zMid(1,i) + & - (potentialDensityMidRef(k) - config_rhomin_buoycoor*1.02) * & + (potentialDensityMidRef(k) - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) * & (zMid(nVertLevels,i) - zMid(1,i)) / & - (config_rhomax_buoycoor*0.98 - config_rhomin_buoycoor*1.02) + (config_eliassen_palm_flux_tensor_rhomax_buoycoor*0.98 - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) end do end do do i = 1,nCells @@ -964,7 +1038,8 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !wrk3DBuoyCoor = wMidBuoyCoor * sigma !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & ! wrk3DBuoyCoor, wsigmaEA) - + wsigmaEA = 0.0 + !------------------------------------------------------------- ! Increment third-order running mean fields @@ -1024,7 +1099,8 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !------------------------------------------------------------- ! compute the force applied to the momentum equation as div(EPFT) !------------------------------------------------------------- - call calculateDivEPFT(domain % on_a_sphere, nBuoyancyLayers, nCells, nEdges, & + call calculateDivEPFT(config_eliassen_palm_flux_tensor_debug, & + domain % on_a_sphere, rho0, nBuoyancyLayers, nCells, nEdges, & meshPool, buoyancyMidRef, sigmaEA, buoyancyMaskEA, EPFT, divEPFT) !------------------------------------------------------------- @@ -1036,7 +1112,8 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !------------------------------------------------------------- ! compute div(ErtelPVFlux) to obtain tendency of Ertel's PV !------------------------------------------------------------- - call calculateErtelPVTendencyFromPVFlux(domain % on_a_sphere, nBuoyancyLayers, nCells, nEdges, & + call calculateErtelPVTendencyFromPVFlux(config_eliassen_palm_flux_tensor_debug, & + domain % on_a_sphere, nBuoyancyLayers, nCells, nEdges, & meshPool, sigmaEA, ErtelPVFlux, ErtelPVTendency) @@ -1059,9 +1136,9 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! Test: ! calculate potential vorticity fluxes using curl of u !------------------------------------------------------------- - if(config_oac_epft_debug) then + if(config_eliassen_palm_flux_tensor_debug) then - relativeVorticityCell => diagnostics % relativeVorticityCell % array + call mpas_pool_get_array(diagnosticsPool, 'relativeVorticityCell', relativeVorticityCell) ! store relVortMidBuoyCoor in array1_3Dbuoy call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & @@ -1130,17 +1207,17 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_deallocate_scratch_field(wrk3DnVertLevelsField, .true.) call mpas_deallocate_scratch_field(wrk3DBuoyCoorField, .true.) - call mpas_deallocate_scratch_field(array1_3D, .true.) - call mpas_deallocate_scratch_field(array2_3D, .true.) - call mpas_deallocate_scratch_field(array3_3D, .true.) - call mpas_deallocate_scratch_field(array1_3Dbuoy, .true.) - call mpas_deallocate_scratch_field(array2_3Dbuoy, .true.) - - call mpas_deallocate_scratch_field(PVMidBuoyCoor, .true.) - call mpas_deallocate_scratch_field(PVMidBuoyCoorEA, .true.) - call mpas_deallocate_scratch_field(uPVMidBuoyCoorEA , .true.) - call mpas_deallocate_scratch_field(vPVMidBuoyCoorEA, .true.) - call mpas_deallocate_scratch_field(PVFluxTest, .true.) + call mpas_deallocate_scratch_field(array1_3DField, .true.) + call mpas_deallocate_scratch_field(array2_3DField, .true.) + call mpas_deallocate_scratch_field(array3_3DField, .true.) + call mpas_deallocate_scratch_field(array1_3DbuoyField, .true.) + call mpas_deallocate_scratch_field(array2_3DbuoyField, .true.) + + call mpas_deallocate_scratch_field(PVMidBuoyCoorField, .true.) + call mpas_deallocate_scratch_field(PVMidBuoyCoorEAField, .true.) + call mpas_deallocate_scratch_field(uPVMidBuoyCoorEAField, .true.) + call mpas_deallocate_scratch_field(vPVMidBuoyCoorEAField, .true.) + call mpas_deallocate_scratch_field(PVFluxTestField, .true.) !------------------------------------------------------------- ! update test variables @@ -1158,7 +1235,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! TESTS: ! mpi gather/scatter calls may be placed here. !------------------------------------------------------------- - if(config_oac_epft_debug) then + if(config_eliassen_palm_flux_tensor_debug) then RMSglobal1 = 1.0D36 call mpas_dmpar_sum_int(dminfo, nCellsCum, nCellsGlobal) call mpas_dmpar_sum_real(dminfo, RMSlocal1, RMSglobal1) @@ -1210,7 +1287,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_timer_stop("eliassen_palm_flux_tensor", am_eliassen_palm_flux_tensorTimer) - if(config_epft_debug) then + if(config_eliassen_palm_flux_tensor_debug) then write(stderrUnit, *) ' ' write(stderrUnit, *) 'exiting ocn_compute_epft' write(stderrUnit, *) ' ' @@ -1430,22 +1507,22 @@ subroutine check_potentialDensityRef_range(nVertLevels, nCells, maxLevelCell, & integer :: k, iCell, iCellMinBound, iCellMaxBound logical :: printWarning - real (kind=RKIND), pointer :: config_epft_rhomin_buoycoor, config_epft_rhomax_buoycoor + real (kind=RKIND), pointer :: config_eliassen_palm_flux_tensor_rhomin_buoycoor, config_eliassen_palm_flux_tensor_rhomax_buoycoor - call mpas_pool_get_config(ocnConfigs, 'config_epft_rhomin_buoycoor', config_epft_rhomin_buoycoor) - call mpas_pool_get_config(ocnConfigs, 'config_epft_rhomax_buoycoor', config_epft_rhomax_buoycoor) + call mpas_pool_get_config(ocnConfigs, 'config_eliassen_palm_flux_tensor_rhomin_buoycoor', config_eliassen_palm_flux_tensor_rhomin_buoycoor) + call mpas_pool_get_config(ocnConfigs, 'config_eliassen_palm_flux_tensor_rhomax_buoycoor', config_eliassen_palm_flux_tensor_rhomax_buoycoor) printWarning = .false. iCellMinBound = -1 iCellMaxBound = -1 do iCell = 1, nCells - if (potentialDensity(1,iCell) < config_epft_rhomin_buoycoor) then + if (potentialDensity(1,iCell) < config_eliassen_palm_flux_tensor_rhomin_buoycoor) then printWarning = .true. iCellMinBound = iCell exit end if - if (potentialDensity(maxLevelCell(iCell),iCell) > config_epft_rhomax_buoycoor) then + if (potentialDensity(maxLevelCell(iCell),iCell) > config_eliassen_palm_flux_tensor_rhomax_buoycoor) then printWarning = .true. iCellMaxBound = iCell exit @@ -1589,16 +1666,14 @@ end subroutine linear_interp_1d_field_along_column!}}} ! !----------------------------------------------------------------------- - subroutine computeBuoyancyColumn(nLayers, potentialDensity, buoyancy)!{{{ + subroutine computeBuoyancyColumn(nLayers, rho0, potentialDensity, buoyancy)!{{{ integer, intent(in) :: nLayers + real (kind=RKIND), intent(in) :: rho0 ! config_density0 real (kind=RKIND), dimension(nLayers), intent(in) :: potentialDensity real (kind=RKIND), dimension(nLayers), intent(out) :: buoyancy !local variables integer :: i, k - real (kind=RKIND) :: rho0 - - rho0 = config_density0 buoyancy = 0.0 @@ -1621,16 +1696,15 @@ end subroutine computeBuoyancyColumn!}}} ! !----------------------------------------------------------------------- - subroutine computeBuoyancyColumnP1(nLayers, potentialDensity, buoyancy)!{{{ + subroutine computeBuoyancyColumnP1(nLayers, rho0, rhoMax, potentialDensity, buoyancy)!{{{ integer, intent(in) :: nLayers + real (kind=RKIND), intent(in) :: rho0 ! config_density0 + real (kind=RKIND), intent(in) :: rhoMax ! config_eliassen_palm_flux_tensor_rhomax_buoycoor real (kind=RKIND), dimension(nLayers-1), intent(in) :: potentialDensity real (kind=RKIND), dimension(nLayers), intent(out) :: buoyancy !local variables integer :: i, k - real (kind=RKIND) :: rho0 - - rho0 = config_density0 buoyancy = 0.0 @@ -1638,7 +1712,7 @@ subroutine computeBuoyancyColumnP1(nLayers, potentialDensity, buoyancy)!{{{ buoyancy(k) = -gravity * (potentialDensity(k)-rho0) / rho0 enddo - buoyancy(nLayers) = -gravity * (config_rhomax_buoycoor-rho0) / rho0 + buoyancy(nLayers) = -gravity * (rhoMax-rho0) / rho0 end subroutine computeBuoyancyColumnP1!}}} @@ -2028,14 +2102,16 @@ end subroutine calculateEPFTfromTWA!}}} ! !----------------------------------------------------------------------- - subroutine calculateDivEPFT(onASphere, nLayers, nCells, nEdges, & + subroutine calculateDivEPFT(debugFlag, onASphere, rho0, nLayers, nCells, nEdges, & meshPool, buoyancyMidRef, sigmaEA, buoyancyMaskEA, tensorCellIn, vectorCellOut)!{{{ use mpas_vector_operations + logical, intent(in) :: debugFlag logical, intent(in) :: onASphere integer, intent(in) :: nLayers, nCells, nEdges type (mpas_pool_type), intent(in) :: meshPool + real (kind=RKIND), intent(in) :: rho0 ! config_density0 real (kind=RKIND), dimension(:), intent(in) :: buoyancyMidRef real (kind=RKIND), dimension(:,:), intent(in) :: sigmaEA real (kind=RKIND), dimension(:,:), intent(in) :: buoyancyMaskEA @@ -2054,31 +2130,29 @@ subroutine calculateDivEPFT(onASphere, nLayers, nCells, nEdges, & real (kind=RKIND), dimension(:,:,:), allocatable :: vectorCellWrk2 real (kind=RKIND), dimension(:,:,:), allocatable :: vectorEdgeWrk1 real (kind=RKIND), dimension(:), allocatable :: vertVector - real (kind=RKIND) :: rho0 ! variables used for testing and debugging real (kind=RKIND), dimension(:), allocatable :: divExact real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell - xCell => mesh % xCell % array - yCell => mesh % yCell % array - zCell => mesh % zCell % array + real (kind=RKIND), dimension(:,:), pointer :: boundaryCell - if (config_oac_epft_debug) then + if (debugFlag) then allocate(divExact(nCells+1)) end if - - rho0 = config_density0 - allocate(scalarWrk1(nLayers,nCells+1)) allocate(vectorCellWrk1(3,nLayers,nCells+1)) allocate(vectorCellWrk2(3,nLayers,nCells+1)) allocate(vectorEdgeWrk1(3,nLayers,nEdges+1)) allocate(vertVector(nLayers)) - call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) call mpas_pool_get_array(meshPool, 'latCell', latCell) call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) + call mpas_pool_get_array(meshPool, 'boundaryCell', boundaryCell) includeHalo = .true. @@ -2100,7 +2174,7 @@ subroutine calculateDivEPFT(onASphere, nLayers, nCells, nEdges, & ! use q=3 as a test vector - if (q.eq.3 .and. config_oac_epft_debug) then + if (q.eq.3 .and. debugFlag) then do iCell = 1,nCells vectorCellWrk1(1,:,iCell) = xCell(iCell) vectorCellWrk1(2,:,iCell) = yCell(iCell) @@ -2139,7 +2213,7 @@ subroutine calculateDivEPFT(onASphere, nLayers, nCells, nEdges, & edgeSignOnCell, includeHalo, scalarWrk1) ! use q=3 as a test vector - if (q.eq.3 .and. config_oac_epft_debug) then + if (q.eq.3 .and. debugFlag) then print *, ' ' do kLayer = 1,nLayers wrk = sqrt( & @@ -2147,14 +2221,14 @@ subroutine calculateDivEPFT(onASphere, nLayers, nCells, nEdges, & ( & (divExact(:)-scalarWrk1(kLayer,:))/ max(abs(divExact(:)),1.0e-15) & )**2 * & - (1.0 - mesh % boundaryCell % array(1,:)) & + (1.0 - boundaryCell(1,:)) & ) / nCells ) print *, 'div RMS relative error on layer:', wrk enddo endif - if (q < 3 .or. .not. config_oac_epft_debug) then + if (q < 3 .or. .not. debugFlag) then do iCell = 1,nCells do kLayer = 1,nLayers sigma = max(sigmaEA(kLayer,iCell), epsilonEPFT) @@ -2171,7 +2245,7 @@ subroutine calculateDivEPFT(onASphere, nLayers, nCells, nEdges, & vertVector(:) = tensorCellIn(3,q,:,iCell) ! use q=3 as a test vector - if (q.eq.3 .and. config_oac_epft_debug) then + if (q.eq.3 .and. debugFlag) then vertVector(:) = 0.0 endif @@ -2268,69 +2342,70 @@ end subroutine calculateErtelPVFlux ! !----------------------------------------------------------------------- - subroutine mpas_tensor_cell_to_edge_BuoyCoor(matrixCell, grid, & - includeHalo, matrixEdge)!{{{ - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - - real (kind=RKIND), dimension(:,:,:,:), intent(in) :: & - matrixCell !< Input: matrix located at Cell - - type (mesh_type), intent(in) :: & - grid !< Input: grid information - - logical, intent(in) :: & - includeHalo !< Input: If true, halo cells and edges are included in computation - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - real (kind=RKIND), dimension(:,:,:,:), intent(out) :: & - matrixEdge !< Output: matrix located at Edge - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - - integer :: iEdge, cell1, cell2, p, q, k - integer :: nEdgesCompute, nBuoyancyLayers, nCells - integer, dimension(:,:), pointer :: cellsOnEdge - - if (includeHalo) then - nEdgesCompute = grid % nEdges - else - nEdgesCompute = grid % nEdgesSolve - endif - nBuoyancyLayers = grid % nBuoyancyLayers - nCells = grid % nCells - - cellsOnEdge => grid % cellsOnEdge % array - - ! error check that index 1 of matrixEdge and matrixCell are same length? - - do iEdge=1,nEdgesCompute - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - do k=1,nBuoyancyLayers - do q = 1, 3 - do p = 1, 3 - matrixEdge(p,q,k,iEdge) = & - 0.5*(matrixCell(p,q,k,cell1) + matrixCell(p,q,k,cell2)) - end do - end do - enddo - enddo - - end subroutine mpas_tensor_cell_to_edge_BuoyCoor!}}} +! subroutine mpas_tensor_cell_to_edge_BuoyCoor(matrixCell, grid, & +! includeHalo, matrixEdge)!{{{ +! +! !----------------------------------------------------------------- +! ! +! ! input variables +! ! +! !----------------------------------------------------------------- +! +! real (kind=RKIND), dimension(:,:,:,:), intent(in) :: & +! matrixCell !< Input: matrix located at Cell +! +! type (mpas_pool_type), intent(in) :: meshPool +! type (mesh_type), intent(in) :: & +! grid !< Input: grid information +! +! logical, intent(in) :: & +! includeHalo !< Input: If true, halo cells and edges are included in computation +! +! !----------------------------------------------------------------- +! ! +! ! output variables +! ! +! !----------------------------------------------------------------- +! +! real (kind=RKIND), dimension(:,:,:,:), intent(out) :: & +! matrixEdge !< Output: matrix located at Edge +! +! !----------------------------------------------------------------- +! ! +! ! local variables +! ! +! !----------------------------------------------------------------- +! +! integer :: iEdge, cell1, cell2, p, q, k +! integer :: nEdgesCompute, nBuoyancyLayers, nCells +! integer, dimension(:,:), pointer :: cellsOnEdge +! +! if (includeHalo) then +! nEdgesCompute = grid % nEdges +! else +! nEdgesCompute = grid % nEdgesSolve +! endif +! nBuoyancyLayers = grid % nBuoyancyLayers +! nCells = grid % nCells +! +! cellsOnEdge => grid % cellsOnEdge % array +! +! ! error check that index 1 of matrixEdge and matrixCell are same length? +! +! do iEdge=1,nEdgesCompute +! cell1 = cellsOnEdge(1,iEdge) +! cell2 = cellsOnEdge(2,iEdge) +! do k=1,nBuoyancyLayers +! do q = 1, 3 +! do p = 1, 3 +! matrixEdge(p,q,k,iEdge) = & +! 0.5*(matrixCell(p,q,k,cell1) + matrixCell(p,q,k,cell2)) +! end do +! end do +! enddo +! enddo +! +! end subroutine mpas_tensor_cell_to_edge_BuoyCoor!}}} !*********************************************************************** @@ -2346,11 +2421,12 @@ end subroutine mpas_tensor_cell_to_edge_BuoyCoor!}}} ! !----------------------------------------------------------------------- - subroutine calculateErtelPVTendencyFromPVFlux(onASphere, nLayers, nCells, nEdges, & + subroutine calculateErtelPVTendencyFromPVFlux(debugFlag, onASphere, nLayers, nCells, nEdges, & meshPool, sigma, vectorCell, divVectorCell)!{{{ use mpas_vector_operations + logical, intent(in) :: debugFlag logical, intent(in) :: onASphere integer, intent(in) :: nLayers, nCells, nEdges type (mpas_pool_type), intent(in) :: meshPool @@ -2372,11 +2448,8 @@ subroutine calculateErtelPVTendencyFromPVFlux(onASphere, nLayers, nCells, nEdges real (kind=RKIND) :: wrk real (kind=RKIND), dimension(:), allocatable :: divExact real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell - xCell => mesh % xCell % array - yCell => mesh % yCell % array - zCell => mesh % zCell % array - if (config_oac_epft_debug) then + if (debugFlag) then allocate(divExact(nCells+1)) end if @@ -2389,6 +2462,9 @@ subroutine calculateErtelPVTendencyFromPVFlux(onASphere, nLayers, nCells, nEdges call mpas_pool_get_array(meshPool, 'boundaryCell', boundaryCell) call mpas_pool_get_array(meshPool, 'latCell', latCell) call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) includeHalo = .true. @@ -2401,7 +2477,7 @@ subroutine calculateErtelPVTendencyFromPVFlux(onASphere, nLayers, nCells, nEdges enddo - if (config_oac_epft_debug) then + if (debugFlag) then do i= 1,nCells vectorCellWrk1(1,:,i) = xCell(i) vectorCellWrk1(2,:,i) = yCell(i) @@ -2435,7 +2511,7 @@ subroutine calculateErtelPVTendencyFromPVFlux(onASphere, nLayers, nCells, nEdges includeHalo, divVectorCell) - if (config_oac_epft_debug) then + if (debugFlag) then print *, ' ' do k= 1,nLayers wrk = sqrt( & @@ -2443,14 +2519,14 @@ subroutine calculateErtelPVTendencyFromPVFlux(onASphere, nLayers, nCells, nEdges ( & (divExact(:)-divVectorCell(k,:))/ max(abs(divExact(:)),1.0e-15) & )**2 * & - (1.0 - mesh % boundaryCell % array(1,:)) & + (1.0 - boundaryCell(1,:)) & ) / nCells ) print *, 'div RMS relative error on layer:', wrk enddo endif - if (.not. config_oac_epft_debug) then + if (.not. debugFlag) then do i = 1,nCells do k = 1,nLayers divVectorCell(k,i) = divVectorCell(k,i) / max(sigma(k,i), epsilonEPFT) From 6b7cd3740664a8d8579afc1a75a1235cf088868f Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Tue, 9 Jun 2015 16:13:37 -0600 Subject: [PATCH 0076/1724] finished adding epft AM to AM driver --- .../mpas_ocn_analysis_driver.F | 66 +++++++++++++++++++ 1 file changed, 66 insertions(+) diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F index 9ba89c772c..47795f1fdd 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -31,6 +31,7 @@ module ocn_analysis_driver use ocn_zonal_mean use ocn_okubo_weiss use ocn_water_mass_census + use ocn_eliassen_palm_flux_tensor ! use ocn_TEMPLATE implicit none @@ -160,6 +161,12 @@ subroutine ocn_analysis_setup_packages(configPool, packagePool, err)!{{{ err = ior(err, err_tmp) endif + call mpas_pool_get_config(configPool, 'config_use_AM_eliassen_palm_flux_tensor', config_use_AM_eliassen_palm_flux_tensor) + if (config_use_AM_eliassen_palm_flux_tensor) then + call ocn_setup_packages_eliassen_palm_flux_tensor(configPool, packagePool, err_tmp) + err = ior(err, err_tmp) + endif + ! call mpas_pool_get_config(configPool, 'config_use_TEMPLATE', config_use_TEMPLATE) ! if (config_use_TEMPLATE) then ! call ocn_setup_packages_TEMPLATE(configPool, packagePool, err_tmp) @@ -218,6 +225,7 @@ subroutine ocn_analysis_init(domain, err)!{{{ logical, pointer :: config_use_zonal_mean logical, pointer :: config_use_okubo_weiss logical, pointer :: config_use_AM_water_mass_census + logical, pointer :: config_use_AM_eliassen_palm_flux_tensor ! logical, pointer :: config_use_TEMPLATE err = 0 @@ -258,6 +266,13 @@ subroutine ocn_analysis_init(domain, err)!{{{ err = ior(err, err_tmp) endif + call mpas_pool_get_config(domain % configs, 'config_use_AM_eliassen_palm_flux_tensor', & + config_use_AM_eliassen_palm_flux_tensor) + if (config_use_AM_eliassen_palm_flux_tensor) then + call ocn_init_eliassen_palm_flux_tensor(domain, err_tmp) + err = ior(err, err_tmp) + endif + ! call mpas_pool_get_config(domain % configs, 'config_use_TEMPLATE', config_use_TEMPLATE) ! if (config_use_TEMPLATE) then ! call ocn_init_TEMPLATE(domain, err_tmp) @@ -318,6 +333,7 @@ subroutine ocn_analysis_compute_startup(domain, stream_manager, err)!{{{ logical, pointer :: config_use_zonal_mean, config_zonal_mean_compute_startup logical, pointer :: config_use_okubo_weiss, config_okubo_weiss_compute_startup logical, pointer :: config_use_AM_water_mass_census, config_AM_water_mass_census_compute_startup + logical, pointer :: config_use_AM_eliassen_palm_flux_tensor, config_eliassen_palm_flux_tensor_compute_startup ! logical, pointer :: config_use_TEMPLATE, config_TEMPLATE_compute_startup err = 0 @@ -381,6 +397,16 @@ subroutine ocn_analysis_compute_startup(domain, stream_manager, err)!{{{ err = ior(err, err_tmp) endif + call mpas_pool_get_config(domain % configs, 'config_use_AM_eliassen_palm_flux_tensor', config_use_AM_eliassen_palm_flux_tensor) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_compute_startup', config_eliassen_palm_flux_tensor_compute_startup) + if (config_use_AM_eliassen_palm_flux_tensor.and.config_eliassen_palm_flux_tensor_compute_startup) then + call ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err_tmp) + call mpas_timer_start('io_write', .false.) + call mpas_stream_mgr_write(stream_manager, streamID='eliassenPalmFluxTensorOutput', forceWriteNow=.true., ierr=err_tmp) + call mpas_timer_stop('io_write') + err = ior(err, err_tmp) + endif + ! call mpas_pool_get_config(domain % configs, 'config_use_TEMPLATE', config_use_TEMPLATE) ! call mpas_pool_get_config(domain % configs, 'config_TEMPLATE_compute_startup', config_TEMPLATE_compute_startup) ! if (config_use_TEMPLATE.and.config_TEMPLATE_compute_startup) then @@ -443,6 +469,7 @@ subroutine ocn_analysis_compute(domain, err)!{{{ logical, pointer :: config_use_zonal_mean logical, pointer :: config_use_okubo_weiss logical, pointer :: config_use_AM_water_mass_census + logical, pointer :: config_use_AM_eliassen_palm_flux_tensor ! logical, pointer :: config_use_TEMPLATE err = 0 @@ -478,6 +505,11 @@ subroutine ocn_analysis_compute(domain, err)!{{{ call ocn_compute_water_mass_census(domain, timeLevel, err_tmp) endif + call mpas_pool_get_config(domain % configs, 'config_use_AM_eliassen_palm_flux_tensor', config_use_AM_eliassen_palm_flux_tensor) + if (config_use_AM_eliassen_palm_flux_tensor) then + call ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err_tmp) + endif + ! call mpas_pool_get_config(domain % configs, 'config_use_TEMPLATE', config_use_TEMPLATE) ! if (config_use_TEMPLATE) then ! call ocn_compute_TEMPLATE(domain, timeLevel, err_tmp) @@ -536,6 +568,7 @@ subroutine ocn_analysis_compute_w_alarms(stream_manager, domain, err)!{{{ logical, pointer :: config_use_zonal_mean logical, pointer :: config_use_okubo_weiss logical, pointer :: config_use_AM_water_mass_census + logical, pointer :: config_use_AM_eliassen_palm_flux_tensor ! logical, pointer :: config_use_TEMPLATE err = 0 @@ -583,6 +616,13 @@ subroutine ocn_analysis_compute_w_alarms(stream_manager, domain, err)!{{{ endif endif + call mpas_pool_get_config(domain % configs, 'config_use_AM_eliassen_palm_flux_tensor', config_use_AM_eliassen_palm_flux_tensor) + if (config_use_AM_eliassen_palm_flux_tensor) then + if (mpas_stream_mgr_ringing_alarms(stream_manager, streamID='eliassenPalmFluxTensorOutput', direction=MPAS_STREAM_OUTPUT, ierr=err_tmp)) then + call ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err_tmp) + endif + endif + ! call mpas_pool_get_config(domain % configs, 'config_use_TEMPLATE', config_use_TEMPLATE) ! if (config_use_TEMPLATE) then ! if (mpas_stream_mgr_ringing_alarms(stream_manager, streamID='TEMPLATEOutput', direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) then @@ -642,6 +682,7 @@ subroutine ocn_analysis_restart(domain, err)!{{{ logical, pointer :: config_use_zonal_mean logical, pointer :: config_use_okubo_weiss logical, pointer :: config_use_AM_water_mass_census + logical, pointer :: config_use_AM_eliassen_palm_flux_tensor ! logical, pointer :: config_use_TEMPLATE err = 0 @@ -682,6 +723,12 @@ subroutine ocn_analysis_restart(domain, err)!{{{ err = ior(err, err_tmp) endif + call mpas_pool_get_config(domain % configs, 'config_use_AM_eliassen_palm_flux_tensor', config_use_AM_eliassen_palm_flux_tensor) + if (config_use_AM_eliassen_palm_flux_tensor) then + call ocn_restart_eliassen_palm_flux_tensor(domain, err_tmp) + err = ior(err, err_tmp) + endif + ! call mpas_pool_get_config(domain % configs, 'config_use_TEMPLATE', config_use_TEMPLATE) ! if (config_use_TEMPLATE) then ! call ocn_restart_TEMPLATE(domain, err_tmp) @@ -743,6 +790,7 @@ subroutine ocn_analysis_write(stream_manager, err)!{{{ logical, pointer :: config_use_zonal_mean logical, pointer :: config_use_okubo_weiss logical, pointer :: config_use_AM_water_mass_census + logical, pointer :: config_use_AM_eliassen_palm_flux_tensor ! logical, pointer :: config_use_TEMPLATE err = 0 @@ -813,6 +861,17 @@ subroutine ocn_analysis_write(stream_manager, err)!{{{ err = ior(err, err_tmp) endif + call mpas_pool_get_config(ocnConfigs, 'config_use_AM_eliassen_palm_flux_tensor', config_use_AM_eliassen_palm_flux_tensor) + if (config_use_AM_eliassen_palm_flux_tensor) then + call mpas_timer_start('io_write', .false.) + call mpas_stream_mgr_write(stream_manager, streamID='eliassenPalmFluxTensorOutput', ierr=err_tmp) + call mpas_timer_stop('io_write') + call mpas_timer_start('io_reset_alarms', .false.) + call mpas_stream_mgr_reset_alarms(stream_manager, streamID='eliassenPalmFluxTensorOutput', ierr=err_tmp) + call mpas_timer_stop('io_reset_alarms') + err = ior(err, err_tmp) + endif + ! call mpas_pool_get_config(ocnConfigs, 'config_use_TEMPLATE', config_use_TEMPLATE) ! if (config_use_TEMPLATE) then ! call mpas_timer_start('io_write', .false.) @@ -876,6 +935,7 @@ subroutine ocn_analysis_finalize(domain, err)!{{{ logical, pointer :: config_use_zonal_mean logical, pointer :: config_use_okubo_weiss logical, pointer :: config_use_AM_water_mass_census + logical, pointer :: config_use_AM_eliassen_palm_flux_tensor ! logical, pointer :: config_use_TEMPLATE err = 0 @@ -916,6 +976,12 @@ subroutine ocn_analysis_finalize(domain, err)!{{{ err = ior(err, err_tmp) endif + call mpas_pool_get_config(domain % configs, 'config_use_AM_eliassen_palm_flux_tensor', config_use_AM_eliassen_palm_flux_tensor) + if (config_use_AM_eliassen_palm_flux_tensor) then + call ocn_finalize_eliassen_palm_flux_tensor(domain, err_tmp) + err = ior(err, err_tmp) + endif + ! call mpas_pool_get_config(domain % configs, 'config_use_TEMPLATE', config_use_TEMPLATE) ! if (config_use_TEMPLATE) then ! call ocn_finalize_TEMPLATE(domain, err_tmp) From 60b50f354a8041a6a3e8b447eb01346f98ab2d83 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 11 Jun 2015 09:39:25 -0600 Subject: [PATCH 0077/1724] Fix FO floating ice mask in cpp interface The floating edges were not being cleared before each solve, so on subsequent time steps the list of floating edges was being appended to the current list, causing an error. This fixes that, as well as the same issue for dirichlet nodes. --- src/core_landice/Interface_velocity_solver.cpp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/core_landice/Interface_velocity_solver.cpp b/src/core_landice/Interface_velocity_solver.cpp index c51d73704d..f4bcb4dfe3 100644 --- a/src/core_landice/Interface_velocity_solver.cpp +++ b/src/core_landice/Interface_velocity_solver.cpp @@ -630,6 +630,7 @@ void velocity_solver_compute_2d_grid(int const* verticesMask_F, int const* _diri nEdges = edgeToFEdge.size(); indexToEdgeID.resize(nEdges); + floatingEdgesIds.clear(); floatingEdgesIds.reserve(nEdges); for (int index = 0; index < nEdges; index++) { int fEdge = edgeToFEdge[index]; @@ -697,6 +698,7 @@ void velocity_solver_compute_2d_grid(int const* verticesMask_F, int const* _diri << std::endl; indexToVertexID.resize(nVertices); + dirichletNodesIDs.clear(); dirichletNodesIDs.reserve(nVertices); //need to improve storage efficiency for (int index = 0; index < nVertices; index++) { int fCell = vertexToFCell[index]; From 547b2b89f939354ed40824ea383978bee88aa78b Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Fri, 12 Jun 2015 14:30:16 -0600 Subject: [PATCH 0078/1724] cleaning up Eliassen-Palm Flux Tensor files --- .../Registry_eliassen_palm_flux_tensor.xml | 6 - .../mpas_ocn_eliassen_palm_flux_tensor.F | 367 ++++++------------ 2 files changed, 115 insertions(+), 258 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml index 816b883f93..d985100c1f 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml @@ -421,12 +421,6 @@ units="m" description="z-coordinate of each buoyancy layer, ensemble average" /> - domain % blocklist do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'amEPFT', amEPFTPool) + call mpas_pool_get_subpool(block % structs, 'amEliassenPalmFluxTensor', amEPFTPool) !----------------------------------------------------------------- ! set up pointers @@ -238,7 +236,8 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ ! at present we use layer interfaces that are evenly-spaced in buoyancy space !----------------------------------------------------------------- nBuoyancyLayers = config_eliassen_palm_flux_tensor_nBuoyancyLayers - deltaDensity = (config_eliassen_palm_flux_tensor_rhomax_buoycoor - config_eliassen_palm_flux_tensor_rhomin_buoycoor) / config_eliassen_palm_flux_tensor_nBuoyancyLayers + deltaDensity = (config_eliassen_palm_flux_tensor_rhomax_buoycoor & + - config_eliassen_palm_flux_tensor_rhomin_buoycoor) / config_eliassen_palm_flux_tensor_nBuoyancyLayers deltaBuoyancy = -gravity * deltaDensity / config_density0 !----------------------------------------------------------------- @@ -246,7 +245,9 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ !----------------------------------------------------------------- do k = 1, nBuoyancyLayers potentialDensityTopRef(k) = config_eliassen_palm_flux_tensor_rhomin_buoycoor + deltaDensity * (k-1) - buoyancyInterfaceRef(k) = -gravity * (config_eliassen_palm_flux_tensor_rhomin_buoycoor - config_density0) / config_density0 + deltaBuoyancy * (k-1) + buoyancyInterfaceRef(k) = -gravity & + * (config_eliassen_palm_flux_tensor_rhomin_buoycoor - config_density0) / config_density0 & + + deltaBuoyancy * (k-1) end do k=nBuoyancyLayers buoyancyInterfaceRef(k+1) = buoyancyInterfaceRef(k) + deltaBuoyancy @@ -263,12 +264,12 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ buoyancyMidRef(k) = 0.5*(buoyancyInterfaceRef(k) + buoyancyInterfaceRef(k+1)) !----------------------------------------------------------------- - ! initialize ensemble averages when it is not a restart or when a reset is specified + ! initialize ensemble averages when it is not a restart or when a reset requested !----------------------------------------------------------------- if (.not. config_eliassen_palm_flux_tensor_do_restart .or. config_eliassen_palm_flux_tensor_reset) then + call mpas_pool_get_array(amEPFTPool, 'nSamplesEA', nSamplesEA) call mpas_pool_get_array(amEPFTPool, 'buoyancyMaskEA', buoyancyMaskEA) call mpas_pool_get_array(amEPFTPool, 'sigmaEA', sigmaEA) - call mpas_pool_get_array(amEPFTPool, 'nSamplesEA', nSamplesEA) call mpas_pool_get_array(amEPFTPool, 'heightMidBuoyCoorEA', heightMidBuoyCoorEA) call mpas_pool_get_array(amEPFTPool, 'montgPotBuoyCoorEA', montgPotBuoyCoorEA) call mpas_pool_get_array(amEPFTPool, 'montgPotGradZonalEA', montgPotGradZonalEA) @@ -284,14 +285,14 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ call mpas_pool_get_array(amEPFTPool, 'uwsigmaEA', uwsigmaEA) call mpas_pool_get_array(amEPFTPool, 'vwsigmaEA', vwsigmaEA) + nSamplesEA = 0.0 buoyancyMaskEA = 0.0 sigmaEA = 0.0 - nSamplesEA = 0.0 heightMidBuoyCoorEA = 0.0 - montgPotBuoyCoorEA = 0.0 montgPotGradZonalEA = 0.0 montgPotGradMeridEA = 0.0 heightMidBuoyCoorSqEA = 0.0 + montgPotBuoyCoorEA = 0.0 heightMGradZonalEA = 0.0 heightMGradMeridEA = 0.0 usigmaEA = 0.0 @@ -318,12 +319,12 @@ end subroutine ocn_init_eliassen_palm_flux_tensor!}}} !> \author Juan A. Saenz, Todd Ringler !> \date May 2015 !> \details -!> This routine conducts all computation required for the EPFT analysis member. +!> This routine conducts all computations required for the EPFT analysis member. !> Each time this AM is called, the instananeous ocean state is interpolated -!> onto the target buoyancy values. The state is then accumulated in the -!> accumulated into the ensemble average (*EA) arrays. Based on the current -!> estimate of the ensemble average, thickness-weight velocities are estimates -!> along with the computation of the Eliassen-Palm flux tensor +!> onto the target buoyancy values. The state is then accumulated into the +!> ensemble average variable arrays (varEA). Based on the current +!> estimate of the ensemble average, thickness-weight velocities are estimated +!> along with the computation of the Eliassen-Palm flux tensor. ! !----------------------------------------------------------------------- @@ -375,9 +376,8 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ real (kind=RKIND), pointer :: config_density0 - !----------------------------------------------------------------- - ! define namelist config variables local to the EPFT module + ! define pointers to namelist config variables local to the EPFT module !----------------------------------------------------------------- logical, pointer :: config_eliassen_palm_flux_tensor_debug real (kind=RKIND), pointer :: config_eliassen_palm_flux_tensor_rhomin_buoycoor @@ -390,7 +390,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ integer, pointer :: nEdges, nCells, nCellsSolve ! nCellsSolve does not include halo !----------------------------------------------------------------- - ! define buoyancy coordinate and field related to the vertical direction + ! define buoyancy coordinates and fields related to the vertical direction !----------------------------------------------------------------- integer, dimension(:), pointer :: maxLevelCell real(KIND=RKIND), dimension(:), pointer :: potentialDensityMidRef @@ -437,18 +437,18 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !----------------------------------------------------------------- ! define Ertel's potential vorticity and related fields !----------------------------------------------------------------- - real(KIND=RKIND), dimension(:,:,:), pointer :: ErtelPVFlux - real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVTendency real(KIND=RKIND), dimension(:,:), pointer :: ErtelPV + real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVTendency + real(KIND=RKIND), dimension(:,:,:), pointer :: ErtelPVFlux !----------------------------------------------------------------- - ! define the reason for doing all of this, i.e. Eliassen-Palm flux tensor + ! define the Eliassen-Palm flux tensor and related fields !----------------------------------------------------------------- real(KIND=RKIND), dimension(:,:,:,:), pointer :: EPFT - real(KIND=RKIND), dimension(:,:,:), pointer :: divEPFT + real(KIND=RKIND), dimension(:,:,:), pointer :: divEPFT !----------------------------------------------------------------- - ! define scratch fields + ! define scratch fields used as work variables and for testing !----------------------------------------------------------------- type(field1DInteger), pointer :: firstLayerBuoyCoorField type(field1DInteger), pointer :: lastLayerBuoyCoorField @@ -524,7 +524,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:,:), pointer :: PVFluxTest !----------------------------------------------------------------- - ! define arrays holding instantaneous state in z-coordinates + ! define some arrays in z-coordinates, obtained from diagnostics and forcing !----------------------------------------------------------------- real(KIND=RKIND), dimension(:), pointer :: seaSurfacePressure real(KIND=RKIND), dimension(:,:), pointer :: zMid @@ -534,13 +534,13 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: pressure real(KIND=RKIND), dimension(:,:), pointer :: normalVelocityZonal real(KIND=RKIND), dimension(:,:), pointer :: normalVelocityMeridional - !real(KIND=RKIND), dimension(:,:), pointer :: wCellCenter real(KIND=RKIND), dimension(:,:), pointer :: relativeVorticityCell ! jas used for testing + !real(KIND=RKIND), dimension(:,:), pointer :: wCellCenter !----------------------------------------------------------------- ! define local test variables !----------------------------------------------------------------- - ! jas to do : move these to Registry + ! jas to do : move these to scratch in Registry_epft integer :: nCellsCum real(KIND=RKIND) :: RMSlocal1, RMSglobal1 real(KIND=RKIND) :: RMSlocal2, RMSglobal2 @@ -553,10 +553,9 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ integer :: nCellsGlobal, k, i real(KIND=RKIND) :: rho0 + err = 0 - dminfo = domain % dminfo - RMSlocal1 = 0.0 RMSlocal2 = 0.0 RMSglobal1 = 0.0 @@ -565,10 +564,17 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ RMSPVFlux2local = 0.0 RMSPVFlux1global = 0.0 RMSPVFlux2global = 0.0 - + + dminfo = domain % dminfo + + call mpas_timer_start("compute_eliassen_palm_flux_tensor", .false., & am_eliassen_palm_flux_tensorTimer) + + !-------------------------------------------------- + ! get config variables + !-------------------------------------------------- call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_debug', & config_eliassen_palm_flux_tensor_debug) call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_rhomin_buoycoor', & @@ -579,11 +585,12 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_pool_get_config(domain % configs, 'config_density0', config_density0) rho0 = config_density0 + block => domain % blocklist do while (associated(block)) !-------------------------------------------------- - ! assign pointers for each block + ! assign pointers for each pool !-------------------------------------------------- call mpas_pool_get_subpool(block % structs, 'amEliassenPalmFluxTensor', am_epftPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) @@ -596,8 +603,6 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! assign pointers for mesh-related variables !-------------------------------------------------- call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(block % dimensions, 'nBuoyancyLayers', nBuoyancyLayers) - call mpas_pool_get_dimension(block % dimensions, 'nBuoyancyLayersP1', nBuoyancyLayersP1) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) @@ -721,6 +726,11 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ vPVMidBuoyCoorEA => vPVMidBuoyCoorEAField % array PVFluxTest => PVFluxTestField % array + !-------------------------------------------------- + ! assign pointers used from forcing pool + !-------------------------------------------------- + call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) + !-------------------------------------------------- ! get diagnostic variables !-------------------------------------------------- @@ -733,15 +743,17 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_pool_get_array(diagnosticsPool, 'normalVelocityMeridional', normalVelocityMeridional) !-------------------------------------------------- - ! define the vertical coordinate system in density/buoyancy space + ! variables that define the vertical coordinate system in density/buoyancy space !-------------------------------------------------- + call mpas_pool_get_dimension(block % dimensions, 'nBuoyancyLayers', nBuoyancyLayers) + call mpas_pool_get_dimension(block % dimensions, 'nBuoyancyLayersP1', nBuoyancyLayersP1) call mpas_pool_get_array(am_epftPool, 'potentialDensityMidRef', potentialDensityMidRef) call mpas_pool_get_array(am_epftPool, 'potentialDensityTopRef', potentialDensityTopRef) call mpas_pool_get_array(am_epftPool, 'buoyancyMidRef', buoyancyMidRef) call mpas_pool_get_array(am_epftPool, 'buoyancyInterfaceRef', buoyancyInterfaceRef) !-------------------------------------------------- - ! assign pointers for EA / TWA state + ! assign pointers for ensemble average (EA) and thickness-weighted averaged state !-------------------------------------------------- call mpas_pool_get_array(am_epftPool, 'nSamplesEA', nSamplesEA) call mpas_pool_get_array(am_epftPool, 'buoyancyMaskEA', buoyancyMaskEA) @@ -764,25 +776,22 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ call mpas_pool_get_array(am_epftPool, 'uTWA', uTWA) call mpas_pool_get_array(am_epftPool, 'vTWA', vTWA) call mpas_pool_get_array(am_epftPool, 'wTWA', wTWA) + + !-------------------------------------------------- + ! Eliassen-Palm Flux Tensor and related products + !-------------------------------------------------- call mpas_pool_get_array(am_epftPool, 'EPFT', EPFT) call mpas_pool_get_array(am_epftPool, 'divEPFT', divEPFT) call mpas_pool_get_array(am_epftPool, 'ErtelPVFlux', ErtelPVFlux) call mpas_pool_get_array(am_epftPool, 'ErtelPVTendency', ErtelPVTendency) call mpas_pool_get_array(am_epftPool, 'ErtelPV', ErtelPV) - + !-------------------------------------------------- - ! assign pointers used from forcing pool + ! Get variables associated to diabatic processes !-------------------------------------------------- - call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) - - - - - ! jas issue diabatic terms - !diabaticHeating(nVertLevels,nCells)! "vertical velocity" in buoyancy space - !wCellCenter = 0.0 - !jas issue diabatic terms + ! diabaticHeating(nVertLevels,nCells)! "vertical velocity" in buoyancy space + !wCellCenter = 0.0 ! Get diabaticTimeTendency of a buoyancy surface, omega with funny hat, if any. !call any existing MPAS-O subroutines for this @@ -795,11 +804,15 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! compute firstLayerBuoyCoor and lastLayerBuoyCoor ! firstLayerBuoyCoor == top buoyancy coordinate to exist in each column ! lastLayerBuoyCoor == bottom buoyancy coordinate to exist in each column + ! buoyancyMask == 1.0 between layers firstLayerBuoyCoor and lastLayerBuoyCoor !------------------------------------------------------------- call get_masks_in_buoyancy_coordinates(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, potentialDensity, potentialDensityMidRef, & firstLayerBuoyCoor, lastLayerBuoyCoor, buoyancyMask) + !------------------------------------------------------------- + ! TEST for general consistency + !------------------------------------------------------------- if(config_eliassen_palm_flux_tensor_debug) then print *, ' ' print *, 'timeLevel:', timeLevel @@ -818,7 +831,6 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ print *, minval(density), maxval(density) endif - !------------------------------------------------------------- ! INTERPOLATION TEST 1 ! stratified, horizontally uniform @@ -831,7 +843,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ end do print *, ' ' print *, 'Testing interpolatoin function' - print *, 'Interpolating from z, rho to z, rho' + print *, 'Interpolating from (z, rho) to (z, rho)' print *, 'call linear_interp_1d_field_along_column(nVertLevels, nCells, & nVertLevels, maxLevelCell, array1_3D, array2_3D, array1_3D(:,1), array3_3D)' @@ -862,7 +874,6 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ end do endif - !------------------------------------------------------------- ! INTERPOLATION TEST 2 ! Define a stratification where potential density varies linearly with depth @@ -875,11 +886,13 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ do k = 1, nVertLevels array1_3D(k,i) = config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02 + & (zMid(k,i)-zMid(1,i)) * & - (config_eliassen_palm_flux_tensor_rhomax_buoycoor*0.98 - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) / & + (config_eliassen_palm_flux_tensor_rhomax_buoycoor*0.98 & + - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) / & (zMid(nVertLevels,i) - zMid(1,i)) array2_3D(k,i) = config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02 + & (zTop(k,i)-zMid(1,i)) * & - (config_eliassen_palm_flux_tensor_rhomax_buoycoor*0.98 - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) / & + (config_eliassen_palm_flux_tensor_rhomax_buoycoor*0.98 & + - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) / & (zMid(nVertLevels,i) - zMid(1,i)) end do end do @@ -891,7 +904,8 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ array2_3Dbuoy(k,i) = zMid(1,i) + & (potentialDensityMidRef(k) - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) * & (zMid(nVertLevels,i) - zMid(1,i)) / & - (config_eliassen_palm_flux_tensor_rhomax_buoycoor*0.98 - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) + (config_eliassen_palm_flux_tensor_rhomax_buoycoor*0.98 & + - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) end do end do do i = 1,nCells @@ -953,7 +967,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ vMidBuoyCoor(k,i) = normalVelocityMeridional(1,i) densityMidBuoyCoor(k,i) = density(1,i) densityTopBuoyCoor(k,i) = density(1,i) - ! TDR: diabatic + ! diabatic !wMidBuoyCoor(k,i) = wCellCenter(1,i) end do do k = lastLayerBuoyCoor(i) + 1, nBuoyancyLayers @@ -963,7 +977,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ vMidBuoyCoor(k,i) = normalVelocityMeridional(maxLevelCell(i),i) densityMidBuoyCoor(k,i) = density(maxLevelCell(i),i) densityTopBuoyCoor(k,i) = density(maxLevelCell(i),i) - ! TDR: diabatic + ! diabatic !wMidBuoyCoor(k,i) = wCellCenter(maxLevelCell(i),i) end do heightInterfaceBuoyCoor(1:nBuoyancyLayers,i) = heightTopBuoyCoor(1:nBuoyancyLayers,i) @@ -985,59 +999,47 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !------------------------------------------------------------- ! compute the normal derivative of Montgomery potential at cell edges !------------------------------------------------------------- - call computeNormalGradientOnEdge(nBuoyancyLayers, nCells, nEdges, & + call computeNormalGradientOnEdge(nBuoyancyLayers, nCells, nEdges, & meshPool, montgPotBuoyCoor, montgPotNormalGradOnEdge) !------------------------------------------------------------- ! reconstruct full gradient vector at cell centers !------------------------------------------------------------- - call mpas_reconstruct(meshPool, montgPotNormalGradOnEdge, & + call mpas_reconstruct(meshPool, montgPotNormalGradOnEdge, & montgPotGradX, montgPotGradY, montgPotGradZ, & montgPotGradZonal, montgPotGradMerid) !------------------------------------------------------------- ! Increment first-order running mean fields !------------------------------------------------------------- - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - buoyancyMask, buoyancyMaskEA) - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - sigma, sigmaEA) - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - heightMidBuoyCoor, heightMidBuoyCoorEA) - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - montgPotBuoyCoor, montgPotBuoyCoorEA) - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - montgPotGradZonal, montgPotGradZonalEA) - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - montgPotGradMerid, montgPotGradMeridEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, buoyancyMask, buoyancyMaskEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, sigma, sigmaEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, heightMidBuoyCoor, heightMidBuoyCoorEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, montgPotBuoyCoor, montgPotBuoyCoorEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, montgPotGradZonal, montgPotGradZonalEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, montgPotGradMerid, montgPotGradMeridEA) !------------------------------------------------------------- ! Increment second-order running mean fields !------------------------------------------------------------- wrk3DBuoyCoor = heightMidBuoyCoor * heightMidBuoyCoor - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - wrk3DBuoyCoor, heightMidBuoyCoorSqEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, heightMidBuoyCoorSqEA) wrk3DBuoyCoor = heightMidBuoyCoor * montgPotGradZonal - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - wrk3DBuoyCoor, heightMGradZonalEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, heightMGradZonalEA) wrk3DBuoyCoor = heightMidBuoyCoor * montgPotGradMerid - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - wrk3DBuoyCoor, heightMGradMeridEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, heightMGradMeridEA) wrk3DBuoyCoor = uMidBuoyCoor * sigma - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - wrk3DBuoyCoor, usigmaEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, usigmaEA) wrk3DBuoyCoor = vMidBuoyCoor * sigma - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - wrk3DBuoyCoor, vsigmaEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, vsigmaEA) ! Diabatic terms !wrk3DBuoyCoor = wMidBuoyCoor * sigma - !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - ! wrk3DBuoyCoor, wsigmaEA) + !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, wsigmaEA) wsigmaEA = 0.0 @@ -1045,27 +1047,22 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! Increment third-order running mean fields !------------------------------------------------------------- wrk3DBuoyCoor = uMidBuoyCoor * uMidBuoyCoor * sigma - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - wrk3DBuoyCoor, uusigmaEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, uusigmaEA) wrk3DBuoyCoor = vMidBuoyCoor * vMidBuoyCoor * sigma - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - wrk3DBuoyCoor, vvsigmaEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, vvsigmaEA) wrk3DBuoyCoor = uMidBuoyCoor * vMidBuoyCoor * sigma - call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - wrk3DBuoyCoor, uvsigmaEA) + call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, uvsigmaEA) ! Diabatic terms !wrk3DBuoyCoor = uMidBuoyCoor * wMidBuoyCoor * sigma - !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - ! wrk3DBuoyCoor, uwsigmaEA) + !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, uwsigmaEA) uwsigmaEA = 0.0 ! Diabatic terms !wrk3DBuoyCoor = vMidBuoyCoor * wMidBuoyCoor* sigma - !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, & - ! wrk3DBuoyCoor, vwsigmaEA) + !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, vwsigmaEA) vwsigmaEA = 0.0 !------------------------------------------------------------- @@ -1077,13 +1074,10 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! based on current estimate of ensemble-average state, ! compute the thickness-weighted average velocity !------------------------------------------------------------- - call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, & - sigmaEA, usigmaEA, uTWA) - call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, & - sigmaEA, vsigmaEA, vTWA) + call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, sigmaEA, usigmaEA, uTWA) + call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, sigmaEA, vsigmaEA, vTWA) ! Diabatic terms - !call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, & - ! sigmaEA, wsigmaEA, wTWA) + !call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, sigmaEA, wsigmaEA, wTWA) wTWA = 0.0 !------------------------------------------------------------- @@ -1116,7 +1110,6 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ domain % on_a_sphere, nBuoyancyLayers, nCells, nEdges, & meshPool, sigmaEA, ErtelPVFlux, ErtelPVTendency) - !------------------------------------------------------------- ! compute Ertel PV based on EA/TWA fields !------------------------------------------------------------- @@ -1133,7 +1126,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !------------------------------------------------------------- - ! Test: + ! TEST: ! calculate potential vorticity fluxes using curl of u !------------------------------------------------------------- if(config_eliassen_palm_flux_tensor_debug) then @@ -1232,8 +1225,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ end do !------------------------------------------------------------- - ! TESTS: - ! mpi gather/scatter calls may be placed here. + ! TESTS: tallying up tests across processors. !------------------------------------------------------------- if(config_eliassen_palm_flux_tensor_debug) then RMSglobal1 = 1.0D36 @@ -1250,7 +1242,6 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ print *, ' ' endif - call mpas_dmpar_sum_real(dminfo, sum(abs(ErtelPVFlux(1,:,:))), RMSglobal1) call mpas_dmpar_max_real(dminfo, maxval(abs(ErtelPVFlux(1,:,:))), RMSglobal2) if (dminfo % my_proc_id == IO_NODE) then @@ -1392,6 +1383,12 @@ subroutine ocn_finalize_eliassen_palm_flux_tensor(domain, err)!{{{ end subroutine ocn_finalize_eliassen_palm_flux_tensor!}}} + +!*********************************************************************** +! Local routines start here +!*********************************************************************** + + !*********************************************************************** ! ! subroutine get_masks_in_buoyancy_coordinates @@ -1507,10 +1504,13 @@ subroutine check_potentialDensityRef_range(nVertLevels, nCells, maxLevelCell, & integer :: k, iCell, iCellMinBound, iCellMaxBound logical :: printWarning - real (kind=RKIND), pointer :: config_eliassen_palm_flux_tensor_rhomin_buoycoor, config_eliassen_palm_flux_tensor_rhomax_buoycoor + real (kind=RKIND), pointer :: config_eliassen_palm_flux_tensor_rhomin_buoycoor, & + config_eliassen_palm_flux_tensor_rhomax_buoycoor - call mpas_pool_get_config(ocnConfigs, 'config_eliassen_palm_flux_tensor_rhomin_buoycoor', config_eliassen_palm_flux_tensor_rhomin_buoycoor) - call mpas_pool_get_config(ocnConfigs, 'config_eliassen_palm_flux_tensor_rhomax_buoycoor', config_eliassen_palm_flux_tensor_rhomax_buoycoor) + call mpas_pool_get_config(ocnConfigs, 'config_eliassen_palm_flux_tensor_rhomin_buoycoor', & + config_eliassen_palm_flux_tensor_rhomin_buoycoor) + call mpas_pool_get_config(ocnConfigs, 'config_eliassen_palm_flux_tensor_rhomax_buoycoor', & + config_eliassen_palm_flux_tensor_rhomax_buoycoor) printWarning = .false. iCellMinBound = -1 @@ -1532,7 +1532,7 @@ subroutine check_potentialDensityRef_range(nVertLevels, nCells, maxLevelCell, & if (printWarning) then write(stderrUnit,*) write(stderrUnit,*) 'Warning: in EPFT package, subroutine check_potentialDensityRef_range' - write(stderrUnit,*) 'One or more columns in the ocean doman have densities that are not' + write(stderrUnit,*) 'One or more columns in the ocean domain have densities that are not' write(stderrUnit,*) 'contained in the defined buoyancy space of the EPFT module' if (iCellMinBound.gt.0) write(stderrUnit,*) 'fluid is lighter than min buoyancy at cell: ',iCellMinBound if (iCellMaxBound.gt.0) write(stderrUnit,*) 'fluid is lighter than max buoyancy at cell: ',iCellMaxBound @@ -1654,71 +1654,6 @@ subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLay end subroutine linear_interp_1d_field_along_column!}}} -!*********************************************************************** -! -! subroutine computeBuoyancyColumn -! -!> \brief Compute buoyancy -!> \author Juan A. Saenz -!> \date 17 December 2013 -!> \details -!> This subroutine computes buoyancy -! -!----------------------------------------------------------------------- - - subroutine computeBuoyancyColumn(nLayers, rho0, potentialDensity, buoyancy)!{{{ - integer, intent(in) :: nLayers - real (kind=RKIND), intent(in) :: rho0 ! config_density0 - real (kind=RKIND), dimension(nLayers), intent(in) :: potentialDensity - real (kind=RKIND), dimension(nLayers), intent(out) :: buoyancy - - !local variables - integer :: i, k - - buoyancy = 0.0 - - do k = 1, nLayers - buoyancy(k) = -gravity * (potentialDensity(k)-rho0) / rho0 - enddo - - end subroutine computeBuoyancyColumn!}}} - - -!*********************************************************************** -! -! subroutine computeBuoyancyColumnP1 -! -!> \brief Compute buoyancy -!> \author Juan A. Saenz -!> \date Jan 2014 -!> \details -!> This subroutine computes buoyancy -! -!----------------------------------------------------------------------- - - subroutine computeBuoyancyColumnP1(nLayers, rho0, rhoMax, potentialDensity, buoyancy)!{{{ - integer, intent(in) :: nLayers - real (kind=RKIND), intent(in) :: rho0 ! config_density0 - real (kind=RKIND), intent(in) :: rhoMax ! config_eliassen_palm_flux_tensor_rhomax_buoycoor - real (kind=RKIND), dimension(nLayers-1), intent(in) :: potentialDensity - real (kind=RKIND), dimension(nLayers), intent(out) :: buoyancy - - !local variables - integer :: i, k - - buoyancy = 0.0 - - do k = 1, nLayers-1 - buoyancy(k) = -gravity * (potentialDensity(k)-rho0) / rho0 - enddo - - buoyancy(nLayers) = -gravity * (rhoMax-rho0) / rho0 - - - end subroutine computeBuoyancyColumnP1!}}} - - - !*********************************************************************** ! ! subroutine computeSigma @@ -2098,7 +2033,10 @@ end subroutine calculateEPFTfromTWA!}}} !> \author Juan A. Saenz, Todd Ringler !> \date May 2015 !> \details -!> This subroutine calculates the divergence of the Eliassen-Palm flux tensor +!> This subroutine calculates the divergence of the Eliassen-Palm flux tensor. +!> This is done by calculating the divergence of the column vectors in the tensor. +!> The divergence of a vector v in buoyancy coordinates is given by (Young 2012): +!> div of v = sigma^-1 (sigma * v_i)_xi ! !----------------------------------------------------------------------- @@ -2228,6 +2166,7 @@ subroutine calculateDivEPFT(debugFlag, onASphere, rho0, nLayers, nCells, nEdges, endif + ! Normalize by sigma, after having taken the derivative of sigma * v_i if (q < 3 .or. .not. debugFlag) then do iCell = 1,nCells do kLayer = 1,nLayers @@ -2328,86 +2267,6 @@ subroutine calculateErtelPVFlux(nCells, nBuoyancyLayers, & end subroutine calculateErtelPVFlux - -!*********************************************************************** -! -! routine mpas_tensor_cell_to_edge_BuoyCoor -! -!> \brief Interpolate a matrix from cell to edge -!> \author Mark Petersen, Juan A. Saenz -!> \date Jan 2014 -!> \details -!> This routine interpolates a matrix from cell to edge locations, -!> looping through nBuoyancyLayers. -! -!----------------------------------------------------------------------- - -! subroutine mpas_tensor_cell_to_edge_BuoyCoor(matrixCell, grid, & -! includeHalo, matrixEdge)!{{{ -! -! !----------------------------------------------------------------- -! ! -! ! input variables -! ! -! !----------------------------------------------------------------- -! -! real (kind=RKIND), dimension(:,:,:,:), intent(in) :: & -! matrixCell !< Input: matrix located at Cell -! -! type (mpas_pool_type), intent(in) :: meshPool -! type (mesh_type), intent(in) :: & -! grid !< Input: grid information -! -! logical, intent(in) :: & -! includeHalo !< Input: If true, halo cells and edges are included in computation -! -! !----------------------------------------------------------------- -! ! -! ! output variables -! ! -! !----------------------------------------------------------------- -! -! real (kind=RKIND), dimension(:,:,:,:), intent(out) :: & -! matrixEdge !< Output: matrix located at Edge -! -! !----------------------------------------------------------------- -! ! -! ! local variables -! ! -! !----------------------------------------------------------------- -! -! integer :: iEdge, cell1, cell2, p, q, k -! integer :: nEdgesCompute, nBuoyancyLayers, nCells -! integer, dimension(:,:), pointer :: cellsOnEdge -! -! if (includeHalo) then -! nEdgesCompute = grid % nEdges -! else -! nEdgesCompute = grid % nEdgesSolve -! endif -! nBuoyancyLayers = grid % nBuoyancyLayers -! nCells = grid % nCells -! -! cellsOnEdge => grid % cellsOnEdge % array -! -! ! error check that index 1 of matrixEdge and matrixCell are same length? -! -! do iEdge=1,nEdgesCompute -! cell1 = cellsOnEdge(1,iEdge) -! cell2 = cellsOnEdge(2,iEdge) -! do k=1,nBuoyancyLayers -! do q = 1, 3 -! do p = 1, 3 -! matrixEdge(p,q,k,iEdge) = & -! 0.5*(matrixCell(p,q,k,cell1) + matrixCell(p,q,k,cell2)) -! end do -! end do -! enddo -! enddo -! -! end subroutine mpas_tensor_cell_to_edge_BuoyCoor!}}} - - !*********************************************************************** ! ! subroutine calculateErtelPVTendencyFromPVFlux @@ -2417,7 +2276,7 @@ end subroutine calculateErtelPVFlux !> \date May 2015 !> \details !> This subroutine calculates the Ertel PV tendency as the divergence of -!> the Ertel PV flux +!> the Ertel PV flux, where the latter only has horizontal components. ! !----------------------------------------------------------------------- @@ -2467,6 +2326,8 @@ subroutine calculateErtelPVTendencyFromPVFlux(debugFlag, onASphere, nLayers, nCe call mpas_pool_get_array(meshPool, 'zCell', zCell) includeHalo = .true. + + divVectorCell = 0.0 ! copy vector into work array vectorCellWrk1 = vectorCell @@ -2598,6 +2459,8 @@ subroutine computeErtelPV(nCells, nLayers, nEdges, meshPool, & velGradZonal, velGradMerid) vGradZonal = velGradZonal + ErtelPV = 0.0 + do i = 1, nCells do k = 1,nLayers ErtelPV(k,i) = (fCell(i) + vGradZonal(k,i) - uGradMerid(k,i))/max(sigma(k,i),epsilonEPFT) From 049f5c290b90270511f5ef2328941e3f339218b0 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Wed, 17 Jun 2015 14:28:24 -0600 Subject: [PATCH 0079/1724] fixed bug in name of variable used to activate pkg --- .../analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F index 50d7b2826b..7821663b7f 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm_flux_tensor.F @@ -111,15 +111,15 @@ subroutine ocn_setup_packages_eliassen_palm_flux_tensor(configPool, packagePool, ! !----------------------------------------------------------------- - logical, pointer :: am_eliassen_palm_flux_tensor_Active + logical, pointer :: amEliassenPalmFluxTensorPkgActive err = 0 call mpas_pool_get_package(packagePool, & - 'am_eliassen_palm_flux_tensor_Active', am_eliassen_palm_flux_tensor_Active) + 'amEliassenPalmFluxTensorPkgActive', amEliassenPalmFluxTensorPkgActive) ! turn on package for this analysis member - am_eliassen_palm_flux_tensor_Active = .true. + amEliassenPalmFluxTensorPkgActive = .true. end subroutine ocn_setup_packages_eliassen_palm_flux_tensor!}}} From bacc368b7e270fe176fdd79a300fd61a1a77377c Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Thu, 18 Jun 2015 09:16:59 -0600 Subject: [PATCH 0080/1724] changed names, removing 'flux tensor' part --- src/core_ocean/analysis_members/Makefile | 6 +- .../Registry_analysis_members.xml | 2 +- ..._tensor.xml => Registry_eliassen_palm.xml} | 54 +++--- .../mpas_ocn_analysis_driver.F | 76 ++++---- ...flux_tensor.F => mpas_ocn_eliassen_palm.F} | 176 +++++++++--------- 5 files changed, 157 insertions(+), 157 deletions(-) rename src/core_ocean/analysis_members/{Registry_eliassen_palm_flux_tensor.xml => Registry_eliassen_palm.xml} (90%) rename src/core_ocean/analysis_members/{mpas_ocn_eliassen_palm_flux_tensor.F => mpas_ocn_eliassen_palm.F} (95%) diff --git a/src/core_ocean/analysis_members/Makefile b/src/core_ocean/analysis_members/Makefile index b61d1f1696..3fa47c0eec 100644 --- a/src/core_ocean/analysis_members/Makefile +++ b/src/core_ocean/analysis_members/Makefile @@ -7,11 +7,11 @@ OBJS = mpas_ocn_analysis_driver.o \ mpas_ocn_surface_area_weighted_averages.o \ mpas_ocn_water_mass_census.o \ mpas_ocn_zonal_mean.o \ - mpas_ocn_eliassen_palm_flux_tensor.o + mpas_ocn_eliassen_palm.o all: $(OBJS) -mpas_ocn_analysis_driver.o: mpas_ocn_global_stats.o mpas_ocn_okubo_weiss.o mpas_ocn_zonal_mean.o mpas_ocn_okubo_weiss_eigenvalues.o mpas_ocn_surface_area_weighted_averages.o mpas_ocn_water_mass_census.o mpas_ocn_layer_volume_weighted_averages.o mpas_ocn_eliassen_palm_flux_tensor.o +mpas_ocn_analysis_driver.o: mpas_ocn_global_stats.o mpas_ocn_okubo_weiss.o mpas_ocn_zonal_mean.o mpas_ocn_okubo_weiss_eigenvalues.o mpas_ocn_surface_area_weighted_averages.o mpas_ocn_water_mass_census.o mpas_ocn_layer_volume_weighted_averages.o mpas_ocn_eliassen_palm.o mpas_ocn_global_stats.o: @@ -23,7 +23,7 @@ mpas_ocn_water_mass_census.o: mpas_ocn_layer_volume_weighted_averages.o: -mpas_ocn_eliassen_palm_flux_tensor.o: +mpas_ocn_eliassen_palm.o: clean: $(RM) *.o *.i *.mod *.f90 diff --git a/src/core_ocean/analysis_members/Registry_analysis_members.xml b/src/core_ocean/analysis_members/Registry_analysis_members.xml index da2a3617cd..47f8967f1d 100644 --- a/src/core_ocean/analysis_members/Registry_analysis_members.xml +++ b/src/core_ocean/analysis_members/Registry_analysis_members.xml @@ -4,4 +4,4 @@ #include "Registry_layer_volume_weighted_averages.xml" #include "Registry_zonal_mean.xml" #include "Registry_okubo_weiss.xml" -#include "Registry_eliassen_palm_flux_tensor.xml" +#include "Registry_eliassen_palm.xml" diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml similarity index 90% rename from src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml rename to src/core_ocean/analysis_members/Registry_eliassen_palm.xml index d985100c1f..de23de86ce 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm_flux_tensor.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -1,61 +1,61 @@ - - + - - - - - - - - - + - @@ -135,14 +135,14 @@ - @@ -168,7 +168,7 @@ - + - + packages="amEliassenPalmPkg"> \brief Set up packages for MPAS-Ocean analysis member !> \author Juan Saenz, Todd Ringler @@ -79,7 +79,7 @@ module ocn_eliassen_palm_flux_tensor ! !----------------------------------------------------------------------- - subroutine ocn_setup_packages_eliassen_palm_flux_tensor(configPool, packagePool, err)!{{{ + subroutine ocn_setup_packages_eliassen_palm(configPool, packagePool, err)!{{{ use mpas_packages @@ -111,22 +111,22 @@ subroutine ocn_setup_packages_eliassen_palm_flux_tensor(configPool, packagePool, ! !----------------------------------------------------------------- - logical, pointer :: amEliassenPalmFluxTensorPkgActive + logical, pointer :: amEliassenPalmPkgActive err = 0 call mpas_pool_get_package(packagePool, & - 'amEliassenPalmFluxTensorPkgActive', amEliassenPalmFluxTensorPkgActive) + 'amEliassenPalmPkgActive', ameliassenPalmPkgActive) ! turn on package for this analysis member - amEliassenPalmFluxTensorPkgActive = .true. + amEliassenPalmPkgActive = .true. - end subroutine ocn_setup_packages_eliassen_palm_flux_tensor!}}} + end subroutine ocn_setup_packages_eliassen_palm!}}} !*********************************************************************** ! -! routine ocn_init_eliassen_palm_flux_tensor +! routine ocn_init_eliassen_palm ! !> \brief Initialize MPAS-Ocean analysis member !> \author Juan A. Saenz, Todd Ringler @@ -137,7 +137,7 @@ end subroutine ocn_setup_packages_eliassen_palm_flux_tensor!}}} ! !----------------------------------------------------------------------- - subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ + subroutine ocn_init_eliassen_palm(domain, err)!{{{ use mpas_packages @@ -179,10 +179,10 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ real (kind=RKIND), dimension(:), pointer :: buoyancyMidRef real (kind=RKIND), dimension(:), pointer :: buoyancyInterfaceRef - logical, pointer :: amEPFTActive, config_eliassen_palm_flux_tensor_do_restart, config_eliassen_palm_flux_tensor_reset - integer, pointer :: config_eliassen_palm_flux_tensor_nBuoyancyLayers - real (kind=RKIND), pointer :: config_eliassen_palm_flux_tensor_rhomax_buoycoor - real (kind=RKIND), pointer :: config_eliassen_palm_flux_tensor_rhomin_buoycoor + logical, pointer :: amEPFTActive, config_eliassen_palm_do_restart, config_eliassen_palm_reset + integer, pointer :: config_eliassen_palm_nBuoyancyLayers + real (kind=RKIND), pointer :: config_eliassen_palm_rhomax_buoycoor + real (kind=RKIND), pointer :: config_eliassen_palm_rhomin_buoycoor real (kind=RKIND), pointer :: config_density0 integer, pointer :: nSamplesEA @@ -206,22 +206,22 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ err = 0 - call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_do_restart', & - config_eliassen_palm_flux_tensor_do_restart) - call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_reset', & - config_eliassen_palm_flux_tensor_reset) - call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_nBuoyancyLayers', & - config_eliassen_palm_flux_tensor_nBuoyancyLayers) - call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_rhomax_buoycoor', & - config_eliassen_palm_flux_tensor_rhomax_buoycoor) - call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_rhomin_buoycoor', & - config_eliassen_palm_flux_tensor_rhomin_buoycoor) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_do_restart', & + config_eliassen_palm_do_restart) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_reset', & + config_eliassen_palm_reset) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_nBuoyancyLayers', & + config_eliassen_palm_nBuoyancyLayers) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_rhomax_buoycoor', & + config_eliassen_palm_rhomax_buoycoor) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_rhomin_buoycoor', & + config_eliassen_palm_rhomin_buoycoor) call mpas_pool_get_config(domain % configs, 'config_density0', config_density0) block => domain % blocklist do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'amEliassenPalmFluxTensor', amEPFTPool) + call mpas_pool_get_subpool(block % structs, 'amEliassenPalm', amEPFTPool) !----------------------------------------------------------------- ! set up pointers @@ -235,18 +235,18 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ ! compute buoyancy and density increment of each layer ! at present we use layer interfaces that are evenly-spaced in buoyancy space !----------------------------------------------------------------- - nBuoyancyLayers = config_eliassen_palm_flux_tensor_nBuoyancyLayers - deltaDensity = (config_eliassen_palm_flux_tensor_rhomax_buoycoor & - - config_eliassen_palm_flux_tensor_rhomin_buoycoor) / config_eliassen_palm_flux_tensor_nBuoyancyLayers + nBuoyancyLayers = config_eliassen_palm_nBuoyancyLayers + deltaDensity = (config_eliassen_palm_rhomax_buoycoor & + - config_eliassen_palm_rhomin_buoycoor) / config_eliassen_palm_nBuoyancyLayers deltaBuoyancy = -gravity * deltaDensity / config_density0 !----------------------------------------------------------------- ! compute density/bouyancy at top of each layer !----------------------------------------------------------------- do k = 1, nBuoyancyLayers - potentialDensityTopRef(k) = config_eliassen_palm_flux_tensor_rhomin_buoycoor + deltaDensity * (k-1) + potentialDensityTopRef(k) = config_eliassen_palm_rhomin_buoycoor + deltaDensity * (k-1) buoyancyInterfaceRef(k) = -gravity & - * (config_eliassen_palm_flux_tensor_rhomin_buoycoor - config_density0) / config_density0 & + * (config_eliassen_palm_rhomin_buoycoor - config_density0) / config_density0 & + deltaBuoyancy * (k-1) end do k=nBuoyancyLayers @@ -260,13 +260,13 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ buoyancyMidRef(k) = 0.5*(buoyancyInterfaceRef(k) + buoyancyInterfaceRef(k+1)) end do k=nBuoyancyLayers - potentialDensityMidRef(k) = 0.5*(potentialDensityTopRef(k-1) + config_eliassen_palm_flux_tensor_rhomax_buoycoor) + potentialDensityMidRef(k) = 0.5*(potentialDensityTopRef(k-1) + config_eliassen_palm_rhomax_buoycoor) buoyancyMidRef(k) = 0.5*(buoyancyInterfaceRef(k) + buoyancyInterfaceRef(k+1)) !----------------------------------------------------------------- ! initialize ensemble averages when it is not a restart or when a reset requested !----------------------------------------------------------------- - if (.not. config_eliassen_palm_flux_tensor_do_restart .or. config_eliassen_palm_flux_tensor_reset) then + if (.not. config_eliassen_palm_do_restart .or. config_eliassen_palm_reset) then call mpas_pool_get_array(amEPFTPool, 'nSamplesEA', nSamplesEA) call mpas_pool_get_array(amEPFTPool, 'buoyancyMaskEA', buoyancyMaskEA) call mpas_pool_get_array(amEPFTPool, 'sigmaEA', sigmaEA) @@ -309,11 +309,11 @@ subroutine ocn_init_eliassen_palm_flux_tensor(domain, err)!{{{ end do - end subroutine ocn_init_eliassen_palm_flux_tensor!}}} + end subroutine ocn_init_eliassen_palm!}}} !*********************************************************************** ! -! routine ocn_compute_eliassen_palm_flux_tensor +! routine ocn_compute_eliassen_palm ! !> \brief Compute Eliassen-Palm flux tensor !> \author Juan A. Saenz, Todd Ringler @@ -328,7 +328,7 @@ end subroutine ocn_init_eliassen_palm_flux_tensor!}}} ! !----------------------------------------------------------------------- - subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ + subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ use mpas_vector_reconstruction @@ -379,9 +379,9 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !----------------------------------------------------------------- ! define pointers to namelist config variables local to the EPFT module !----------------------------------------------------------------- - logical, pointer :: config_eliassen_palm_flux_tensor_debug - real (kind=RKIND), pointer :: config_eliassen_palm_flux_tensor_rhomin_buoycoor - real (kind=RKIND), pointer :: config_eliassen_palm_flux_tensor_rhomax_buoycoor + logical, pointer :: config_eliassen_palm_debug + real (kind=RKIND), pointer :: config_eliassen_palm_rhomin_buoycoor + real (kind=RKIND), pointer :: config_eliassen_palm_rhomax_buoycoor !----------------------------------------------------------------- ! define local scalars holding length of dimensions @@ -568,19 +568,19 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ dminfo = domain % dminfo - call mpas_timer_start("compute_eliassen_palm_flux_tensor", .false., & - am_eliassen_palm_flux_tensorTimer) + call mpas_timer_start("compute_eliassen_palm", .false., & + am_eliassen_palmTimer) !-------------------------------------------------- ! get config variables !-------------------------------------------------- - call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_debug', & - config_eliassen_palm_flux_tensor_debug) - call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_rhomin_buoycoor', & - config_eliassen_palm_flux_tensor_rhomin_buoycoor) - call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_flux_tensor_rhomax_buoycoor', & - config_eliassen_palm_flux_tensor_rhomax_buoycoor) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_debug', & + config_eliassen_palm_debug) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_rhomin_buoycoor', & + config_eliassen_palm_rhomin_buoycoor) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_rhomax_buoycoor', & + config_eliassen_palm_rhomax_buoycoor) call mpas_pool_get_config(domain % configs, 'config_density0', config_density0) rho0 = config_density0 @@ -592,10 +592,10 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !-------------------------------------------------- ! assign pointers for each pool !-------------------------------------------------- - call mpas_pool_get_subpool(block % structs, 'amEliassenPalmFluxTensor', am_epftPool) + call mpas_pool_get_subpool(block % structs, 'amEliassenPalm', am_epftPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'eliassenPalmFluxTensorScratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'eliassenPalmScratch', scratchPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) @@ -813,7 +813,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !------------------------------------------------------------- ! TEST for general consistency !------------------------------------------------------------- - if(config_eliassen_palm_flux_tensor_debug) then + if(config_eliassen_palm_debug) then print *, ' ' print *, 'timeLevel:', timeLevel print *, ' ' @@ -836,7 +836,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! stratified, horizontally uniform ! Interpolating from z, rho to z, rho !------------------------------------------------------------- - if(config_eliassen_palm_flux_tensor_debug) then + if(config_eliassen_palm_debug) then do i = 1, nCells array1_3D(:,i) = -zMid(:,nCells/2) array2_3D(:,i) = potentialDensity(:,nCells/2) @@ -881,18 +881,18 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! Interpolate z from that potential density to reference potential density ! compare to expected values !------------------------------------------------------------- - if(config_eliassen_palm_flux_tensor_debug) then + if(config_eliassen_palm_debug) then do i = 1,nCells do k = 1, nVertLevels - array1_3D(k,i) = config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02 + & + array1_3D(k,i) = config_eliassen_palm_rhomin_buoycoor*1.02 + & (zMid(k,i)-zMid(1,i)) * & - (config_eliassen_palm_flux_tensor_rhomax_buoycoor*0.98 & - - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) / & + (config_eliassen_palm_rhomax_buoycoor*0.98 & + - config_eliassen_palm_rhomin_buoycoor*1.02) / & (zMid(nVertLevels,i) - zMid(1,i)) - array2_3D(k,i) = config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02 + & + array2_3D(k,i) = config_eliassen_palm_rhomin_buoycoor*1.02 + & (zTop(k,i)-zMid(1,i)) * & - (config_eliassen_palm_flux_tensor_rhomax_buoycoor*0.98 & - - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) / & + (config_eliassen_palm_rhomax_buoycoor*0.98 & + - config_eliassen_palm_rhomin_buoycoor*1.02) / & (zMid(nVertLevels,i) - zMid(1,i)) end do end do @@ -902,10 +902,10 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ do i = 1,nCells do k = 1, nBuoyancyLayers array2_3Dbuoy(k,i) = zMid(1,i) + & - (potentialDensityMidRef(k) - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) * & + (potentialDensityMidRef(k) - config_eliassen_palm_rhomin_buoycoor*1.02) * & (zMid(nVertLevels,i) - zMid(1,i)) / & - (config_eliassen_palm_flux_tensor_rhomax_buoycoor*0.98 & - - config_eliassen_palm_flux_tensor_rhomin_buoycoor*1.02) + (config_eliassen_palm_rhomax_buoycoor*0.98 & + - config_eliassen_palm_rhomin_buoycoor*1.02) end do end do do i = 1,nCells @@ -1093,7 +1093,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !------------------------------------------------------------- ! compute the force applied to the momentum equation as div(EPFT) !------------------------------------------------------------- - call calculateDivEPFT(config_eliassen_palm_flux_tensor_debug, & + call calculateDivEPFT(config_eliassen_palm_debug, & domain % on_a_sphere, rho0, nBuoyancyLayers, nCells, nEdges, & meshPool, buoyancyMidRef, sigmaEA, buoyancyMaskEA, EPFT, divEPFT) @@ -1106,7 +1106,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !------------------------------------------------------------- ! compute div(ErtelPVFlux) to obtain tendency of Ertel's PV !------------------------------------------------------------- - call calculateErtelPVTendencyFromPVFlux(config_eliassen_palm_flux_tensor_debug, & + call calculateErtelPVTendencyFromPVFlux(config_eliassen_palm_debug, & domain % on_a_sphere, nBuoyancyLayers, nCells, nEdges, & meshPool, sigmaEA, ErtelPVFlux, ErtelPVTendency) @@ -1129,7 +1129,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ ! TEST: ! calculate potential vorticity fluxes using curl of u !------------------------------------------------------------- - if(config_eliassen_palm_flux_tensor_debug) then + if(config_eliassen_palm_debug) then call mpas_pool_get_array(diagnosticsPool, 'relativeVorticityCell', relativeVorticityCell) @@ -1227,7 +1227,7 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ !------------------------------------------------------------- ! TESTS: tallying up tests across processors. !------------------------------------------------------------- - if(config_eliassen_palm_flux_tensor_debug) then + if(config_eliassen_palm_debug) then RMSglobal1 = 1.0D36 call mpas_dmpar_sum_int(dminfo, nCellsCum, nCellsGlobal) call mpas_dmpar_sum_real(dminfo, RMSlocal1, RMSglobal1) @@ -1276,19 +1276,19 @@ subroutine ocn_compute_eliassen_palm_flux_tensor(domain, timeLevel, err)!{{{ endif - call mpas_timer_stop("eliassen_palm_flux_tensor", am_eliassen_palm_flux_tensorTimer) + call mpas_timer_stop("eliassen_palm", am_eliassen_palmTimer) - if(config_eliassen_palm_flux_tensor_debug) then + if(config_eliassen_palm_debug) then write(stderrUnit, *) ' ' write(stderrUnit, *) 'exiting ocn_compute_epft' write(stderrUnit, *) ' ' end if - end subroutine ocn_compute_eliassen_palm_flux_tensor!}}} + end subroutine ocn_compute_eliassen_palm!}}} !*********************************************************************** ! -! routine ocn_restart_eliassen_palm_flux_tensor +! routine ocn_restart_eliassen_palm ! !> \brief Save restart for MPAS-Ocean analysis member !> \author FILL_IN_AUTHOR @@ -1299,7 +1299,7 @@ end subroutine ocn_compute_eliassen_palm_flux_tensor!}}} ! !----------------------------------------------------------------------- - subroutine ocn_restart_eliassen_palm_flux_tensor(domain, err)!{{{ + subroutine ocn_restart_eliassen_palm(domain, err)!{{{ !----------------------------------------------------------------- ! @@ -1331,11 +1331,11 @@ subroutine ocn_restart_eliassen_palm_flux_tensor(domain, err)!{{{ err = 0 - end subroutine ocn_restart_eliassen_palm_flux_tensor!}}} + end subroutine ocn_restart_eliassen_palm!}}} !*********************************************************************** ! -! routine ocn_finalize_eliassen_palm_flux_tensor +! routine ocn_finalize_eliassen_palm ! !> \brief Finalize MPAS-Ocean analysis member !> \author Juan A. Saenz @@ -1346,7 +1346,7 @@ end subroutine ocn_restart_eliassen_palm_flux_tensor!}}} ! !----------------------------------------------------------------------- - subroutine ocn_finalize_eliassen_palm_flux_tensor(domain, err)!{{{ + subroutine ocn_finalize_eliassen_palm(domain, err)!{{{ !----------------------------------------------------------------- ! @@ -1378,9 +1378,9 @@ subroutine ocn_finalize_eliassen_palm_flux_tensor(domain, err)!{{{ err = 0 - write(stderrUnit,*) 'ocn_finalize_eliassen_palm_flux_tensor' + write(stderrUnit,*) 'ocn_finalize_eliassen_palm' - end subroutine ocn_finalize_eliassen_palm_flux_tensor!}}} + end subroutine ocn_finalize_eliassen_palm!}}} @@ -1504,25 +1504,25 @@ subroutine check_potentialDensityRef_range(nVertLevels, nCells, maxLevelCell, & integer :: k, iCell, iCellMinBound, iCellMaxBound logical :: printWarning - real (kind=RKIND), pointer :: config_eliassen_palm_flux_tensor_rhomin_buoycoor, & - config_eliassen_palm_flux_tensor_rhomax_buoycoor + real (kind=RKIND), pointer :: config_eliassen_palm_rhomin_buoycoor, & + config_eliassen_palm_rhomax_buoycoor - call mpas_pool_get_config(ocnConfigs, 'config_eliassen_palm_flux_tensor_rhomin_buoycoor', & - config_eliassen_palm_flux_tensor_rhomin_buoycoor) - call mpas_pool_get_config(ocnConfigs, 'config_eliassen_palm_flux_tensor_rhomax_buoycoor', & - config_eliassen_palm_flux_tensor_rhomax_buoycoor) + call mpas_pool_get_config(ocnConfigs, 'config_eliassen_palm_rhomin_buoycoor', & + config_eliassen_palm_rhomin_buoycoor) + call mpas_pool_get_config(ocnConfigs, 'config_eliassen_palm_rhomax_buoycoor', & + config_eliassen_palm_rhomax_buoycoor) printWarning = .false. iCellMinBound = -1 iCellMaxBound = -1 do iCell = 1, nCells - if (potentialDensity(1,iCell) < config_eliassen_palm_flux_tensor_rhomin_buoycoor) then + if (potentialDensity(1,iCell) < config_eliassen_palm_rhomin_buoycoor) then printWarning = .true. iCellMinBound = iCell exit end if - if (potentialDensity(maxLevelCell(iCell),iCell) > config_eliassen_palm_flux_tensor_rhomax_buoycoor) then + if (potentialDensity(maxLevelCell(iCell),iCell) > config_eliassen_palm_rhomax_buoycoor) then printWarning = .true. iCellMaxBound = iCell exit @@ -2632,6 +2632,6 @@ subroutine mpas_vector_R3Cell_to_Edge(vectorCell, meshPool, & end subroutine mpas_vector_R3Cell_to_Edge!}}} -end module ocn_eliassen_palm_flux_tensor +end module ocn_eliassen_palm ! vim: foldmethod=marker From 7115a28ee77a81f19055d27973ede6137d76ca5f Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Mon, 22 Jun 2015 12:55:58 -0600 Subject: [PATCH 0081/1724] fixed some bugs with name variables and types Also changed names of variables associated to vertical velocity. The old vertical velocity was referred to as 'w', but now I changed it to 'varpi' because this is a vertical velocity in buoyancy coordinates not in depth coordinates. --- .../Registry_eliassen_palm.xml | 195 ++++++++++-------- .../analysis_members/mpas_ocn_eliassen_palm.F | 91 ++++---- 2 files changed, 150 insertions(+), 136 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index de23de86ce..7629a3950b 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -6,6 +6,13 @@ description="If true, ocean analysis member eliassen_palm is called." possible_values=".true. or .false." /> + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index 6063fb9377..f42b1e36ed 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -201,8 +201,8 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ real (kind=RKIND), dimension(:,:), pointer :: uusigmaEA real (kind=RKIND), dimension(:,:), pointer :: vvsigmaEA real (kind=RKIND), dimension(:,:), pointer :: uvsigmaEA - real (kind=RKIND), dimension(:,:), pointer :: uwsigmaEA - real (kind=RKIND), dimension(:,:), pointer :: vwsigmaEA + real (kind=RKIND), dimension(:,:), pointer :: uvarpisigmaEA + real (kind=RKIND), dimension(:,:), pointer :: vvarpisigmaEA err = 0 @@ -282,8 +282,8 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ call mpas_pool_get_array(amEPFTPool, 'uusigmaEA', uusigmaEA) call mpas_pool_get_array(amEPFTPool, 'vvsigmaEA', vvsigmaEA) call mpas_pool_get_array(amEPFTPool, 'uvsigmaEA', uvsigmaEA) - call mpas_pool_get_array(amEPFTPool, 'uwsigmaEA', uwsigmaEA) - call mpas_pool_get_array(amEPFTPool, 'vwsigmaEA', vwsigmaEA) + call mpas_pool_get_array(amEPFTPool, 'uvarpisigmaEA', uvarpisigmaEA) + call mpas_pool_get_array(amEPFTPool, 'vvarpisigmaEA', vvarpisigmaEA) nSamplesEA = 0.0 buoyancyMaskEA = 0.0 @@ -300,8 +300,8 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ uusigmaEA = 0.0 vvsigmaEA = 0.0 uvsigmaEA = 0.0 - uwsigmaEA = 0.0 - vwsigmaEA = 0.0 + uvarpisigmaEA = 0.0 + vvarpisigmaEA = 0.0 end if block => block % next @@ -403,7 +403,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ ! define mesh variables !----------------------------------------------------------------- real(KIND=RKIND), dimension(:), pointer :: fCell - real(KIND=RKIND), dimension(:,:), pointer :: cellMask + integer, dimension(:,:), pointer :: cellMask !----------------------------------------------------------------- ! define fields related to the Ensemble Average (EA) @@ -420,19 +420,19 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: heightMGradMeridEA real(KIND=RKIND), dimension(:,:), pointer :: usigmaEA real(KIND=RKIND), dimension(:,:), pointer :: vsigmaEA - real(KIND=RKIND), dimension(:,:), pointer :: wsigmaEA + real(KIND=RKIND), dimension(:,:), pointer :: varpisigmaEA real(KIND=RKIND), dimension(:,:), pointer :: uusigmaEA real(KIND=RKIND), dimension(:,:), pointer :: vvsigmaEA real(KIND=RKIND), dimension(:,:), pointer :: uvsigmaEA - real(KIND=RKIND), dimension(:,:), pointer :: uwsigmaEA - real(KIND=RKIND), dimension(:,:), pointer :: vwsigmaEA + real(KIND=RKIND), dimension(:,:), pointer :: uvarpisigmaEA + real(KIND=RKIND), dimension(:,:), pointer :: vvarpisigmaEA !----------------------------------------------------------------- ! define the Thickness-Weighted Average (TWA) velocity !----------------------------------------------------------------- real(KIND=RKIND), dimension(:,:), pointer :: uTWA real(KIND=RKIND), dimension(:,:), pointer :: vTWA - real(KIND=RKIND), dimension(:,:), pointer :: wTWA + real(KIND=RKIND), dimension(:,:), pointer :: varpiTWA !----------------------------------------------------------------- ! define Ertel's potential vorticity and related fields @@ -532,8 +532,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: density real(KIND=RKIND), dimension(:,:), pointer :: potentialDensity real(KIND=RKIND), dimension(:,:), pointer :: pressure - real(KIND=RKIND), dimension(:,:), pointer :: normalVelocityZonal - real(KIND=RKIND), dimension(:,:), pointer :: normalVelocityMeridional + real(KIND=RKIND), dimension(:,:), pointer :: velocityZonal + real(KIND=RKIND), dimension(:,:), pointer :: velocityMeridional real(KIND=RKIND), dimension(:,:), pointer :: relativeVorticityCell ! jas used for testing !real(KIND=RKIND), dimension(:,:), pointer :: wCellCenter @@ -556,6 +556,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ err = 0 + nCellsCum = 0 RMSlocal1 = 0.0 RMSlocal2 = 0.0 RMSglobal1 = 0.0 @@ -595,7 +596,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call mpas_pool_get_subpool(block % structs, 'amEliassenPalm', am_epftPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'eliassenPalmScratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'amEliassenPalmScratch', scratchPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) @@ -737,10 +738,10 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) call mpas_pool_get_array(diagnosticsPool, 'zTop', zTop) call mpas_pool_get_array(diagnosticsPool, 'density', density) - call mpas_pool_get_array(diagnosticsPool, 'potentialdensity', potentialDensity) + call mpas_pool_get_array(diagnosticsPool, 'potentialDensity', potentialDensity) call mpas_pool_get_array(diagnosticsPool, 'pressure', pressure) - call mpas_pool_get_array(diagnosticsPool, 'normalVelocityZonal', normalVelocityZonal) - call mpas_pool_get_array(diagnosticsPool, 'normalVelocityMeridional', normalVelocityMeridional) + call mpas_pool_get_array(diagnosticsPool, 'velocityZonal', velocityZonal) + call mpas_pool_get_array(diagnosticsPool, 'velocityMeridional', velocityMeridional) !-------------------------------------------------- ! variables that define the vertical coordinate system in density/buoyancy space @@ -767,15 +768,15 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call mpas_pool_get_array(am_epftPool, 'heightMGradMeridEA', HeightMGradMeridEA) call mpas_pool_get_array(am_epftPool, 'usigmaEA', usigmaEA) call mpas_pool_get_array(am_epftPool, 'vsigmaEA', vsigmaEA) - call mpas_pool_get_array(am_epftPool, 'wsigmaEA', wsigmaEA) + call mpas_pool_get_array(am_epftPool, 'varpisigmaEA', varpisigmaEA) call mpas_pool_get_array(am_epftPool, 'uusigmaEA', uusigmaEA) call mpas_pool_get_array(am_epftPool, 'vvsigmaEA', vvsigmaEA) call mpas_pool_get_array(am_epftPool, 'uvsigmaEA', uvsigmaEA) - call mpas_pool_get_array(am_epftPool, 'uwsigmaEA', uwsigmaEA) - call mpas_pool_get_array(am_epftPool, 'vwsigmaEA', vwsigmaEA) + call mpas_pool_get_array(am_epftPool, 'uvarpisigmaEA', uvarpisigmaEA) + call mpas_pool_get_array(am_epftPool, 'vvarpisigmaEA', vvarpisigmaEA) call mpas_pool_get_array(am_epftPool, 'uTWA', uTWA) call mpas_pool_get_array(am_epftPool, 'vTWA', vTWA) - call mpas_pool_get_array(am_epftPool, 'wTWA', wTWA) + call mpas_pool_get_array(am_epftPool, 'varpiTWA', varpiTWA) !-------------------------------------------------- ! Eliassen-Palm Flux Tensor and related products @@ -937,11 +938,11 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ -potentialDensityTopRef, heightTopBuoyCoor) call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & - maxLevelCell, -potentialDensity, normalVelocityZonal, & + maxLevelCell, -potentialDensity, velocityZonal, & -potentialDensityMidRef, uMidBuoyCoor) call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & - maxLevelCell, -potentialDensity, normalVelocityMeridional, & + maxLevelCell, -potentialDensity, velocityMeridional, & -potentialDensityMidRef, vMidBuoyCoor) call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & @@ -963,8 +964,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ do k = 1, firstLayerBuoyCoor(i)-1 heightMidBuoyCoor(k,i) = zTop(1,i) heightTopBuoyCoor(k,i) = zTop(1,i) - uMidBuoyCoor(k,i) = normalVelocityZonal(1,i) - vMidBuoyCoor(k,i) = normalVelocityMeridional(1,i) + uMidBuoyCoor(k,i) = velocityZonal(1,i) + vMidBuoyCoor(k,i) = velocityMeridional(1,i) densityMidBuoyCoor(k,i) = density(1,i) densityTopBuoyCoor(k,i) = density(1,i) ! diabatic @@ -973,8 +974,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ do k = lastLayerBuoyCoor(i) + 1, nBuoyancyLayers heightMidBuoyCoor(k,i) = -bottomDepth(i) heightTopBuoyCoor(k,i) = -bottomDepth(i) - uMidBuoyCoor(k,i) = normalVelocityZonal(maxLevelCell(i),i) - vMidBuoyCoor(k,i) = normalVelocityMeridional(maxLevelCell(i),i) + uMidBuoyCoor(k,i) = velocityZonal(maxLevelCell(i),i) + vMidBuoyCoor(k,i) = velocityMeridional(maxLevelCell(i),i) densityMidBuoyCoor(k,i) = density(maxLevelCell(i),i) densityTopBuoyCoor(k,i) = density(maxLevelCell(i),i) ! diabatic @@ -1039,8 +1040,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ ! Diabatic terms !wrk3DBuoyCoor = wMidBuoyCoor * sigma - !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, wsigmaEA) - wsigmaEA = 0.0 + !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, varpisigmaEA) + varpisigmaEA = 0.0 !------------------------------------------------------------- @@ -1057,13 +1058,13 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ ! Diabatic terms !wrk3DBuoyCoor = uMidBuoyCoor * wMidBuoyCoor * sigma - !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, uwsigmaEA) - uwsigmaEA = 0.0 + !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, uvarpisigmaEA) + uvarpisigmaEA = 0.0 ! Diabatic terms !wrk3DBuoyCoor = vMidBuoyCoor * wMidBuoyCoor* sigma - !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, vwsigmaEA) - vwsigmaEA = 0.0 + !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, vvarpisigmaEA) + vvarpisigmaEA = 0.0 !------------------------------------------------------------- ! update number of samples in ensemble average @@ -1077,8 +1078,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, sigmaEA, usigmaEA, uTWA) call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, sigmaEA, vsigmaEA, vTWA) ! Diabatic terms - !call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, sigmaEA, wsigmaEA, wTWA) - wTWA = 0.0 + !call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, sigmaEA, varpisigmaEA, varpiTWA) + varpiTWA = 0.0 !------------------------------------------------------------- ! based on current estimate of ensemble-average state, @@ -1087,8 +1088,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call calculateEPFTfromTWA(nBuoyancyLayers, nCells, & sigmaEA, heightMidBuoyCoorEA, & heightMidBuoyCoorSqEA, montgPotGradZonalEA, montgPotGradMeridEA, & - heightMGradZonalEA, heightMGradMeridEA, uTWA, vTWA, wTWA, & - uusigmaEA, vvsigmaEA, uvsigmaEA, uwsigmaEA, vwsigmaEA, EPFT) + heightMGradZonalEA, heightMGradMeridEA, uTWA, vTWA, varpiTWA, & + uusigmaEA, vvsigmaEA, uvsigmaEA, uvarpisigmaEA, vvarpisigmaEA, EPFT) !------------------------------------------------------------- ! compute the force applied to the momentum equation as div(EPFT) @@ -1961,8 +1962,8 @@ end subroutine calculateTWA!}}} !----------------------------------------------------------------------- subroutine calculateEPFTfromTWA(nLayers, nCells, & - sigmaEA, heightEA, heightSqEA, MxEA, MyEA, HMxEA, HMyEA, uTWA, vTWA, wTWA, & - uuSigmaEA, vvSigmaEA, uvSigmaEA, uwSigmaEA, vwSigmaEA, Etensor)!{{{ + sigmaEA, heightEA, heightSqEA, MxEA, MyEA, HMxEA, HMyEA, uTWA, vTWA, varpiTWA, & + uuSigmaEA, vvSigmaEA, uvSigmaEA, uvarpisigmaEA, vvarpisigmaEA, Etensor)!{{{ integer, intent(in) :: nLayers, nCells real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: sigmaEA real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: heightEA @@ -1973,12 +1974,12 @@ subroutine calculateEPFTfromTWA(nLayers, nCells, & real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: HMyEA real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: uTWA real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: vTWA - real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: wTWA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: varpiTWA real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: uuSigmaEA real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: vvSigmaEA real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: uvSigmaEA - real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: uwSigmaEA - real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: vwSigmaEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: uvarpisigmaEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: vvarpisigmaEA real (kind=RKIND), dimension(3, 3, nLayers, nCells), intent(out) :: Etensor ! local variables @@ -1997,8 +1998,8 @@ subroutine calculateEPFTfromTWA(nLayers, nCells, & uppupp = uuSigmaEA(kLayer,iCell) / sigma - uTWA(kLayer,iCell)*uTWA(kLayer,iCell) vppvpp = vvSigmaEA(kLayer,iCell) / sigma - vTWA(kLayer,iCell)*vTWA(kLayer,iCell) uppvpp = uvSigmaEA(kLayer,iCell) / sigma - uTWA(kLayer,iCell)*vTWA(kLayer,iCell) - uppwpp = uwSigmaEA(kLayer,iCell) / sigma - uTWA(kLayer,iCell)*wTWA(kLayer,iCell) - vppwpp = vwSigmaEA(kLayer,iCell) / sigma - vTWA(kLayer,iCell)*wTWA(kLayer,iCell) + uppwpp = uvarpisigmaEA(kLayer,iCell) / sigma - uTWA(kLayer,iCell)*varpiTWA(kLayer,iCell) + vppwpp = vvarpisigmaEA(kLayer,iCell) / sigma - vTWA(kLayer,iCell)*varpiTWA(kLayer,iCell) HpHp = heightSqEA(kLayer,iCell) - heightEA(kLayer,iCell)*heightEA(kLayer,iCell) HpMxp = HMxEA(kLayer,iCell) - heightEA(kLayer,iCell)*MxEA(kLayer,iCell) HpMyp = HMyEA(kLayer,iCell) - heightEA(kLayer,iCell)*MyEA(kLayer,iCell) @@ -2072,7 +2073,7 @@ subroutine calculateDivEPFT(debugFlag, onASphere, rho0, nLayers, nCells, nEdges, ! variables used for testing and debugging real (kind=RKIND), dimension(:), allocatable :: divExact real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell - real (kind=RKIND), dimension(:,:), pointer :: boundaryCell + integer, dimension(:,:), pointer :: boundaryCell if (debugFlag) then allocate(divExact(nCells+1)) From f6bb7d6a7402c434588d96a58011711e736084c5 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Mon, 22 Jun 2015 13:35:17 -0600 Subject: [PATCH 0082/1724] removed variable from output stream --- src/core_ocean/analysis_members/Registry_eliassen_palm.xml | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index 7629a3950b..2b2c01eae1 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -506,7 +506,6 @@ - @@ -544,7 +543,6 @@ - From 964e823d505f6f717636db375838b1c4900c6c54 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Tue, 23 Jun 2015 08:59:19 -0600 Subject: [PATCH 0083/1724] trying to fix the output stream in registry --- src/core_ocean/analysis_members/Registry_eliassen_palm.xml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index 2b2c01eae1..1561b6eb42 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -491,11 +491,10 @@ --!> From 987284802a86bf0ed747b34027930bcabc7b1cba Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Wed, 24 Jun 2015 11:07:08 -0600 Subject: [PATCH 0084/1724] fixed bug in calculation of potentialDensityMidRef --- .../analysis_members/mpas_ocn_eliassen_palm.F | 23 +++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index f42b1e36ed..2895859ecd 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -260,7 +260,7 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ buoyancyMidRef(k) = 0.5*(buoyancyInterfaceRef(k) + buoyancyInterfaceRef(k+1)) end do k=nBuoyancyLayers - potentialDensityMidRef(k) = 0.5*(potentialDensityTopRef(k-1) + config_eliassen_palm_rhomax_buoycoor) + potentialDensityMidRef(k) = 0.5*(potentialDensityTopRef(k) + config_eliassen_palm_rhomax_buoycoor) buoyancyMidRef(k) = 0.5*(buoyancyInterfaceRef(k) + buoyancyInterfaceRef(k+1)) !----------------------------------------------------------------- @@ -586,6 +586,11 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call mpas_pool_get_config(domain % configs, 'config_density0', config_density0) rho0 = config_density0 + if(config_eliassen_palm_debug) then + write(stderrUnit, *) ' ' + write(stderrUnit, *) 'starting ocn_compute_epft' + write(stderrUnit, *) ' ' + end if block => domain % blocklist do while (associated(block)) @@ -817,13 +822,23 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ if(config_eliassen_palm_debug) then print *, ' ' print *, 'timeLevel:', timeLevel + print *, 'nBuoyancyLayers:', timeLevel print *, ' ' - print *, 'potentialDensityTopRef' + print *, 'config_eliassen_palm_rhomin_buoycoor, config_eliassen_palm_rhomax_buoycoor' + print *, config_eliassen_palm_rhomin_buoycoor, config_eliassen_palm_rhomax_buoycoor + print *, '(config_eliassen_palm_rhomax_buoycoor - config_eliassen_palm_rhomin_buoycoor)/nBuoyancyLayers' + print *, (config_eliassen_palm_rhomax_buoycoor - config_eliassen_palm_rhomin_buoycoor)/nBuoyancyLayers + print *, 'potentialDensityTopRef (nBuoyancyLayers)' print *, potentialDensityTopRef - print *, 'potentialDensityMidRef' + print *, 'potentialDensityTopRef(2:nBuoyancyLayers)-potentialDensityTopRef(:nBuoyancyLayers-1)' + print *, potentialDensityTopRef(2:nBuoyancyLayers)-potentialDensityTopRef(:nBuoyancyLayers-1) + print *, 'potentialDensityMidRef (nBuoyancyLayers)' print *, potentialDensityMidRef + print *, 'potentialDensityMidRef(2:nBuoyancyLayers)-potentialDensityMidRef(:nBuoyancyLayers-1)' + print *, potentialDensityMidRef(2:nBuoyancyLayers)-potentialDensityMidRef(:nBuoyancyLayers-1) + print *, 'nCells,nBuoyancyLayers', nCells,nBuoyancyLayers print *, 'nCells*nBuoyancyLayers', nCells*nBuoyancyLayers - print *, 'sum(buoyancyMask)', sum(buoyancyMask) + print *, 'No. valid cells in buoyancy coords sum(buoyancyMask)', sum(buoyancyMask) print *, 'nCells*nVertLevels', nCells*nVertLevels print *, 'sum(cellMask)', sum(cellMask) print *, 'minval(potentialDensity), maxval(potentialDensity)' From f23c98f622b722254fd931a16c882c1d28a60bac Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Wed, 24 Jun 2015 16:01:05 -0600 Subject: [PATCH 0085/1724] fixed bug in test 1 and cleaned up other tests --- .../analysis_members/mpas_ocn_eliassen_palm.F | 39 ++++++++++++++----- 1 file changed, 29 insertions(+), 10 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index 2895859ecd..34b4d480a8 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -854,11 +854,11 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ !------------------------------------------------------------- if(config_eliassen_palm_debug) then do i = 1, nCells - array1_3D(:,i) = -zMid(:,nCells/2) + array1_3D(:,i) = zMid(:,nCells/2) array2_3D(:,i) = potentialDensity(:,nCells/2) end do print *, ' ' - print *, 'Testing interpolatoin function' + print *, 'TEST1: Testing interpolatoin function' print *, 'Interpolating from (z, rho) to (z, rho)' print *, 'call linear_interp_1d_field_along_column(nVertLevels, nCells, & nVertLevels, maxLevelCell, array1_3D, array2_3D, array1_3D(:,1), array3_3D)' @@ -872,8 +872,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ maxLevelCell, array1_3D, array2_3D, array1_3D(:,1), array3_3D) print *, 'array1_3D(:,1)' print *, array1_3D(:,1) - print *, '-zMid(:,nCells/2)' - print *, -zMid(:,nCells/2) + print *, 'zMid(:,nCells/2)' + print *, zMid(:,nCells/2) print *, 'array2_3D(:,1)' print *, array2_3D(:,1) print *, 'array3_3D(:,1)' @@ -892,10 +892,10 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ !------------------------------------------------------------- ! INTERPOLATION TEST 2 - ! Define a stratification where potential density varies linearly with depth - ! Using reference potential density that varies linearly with index - ! Interpolate z from that potential density to reference potential density - ! compare to expected values + ! Define a stratification where potential density varies linearly with depth. + ! Using reference potential density that varies linearly with index. + ! Interpolate z from that potential density to reference potential density. + ! Compare to expected values. !------------------------------------------------------------- if(config_eliassen_palm_debug) then do i = 1,nCells @@ -930,6 +930,15 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ ((array1_3Dbuoy(k,i) - array2_3Dbuoy(k,i))/array2_3Dbuoy(k,i))**2 end do end do + print *, ' ' + print *, 'TEST2: Testing interpolation function' + print *, 'interpolating a linear function' + print *, 'array1_3Dbuoy(:,nCells/2)' + print *, array1_3Dbuoy(:,nCells/2) + print *, 'array2_3Dbuoy(:,nCells/2)' + print *, array2_3Dbuoy(:,nCells/2) + print *, 'array1_3Dbuoy(:,nCells/2) - array2_3Dbuoy(:,nCells/2)' + print *, array1_3Dbuoy(:,nCells/2) - array2_3Dbuoy(:,nCells/2) endif @@ -1596,6 +1605,12 @@ subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLay integer :: iCell, maxLevel, kB, kBBottom, kBTop, kDataAbove, kDataBelow, kData real (kind=RKIND) :: dx, dy + + !----------------------------------------------------------------- + ! test for monoticity of xFieldIn + !----------------------------------------------------------------- + ! jas issue : to do + !----------------------------------------------------------------- ! initialize intent(out) !----------------------------------------------------------------- @@ -2169,6 +2184,8 @@ subroutine calculateDivEPFT(debugFlag, onASphere, rho0, nLayers, nCells, nEdges, ! use q=3 as a test vector if (q.eq.3 .and. debugFlag) then print *, ' ' + print *, 'calculateDivEPFT:' + print *, 'layer, RMS relative error on layer :' do kLayer = 1,nLayers wrk = sqrt( & sum( & @@ -2177,7 +2194,7 @@ subroutine calculateDivEPFT(debugFlag, onASphere, rho0, nLayers, nCells, nEdges, )**2 * & (1.0 - boundaryCell(1,:)) & ) / nCells ) - print *, 'div RMS relative error on layer:', wrk + print *, kLayer, wrk enddo endif @@ -2390,6 +2407,8 @@ subroutine calculateErtelPVTendencyFromPVFlux(debugFlag, onASphere, nLayers, nCe if (debugFlag) then print *, ' ' + print *, 'calculateErtelPVTendencyFromPVFlux:' + print *, 'k, RMS relative error on layer:' do k= 1,nLayers wrk = sqrt( & sum( & @@ -2398,7 +2417,7 @@ subroutine calculateErtelPVTendencyFromPVFlux(debugFlag, onASphere, nLayers, nCe )**2 * & (1.0 - boundaryCell(1,:)) & ) / nCells ) - print *, 'div RMS relative error on layer:', wrk + print *, k, wrk enddo endif From d7a8426e488609d43b943721a990b514682c67eb Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Thu, 25 Jun 2015 15:41:06 -0600 Subject: [PATCH 0086/1724] output elements of vectors and tensors. There is a bug on my mac that does not allow me to output tensors. Also, paraview may not read in tensors or vectors (?) So output elements of tensors and vectors as scalar arrays. --- .../Registry_eliassen_palm.xml | 68 +++++++++++++++++- .../analysis_members/mpas_ocn_eliassen_palm.F | 72 ++++++++++++++++--- 2 files changed, 130 insertions(+), 10 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index 1561b6eb42..e047c66e85 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -206,12 +206,23 @@ description="work array" /> + + @@ -442,36 +453,89 @@ units="m s^{-3}" description="Vertical velocity, thickness weighted" /> + + + + + + + + + + + + - + diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index 34b4d480a8..27b1fa5400 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -440,12 +440,20 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: ErtelPV real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVTendency real(KIND=RKIND), dimension(:,:,:), pointer :: ErtelPVFlux + real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVFlux1 + real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVFlux2 !----------------------------------------------------------------- ! define the Eliassen-Palm flux tensor and related fields !----------------------------------------------------------------- real(KIND=RKIND), dimension(:,:,:,:), pointer :: EPFT real(KIND=RKIND), dimension(:,:,:), pointer :: divEPFT + real(KIND=RKIND), dimension(:,:), pointer :: divEPFT1 + real(KIND=RKIND), dimension(:,:), pointer :: divEPFT2 + real(KIND=RKIND), dimension(:,:), pointer :: divEPFTshear1 + real(KIND=RKIND), dimension(:,:), pointer :: divEPFTshear2 + real(KIND=RKIND), dimension(:,:), pointer :: divEPFTdrag1 + real(KIND=RKIND), dimension(:,:), pointer :: divEPFTdrag2 !----------------------------------------------------------------- ! define scratch fields used as work variables and for testing @@ -471,6 +479,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ type(field2DReal), pointer :: wrk3DnVertLevelsP1Field type(field2DReal), pointer :: wrk3DnVertLevelsField type(field2DReal), pointer :: wrk3DBuoyCoorField + type(field3DReal), pointer :: wrkVectorField + type(field4DReal), pointer :: wrkTensorField type(field2DReal), pointer :: array1_3DField type(field2DReal), pointer :: array2_3DField @@ -509,6 +519,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: wrk3DnVertLevelsP1 real(KIND=RKIND), dimension(:,:), pointer :: wrk3DnVertLevels real(KIND=RKIND), dimension(:,:), pointer :: wrk3DBuoyCoor + real(KIND=RKIND), dimension(:,:,:), pointer :: wrkVector + real(KIND=RKIND), dimension(:,:,:,:), pointer :: wrkTensor real(KIND=RKIND), dimension(:,:), pointer :: array1_3D real(KIND=RKIND), dimension(:,:), pointer :: array2_3D @@ -642,6 +654,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call mpas_pool_get_field(scratchPool, 'wrk3DnVertLevelsP1', wrk3DnVertLevelsP1Field) call mpas_pool_get_field(scratchPool, 'wrk3DnVertLevels', wrk3DnVertLevelsField) call mpas_pool_get_field(scratchPool, 'wrk3DBuoyCoor', wrk3DBuoyCoorField) + call mpas_pool_get_field(scratchPool, 'wrkVector', wrkVectorField) + call mpas_pool_get_field(scratchPool, 'wrkTensor', wrkTensorField) call mpas_pool_get_field(scratchPool, 'array1_3D', array1_3DField) call mpas_pool_get_field(scratchPool, 'array2_3D', array2_3DField) @@ -680,6 +694,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call mpas_allocate_scratch_field(wrk3DnVertLevelsP1Field, .true.) call mpas_allocate_scratch_field(wrk3DnVertLevelsField, .true.) call mpas_allocate_scratch_field(wrk3DBuoyCoorField, .true.) + call mpas_allocate_scratch_field(wrkVectorField, .true.) + call mpas_allocate_scratch_field(wrkTensorField, .true.) call mpas_allocate_scratch_field(array1_3DField, .true.) call mpas_allocate_scratch_field(array2_3DField, .true.) @@ -718,6 +734,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ wrk3DnVertLevelsP1 => wrk3DnVertLevelsP1Field % array wrk3DnVertLevels => wrk3DnVertLevelsField % array wrk3DBuoyCoor => wrk3DBuoyCoorField % array + wrkVector => wrkVectorField % array + wrkTensor => wrkTensorField % array array1_3D => array1_3DField % array array2_3D => array2_3DField % array @@ -788,7 +806,15 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ !-------------------------------------------------- call mpas_pool_get_array(am_epftPool, 'EPFT', EPFT) call mpas_pool_get_array(am_epftPool, 'divEPFT', divEPFT) - call mpas_pool_get_array(am_epftPool, 'ErtelPVFlux', ErtelPVFlux) + call mpas_pool_get_array(am_epftPool, 'divEPFT1', divEPFT1) + call mpas_pool_get_array(am_epftPool, 'divEPFT2', divEPFT2) + call mpas_pool_get_array(am_epftPool, 'divEPFTshear1', divEPFTshear1) + call mpas_pool_get_array(am_epftPool, 'divEPFTshear2', divEPFTshear2) + call mpas_pool_get_array(am_epftPool, 'divEPFTdrag1', divEPFTdrag1) + call mpas_pool_get_array(am_epftPool, 'divEPFTdrag2', divEPFTdrag2) + call mpas_pool_get_array(am_epftPool, 'ErtelPVFlux' , ErtelPVFlux) + call mpas_pool_get_array(am_epftPool, 'ErtelPVFlux1', ErtelPVFlux1) + call mpas_pool_get_array(am_epftPool, 'ErtelPVFlux2', ErtelPVFlux2) call mpas_pool_get_array(am_epftPool, 'ErtelPVTendency', ErtelPVTendency) call mpas_pool_get_array(am_epftPool, 'ErtelPV', ErtelPV) @@ -1096,8 +1122,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ nSamplesEA = nSamplesEA + 1 !------------------------------------------------------------- - ! based on current estimate of ensemble-average state, ! compute the thickness-weighted average velocity + ! based on current estimate of ensemble-average state !------------------------------------------------------------- call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, sigmaEA, usigmaEA, uTWA) call calculateTWA(nBuoyancyLayers, nCells, nBuoyancyLayers, sigmaEA, vsigmaEA, vTWA) @@ -1106,8 +1132,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ varpiTWA = 0.0 !------------------------------------------------------------- - ! based on current estimate of ensemble-average state, ! compute the Eliassen-Palm flux tensor + ! based on current estimate of ensemble-average state !------------------------------------------------------------- call calculateEPFTfromTWA(nBuoyancyLayers, nCells, & sigmaEA, heightMidBuoyCoorEA, & @@ -1116,22 +1142,49 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ uusigmaEA, vvsigmaEA, uvsigmaEA, uvarpisigmaEA, vvarpisigmaEA, EPFT) !------------------------------------------------------------- - ! compute the force applied to the momentum equation as div(EPFT) + ! compute the total force from the EPFT: div(EPFT) !------------------------------------------------------------- call calculateDivEPFT(config_eliassen_palm_debug, & domain % on_a_sphere, rho0, nBuoyancyLayers, nCells, nEdges, & meshPool, buoyancyMidRef, sigmaEA, buoyancyMaskEA, EPFT, divEPFT) + ! decompose the vector into its components for output + divEPFT1 = divEPFT(1,:,:) + divEPFT2 = divEPFT(2,:,:) + + !------------------------------------------------------------- + ! compute the force from horizontal shear component of the EPFT + !------------------------------------------------------------- + wrkTensor = 0.0 + wrkTensor(1:2,1:2,:,:) = EPFT(1:2,1:2,:,:) + call calculateDivEPFT(config_eliassen_palm_debug, & + domain % on_a_sphere, rho0, nBuoyancyLayers, nCells, nEdges, & + meshPool, buoyancyMidRef, sigmaEA, buoyancyMaskEA, wrkTensor, wrkVector) + divEPFTshear1 = wrkVector(1,:,:) + divEPFTshear2 = wrkVector(2,:,:) + + !------------------------------------------------------------- + ! compute the force from vertical form drag component of the EPFT + !------------------------------------------------------------- + wrkTensor = 0.0 + wrkTensor(3,1:2,:,:) = EPFT(3,1:2,:,:) + call calculateDivEPFT(config_eliassen_palm_debug, & + domain % on_a_sphere, rho0, nBuoyancyLayers, nCells, nEdges, & + meshPool, buoyancyMidRef, sigmaEA, buoyancyMaskEA, wrkTensor, wrkVector) + divEPFTdrag1 = wrkVector(1,:,:) + divEPFTdrag2 = wrkVector(2,:,:) !------------------------------------------------------------- ! transform div(EPFT) into a flux of Ertel's PV !------------------------------------------------------------- - call calculateErtelPVFlux(nCells, nBuoyancyLayers, & + call calculateErtelPVFlux(nCells, nBuoyancyLayers, & sigmaEA, divEPFT, ErtelPVFlux) + ErtelPVFlux1 = ErtelPVFlux(1,:,:) + ErtelPVFlux2 = ErtelPVFlux(2,:,:) !------------------------------------------------------------- ! compute div(ErtelPVFlux) to obtain tendency of Ertel's PV !------------------------------------------------------------- - call calculateErtelPVTendencyFromPVFlux(config_eliassen_palm_debug, & + call calculateErtelPVTendencyFromPVFlux(config_eliassen_palm_debug, & domain % on_a_sphere, nBuoyancyLayers, nCells, nEdges, & meshPool, sigmaEA, ErtelPVFlux, ErtelPVTendency) @@ -1994,6 +2047,7 @@ end subroutine calculateTWA!}}} subroutine calculateEPFTfromTWA(nLayers, nCells, & sigmaEA, heightEA, heightSqEA, MxEA, MyEA, HMxEA, HMyEA, uTWA, vTWA, varpiTWA, & uuSigmaEA, vvSigmaEA, uvSigmaEA, uvarpisigmaEA, vvarpisigmaEA, Etensor)!{{{ + implicit none integer, intent(in) :: nLayers, nCells real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: sigmaEA real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: heightEA @@ -2017,6 +2071,7 @@ subroutine calculateEPFTfromTWA(nLayers, nCells, & real (kind=RKIND) :: sigma real (kind=RKIND) :: uppupp, vppvpp, uppvpp, uppwpp, vppwpp real (kind=RKIND) :: HpHp, HpMxp, HpMyp + real (kind=RKIND) :: dummy1, dummy2, dummy3 Etensor = 0.0 @@ -2030,9 +2085,10 @@ subroutine calculateEPFTfromTWA(nLayers, nCells, & uppvpp = uvSigmaEA(kLayer,iCell) / sigma - uTWA(kLayer,iCell)*vTWA(kLayer,iCell) uppwpp = uvarpisigmaEA(kLayer,iCell) / sigma - uTWA(kLayer,iCell)*varpiTWA(kLayer,iCell) vppwpp = vvarpisigmaEA(kLayer,iCell) / sigma - vTWA(kLayer,iCell)*varpiTWA(kLayer,iCell) + HpHp = heightSqEA(kLayer,iCell) - heightEA(kLayer,iCell)*heightEA(kLayer,iCell) - HpMxp = HMxEA(kLayer,iCell) - heightEA(kLayer,iCell)*MxEA(kLayer,iCell) - HpMyp = HMyEA(kLayer,iCell) - heightEA(kLayer,iCell)*MyEA(kLayer,iCell) + HpMxp = HMxEA(kLayer,iCell) - heightEA(kLayer,iCell) * MxEA(kLayer,iCell) + HpMyp = HMyEA(kLayer,iCell) - heightEA(kLayer,iCell) * MyEA(kLayer,iCell) !EPTF_pq(x,y,z) is represented as EPFT(p,q,kLayer,iCell) !column 1: Eu From 7079dff307762b3a8119f2446bf743093d558fb7 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Fri, 26 Jun 2015 11:15:07 -0600 Subject: [PATCH 0087/1724] cleaning up a little bit --- .../Registry_eliassen_palm.xml | 2 +- .../analysis_members/mpas_ocn_eliassen_palm.F | 26 ++++++++++--------- 2 files changed, 15 insertions(+), 13 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index e047c66e85..c467ed6245 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -604,7 +604,6 @@ - @@ -614,6 +613,7 @@ + diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index 27b1fa5400..a53141825e 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -783,10 +783,10 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call mpas_pool_get_array(am_epftPool, 'buoyancyMaskEA', buoyancyMaskEA) call mpas_pool_get_array(am_epftPool, 'sigmaEA', sigmaEA) call mpas_pool_get_array(am_epftPool, 'heightMidBuoyCoorEA', heightMidBuoyCoorEA) - call mpas_pool_get_array(am_epftPool, 'montgPotGradZonalEA', montgPotGradZonalEA) - call mpas_pool_get_array(am_epftPool, 'montgPotGradMeridEA', montgPotGradMeridEA) call mpas_pool_get_array(am_epftPool, 'heightMidBuoyCoorSqEA', heightMidBuoyCoorSqEA) call mpas_pool_get_array(am_epftPool, 'montgPotBuoyCoorEA', montgPotBuoyCoorEA) + call mpas_pool_get_array(am_epftPool, 'montgPotGradZonalEA', montgPotGradZonalEA) + call mpas_pool_get_array(am_epftPool, 'montgPotGradMeridEA', montgPotGradMeridEA) call mpas_pool_get_array(am_epftPool, 'heightMGradZonalEA', HeightMGradZonalEA) call mpas_pool_get_array(am_epftPool, 'heightMGradMeridEA', HeightMGradMeridEA) call mpas_pool_get_array(am_epftPool, 'usigmaEA', usigmaEA) @@ -797,6 +797,10 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call mpas_pool_get_array(am_epftPool, 'uvsigmaEA', uvsigmaEA) call mpas_pool_get_array(am_epftPool, 'uvarpisigmaEA', uvarpisigmaEA) call mpas_pool_get_array(am_epftPool, 'vvarpisigmaEA', vvarpisigmaEA) + + !-------------------------------------------------- + ! assign pointers for thickness-weighted averaged state + !-------------------------------------------------- call mpas_pool_get_array(am_epftPool, 'uTWA', uTWA) call mpas_pool_get_array(am_epftPool, 'vTWA', vTWA) call mpas_pool_get_array(am_epftPool, 'varpiTWA', varpiTWA) @@ -1061,7 +1065,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ montgPotGradZonal, montgPotGradMerid) !------------------------------------------------------------- - ! Increment first-order running mean fields + ! Increment first-order running ensemble average fields !------------------------------------------------------------- call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, buoyancyMask, buoyancyMaskEA) call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, sigma, sigmaEA) @@ -1071,7 +1075,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, montgPotGradMerid, montgPotGradMeridEA) !------------------------------------------------------------- - ! Increment second-order running mean fields + ! Increment second-order running ensemble average fields !------------------------------------------------------------- wrk3DBuoyCoor = heightMidBuoyCoor * heightMidBuoyCoor call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, heightMidBuoyCoorSqEA) @@ -1093,9 +1097,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ !call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, varpisigmaEA) varpisigmaEA = 0.0 - !------------------------------------------------------------- - ! Increment third-order running mean fields + ! Increment third-order running ensemble average fields !------------------------------------------------------------- wrk3DBuoyCoor = uMidBuoyCoor * uMidBuoyCoor * sigma call updateEnsembleAverage(nBuoyancyLayers, nCells, nSamplesEA, wrk3DBuoyCoor, uusigmaEA) @@ -1147,7 +1150,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call calculateDivEPFT(config_eliassen_palm_debug, & domain % on_a_sphere, rho0, nBuoyancyLayers, nCells, nEdges, & meshPool, buoyancyMidRef, sigmaEA, buoyancyMaskEA, EPFT, divEPFT) - ! decompose the vector into its components for output + ! decompose the vector into its components for output divEPFT1 = divEPFT(1,:,:) divEPFT2 = divEPFT(2,:,:) @@ -1174,22 +1177,21 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ divEPFTdrag2 = wrkVector(2,:,:) !------------------------------------------------------------- - ! transform div(EPFT) into a flux of Ertel's PV + ! transform div(EPFT) into a flux of Ertel PV !------------------------------------------------------------- - call calculateErtelPVFlux(nCells, nBuoyancyLayers, & - sigmaEA, divEPFT, ErtelPVFlux) + call calculateErtelPVFlux(nCells, nBuoyancyLayers, sigmaEA, divEPFT, ErtelPVFlux) ErtelPVFlux1 = ErtelPVFlux(1,:,:) ErtelPVFlux2 = ErtelPVFlux(2,:,:) !------------------------------------------------------------- - ! compute div(ErtelPVFlux) to obtain tendency of Ertel's PV + ! compute Ertel PV tendency from Ertel PV fluxes, div(ErtelPVFlux) !------------------------------------------------------------- call calculateErtelPVTendencyFromPVFlux(config_eliassen_palm_debug, & domain % on_a_sphere, nBuoyancyLayers, nCells, nEdges, & meshPool, sigmaEA, ErtelPVFlux, ErtelPVTendency) !------------------------------------------------------------- - ! compute Ertel PV based on EA/TWA fields + ! compute Ertel PV based on EA and TWA fields !------------------------------------------------------------- call computeErtelPV(nCells, nBuoyancyLayers, nEdges, meshPool, & fCell, uTWA, vTWA, sigmaEA, ErtelPV) From 740a62b1e4ce9056eed57d3098c31d8645a40f0e Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Mon, 13 Jul 2015 14:36:07 -0600 Subject: [PATCH 0088/1724] added more diagnostics and fixed leak and units More diagnostics were added: vertical gradients of uTWA, vTWA horizontal gradients of EPV Fixed memory leak: not all scratch variables were being deallocated. In Registry file: fixed units of variables associated to EPV. --- .../Registry_eliassen_palm.xml | 40 ++++- .../analysis_members/mpas_ocn_eliassen_palm.F | 140 ++++++++++++++++-- 2 files changed, 164 insertions(+), 16 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index c467ed6245..a3eab2c1e1 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -448,11 +448,25 @@ description="Meridional velocity, thickness weighted" /> + + + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index a53141825e..fa11c2d8de 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -433,11 +433,15 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: uTWA real(KIND=RKIND), dimension(:,:), pointer :: vTWA real(KIND=RKIND), dimension(:,:), pointer :: varpiTWA + real(KIND=RKIND), dimension(:,:), pointer :: duTWAdz + real(KIND=RKIND), dimension(:,:), pointer :: dvTWAdz !----------------------------------------------------------------- ! define Ertel's potential vorticity and related fields !----------------------------------------------------------------- real(KIND=RKIND), dimension(:,:), pointer :: ErtelPV + real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVGradZonal + real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVGradMerid real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVTendency real(KIND=RKIND), dimension(:,:,:), pointer :: ErtelPVFlux real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVFlux1 @@ -479,6 +483,10 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ type(field2DReal), pointer :: wrk3DnVertLevelsP1Field type(field2DReal), pointer :: wrk3DnVertLevelsField type(field2DReal), pointer :: wrk3DBuoyCoorField + type(field2DReal), pointer :: ErtelPVNormalGradOnEdgeField + type(field2DReal), pointer :: ErtelPVGradXField + type(field2DReal), pointer :: ErtelPVGradYField + type(field2DReal), pointer :: ErtelPVGradZField type(field3DReal), pointer :: wrkVectorField type(field4DReal), pointer :: wrkTensorField @@ -519,6 +527,10 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: wrk3DnVertLevelsP1 real(KIND=RKIND), dimension(:,:), pointer :: wrk3DnVertLevels real(KIND=RKIND), dimension(:,:), pointer :: wrk3DBuoyCoor + real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVNormalGradOnEdge + real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVGradX + real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVGradY + real(KIND=RKIND), dimension(:,:), pointer :: ErtelPVGradZ real(KIND=RKIND), dimension(:,:,:), pointer :: wrkVector real(KIND=RKIND), dimension(:,:,:,:), pointer :: wrkTensor @@ -654,6 +666,10 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call mpas_pool_get_field(scratchPool, 'wrk3DnVertLevelsP1', wrk3DnVertLevelsP1Field) call mpas_pool_get_field(scratchPool, 'wrk3DnVertLevels', wrk3DnVertLevelsField) call mpas_pool_get_field(scratchPool, 'wrk3DBuoyCoor', wrk3DBuoyCoorField) + call mpas_pool_get_field(scratchPool, 'ErtelPVNormalGradOnEdge', ErtelPVNormalGradOnEdgeField) + call mpas_pool_get_field(scratchPool, 'ErtelPVGradX', ErtelPVGradXField) + call mpas_pool_get_field(scratchPool, 'ErtelPVGradY', ErtelPVGradYField) + call mpas_pool_get_field(scratchPool, 'ErtelPVGradZ', ErtelPVGradZField) call mpas_pool_get_field(scratchPool, 'wrkVector', wrkVectorField) call mpas_pool_get_field(scratchPool, 'wrkTensor', wrkTensorField) @@ -694,6 +710,10 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call mpas_allocate_scratch_field(wrk3DnVertLevelsP1Field, .true.) call mpas_allocate_scratch_field(wrk3DnVertLevelsField, .true.) call mpas_allocate_scratch_field(wrk3DBuoyCoorField, .true.) + call mpas_allocate_scratch_field(ErtelPVNormalGradOnEdgeField, .true.) + call mpas_allocate_scratch_field(ErtelPVGradXField, .true.) + call mpas_allocate_scratch_field(ErtelPVGradYField, .true.) + call mpas_allocate_scratch_field(ErtelPVGradZField, .true.) call mpas_allocate_scratch_field(wrkVectorField, .true.) call mpas_allocate_scratch_field(wrkTensorField, .true.) @@ -734,6 +754,10 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ wrk3DnVertLevelsP1 => wrk3DnVertLevelsP1Field % array wrk3DnVertLevels => wrk3DnVertLevelsField % array wrk3DBuoyCoor => wrk3DBuoyCoorField % array + ErtelPVNormalGradOnEdge => ErtelPVNormalGradOnEdgeField % array + ErtelPVGradX => ErtelPVGradXField % array + ErtelPVGradY => ErtelPVGradYField % array + ErtelPVGradZ => ErtelPVGradZField % array wrkVector => wrkVectorField % array wrkTensor => wrkTensorField % array @@ -804,6 +828,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call mpas_pool_get_array(am_epftPool, 'uTWA', uTWA) call mpas_pool_get_array(am_epftPool, 'vTWA', vTWA) call mpas_pool_get_array(am_epftPool, 'varpiTWA', varpiTWA) + call mpas_pool_get_array(am_epftPool, 'duTWAdz', duTWAdz) + call mpas_pool_get_array(am_epftPool, 'dvTWAdz', dvTWAdz) !-------------------------------------------------- ! Eliassen-Palm Flux Tensor and related products @@ -821,6 +847,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call mpas_pool_get_array(am_epftPool, 'ErtelPVFlux2', ErtelPVFlux2) call mpas_pool_get_array(am_epftPool, 'ErtelPVTendency', ErtelPVTendency) call mpas_pool_get_array(am_epftPool, 'ErtelPV', ErtelPV) + call mpas_pool_get_array(am_epftPool, 'ErtelPVGradZonal', ErtelPVGradZonal) + call mpas_pool_get_array(am_epftPool, 'ErtelPVGradMerid', ErtelPVGradMerid) !-------------------------------------------------- ! Get variables associated to diabatic processes @@ -1196,6 +1224,30 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call computeErtelPV(nCells, nBuoyancyLayers, nEdges, meshPool, & fCell, uTWA, vTWA, sigmaEA, ErtelPV) + !------------------------------------------------------------- + ! compute the normal derivative of EPV at cell edges + !------------------------------------------------------------- + call computeNormalGradientOnEdge(nBuoyancyLayers, nCells, nEdges, & + meshPool, ErtelPV, ErtelPVNormalGradOnEdge) + + !------------------------------------------------------------- + ! reconstruct full gradient vector at cell centers + !------------------------------------------------------------- + call mpas_reconstruct(meshPool, ErtelPVNormalGradOnEdge, & + ErtelPVGradX, ErtelPVGradY, ErtelPVGradZ, ErtelPVGradZonal, ErtelPVGradMerid) + + !------------------------------------------------------------- + ! compute the vertical derivative of uTWA + !------------------------------------------------------------- + call computeVerticalDerivative(nCells, nBuoyancyLayers, & + firstLayerBuoyCoor, lastLayerBuoyCoor, heightMidBuoyCoor, uTWA, duTWAdz) + + !------------------------------------------------------------- + ! compute the vertical derivative of vTWA + !------------------------------------------------------------- + call computeVerticalDerivative(nCells, nBuoyancyLayers, & + firstLayerBuoyCoor, lastLayerBuoyCoor, heightMidBuoyCoor, vTWA, dvTWAdz) + !------------------------------------------------------------- ! Compute the geometric decomposition in terms of angles and ! eccentricities using the entries of EPFT. @@ -1261,33 +1313,41 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ !------------------------------------------------------------- call mpas_deallocate_scratch_field(firstLayerBuoyCoorField, .true.) call mpas_deallocate_scratch_field(lastLayerBuoyCoorField, .true.) - call mpas_deallocate_scratch_field(buoyancyMaskField, .true.) - call mpas_deallocate_scratch_field(sigmaField, .true.) call mpas_deallocate_scratch_field(heightMidBuoyCoorField, .true.) call mpas_deallocate_scratch_field(heightTopBuoyCoorField, .true.) call mpas_deallocate_scratch_field(heightInterfaceBuoyCoorField, .true.) + call mpas_deallocate_scratch_field(sigmaField, .true.) + call mpas_deallocate_scratch_field(montgPotBuoyCoorField, .true.) + call mpas_deallocate_scratch_field(montgPotNormalGradOnEdgeField, .true.) call mpas_deallocate_scratch_field(uMidBuoyCoorField, .true.) call mpas_deallocate_scratch_field(vMidBuoyCoorField, .true.) call mpas_deallocate_scratch_field(densityMidBuoyCoorField, .true.) call mpas_deallocate_scratch_field(densityTopBuoyCoorField, .true.) - call mpas_deallocate_scratch_field(montgPotBuoyCoorField, .true.) - call mpas_deallocate_scratch_field(montgPotNormalGradOnEdgeField, .true.) + call mpas_deallocate_scratch_field(buoyancyMaskField, .true.) call mpas_deallocate_scratch_field(montgPotGradXField, .true.) call mpas_deallocate_scratch_field(montgPotGradYField, .true.) call mpas_deallocate_scratch_field(montgPotGradZField, .true.) call mpas_deallocate_scratch_field(montgPotGradZonalField, .true.) call mpas_deallocate_scratch_field(montgPotGradMeridField, .true.) + call mpas_deallocate_scratch_field(wrk3DnVertLevelsP1Field, .true.) call mpas_deallocate_scratch_field(wrk3DnVertLevelsField, .true.) call mpas_deallocate_scratch_field(wrk3DBuoyCoorField, .true.) - + call mpas_deallocate_scratch_field(ErtelPVNormalGradOnEdgeField, .true.) + call mpas_deallocate_scratch_field(ErtelPVGradXField, .true.) + call mpas_deallocate_scratch_field(ErtelPVGradYField, .true.) + call mpas_deallocate_scratch_field(ErtelPVGradZField, .true.) + call mpas_deallocate_scratch_field(wrkVectorField, .true.) + call mpas_deallocate_scratch_field(wrkTensorField, .true.) + call mpas_deallocate_scratch_field(array1_3DField, .true.) call mpas_deallocate_scratch_field(array2_3DField, .true.) call mpas_deallocate_scratch_field(array3_3DField, .true.) call mpas_deallocate_scratch_field(array1_3DbuoyField, .true.) call mpas_deallocate_scratch_field(array2_3DbuoyField, .true.) - call mpas_deallocate_scratch_field(PVMidBuoyCoorField, .true.) call mpas_deallocate_scratch_field(PVMidBuoyCoorEAField, .true.) + call mpas_deallocate_scratch_field(uMidBuoyCoorEAField, .true.) + call mpas_deallocate_scratch_field(vMidBuoyCoorEAField, .true.) call mpas_deallocate_scratch_field(uPVMidBuoyCoorEAField, .true.) call mpas_deallocate_scratch_field(vPVMidBuoyCoorEAField, .true.) call mpas_deallocate_scratch_field(PVFluxTestField, .true.) @@ -2303,14 +2363,17 @@ subroutine calculateDivEPFT(debugFlag, onASphere, rho0, nLayers, nCells, nEdges, scalarWrk1(kLayer,iCell) = scalarWrk1(kLayer,iCell) + wrk - end do ! do iCell=1,nCells + end do ! kLayer = 1,nLayers - end do ! do q=1,3 + end do ! iCell = 1,nCells vectorCellOut(q,:,:) = scalarWrk1 - end do + end do !do q=1,3 + if (debugFlag) then + deallocate(divExact) + end if deallocate(scalarWrk1) deallocate(vectorCellWrk1) deallocate(vectorCellWrk2) @@ -2488,6 +2551,9 @@ subroutine calculateErtelPVTendencyFromPVFlux(debugFlag, onASphere, nLayers, nCe end do end if + if (debugFlag) then + deallocate(divExact) + end if deallocate(vectorCellWrk1) deallocate(vectorCellWrk2) deallocate(vectorEdgeWrk1) @@ -2573,6 +2639,62 @@ subroutine computeErtelPV(nCells, nLayers, nEdges, meshPool, & end subroutine computeErtelPV +!*********************************************************************** +! +! subroutine computeVerticalDerivative +! +!> \brief Calculate the the vertical derivative, in depth coordinates, of a scalar +!> \author Juan A. Saenz +!> \date July, 2015 +!> \details +!> This subroutine calculates the vertical derivative, in depth coordinates, of a scalar. +!> The scalar is assumed to exist in the middle of a cell layer. +!> The vertical derivative in the middle of the cell layer is returned. +! +!----------------------------------------------------------------------- + + subroutine computeVerticalDerivative(nCells, nLayers, & + firstLayer, lastLayer, heightMid, field, derivativeField)!{{{ + integer, intent(in) :: nCells, nLayers + integer, dimension(nCells), intent(in) :: firstLayer, lastLayer + real (kind=RKIND), dimension(:,:), intent(in) :: heightMid + real (kind=RKIND), dimension(:,:), intent(in) :: field + real (kind=RKIND), dimension(:,:), intent(out) :: derivativeField + + ! local variables + integer :: iCell, kLayer + real (kind=RKIND) :: wrkAbove, wrkBelow, dz + + derivativeField(nLayers, 1:nCells) = 0.0 + + do iCell = 1,nCells + + wrkAbove = field(firstLayer(iCell),iCell) + wrkBelow = field(firstLayer(iCell)+1,iCell) + dz = heightMid(firstLayer(iCell),iCell)-heightMid(firstLayer(iCell)+1,iCell) + + derivativeField(firstLayer(iCell), iCell) = (wrkAbove - wrkBelow) / dz + + do kLayer = firstLayer(iCell)+1, lastLayer(iCell)-1 + + wrkAbove = field(kLayer-1,iCell) + wrkBelow = field(kLayer+1,iCell) + dz = heightMid(kLayer-1,iCell)-heightMid(kLayer+1,iCell) + + derivativeField(kLayer, iCell) = (wrkAbove - wrkBelow) / dz + + end do ! kLayer = firstLayer(iCell)+1, lastLayer(iCell)-1 + + wrkAbove = field(lastLayer(iCell)-1,iCell) + wrkBelow = field(lastLayer(iCell),iCell) + dz = heightMid(lastLayer(iCell)-1,iCell)-heightMid(lastLayer(iCell),iCell) + + derivativeField(lastLayer(iCell), iCell) = (wrkAbove - wrkBelow) / dz + + end do ! iCell = 1,nCells + end subroutine computeVerticalDerivative!}}} + + !*********************************************************************** ! ! subroutine eddyGeomDecompEPFT From de6033a05bd58ce8abe54d96b81dbea76e8c46a0 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Mon, 13 Jul 2015 15:54:05 -0600 Subject: [PATCH 0089/1724] added scratch variables to epft's Registry --- .../Registry_eliassen_palm.xml | 45 +++++++++++++++---- 1 file changed, 36 insertions(+), 9 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index a3eab2c1e1..f1f48bc233 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -126,12 +126,14 @@ /> - + + + + - From fa5c50667bb00d278013068956a3eb716e13e5c1 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Fri, 3 Apr 2015 11:39:57 -0600 Subject: [PATCH 0090/1724] Initial setup for the init run mode. This commit adds the init run mode driver and files. Only utilities are added in this commit, no actual configurations are defined yet. --- src/core_ocean/Makefile | 8 +- src/core_ocean/Registry.xml | 163 ++++- src/core_ocean/build_options.mk | 5 +- src/core_ocean/driver/mpas_ocn_core.F | 7 + .../driver/mpas_ocn_core_interface.F | 14 +- src/core_ocean/driver/mpas_ocn_mpas_core.F | 363 +++++++++++ src/core_ocean/mode_init/Makefile | 35 ++ src/core_ocean/mode_init/Registry.xml | 1 + .../mode_init/Registry_TEMPLATE.xml | 5 + .../mode_init/mpas_ocn_init_TEMPLATE.F | 141 +++++ .../mode_init/mpas_ocn_init_cell_markers.F | 301 +++++++++ src/core_ocean/mode_init/mpas_ocn_init_mode.F | 317 ++++++++++ .../mode_init/mpas_ocn_init_spherical_utils.F | 579 ++++++++++++++++++ .../mode_init/mpas_ocn_init_vertical_grids.F | 296 +++++++++ 14 files changed, 2223 insertions(+), 12 deletions(-) create mode 100644 src/core_ocean/driver/mpas_ocn_mpas_core.F create mode 100644 src/core_ocean/mode_init/Makefile create mode 100644 src/core_ocean/mode_init/Registry.xml create mode 100644 src/core_ocean/mode_init/Registry_TEMPLATE.xml create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_TEMPLATE.F create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_cell_markers.F create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_mode.F create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_spherical_utils.F create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index b5a10764ce..6d547678ed 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -2,11 +2,12 @@ OCEAN_SHARED_INCLUDES = -I$(PWD)/../framework -I$(PWD)/../external/esmf_time_f90 -I$(PWD)/../operators -OCEAN_SHARED_INCLUDES += -I$(PWD)/shared -I$(PWD)/analysis_members -I$(PWD)/cvmix -I$(PWD)/mode_forward -I$(PWD)/mode_analysis +OCEAN_SHARED_INCLUDES += -I$(PWD)/shared -I$(PWD)/analysis_members -I$(PWD)/cvmix -I$(PWD)/mode_forward -I$(PWD)/mode_analysis -I$(PWD)/mode_init all: shared libcvmix analysis_members (cd mode_forward; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(OCEAN_SHARED_INCLUDES)" all ) (cd mode_analysis; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(OCEAN_SHARED_INCLUDES)" all ) + (cd mode_init; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(OCEAN_SHARED_INCLUDES)" all ) (cd driver; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(OCEAN_SHARED_INCLUDES)" all ) if [ -e libdycore.a ]; then \ ($(RM) libdycore.a) \ @@ -21,9 +22,13 @@ core_input_gen: (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean ) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.forward mode=forward ) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.analysis mode=analysis ) + (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init mode=init ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean stream_list.ocean. mutable ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.forward stream_list.ocean.forward. mutable mode=forward ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis ) + (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.init stream_list.ocean.init. mutable mode=init ) + #(cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.TEMPLATE mode=init configuration=TEMPLATE) + #(cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.init.TEMPLATE stream_list.ocean.init.TEMPLATE. mutable mode=init configuration=TEMPLATE ) gen_includes: $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml @@ -58,6 +63,7 @@ clean: fi (cd mode_forward; $(MAKE) clean) (cd mode_analysis; $(MAKE) clean) + (cd mode_init; $(MAKE) clean) (cd driver; $(MAKE) clean) (cd analysis_members; $(MAKE) clean) (cd shared; $(MAKE) clean) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 77982e95f7..8b1fea153c 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -38,7 +38,7 @@ - - + @@ -98,15 +98,15 @@ - + + + + + + + + + + + + @@ -837,9 +863,123 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +#include "mode_init/Registry.xml" + #include "analysis_members/Registry_analysis_members.xml" diff --git a/src/core_ocean/build_options.mk b/src/core_ocean/build_options.mk index 8c6c25a7c7..67d44adc11 100644 --- a/src/core_ocean/build_options.mk +++ b/src/core_ocean/build_options.mk @@ -3,7 +3,10 @@ ifeq "$(ROOT_DIR)" "" endif EXE_NAME=ocean_model NAMELIST_SUFFIX=ocean -FCINCLUDES += -I$(ROOT_DIR)/core_ocean/driver -I$(ROOT_DIR)/core_ocean/mode_forward -I$(ROOT_DIR)/core_ocean/mode_analysis -I$(ROOT_DIR)/core_ocean/shared -I$(ROOT_DIR)/core_ocean/analysis_members -I$(ROOT_DIR)/core_ocean/cvmix +FCINCLUDES += -I$(ROOT_DIR)/core_ocean/driver +FCINCLUDES += -I$(ROOT_DIR)/core_ocean/mode_forward -I$(ROOT_DIR)/core_ocean/mode_analysis -I$(ROOT_DIR)/core_ocean/mode_init +FCINCLUDES += -I$(ROOT_DIR)/core_ocean/shared -I$(ROOT_DIR)/core_ocean/analysis_members +FCINCLUDES += -I$(ROOT_DIR)/core_ocean/cvmix override CPPFLAGS += -DCORE_OCEAN report_builds: diff --git a/src/core_ocean/driver/mpas_ocn_core.F b/src/core_ocean/driver/mpas_ocn_core.F index eedc9734c5..3c94254986 100644 --- a/src/core_ocean/driver/mpas_ocn_core.F +++ b/src/core_ocean/driver/mpas_ocn_core.F @@ -31,6 +31,7 @@ module ocn_core use ocn_forward_mode use ocn_analysis_mode + use ocn_init_mode implicit none private @@ -68,6 +69,8 @@ function ocn_core_init(domain, startTimeStamp) result(ierr)!{{{ ierr = ocn_forward_mode_init(domain, startTimeStamp) else if ( trim(config_ocean_run_mode) == 'analysis' ) then ierr = ocn_analysis_mode_init(domain, startTimeStamp) + else if ( trim(config_ocean_run_mode) == 'init' ) then + ierr = ocn_init_mode_init(domain, startTimeStamp) end if end function ocn_core_init!}}} @@ -101,6 +104,8 @@ function ocn_core_run(domain) result(iErr)!{{{ ierr = ocn_forward_mode_run(domain) else if ( trim(config_ocean_run_mode) == 'analysis' ) then ierr = ocn_analysis_mode_run(domain) + else if ( trim(config_ocean_run_mode) == 'init' ) then + ierr = ocn_init_mode_run(domain) end if end function ocn_core_run!}}} @@ -132,6 +137,8 @@ function ocn_core_finalize(domain) result(ierr)!{{{ ierr = ocn_forward_mode_finalize(domain) else if (trim(config_ocean_run_mode) == 'analysis' ) then ierr = ocn_analysis_mode_finalize(domain) + else if (trim(config_ocean_run_mode) == 'init' ) then + ierr = ocn_init_mode_finalize(domain) end if end function ocn_core_finalize!}}} diff --git a/src/core_ocean/driver/mpas_ocn_core_interface.F b/src/core_ocean/driver/mpas_ocn_core_interface.F index fa278bbdc4..e5cd8901d5 100644 --- a/src/core_ocean/driver/mpas_ocn_core_interface.F +++ b/src/core_ocean/driver/mpas_ocn_core_interface.F @@ -16,6 +16,7 @@ module ocn_core_interface use ocn_forward_mode use ocn_analysis_mode + use ocn_init_mode private @@ -102,7 +103,7 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ integer :: err_tmp - logical, pointer :: forwardModeActive, analysisModeActive + logical, pointer :: forwardModeActive, analysisModeActive, initModeActive logical, pointer :: thicknessFilterActive logical, pointer :: splitTimeIntegratorActive logical, pointer :: surfaceRestoringActive @@ -118,6 +119,7 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ ! Get Packages call mpas_pool_get_package(packagePool, 'forwardModeActive', forwardModeActive) call mpas_pool_get_package(packagePool, 'analysisModeActive', analysisModeActive) + call mpas_pool_get_package(packagePool, 'initModeActive', initModeActive) call mpas_pool_get_package(packagePool, 'thicknessFilterActive', thicknessFilterActive) call mpas_pool_get_package(packagePool, 'splitTimeIntegratorActive', splitTimeIntegratorActive) call mpas_pool_get_package(packagePool, 'surfaceRestoringActive', surfaceRestoringActive) @@ -166,9 +168,13 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ ierr = ior(ierr, err_tmp) else if (trim(config_ocean_run_mode) == 'analysis' ) then analysisModeActive = .true. - call ocn_analysis_setup_packages(configPool, packagePool, ierr) + else if (trim(config_ocean_run_mode) == 'init' ) then + initModeActive = .true. end if + call ocn_analysis_setup_packages(configPool, packagePool, ierr) + call ocn_init_mode_validate_configuration(configPool, packagePool, ierr) + end function ocn_setup_packages!}}} @@ -246,6 +252,8 @@ function ocn_setup_clock(core_clock, configs) result(ierr)!{{{ ierr = ocn_forward_mode_setup_clock(core_clock, configs) else if ( trim(config_ocean_run_mode) == 'analysis' ) then ierr = ocn_analysis_mode_setup_clock(core_clock, configs) + else if ( trim(config_ocean_run_mode) == 'init' ) then + ierr = ocn_init_mode_setup_clock(core_clock, configs) end if @@ -294,6 +302,8 @@ function ocn_get_mesh_stream(configs, stream) result(ierr)!{{{ else write(stream,'(a)') 'input' end if + else if ( trim(config_ocean_run_mode) == 'init' ) then + write(stream,'(a)') 'input_init' end if end function ocn_get_mesh_stream!}}} diff --git a/src/core_ocean/driver/mpas_ocn_mpas_core.F b/src/core_ocean/driver/mpas_ocn_mpas_core.F new file mode 100644 index 0000000000..c35ae9485d --- /dev/null +++ b/src/core_ocean/driver/mpas_ocn_mpas_core.F @@ -0,0 +1,363 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! mpas_core +! +!> \brief Main driver for MPAS ocean core +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This module contains initialization and timestep drivers for +!> the MPAS ocean core. +! +!----------------------------------------------------------------------- + +module mpas_core + + use mpas_framework + use mpas_timekeeping + use mpas_dmpar + use mpas_timer + use mpas_io_units + + use ocn_forward_mode + use ocn_analysis_mode + use ocn_init_mode + + contains + +!*********************************************************************** +! +! routine mpas_core_init +! +!> \brief Initialize MPAS-Ocean core +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine calls all initializations required to begin a +!> simulation with MPAS-Ocean +! +!----------------------------------------------------------------------- + + subroutine mpas_core_init(domain, stream_manager, startTimeStamp)!{{{ + + use mpas_grid_types + use mpas_stream_manager + + implicit none + + type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager + character(len=*), intent(out) :: startTimeStamp + + type (dm_info) :: dminfo + + integer :: err + + character (len=StrKIND), pointer :: config_ocean_run_mode + + err = 0 + + dminfo = domain % dminfo + + call mpas_pool_get_config(domain % configs, 'config_ocean_run_mode', config_ocean_run_mode) + + if ( trim(config_ocean_run_mode) == 'forward' ) then + call ocn_forward_mode_init(domain, stream_manager, startTimeStamp) + else if ( trim(config_ocean_run_mode) == 'analysis' ) then + call ocn_analysis_mode_init(domain, stream_manager, startTimeStamp) + else if ( trim(config_ocean_run_mode) == 'init' ) then + call ocn_init_mode_init(domain, stream_manager, startTimeStamp) + end if + + end subroutine mpas_core_init!}}} + +!*********************************************************************** +! +! routine mpas_core_run +! +!> \brief Main driver for MPAS-Ocean time-stepping +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine includes the time-stepping loop, and calls timer +!> routines to write output and restart files. +! +!----------------------------------------------------------------------- + + subroutine mpas_core_run(domain, stream_manager)!{{{ + + use mpas_kind_types + use mpas_grid_types + use mpas_stream_manager + use mpas_timer + + implicit none + + type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager + + character(len=StrKIND), pointer :: config_ocean_run_mode + + call mpas_pool_get_config(domain % configs, 'config_ocean_run_mode', config_ocean_run_mode) + + if ( trim(config_ocean_run_mode) == 'forward' ) then + call ocn_forward_mode_run(domain, stream_manager) + else if ( trim(config_ocean_run_mode) == 'analysis' ) then + call ocn_analysis_mode_run(domain, stream_manager) + else if ( trim(config_ocean_run_mode) == 'init' ) then + call ocn_init_mode_run(domain, stream_manager) + end if + + end subroutine mpas_core_run!}}} + + subroutine mpas_core_finalize(domain, stream_manager)!{{{ + + use mpas_grid_types + use mpas_stream_manager + + implicit none + + type (domain_type), intent(inout) :: domain + type (MPAS_streamManager_type), intent(inout) :: stream_manager + integer :: ierr + + character(len=StrKIND), pointer :: config_ocean_run_mode + + call mpas_pool_get_config(domain % configs, 'config_ocean_run_mode', config_ocean_run_mode) + + if ( trim(config_ocean_run_mode) == 'forward' ) then + call ocn_forward_mode_finalize(domain, stream_manager) + else if (trim(config_ocean_run_mode) == 'analysis' ) then + call ocn_analysis_mode_finalize(domain, stream_manager) + else if (trim(config_ocean_run_mode) == 'init' ) then + call ocn_init_mode_finalize(domain, stream_manager) + end if + + end subroutine mpas_core_finalize!}}} + +!*********************************************************************** +! +! routine mpas_core_setup_packages +! +!> \brief Package setup routine +!> \author Doug Jacobsen +!> \date September 2011 +!> \details +!> This routine is intended to correctly configure the packages for this MPAS +!> core. It can use any Fortran logic to properly configure packages, and it +!> can also make use of any namelist options. All variables in the model are +!> *not* allocated until after this routine is called. +! +!----------------------------------------------------------------------- + subroutine mpas_core_setup_packages(configPool, packagePool, ierr)!{{{ + + use ocn_analysis_driver + + implicit none + + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + + integer, intent(out) :: ierr + + integer :: err_tmp + + logical, pointer :: forwardModeActive, analysisModeActive, initModeActive + logical, pointer :: thicknessFilterActive + logical, pointer :: splitTimeIntegratorActive + logical, pointer :: surfaceRestoringActive + logical, pointer :: bulkForcingActive + logical, pointer :: frazilIceActive + logical, pointer :: inSituEOSActive + + logical, pointer :: config_use_freq_filtered_thickness + logical, pointer :: config_frazil_ice_formation + character (len=StrKIND), pointer :: config_time_integrator, config_forcing_type + character (len=StrKIND), pointer :: config_ocean_run_mode, config_pressure_gradient_type + + ! Get Packages + call mpas_pool_get_package(packagePool, 'forwardModeActive', forwardModeActive) + call mpas_pool_get_package(packagePool, 'analysisModeActive', analysisModeActive) + call mpas_pool_get_package(packagePool, 'initModeActive', initModeActive) + call mpas_pool_get_package(packagePool, 'thicknessFilterActive', thicknessFilterActive) + call mpas_pool_get_package(packagePool, 'splitTimeIntegratorActive', splitTimeIntegratorActive) + call mpas_pool_get_package(packagePool, 'surfaceRestoringActive', surfaceRestoringActive) + call mpas_pool_get_package(packagePool, 'bulkForcingActive', bulkForcingActive) + call mpas_pool_get_package(packagePool, 'frazilIceActive', frazilIceActive) + call mpas_pool_get_package(packagePool, 'inSituEOSActive', inSituEOSActive) + + call mpas_pool_get_config(configPool, 'config_ocean_run_mode', config_ocean_run_mode) + + ierr = 0 + + if ( trim(config_ocean_run_mode) == 'forward' ) then + forwardModeActive = .true. + + call mpas_pool_get_config(configPool, 'config_use_freq_filtered_thickness', config_use_freq_filtered_thickness) + call mpas_pool_get_config(configPool, 'config_time_integrator', config_time_integrator) + call mpas_pool_get_config(configPool, 'config_forcing_type', config_forcing_type) + call mpas_pool_get_config(configPool, 'config_frazil_ice_formation', config_frazil_ice_formation) + call mpas_pool_get_config(configPool, 'config_pressure_gradient_type', config_pressure_gradient_type) + + if (config_use_freq_filtered_thickness) then + thicknessFilterActive = .true. + end if + + if (config_time_integrator == trim('split_explicit') & + .or. config_time_integrator == trim('unsplit_explicit') ) then + + splitTimeIntegratorActive = .true. + end if + + if (config_forcing_type == trim('restoring')) then + surfaceRestoringActive = .true. + else if (config_forcing_type == trim('bulk')) then + bulkForcingActive = .true. + end if + + if (config_frazil_ice_formation) then + frazilIceActive = .true. + end if + + if (config_pressure_gradient_type.eq.'Jacobian_from_TS') then + inSituEOSActive = .true. + end if + + call ocn_analysis_setup_packages(configPool, packagePool, err_tmp) + ierr = ior(ierr, err_tmp) + else if (trim(config_ocean_run_mode) == 'analysis' ) then + analysisModeActive = .true. + call ocn_analysis_setup_packages(configPool, packagePool, ierr) + else if (trim(config_ocean_run_mode) == 'init' ) then + initModeActive = .true. + call ocn_init_validate_configuration(configPool, packagePool, ierr) + end if + + end subroutine mpas_core_setup_packages!}}} + +!*********************************************************************** +! +! routine mpas_core_setup_clock +! +!> \brief Pacakge setup routine +!> \author Michael Duda +!> \date 6 August 2014 +!> \details +!> The purpose of this routine is to allow the core to set up a simulation +!> clock that will be used by the I/O subsystem for timing reads and writes +!> of I/O streams. +!> This routine is called from the superstructure after the framework +!> has been initialized but before any fields have been allocated and +!> initial fields have been read from input files. However, all namelist +!> options are available. +! +!----------------------------------------------------------------------- + subroutine mpas_core_setup_clock(core_clock, configs, ierr)!{{{ + + implicit none + + type (MPAS_Clock_type), intent(inout) :: core_clock + type (mpas_pool_type), intent(inout) :: configs + integer, intent(out) :: ierr + + character(len=StrKIND), pointer :: config_ocean_run_mode + + call mpas_pool_get_config(configs, 'config_ocean_run_mode', config_ocean_run_mode) + + if ( trim(config_ocean_run_mode) == 'forward' ) then + call ocn_forward_mode_simulation_clock_init(core_clock, configs, ierr) + else if ( trim(config_ocean_run_mode) == 'analysis' ) then + call ocn_analysis_mode_simulation_clock_init(core_clock, configs, ierr) + else if ( trim(config_ocean_run_mode) == 'init' ) then + call ocn_init_mode_simulation_clock_init(core_clock, configs, ierr) + end if + + end subroutine mpas_core_setup_clock!}}} + +!*********************************************************************** +! +! routine mpas_core_get_mesh_stream +! +!> \brief Returns the name of the stream containing mesh information +!> \author Michael Duda +!> \date 8 August 2014 +!> \details +!> This routine returns the name of the I/O stream containing dimensions, +!> attributes, and mesh fields needed by the framework bootstrapping +!> routine. At the time this routine is called, only namelist options +!> are available. +! +!----------------------------------------------------------------------- + subroutine mpas_core_get_mesh_stream(configs, stream, ierr)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: configs + character(len=*), intent(out) :: stream + integer, intent(out) :: ierr + + logical, pointer :: config_do_restart + character(len=StrKIND), pointer :: config_ocean_run_mode + + ierr = 0 + + call mpas_pool_get_config(configs, 'config_ocean_run_mode', config_ocean_run_mode) + + if ( trim(config_ocean_run_mode) == 'forward' .or. trim(config_ocean_run_mode) == 'analysis' ) then + call mpas_pool_get_config(configs, 'config_do_restart', config_do_restart) + + if (.not. associated(config_do_restart)) then + ierr = 1 + else if (config_do_restart) then + write(stream,'(a)') 'restart' + else + write(stream,'(a)') 'input' + end if + else if ( trim(config_ocean_run_mode) == 'init' ) then + write(stream, '(a)') 'input_init' + end if + + end subroutine mpas_core_get_mesh_stream!}}} + + + !*********************************************************************** + ! + ! routine mpas_core_setup_decompositions + ! + !> \brief Decomposition setup routine + !> \author Doug Jacobsen + !> \date September 2011 + !> \details + !> This routine is intended to create the decomposition list within a + !> domain type, and register any decompositons the core wants within it. + ! + !----------------------------------------------------------------------- + subroutine mpas_core_setup_decompositions(ierr)!{{{ + + use mpas_decomp + + implicit none + + integer, intent(out) :: ierr + procedure (mpas_decomp_function), pointer :: decompFunc + + ierr = 0 + + call mpas_decomp_create_decomp_list(decompositions) + + decompFunc => mpas_uniform_decomp + + call mpas_decomp_register_method(decompositions, 'uniform', decompFunc, iErr) + + end subroutine mpas_core_setup_decompositions!}}} + +end module mpas_core + +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile new file mode 100644 index 0000000000..bdf429c615 --- /dev/null +++ b/src/core_ocean/mode_init/Makefile @@ -0,0 +1,35 @@ +.SUFFIXES: .F .o + +OBJS = mpas_ocn_init_mode.o + +UTILS = mpas_ocn_init_spherical_utils.o \ + mpas_ocn_init_vertical_grids.o \ + mpas_ocn_init_cell_markers.o + +TEST_CASES = #mpas_ocn_init_TEMPLATE.o + +all: init_mode + +init_mode: $(UTILS) $(TEST_CASES) $(OBJS) + +mpas_ocn_init_mode.o: $(UTILS) $(TEST_CASES) + +mpas_ocn_init_cell_markers.o: + +mpas_ocn_init_spherical_utils.o: + +mpas_ocn_init_vertical_grids.o: + +#mpas_ocn_init_TEMPLATE.o: $(UTILS) + +clean: + $(RM) *.o *.mod *.f90 + +.F.o: + $(RM) $@ $*.mod +ifeq "$(GEN_F90)" "true" + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) +else + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) +endif diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml new file mode 100644 index 0000000000..8bcd4760fa --- /dev/null +++ b/src/core_ocean/mode_init/Registry.xml @@ -0,0 +1 @@ +// #include "Registry_TEMPLATE.xml" diff --git a/src/core_ocean/mode_init/Registry_TEMPLATE.xml b/src/core_ocean/mode_init/Registry_TEMPLATE.xml new file mode 100644 index 0000000000..99796e5810 --- /dev/null +++ b/src/core_ocean/mode_init/Registry_TEMPLATE.xml @@ -0,0 +1,5 @@ + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_TEMPLATE.F b/src/core_ocean/mode_init/mpas_ocn_init_TEMPLATE.F new file mode 100644 index 0000000000..72152cb17e --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_TEMPLATE.F @@ -0,0 +1,141 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_TEMPLATE +! +!> \brief MPAS ocean initialize case -- TEMPLATE +!> \author Doug Jacobsen +!> \date 03/23/2015 +!> \details +!> This module contains the routines for initializing the +!> the TEMPLATE test case +! +!----------------------------------------------------------------------- + +module ocn_init_TEMPLATE + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + + use ocn_constants + use ocn_init_vertical_grids + use ocn_init_cell_markers + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_TEMPLATE, & + ocn_init_validate_TEMPLATE + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_TEMPLATE +! +!> \brief Setup for baroclinic channel test case +!> \author Doug Jacobsen +!> \date 03/23/2015 +!> \details +!> This routine sets up the initial conditions for the baroclinic channel test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_TEMPLATE(domain, err)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: err + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_configuration', config_configuration) + + if(config_configuration .ne. trim('TEMPLATE')) return + + ! Setup configuration + + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_TEMPLATE!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_TEMPLATE +! +!> \brief Validation for baroclinic channel test case +!> \author Doug Jacobsen +!> \date 03/23/2015 +!> \details +!> This routine validates the configuration options for the baroclinic channel test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_TEMPLATE(configPool, packagePool, err)!{{{ + + !-------------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: configPool, packagePool + + integer, intent(out) :: err + + character (len=StrKIND), pointer :: config_configuration + integer, pointer :: config_vert_levels, config_TEMPLATE_vert_levels + + err = 0 + + call mpas_pool_get_config(configPool, 'config_configuration', config_configuration) + + if(config_configuration .ne. trim('TEMPLATE')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_TEMPLATE_vert_levels', config_TEMPLATE_vert_levels) + + if(config_vert_levels <= 0 .and. config_TEMPLATE_vert_levels > 0) then + config_vert_levels = config_TEMPLATE_vert_levels + else if (config_vert_levels <= 0) then + write(stderrUnit,*) 'ERROR: Validation failed for TEMPLATE. Not given a usable value for vertical levels.' + err = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_TEMPLATE!}}} + + +!*********************************************************************** + +end module ocn_init_TEMPLATE + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cell_markers.F b/src/core_ocean/mode_init/mpas_ocn_init_cell_markers.F new file mode 100644 index 0000000000..c23eae1aad --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_cell_markers.F @@ -0,0 +1,301 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_cell_markers +! +!> \brief MPAS ocean cell marker +!> \author Doug Jacobsen +!> \date 03/20/2015 +!> \details +!> This module contains the routines for marking +!> cells for removing +! +!----------------------------------------------------------------------- +module ocn_init_cell_markers + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + use mpas_timer + + use ocn_constants + + implicit none + private + + public :: ocn_mark_north_boundary, ocn_mark_south_boundary + public :: ocn_mark_east_boundary, ocn_mark_west_boundary + public :: ocn_mark_maxlevelcell + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + + !*********************************************************************** + ! + ! routine ocn_mark_north_boundary + ! + !> \brief North boundary marker + !> \author Doug Jacobsen + !> \date 03/30/2015 + !> \details + !> This routine marks cells along the north boundary of a domain for removal. + !> It can only be applied to a planar mesh. North-south is defined as the y direction. + ! + !----------------------------------------------------------------------- + subroutine ocn_mark_north_boundary(meshPool, yMax, edgeMin, iErr)!{{{ + implicit none + + type (mpas_pool_type), intent(in) :: meshPool + real (kind=RKIND), intent(in) :: yMax + real (kind=RKIND), intent(in) :: edgeMin + integer, intent(out) :: iErr + + real (kind=RKIND), dimension(:), pointer :: yCell + integer, dimension(:), pointer :: cullCell + + logical, pointer :: on_a_sphere + integer, pointer :: nCells + + integer :: iCell + integer :: count + + iErr = 0 + + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + + if ( on_a_sphere ) write(stderrUnit, *) 'WARNING: Can only mark north boundaries of planar meshes. Skipping marking of cells...' + + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'cullCell', cullCell) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + count = 0 + + if ( associated(cullCell) ) then + do iCell = 1, nCells + if ( yCell(iCell) > yMax - 0.8_RKIND * edgeMin ) then + cullCell(iCell) = 1 + count = count + 1 + end if + end do + end if + + end subroutine ocn_mark_north_boundary!}}} + + !*********************************************************************** + ! + ! routine ocn_mark_south_boundary + ! + !> \brief south boundary marker + !> \author Doug Jacobsen + !> \date 03/30/2015 + !> \details + !> This routine marks cells along the south boundary of a domain for removal. + !> It can only be applied to a planar mesh. north-south is defined as the y direction. + ! + !----------------------------------------------------------------------- + subroutine ocn_mark_south_boundary(meshPool, yMin, edgeMin, iErr)!{{{ + implicit none + + type (mpas_pool_type), intent(in) :: meshPool + real (kind=RKIND), intent(in) :: yMin + real (kind=RKIND), intent(in) :: edgeMin + integer, intent(out) :: iErr + + real (kind=RKIND), dimension(:), pointer :: yCell + integer, dimension(:), pointer :: cullCell + + logical, pointer :: on_a_sphere + integer, pointer :: nCells + + integer :: iCell + + iErr = 0 + + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + + if ( on_a_sphere ) write(stderrUnit, *) 'WARNING: Can only mark north boundaries of planar meshes. Skipping marking of cells...' + + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'cullCell', cullCell) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + if ( associated(cullCell) ) then + do iCell = 1, nCells + if ( yCell(iCell) < yMin + 0.8_RKIND * edgeMin ) then + cullCell(iCell) = 1 + end if + end do + end if + + end subroutine ocn_mark_south_boundary!}}} + + !*********************************************************************** + ! + ! routine ocn_mark_east_boundary + ! + !> \brief East boundary marker + !> \author Doug Jacobsen + !> \date 03/30/2015 + !> \details + !> This routine marks cells along the east boundary of a domain for removal. + !> It can only be applied to a planar mesh. west-east is defined as the x direction. + ! + !----------------------------------------------------------------------- + subroutine ocn_mark_east_boundary(meshPool, xMax, edgeMin, iErr)!{{{ + implicit none + + type (mpas_pool_type), intent(in) :: meshPool + real (kind=RKIND), intent(in) :: xMax + real (kind=RKIND), intent(in) :: edgeMin + integer, intent(out) :: iErr + + real (kind=RKIND), dimension(:), pointer :: xCell + integer, dimension(:), pointer :: cullCell + + logical, pointer :: on_a_sphere + integer, pointer :: nCells + + integer :: iCell + + iErr = 0 + + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + + if ( on_a_sphere ) write(stderrUnit, *) 'WARNING: Can only mark north boundaries of planar meshes. Skipping marking of cells...' + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'cullCell', cullCell) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + if ( associated(cullCell) ) then + do iCell = 1, nCells + if ( xCell(iCell) > xMax - 0.8_RKIND * edgeMin ) then + cullCell(iCell) = 1 + end if + end do + end if + + end subroutine ocn_mark_east_boundary!}}} + + !*********************************************************************** + ! + ! routine ocn_mark_west_boundary + ! + !> \brief West boundary marker + !> \author Doug Jacobsen + !> \date 03/30/2015 + !> \details + !> This routine marks cells along the west boundary of a domain for removal. + !> It can only be applied to a planar mesh. west-east is defined as the x direction. + ! + !----------------------------------------------------------------------- + subroutine ocn_mark_west_boundary(meshPool, xMin, edgeMin, iErr)!{{{ + implicit none + + type (mpas_pool_type), intent(in) :: meshPool + real (kind=RKIND), intent(in) :: xMin + real (kind=RKIND), intent(in) :: edgeMin + integer, intent(out) :: iErr + + real (kind=RKIND), dimension(:), pointer :: xCell + integer, dimension(:), pointer :: cullCell + + logical, pointer :: on_a_sphere + integer, pointer :: nCells + + integer :: iCell + + iErr = 0 + + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + + if ( on_a_sphere ) write(stderrUnit, *) 'WARNING: Can only mark north boundaries of planar meshes. Skipping marking of cells...' + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'cullCell', cullCell) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + if ( associated(cullCell) ) then + do iCell = 1, nCells + if ( xCell(iCell) < xMin + 0.8_RKIND * edgeMin ) then + cullCell(iCell) = 1 + end if + end do + end if + + end subroutine ocn_mark_west_boundary!}}} + + !*********************************************************************** + ! + ! routine ocn_mark_maxlevelcell + ! + !> \brief MaxLevelCell cell marker + !> \author Doug Jacobsen + !> \date 03/31/2015 + !> \details + !> This routine marks cells for removal that have maxLevelCell <= 0. + ! + !----------------------------------------------------------------------- + subroutine ocn_mark_maxlevelcell(meshPool, iErr)!{{{ + implicit none + + type (mpas_pool_type), intent(in) :: meshPool + integer, intent(out) :: iErr + + integer, dimension(:), pointer :: cullCell, maxLevelCell + + logical, pointer :: on_a_sphere + + integer, pointer :: nCells + + integer :: iCell + + iErr = 0 + + call mpas_pool_get_array(meshPool, 'cullCell', cullCell) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + if ( associated(cullCell) ) then + do iCell = 1, nCells + if ( maxLevelCell(iCell) <= 0 ) then + cullCell(iCell) = 1 + end if + end do + end if + + end subroutine ocn_mark_maxlevelcell!}}} + +!*********************************************************************** + +end module ocn_init_cell_markers + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F new file mode 100644 index 0000000000..3beae566d7 --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -0,0 +1,317 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_mode +! +!> \brief Main driver for MPAS ocean core +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This module contains initialization and timestep drivers for +!> the MPAS ocean core. +! +!----------------------------------------------------------------------- + +module ocn_init_mode + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use mpas_stream_manager + use mpas_timekeeping + use mpas_dmpar + use mpas_timer + use mpas_io_units + use mpas_constants + use mpas_decomp + + use ocn_init_routines + + use ocn_constants + + use ocn_init_spherical_utils + + !use ocn_init_TEMPLATE + + implicit none + private + + public :: ocn_init_mode_init, ocn_init_mode_run, ocn_init_mode_finalize + public :: ocn_init_mode_setup_clock, ocn_init_mode_validate_configuration + + type (timer_node), pointer :: globalDiagTimer, timeIntTimer, testSuiteTimer + + contains + +!*********************************************************************** +! +! function ocn_init_mode_init +! +!> \brief Initialize MPAS-Ocean core in init mode +!> \author Doug Jacobsen +!> \date 06/15/2015 +!> \details +!> This function calls all initializations required to start MPAS-Ocean in +!> init mode. +! +!----------------------------------------------------------------------- + + function ocn_init_mode_init(domain, startTimeStamp) result(ierr)!{{{ + + type (domain_type), intent(inout) :: domain + character(len=*), intent(out) :: startTimeStamp + integer :: ierr + + real (kind=RKIND) :: dt + type (block_type), pointer :: block + + integer :: err_tmp + integer, pointer :: nVertLevels + real (kind=RKIND) :: maxDensity, maxDensity_global + real (kind=RKIND), dimension(:), pointer :: meshDensity + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: diagnosticsPool + + character (len=StrKIND), pointer :: xtime + type (MPAS_Time_Type) :: startTime + type (MPAS_TimeInterval_type) :: timeStep + + logical, pointer :: config_do_restart, config_filter_btr_mode, config_conduct_tests + logical, pointer :: config_write_stats_on_startup + character (len=StrKIND), pointer :: config_vert_coord_movement, config_pressure_gradient_type + real (kind=RKIND), pointer :: config_maxMeshDensity + + ierr = 0 + + ! + ! Set startTimeStamp based on the start time of the simulation clock + ! + startTime = mpas_get_clock_time(domain % clock, MPAS_START_TIME, err_tmp) + call mpas_get_time(startTime, dateTimeString=startTimeStamp) + ierr = ior(ierr, err_tmp) + + ! Setup ocean config pool + call ocn_constants_init(domain % configs, domain % packages) + + if ( ierr /= 0 ) then + call mpas_dmpar_global_abort("ERROR: Failed validation...") + end if + + ! + ! Read input data for model + ! + call mpas_timer_start('io_read', .false.) + call MPAS_stream_mgr_read(domain % streamManager, streamID='input_init', ierr=err_tmp) + call mpas_timer_stop('io_read') + + call mpas_timer_start('reset_io_alarms', .false.) + call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID='input_init', ierr=err_tmp) + call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) + call mpas_timer_stop('reset_io_alarms') + + ! + ! Initialize core + ! + timeStep = mpas_get_clock_timestep(domain % clock, ierr=err_tmp) + call mpas_get_timeInterval(timeStep, dt=dt) + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_array(diagnosticsPool, 'xtime', xtime) + xtime = startTimeStamp + block => block % next + end do + + ! Expand sphere if it needs to be expanded + call ocn_init_expand_sphere(domain, domain % streamManager, a, ierr) + + end function ocn_init_mode_init!}}} + +!*********************************************************************** +! +! function ocn_init_mode_setup_clock +! +!> \brief Setup MPAS-Ocean clock +!> \author Doug Jacobsen +!> \date 06/15/2015 +!> \details +!> This function initializes the MPAS-Ocean clock for the init mode. +! +!----------------------------------------------------------------------- + function ocn_init_mode_setup_clock(core_clock, configs) result(ierr)!{{{ + + implicit none + + type (MPAS_Clock_type), intent(inout) :: core_clock + type (mpas_pool_type), intent(inout) :: configs + integer :: ierr + + type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime + type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep + character(len=StrKIND) :: restartTimeStamp + character(len=StrKIND), pointer :: config_start_time, config_stop_time, config_run_duration + character(len=StrKIND), pointer :: config_dt, config_restart_timestamp_name + integer :: err_tmp + + ierr = 0 + + call mpas_pool_get_config(configs, 'config_dt', config_dt) + call mpas_pool_get_config(configs, 'config_start_time', config_start_time) + call mpas_pool_get_config(configs, 'config_stop_time', config_stop_time) + call mpas_pool_get_config(configs, 'config_run_duration', config_run_duration) + call mpas_pool_get_config(configs, 'config_restart_timestamp_name', config_restart_timestamp_name) + + call mpas_set_time(startTime, dateTimeString=config_start_time, ierr=err_tmp) + call mpas_set_timeInterval(timeStep, timeString=config_dt, ierr=err_tmp) + if (trim(config_run_duration) /= "none") then + call mpas_set_timeInterval(runDuration, timeString=config_run_duration, ierr=err_tmp) + call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=err_tmp) + + if (trim(config_stop_time) /= "none") then + call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=err_tmp) + if(startTime + runduration /= stopTime) then + write(stderrUnit,*) 'Warning: config_run_duration and config_stop_time are inconsitent: using config_run_duration.' + end if + end if + else if (trim(config_stop_time) /= "none") then + call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=err_tmp) + call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=err_tmp) + else + write(stderrUnit, *) ' Warning: config_run_duration and config_start_time were "none", setting run duration to 1 second.' + call mpas_set_timeInterval(runDuration, timeString="0000_00:00:01", ierr=err_tmp) + call mpas_create_clock(core_clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=err_tmp) + end if + + end function ocn_init_mode_setup_clock!}}} + +!*********************************************************************** +! +! function ocn_init_mode_run +! +!> \brief MPAS-Ocean init mode run step +!> \author Doug Jacobsen +!> \date 06/15/2015 +!> \details +!> This function sets up the initial configuration using the MPAS-Ocean init +!> mode. +! +!----------------------------------------------------------------------- + + function ocn_init_mode_run(domain) result(iErr)!{{{ + + type (domain_type), intent(inout) :: domain + integer :: iErr + + integer :: itimestep + real (kind=RKIND) :: dt + type (block_type), pointer :: block_ptr + + type (MPAS_Time_Type) :: currTime + character(len=StrKIND) :: timeStamp + + type (mpas_pool_type), pointer :: averagePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: forcingPool + + type (MPAS_timeInterval_type) :: timeStep + + character (len=StrKIND), pointer :: config_init_configuration + + ierr = 0 + + ! Eventually, dt should be domain specific + timeStep = mpas_get_clock_timestep(domain % clock, ierr=ierr) + call mpas_get_timeInterval(timeStep, dt=dt) + + currTime = mpas_get_clock_time(domain % clock, MPAS_NOW, ierr) + call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr) + + call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) + write(stderrUnit, *) ' Generating configuration: ' // trim(config_init_configuration) + + !call ocn_init_setup_TEMPLATE(domain, ierr) + + call mpas_timer_start('io_write', .false.) + call mpas_stream_mgr_write(domain % streamManager, streamID='output_init', forceWriteNow=.true., ierr=ierr) + call mpas_timer_stop('io_write') + call mpas_timer_start('reset_io_alarms', .false.) + call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) + call mpas_timer_stop('reset_io_alarms') + + end function ocn_init_mode_run!}}} + +!*********************************************************************** +! +! function ocn_init_mode_finalize +! +!> \brief MPAS-Ocean init mode run step +!> \author Doug Jacobsen +!> \date 06/15/2015 +!> \details +!> This function sets up the initial configuration using the MPAS-Ocean init +!> mode. +! +!----------------------------------------------------------------------- + + function ocn_init_mode_finalize(domain) result(iErr)!{{{ + + type (domain_type), intent(inout) :: domain + integer :: ierr + + iErr = 0 + + call mpas_destroy_clock(domain % clock, ierr) + + call mpas_decomp_destroy_decomp_list(domain % decompositions) + + end function ocn_init_mode_finalize!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_configuration +! +!> \brief Configuration validation routine +!> \author Doug Jacobsen +!> \date 03/20/2015 +!> \details +!> This routine is used to validate the namelist options against the +!> configuration definition. It will call the validate routines for each of the +!> configurations to ensure namelist options are set in a valid way. +! +!----------------------------------------------------------------------- + subroutine ocn_init_mode_validate_configuration(configPool, packagePool, iErr)!{{{ + + type (mpas_pool_type), intent(inout) :: configPool !< Input: Pool with namelist options + type (mpas_pool_type), intent(inout) :: packagePool !< Input: Pool with packages + integer, intent(out) :: iErr !< Output: Error core + + logical, pointer :: cullCellsActive + + logical, pointer :: config_write_cull_cell_mask + + integer :: err_tmp + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_write_cull_cell_mask', config_write_cull_cell_mask) + call mpas_pool_get_package(packagePool, 'cullCellsActive', cullCellsActive) + + if ( config_write_cull_cell_mask ) then + cullCellsActive = .true. + end if + + ! call ocn_config_TEMPLATE_validate(configPool, iErr=err_tmp) + ! iErr = ior(iErr, err_tmp) + end subroutine ocn_init_mode_validate_configuration!}}} + +end module ocn_init_mode + +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_spherical_utils.F b/src/core_ocean/mode_init/mpas_ocn_init_spherical_utils.F new file mode 100644 index 0000000000..ed911e1c0b --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_spherical_utils.F @@ -0,0 +1,579 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_spherical_utils +! +!> \brief MPAS ocean spherical utilities +!> \author Doug Jacobsen +!> \date 03/20/2015 +!> \details +!> This module contains the routines for updating mesh quantities based on a spherical radius +! +!----------------------------------------------------------------------- + +module ocn_init_spherical_utils + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + use mpas_stream_manager + + implicit none + private + + public :: ocn_init_expand_sphere, ocn_transform_from_lonlat_to_xyz + public :: transform_from_xyz_to_lonlat, ocn_unit_vector_in_3space + public :: ocn_vector_on_tangent_plane, ocn_cross_product_in_3space + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_expand_sphere +! +!> \brief MPAS-Ocean Spherical Expansion Routine +!> \author Doug Jacobsen +!> \date 03/20/2015 +!> \details +!> This routine expands mesh quantities to sphere of radius newRadius. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_expand_sphere(domain, stream_manager, newRadius, err)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + type (mpas_streamManager_type), intent(inout) :: stream_manager + real (kind=RKIND), intent(in) :: newRadius + integer, intent(out) :: err + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool + + character (len=StrKIND) :: streamID + integer :: directionProperty + + logical, pointer :: config_expand_sphere, config_realistic_coriolis_parameter + logical, pointer :: on_a_sphere + real (kind=RKIND), pointer :: sphere_radius + + integer, pointer :: nCells, nCellsSolve, nEdgesSolve, nVerticesSolve, vertexDegree + + integer, dimension(:, :), pointer :: cellsOnVertex + + real (kind=RKIND), dimension(:), pointer :: areaCell, areaTriangle + real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge + real (kind=RKIND), dimension(:), pointer :: fCell, fEdge, fVertex + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, latCell, lonCell + real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge, latEdge, lonEdge + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex, latVertex, lonVertex + real (kind=RKIND), dimension(:, :), pointer :: kiteAreasOnVertex + + real (kind=RKIND) :: oldRadius, ratio + real (kind=RKIND) :: norm + real (kind=RKIND) :: oldX, oldY, oldZ + integer :: iCell, iEdge, iVertex, i + + err = 0 + + call mpas_pool_get_config(domain % configs, 'config_expand_sphere', config_expand_sphere) + + if ( .not. config_expand_sphere ) return + + call mpas_pool_get_config(domain % configs, 'config_realistic_coriolis_parameter', config_realistic_coriolis_parameter) + + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(meshPool, 'sphere_radius', sphere_radius) + + if ( .not. on_a_sphere ) then + write(stderrUnit, *) 'Warning: Only spherical meshes can been expanded.' + write(stderrUnit, *) 'Skipping expansion' + return + end if + + if ( sphere_radius == 0.0_RKIND ) then + write(stderrUnit, *) 'ERROR: Sphere radius is 0.0' + err = 1 + return + end if + + write(stderrUnit, *) 'Expanding mesh to a radius of size: ', newRadius, 'm' + + call mpas_stream_mgr_begin_iteration(stream_manager) + do while (mpas_stream_mgr_get_next_stream(stream_manager, streamID, directionProperty)) + if ( directionProperty == MPAS_STREAM_OUTPUT .or. directionProperty == MPAS_STREAM_INPUT_OUTPUT ) then + call mpas_stream_mgr_add_att(stream_manager, 'sphere_radius', newRadius, streamID) + end if + end do + + oldRadius = sphere_radius + ratio = newRadius / oldRadius + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + ! Expand cell quantities + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nVerticesSolve', nVerticesSolve) + call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'fCell', fCell) + + call mpas_pool_get_array(meshPool, 'xEdge', xEdge) + call mpas_pool_get_array(meshPool, 'yEdge', yEdge) + call mpas_pool_get_array(meshPool, 'zEdge', zEdge) + call mpas_pool_get_array(meshPool, 'latEdge', latEdge) + call mpas_pool_get_array(meshPool, 'lonEdge', lonEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + call mpas_pool_get_array(meshPool, 'latVertex', latVertex) + call mpas_pool_get_array(meshPool, 'lonVertex', lonVertex) + call mpas_pool_get_array(meshPool, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(meshPool, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(meshPool, 'fVertex', fVertex) + + do iCell = 1, nCellsSolve + oldX = xCell(iCell) + oldY = yCell(iCell) + oldZ = zCell(iCell) + + norm = sqrt(oldX**2 + oldY**2 + oldZ**2) + + xCell(iCell) = (oldX / norm) * newRadius + yCell(iCell) = (oldY / norm) * newRadius + zCell(iCell) = (oldZ / norm) * newRadius + areaCell(iCell) = (areaCell(iCell) / (oldRadius**2) )* newRadius**2 + + if(config_realistic_coriolis_parameter) then + fCell(iCell) = 2.0_RKIND * omega * sin(latCell(iCell)) + end if + end do + + ! Expand vertex quantities + do iVertex = 1, nVerticesSolve + oldX = xVertex(iVertex) + oldY = yVertex(iVertex) + oldZ = zVertex(iVertex) + + norm = sqrt(oldX**2 + oldY**2 + oldZ**2) + + xVertex(iVertex) = (oldX / norm) * newRadius + yVertex(iVertex) = (oldY / norm) * newRadius + zVertex(iVertex) = (oldZ / norm) * newRadius + areaTriangle(iVertex) = 0.0_RKIND + + do i = 1, vertexDegree + if (cellsOnVertex(i, iVertex) < nCells+1) then + kiteAreasOnVertex(i, iVertex) = ( kiteAreasOnVertex(i, iVertex) / oldRadius**2) * newRadius**2 + else + kiteAreasOnVertex(i, iVertex) = 0.0_RKIND + end if + areaTriangle(iVertex) = areaTriangle(iVertex) + kiteAreasOnVertex(i, iVertex) + end do + + if(config_realistic_coriolis_parameter) then + fVertex(iVertex) = 2.0_RKIND * omega * sin( latVertex(iVertex) ) + end if + end do + + ! Expand edge quantities + do iEdge = 1, nEdgesSolve + oldX = xEdge(iEdge) + oldY = yEdge(iEdge) + oldZ = zEdge(iEdge) + + norm = sqrt(oldX**2 + oldY**2 + oldZ**2) + + xEdge(iEdge) = (oldX / norm) * newRadius + yEdge(iEdge) = (oldY / norm) * newRadius + zEdge(iEdge) = (oldZ / norm) * newRadius + dvEdge(iEdge) = (dvEdge(iEdge) / oldRadius) * newRadius + dcEdge(iEdge) = (dcEdge(iEdge) / oldRadius) * newRadius + + if(config_realistic_coriolis_parameter) then + fEdge(iEdge) = 2.0_RKIND * omega * sin( latEdge(iEdge) ) + end if + end do + + block_ptr % domain % sphere_radius = newRadius + block_ptr => block_ptr % next + end do + + !-------------------------------------------------------------------- + + end subroutine ocn_init_expand_sphere!}}} + +!*********************************************************************** +! +! routine ocn_transform_from_lonlat_to_xyz +! +!> \brief MPAS-Ocean Tranform LatLon to XYZ +!> \author Todd Ringler +!> \date 02/19/2014 +!> \details +!> This routine converts a (lat, lon) coordinate into an (x, y, z) coordinate +!> INTENT(IN) +!> xin = x position +!> yin = y position +!> zin = z position +!> ulon = east component of vector +!> ulat = north component of vector +!> +!> INTENT(OUT) +!> ux = x component of vector +!> uy = y component of vector +!> uz = z component of vector +! +!----------------------------------------------------------------------- + subroutine ocn_transform_from_lonlat_to_xyz(xin, yin, zin, ulon, ulat, ux, uy, uz)!{{{ + implicit none + real, intent(in) :: xin, yin, zin, ulon, ulat + real, intent(out) :: ux, uy, uz + real :: h(3,3), p(3), q(3), g(3), X1(3,3), X2(3,3), trans_X2_to_X1(3,3), r + integer :: i,j,k + logical :: l_Pole + real, parameter :: epsvt = 1.0e-10 + + !----------------------------------------------------------------------- + ! define the e1, e2, and e3 directions + !----------------------------------------------------------------------- + X1(1,1) = 1.0_RKIND; X1(1,2) = 0.0_RKIND; X1(1,3) = 0.0_RKIND + X1(2,1) = 0.0_RKIND; X1(2,2) = 1.0_RKIND; X1(2,3) = 0.0_RKIND + X1(3,1) = 0.0_RKIND; X1(3,2) = 0.0_RKIND; X1(3,3) = 1.0_RKIND + + !----------------------------------------------------------------------- + ! find the vectors (measured in X1) that point in the local + ! east (h(1,:)), north (h(2,:)), and vertical (h(3,:)) direction + !----------------------------------------------------------------------- + h(3,1) = xin; h(3,2) = yin; h(3,3) = zin + call ocn_unit_vector_in_3space(h(3,:)) + + !----------------------------------------------------------------------- + ! g(:) is a work array and holds the vector pointing to the North Pole. + ! measured in X1 + !----------------------------------------------------------------------- + g(:) = X1(3,:) + + !----------------------------------------------------------------------- + ! determine if the local vertical hits a pole + !----------------------------------------------------------------------- + l_Pole = .false. + r = g(1)*h(3,1) + g(2)*h(3,2) + g(3)*h(3,3) + r = abs(r) + epsvt + if(r.gt.1.0) then + l_Pole = .true. + h(3,:) = h(3,:) + epsvt + call ocn_unit_vector_in_3space(h(3,:)) + endif + + !----------------------------------------------------------------------- + ! find the vector that is perpendicular to the local vertical vector + ! and points in the direction of of the North pole, this defines the local + ! north direction. measured in X1 + !----------------------------------------------------------------------- + call ocn_vector_on_tangent_plane ( h(3,:), g(:), h(2,:) ) + + !----------------------------------------------------------------------- + ! take the cross product of the local North direction and the local vertical + ! to find the local east vector. still in X1 + !----------------------------------------------------------------------- + call ocn_cross_product_in_3space ( h(2,:), h(3,:), h(1,:) ) + + !----------------------------------------------------------------------- + ! put these 3 vectors into a matrix X2 + !----------------------------------------------------------------------- + X2(1,:) = h(1,:) ! local east (measured in X1) + X2(2,:) = h(2,:) ! local north (measured in X1) + X2(3,:) = h(3,:) ! local vertical (measured in X1) + + !----------------------------------------------------------------------- + ! compute the transformation matrix + !----------------------------------------------------------------------- + trans_X2_to_X1(:,:) = matmul(X1,transpose(X2)) + + !----------------------------------------------------------------------- + ! transform (ulon, ulat) into (x,y,z) + !----------------------------------------------------------------------- + p(1) = ulon; p(2) = ulat; p(3) = 0 + g(:) = matmul(trans_X2_to_X1(:, :), p(:)) + ux = g(1); uy = g(2); uz = g(3) + + end subroutine ocn_transform_from_lonlat_to_xyz!}}} + +!*********************************************************************** +! +! routine ocn_transform_from_xyz_to_lonlat +! +!> \brief MPAS-Ocean transform XYZ to LatLon +!> \author Todd Ringler +!> \date 02/19/2014 +!> \details +!> This routine converts an (x, y, z) coordinate into a (lat, lon) coordinate +!> INTENT(IN) +!> xin = x position +!> yin = y position +!> zin = z position +!> ux = x component of vector +!> uy = y component of vector +!> uz = z component of vector +!> +!> INTENT(OUT) +!> ulon = east component of vector +!> ulat = north component of vector +! +!----------------------------------------------------------------------- + subroutine transform_from_xyz_to_lonlat(xin, yin, zin, ux, uy, uz, ulon, ulat)!{{{ + implicit none + real, intent(in) :: xin, yin, zin, ux, uy, uz + real, intent(out) :: ulon, ulat + real :: h(3,3), p(3), q(3), g(3), X1(3,3), X2(3,3), trans_X1_to_X2(3,3), r + integer :: i,j,k + logical :: l_Pole + real, parameter :: epsvt = 1.0e-10 + + !----------------------------------------------------------------------- + ! define the e1, e2, and e3 directions + !----------------------------------------------------------------------- + X1(1,1) = 1.0_RKIND; X1(1,2) = 0.0_RKIND; X1(1,3) = 0.0_RKIND + X1(2,1) = 0.0_RKIND; X1(2,2) = 1.0_RKIND; X1(2,3) = 0.0_RKIND + X1(3,1) = 0.0_RKIND; X1(3,2) = 0.0_RKIND; X1(3,3) = 1.0_RKIND + + !----------------------------------------------------------------------- + ! find the vectors (measured in X1) that point in the local + ! east (h(1,:)), north (h(2,:)), and vertical (h(3,:)) direction + !----------------------------------------------------------------------- + h(3,1) = xin; h(3,2) = yin; h(3,3) = zin + call ocn_unit_vector_in_3space(h(3,:)) + + !----------------------------------------------------------------------- + ! g(:) is a work array and holds the vector pointing to the North Pole. + ! measured in X1 + !----------------------------------------------------------------------- + g(:) = X1(3,:) + + !----------------------------------------------------------------------- + ! determine if the local vertical hits a pole + !----------------------------------------------------------------------- + l_Pole = .false. + r = g(1)*h(3,1) + g(2)*h(3,2) + g(3)*h(3,3) + r = abs(r) + epsvt + if(r.gt.1.0) then + l_Pole = .true. + h(3,:) = h(3,:) + epsvt + call ocn_unit_vector_in_3space(h(3,:)) + endif + + !----------------------------------------------------------------------- + ! find the vector that is perpendicular to the local vertical vector + ! and points in the direction of of the North pole, this defines the local + ! north direction. measured in X1 + !----------------------------------------------------------------------- + call ocn_vector_on_tangent_plane ( h(3,:), g(:), h(2,:) ) + + !----------------------------------------------------------------------- + ! take the cross product of the local North direction and the local vertical + ! to find the local east vector. still in X1 + !----------------------------------------------------------------------- + call ocn_cross_product_in_3space ( h(2,:), h(3,:), h(1,:) ) + + !----------------------------------------------------------------------- + ! put these 3 vectors into a matrix X2 + !----------------------------------------------------------------------- + X2(1,:) = h(1,:) ! local east (measured in X1) + X2(2,:) = h(2,:) ! local north (measured in X1) + X2(3,:) = h(3,:) ! local vertical (measured in X1) + + !----------------------------------------------------------------------- + ! compute the transformation matrix + !----------------------------------------------------------------------- + trans_X1_to_X2(:,:) = matmul(X2,transpose(X1)) + + !----------------------------------------------------------------------- + ! transform (ulon, ulat) into (x,y,z) + !----------------------------------------------------------------------- + p(1) = ux; p(2) = uy; p(3) = uz + g(:) = matmul(trans_X1_to_X2(:, :), p(:)) + ulon = g(1); ulat= g(2); + + end subroutine transform_from_xyz_to_lonlat!}}} + +!*********************************************************************** +! +! routine ocn_unit_vector_in_3space +! +!> \brief MPAS-Ocean 3D unit vector +!> \author Todd Ringler +!> \date 02/19/2014 +!> \details +!> This routine normalizes a vector in 3space. +! +!----------------------------------------------------------------------- + subroutine ocn_unit_vector_in_3space (p_1)!{{{ + + !----------------------------------------------------------------------- + ! PURPOSE : normalize p_1 to unit length and overwrite p_1 + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + ! intent(inout) + !----------------------------------------------------------------------- + real , intent(inout) :: & + p_1 (:) + + !----------------------------------------------------------------------- + ! local + !----------------------------------------------------------------------- + real :: length + + length = SQRT (p_1(1)**2 + p_1(2)**2 + p_1(3)**2 ) + length = 1.0_RKIND/length + p_1(1) = p_1(1)*length + p_1(2) = p_1(2)*length + p_1(3) = p_1(3)*length + + end subroutine ocn_unit_vector_in_3space!}}} + +!*********************************************************************** +! +! routine ocn_vector_on_tangent_plane +! +!> \brief MPAS-Ocean Vector on a tangent plane +!> \author Todd Ringler +!> \date 02/19/2014 +!> \details +!> Given two points measured in (x,y,z) and lying on +!> the unit sphere, find the vector (p_out) that lies on the plane +!> perpendicular to the p_1 vector and points in the direction of +!> the projection of p_2 onto the tangent plane. +!> +!> NOTE : p_1 and p_2 are assumed to be of unit length +!> NOTE : p_out is normalized to unit length +! +!----------------------------------------------------------------------- + subroutine ocn_vector_on_tangent_plane(p_1, p_2, p_out)!{{{ +!----------------------------------------------------------------------- +! intent(in) +!----------------------------------------------------------------------- + real , intent(in) :: & + p_1 (:), & + p_2 (:) + +!----------------------------------------------------------------------- +! intent(out) +!----------------------------------------------------------------------- + real , intent(out) :: & + p_out (:) + +!----------------------------------------------------------------------- +! local +!----------------------------------------------------------------------- + real :: & + work (3), t1(3), t2(3) + +! work (1) = - p_1(2) * ( -p_1(2) * p_2(1) + p_1(1) * p_2(2) ) & +! + p_1(3) * ( p_1(3) * p_2(1) - p_1(1) * p_2(3) ) + +! work (2) = + p_1(1) * ( -p_1(2) * p_2(1) + p_1(1) * p_2(2) ) & +! - p_1(3) * ( -p_1(3) * p_2(2) + p_1(2) * p_2(3) ) + +! work (3) = - p_1(1) * ( p_1(3) * p_2(1) - p_1(1) * p_2(3) ) & +! + p_1(2) * ( -p_1(3) * p_2(2) + p_1(2) * p_2(3) ) + + + t1(:) = p_2(:) - p_1(:) + t2(:) = p_1 + + call ocn_unit_vector_in_3space (t1) + call ocn_unit_vector_in_3space (t2) + + call ocn_cross_product_in_3space(t1(:), t2(:), work(:)) + call ocn_unit_vector_in_3space (work) + call ocn_cross_product_in_3space(t2(:),work(:),p_out(:)) + call ocn_unit_vector_in_3space (p_out) + + end subroutine ocn_vector_on_tangent_plane!}}} + +!*********************************************************************** +! +! routine ocn_cross_product_in_3space +! +!> \brief MPAS-Ocean Cross product in 3D +!> \author Todd Ringler +!> \date 02/19/2014 +!> \details +!> compute p_1 cross p_2 and place in p_out +! +!----------------------------------------------------------------------- + subroutine ocn_cross_product_in_3space(p_1,p_2,p_out)!{{{ +!----------------------------------------------------------------------- +! intent(in) +!----------------------------------------------------------------------- + real , intent(in) :: & + p_1 (:), & + p_2 (:) + +!----------------------------------------------------------------------- +! intent(out) +!----------------------------------------------------------------------- + real , intent(out) :: & + p_out (:) + + p_out(1) = p_1(2)*p_2(3)-p_1(3)*p_2(2) + p_out(2) = p_1(3)*p_2(1)-p_1(1)*p_2(3) + p_out(3) = p_1(1)*p_2(2)-p_1(2)*p_2(1) + + end subroutine ocn_cross_product_in_3space!}}} + +!*********************************************************************** + +end module ocn_init_spherical_utils + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F new file mode 100644 index 0000000000..e5b1079c12 --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F @@ -0,0 +1,296 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_vertical_grids +! +!> \brief MPAS ocean vertical grid generator +!> \author Doug Jacobsen +!> \date 03/20/2015 +!> \details +!> This module contains the routines for generating +!> vertical grids. +! +!----------------------------------------------------------------------- +module ocn_init_vertical_grids + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + use mpas_timer + + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_generate_vertical_grid + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + + !*********************************************************************** + ! + ! routine ocn_generate_vertical_grid + ! + !> \brief Vertical grid generator driver + !> \author Doug Jacobsen + !> \date 03/20/2015 + !> \details + !> This routine is a driver for generating vertical grids. It calls a private + !> module routine based on the value of the input argument gridType. + !> The output array layerInterfaces will contain values between 1 and 0 + !> representing the relative locations of layer interfaces. + ! + !----------------------------------------------------------------------- + subroutine ocn_generate_vertical_grid(gridType, layerInterfaces)!{{{ + implicit none + + character (len=*), intent(in) :: gridType + real (kind=RKIND), dimension(:), intent(out) :: layerInterfaces + + if ( trim(gridType) == 'uniform' ) then + call ocn_generate_uniform_vertical_grid(layerInterfaces) + else if ( trim(gridType) == '60layerPHC' ) then + call ocn_generate_60layerPHC_vertical_grid(layerInterfaces) + else if ( trim(gridType) == '42layerWOCE' ) then + call ocn_generate_42layerWOCE_vertical_grid(layerInterfaces) + else + write(stderrUnit, *) ' WARNING: '//trim(gridType)//' is an invalid vertical grid choice. No vertical grid will be generated.' + end if + + end subroutine ocn_generate_vertical_grid!}}} + + !*********************************************************************** + ! + ! routine ocn_generate_uniform_vertical_grid + ! + !> \brief Uniform Vertical grid generator + !> \author Doug Jacobsen + !> \date 03/20/2015 + !> \details + !> This routine generates a uniform vertical grid. + ! + !----------------------------------------------------------------------- + subroutine ocn_generate_uniform_vertical_grid(layerInterfaces)!{{{ + implicit none + + real (kind=RKIND), dimension(:), intent(out) :: layerInterfaces + + real (kind=RKIND) :: layerSpacing + integer :: nInterfaces, iInterface + + write(stderrUnit,* ) ' ---- Generating uniform vertical grid ---- ' + + nInterfaces = size(layerInterfaces, dim=1) + layerSpacing = 1.0_RKIND / (nInterfaces - 1) + + layerInterfaces(1) = 0.0_RKIND + + do iInterface = 2, nInterfaces + layerInterfaces(iInterface) = layerInterfaces(iInterface-1) + layerSpacing + end do + + end subroutine ocn_generate_uniform_vertical_grid!}}} + + !*********************************************************************** + ! + ! routine ocn_generate_60layerPHC_vertical_grid + ! + !> \brief 60 layer PHC vertical grid generator + !> \author Doug Jacobsen + !> \date 03/20/2015 + !> \details + !> This routine generates a 60 layer vertical grid based on the PHC data set. + ! + !----------------------------------------------------------------------- + subroutine ocn_generate_60layerPHC_vertical_grid(layerInterfaces)!{{{ + implicit none + + real (kind=RKIND), dimension(:), intent(out) :: layerInterfaces + + real (kind=RKIND) :: maxInterfaceLocation + integer :: nInterfaces, iInterface + + nInterfaces = size(layerInterfaces, dim=1) + + if ( nInterfaces /= 61 ) then + call mpas_dmpar_global_abort("ERROR: Vertical grid must have 60 layers to apply 60 Layer PHC grid. Exiting...") + end if + + layerInterfaces(1) = 0.0_RKIND + layerInterfaces(2) = 500_RKIND + layerInterfaces(3) = 1500_RKIND + layerInterfaces(4) = 2500_RKIND + layerInterfaces(5) = 3500_RKIND + layerInterfaces(6) = 4500_RKIND + layerInterfaces(7) = 5500_RKIND + layerInterfaces(8) = 6500_RKIND + layerInterfaces(9) = 7500_RKIND + layerInterfaces(10) = 8500_RKIND + layerInterfaces(11) = 9500_RKIND + layerInterfaces(12) = 10500_RKIND + layerInterfaces(13) = 11500_RKIND + layerInterfaces(14) = 12500_RKIND + layerInterfaces(15) = 13500_RKIND + layerInterfaces(16) = 14500_RKIND + layerInterfaces(17) = 15500_RKIND + layerInterfaces(18) = 16509.83984375_RKIND + layerInterfaces(19) = 17547.904296875_RKIND + layerInterfaces(20) = 18629.125_RKIND + layerInterfaces(21) = 19766.025390625_RKIND + layerInterfaces(22) = 20971.134765625_RKIND + layerInterfaces(23) = 22257.826171875_RKIND + layerInterfaces(24) = 23640.880859375_RKIND + layerInterfaces(25) = 25137.013671875_RKIND + layerInterfaces(26) = 26765.416015625_RKIND + layerInterfaces(27) = 28548.361328125_RKIND + layerInterfaces(28) = 30511.91796875_RKIND + layerInterfaces(29) = 32686.794921875_RKIND + layerInterfaces(30) = 35109.34375_RKIND + layerInterfaces(31) = 37822.75390625_RKIND + layerInterfaces(32) = 40878.4609375_RKIND + layerInterfaces(33) = 44337.765625_RKIND + layerInterfaces(34) = 48273.66796875_RKIND + layerInterfaces(35) = 52772.796875_RKIND + layerInterfaces(36) = 57937.28515625_RKIND + layerInterfaces(37) = 63886.2578125_RKIND + layerInterfaces(38) = 70756.328125_RKIND + layerInterfaces(39) = 78700.25_RKIND + layerInterfaces(40) = 87882.5234375_RKIND + layerInterfaces(41) = 98470.5859375_RKIND + layerInterfaces(42) = 110620.421875_RKIND + layerInterfaces(43) = 124456.6953125_RKIND + layerInterfaces(44) = 140049.71875_RKIND + layerInterfaces(45) = 157394.640625_RKIND + layerInterfaces(46) = 176400.328125_RKIND + layerInterfaces(47) = 196894.421875_RKIND + layerInterfaces(48) = 218645.65625_RKIND + layerInterfaces(49) = 241397.15625_RKIND + layerInterfaces(50) = 264900.125_RKIND + layerInterfaces(51) = 288938.46875_RKIND + layerInterfaces(52) = 313340.46875_RKIND + layerInterfaces(53) = 337979.375_RKIND + layerInterfaces(54) = 362767.0625_RKIND + layerInterfaces(55) = 387645.21875_RKIND + layerInterfaces(56) = 412576.84375_RKIND + layerInterfaces(57) = 437539.28125_RKIND + layerInterfaces(58) = 462519.0625_RKIND + layerInterfaces(59) = 487508.375_RKIND + layerInterfaces(60) = 512502.84375_RKIND + layerInterfaces(61) = 537500_RKIND + + maxInterfaceLocation = maxval(layerInterfaces) + + layerInterfaces(:) = layerInterfaces(:) / maxInterfaceLocation + + end subroutine ocn_generate_60layerPHC_vertical_grid!}}} + + !*********************************************************************** + ! + ! routine ocn_generate_42layerWOCE_vertical_grid + ! + !> \brief 42 layer WOCE vertical grid generator + !> \author Doug Jacobsen + !> \date 03/20/2015 + !> \details + !> This routine generates a 42 layer vertical grid based on the WOCE data set. + ! + !----------------------------------------------------------------------- + subroutine ocn_generate_42layerWOCE_vertical_grid(layerInterfaces)!{{{ + implicit none + + real (kind=RKIND), dimension(:), intent(out) :: layerInterfaces + + real (kind=RKIND) :: maxInterfaceLocation + integer :: nInterfaces, iInterface + + nInterfaces = size(layerInterfaces, dim=1) + + if ( nInterfaces /= 43 ) then + call mpas_dmpar_global_abort("ERROR: Vertical grid must have 60 layers to apply 60 Layer PHC grid. Exiting...") + end if + + layerInterfaces(1) = 0.0_RKIND + layerInterfaces(2) = 5.00622_RKIND + layerInterfaces(3) = 15.06873_RKIND + layerInterfaces(4) = 25.28343_RKIND + layerInterfaces(5) = 35.75849_RKIND + layerInterfaces(6) = 46.61269_RKIND + layerInterfaces(7) = 57.98099_RKIND + layerInterfaces(8) = 70.02139_RKIND + layerInterfaces(9) = 82.92409_RKIND + layerInterfaces(10) = 96.92413_RKIND + layerInterfaces(11) = 112.3189_RKIND + layerInterfaces(12) = 129.4936_RKIND + layerInterfaces(13) = 148.9582_RKIND + layerInterfaces(14) = 171.4044_RKIND + layerInterfaces(15) = 197.7919_RKIND + layerInterfaces(16) = 229.4842_RKIND + layerInterfaces(17) = 268.4617_RKIND + layerInterfaces(18) = 317.6501_RKIND + layerInterfaces(19) = 381.3864_RKIND + layerInterfaces(20) = 465.9132_RKIND + layerInterfaces(21) = 579.3073_RKIND + layerInterfaces(22) = 729.3513_RKIND + layerInterfaces(23) = 918.3723_RKIND + layerInterfaces(24) = 1139.153_RKIND + layerInterfaces(25) = 1378.574_RKIND + layerInterfaces(26) = 1625.7_RKIND + layerInterfaces(27) = 1875.106_RKIND + layerInterfaces(28) = 2125.011_RKIND + layerInterfaces(29) = 2375_RKIND + layerInterfaces(30) = 2624.999_RKIND + layerInterfaces(31) = 2874.999_RKIND + layerInterfaces(32) = 3124.999_RKIND + layerInterfaces(33) = 3374.999_RKIND + layerInterfaces(34) = 3624.999_RKIND + layerInterfaces(35) = 3874.999_RKIND + layerInterfaces(36) = 4124.999_RKIND + layerInterfaces(37) = 4374.999_RKIND + layerInterfaces(38) = 4624.999_RKIND + layerInterfaces(39) = 4874.999_RKIND + layerInterfaces(40) = 5124.999_RKIND + layerInterfaces(41) = 5374.999_RKIND + layerInterfaces(42) = 5624.999_RKIND + layerInterfaces(43) = 5874.999_RKIND + + maxInterfaceLocation = maxval(layerInterfaces) + + layerInterfaces(:) = layerInterfaces(:) / maxInterfaceLocation + + end subroutine ocn_generate_42layerWOCE_vertical_grid!}}} + + +!*********************************************************************** + +end module ocn_init_vertical_grids + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker From a61b64865dfd1e234302f3908f20cc9c77319931 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Fri, 3 Apr 2015 11:59:50 -0600 Subject: [PATCH 0091/1724] Adding the baroclinic channel configuration This commit adds the baroclinic channel configuration from Ilicak 2011. --- src/core_ocean/Makefile | 1 + src/core_ocean/mode_init/Makefile | 5 +- src/core_ocean/mode_init/Registry.xml | 1 + .../mode_init/Registry_baroclinic_channel.xml | 42 +++ .../mpas_ocn_init_baroclinic_channel.F | 351 ++++++++++++++++++ src/core_ocean/mode_init/mpas_ocn_init_mode.F | 6 +- 6 files changed, 404 insertions(+), 2 deletions(-) create mode 100644 src/core_ocean/mode_init/Registry_baroclinic_channel.xml create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index 6d547678ed..2ee37d8e1d 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -23,6 +23,7 @@ core_input_gen: (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.forward mode=forward ) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.analysis mode=analysis ) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init mode=init ) + (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.baroclinic_channel mode=init configuration=baroclinic_channel) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean stream_list.ocean. mutable ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.forward stream_list.ocean.forward. mutable mode=forward ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis ) diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile index bdf429c615..656fb6d513 100644 --- a/src/core_ocean/mode_init/Makefile +++ b/src/core_ocean/mode_init/Makefile @@ -6,7 +6,8 @@ UTILS = mpas_ocn_init_spherical_utils.o \ mpas_ocn_init_vertical_grids.o \ mpas_ocn_init_cell_markers.o -TEST_CASES = #mpas_ocn_init_TEMPLATE.o +TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ + #mpas_ocn_init_TEMPLATE.o all: init_mode @@ -20,6 +21,8 @@ mpas_ocn_init_spherical_utils.o: mpas_ocn_init_vertical_grids.o: +mpas_ocn_init_baroclinic_channel.o: $(UTILS) + #mpas_ocn_init_TEMPLATE.o: $(UTILS) clean: diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml index 8bcd4760fa..e6779a827a 100644 --- a/src/core_ocean/mode_init/Registry.xml +++ b/src/core_ocean/mode_init/Registry.xml @@ -1 +1,2 @@ +#include "Registry_baroclinic_channel.xml" // #include "Registry_TEMPLATE.xml" diff --git a/src/core_ocean/mode_init/Registry_baroclinic_channel.xml b/src/core_ocean/mode_init/Registry_baroclinic_channel.xml new file mode 100644 index 0000000000..1891bd2955 --- /dev/null +++ b/src/core_ocean/mode_init/Registry_baroclinic_channel.xml @@ -0,0 +1,42 @@ + + + + + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F b/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F new file mode 100644 index 0000000000..d340a3a8da --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F @@ -0,0 +1,351 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_baroclinic_channel +! +!> \brief MPAS ocean initialize case -- Baroclinic Channel +!> \author Doug Jacobsen +!> \date 02/18/2014 +!> \details +!> This module contains the routines for initializing the +!> the baroclinic channel test case +! +!----------------------------------------------------------------------- + +module ocn_init_baroclinic_channel + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + + use ocn_constants + use ocn_init_vertical_grids + use ocn_init_cell_markers + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_baroclinic_channel, & + ocn_init_validate_baroclinic_channel + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_baroclinic_channel +! +!> \brief Setup for baroclinic channel test case +!> \author Doug Jacobsen +!> \date 02/19/2014 +!> \details +!> This routine sets up the initial conditions for the baroclinic channel test case. +!> It should also ensure the mesh that was input is valid for the configuration. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_baroclinic_channel(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + real (kind=RKIND) :: yMin, yMax, xMin, xMax, dcEdgeMin, dcEdgeMinGlobal + real (kind=RKIND) :: yMinGlobal, yMaxGlobal, yMidGlobal, xMinGlobal, xMaxGlobal + real (kind=RKIND) :: temperature, yOffset, xPerturbationMin, xPerturbationMax + real (kind=RKIND) :: perturbationWidth + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: verticalMeshPool + + integer :: iCell, k, idx + + ! Define config variable pointers + character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid + logical, pointer :: config_baroclinic_channel_use_distances + real (kind=RKIND), pointer :: config_baroclinic_channel_gradient_width_dist, & + config_baroclinic_channel_gradient_width_frac, & + config_baroclinic_channel_bottom_depth, & + config_baroclinic_channel_surface_temperature, & + config_baroclinic_channel_bottom_temperature, & + config_baroclinic_channel_temperature_difference, & + config_baroclinic_channel_salinity, & + config_baroclinic_channel_coriolis_parameter + + ! Define dimension pointers + integer, pointer :: nCellsSolve, nEdgesSolve, nVertLevels, nVertLevelsP1 + integer, pointer :: index_temperature, index_salinity + + ! Define variable pointers + integer, dimension(:), pointer :: maxLevelCell + real (kind=RKIND), dimension(:), pointer :: xCell, yCell,refBottomDepth, refZMid, & + vertCoordMovementWeights, bottomDepth, & + fCell, fEdge, fVertex, dcEdge + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + + ! Define local interfaceLocations variable + real (kind=RKIND), dimension(:), pointer :: interfaceLocations + + logical, pointer :: on_a_sphere + + iErr = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('baroclinic_channel')) return + + call mpas_pool_get_config(ocnConfigs, 'config_vertical_grid', config_vertical_grid) + + call mpas_pool_get_config(ocnConfigs, 'config_baroclinic_channel_use_distances', config_baroclinic_channel_use_distances) + call mpas_pool_get_config(ocnConfigs, 'config_baroclinic_channel_gradient_width_dist', config_baroclinic_channel_gradient_width_dist) + call mpas_pool_get_config(ocnConfigs, 'config_baroclinic_channel_gradient_width_frac', config_baroclinic_channel_gradient_width_frac) + call mpas_pool_get_config(ocnConfigs, 'config_baroclinic_channel_bottom_depth', config_baroclinic_channel_bottom_depth) + call mpas_pool_get_config(ocnConfigs, 'config_baroclinic_channel_surface_temperature', config_baroclinic_channel_surface_temperature) + call mpas_pool_get_config(ocnConfigs, 'config_baroclinic_channel_bottom_temperature', config_baroclinic_channel_bottom_temperature) + call mpas_pool_get_config(ocnConfigs, 'config_baroclinic_channel_temperature_difference', config_baroclinic_channel_temperature_difference) + call mpas_pool_get_config(ocnConfigs, 'config_baroclinic_channel_salinity', config_baroclinic_channel_salinity) + call mpas_pool_get_config(ocnConfigs, 'config_baroclinic_channel_coriolis_parameter', config_baroclinic_channel_coriolis_parameter) + + ! Determine vertical grid for configuration + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nVertLevelsP1', nVertLevelsP1) + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + + if ( on_a_sphere ) call mpas_dmpar_global_abort('ERROR: The baroclinic channel configuration can only be applied to a planar mesh. Exiting...') + + allocate(interfaceLocations(nVertLevelsP1)) + call ocn_generate_vertical_grid( config_vertical_grid, interfaceLocations ) + + ! Initalize min/max values to large positive and negative values + yMin = 1.0E10_RKIND + yMax = -1.0E10_RKIND + xMin = 1.0E10_RKIND + xMax = -1.0E10_RKIND + dcEdgeMin = 1.0E10_RKIND + + ! Determine local min and max values. + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + + yMin = min( yMin, minval(yCell(1:nCellsSolve))) + yMax = max( yMax, maxval(yCell(1:nCellsSolve))) + xMin = min( xMin, minval(xCell(1:nCellsSolve))) + xMax = max( xMax, maxval(xCell(1:nCellsSolve))) + dcEdgeMin = min( dcEdgeMin, minval(dcEdge(1:nEdgesSolve))) + + block_ptr => block_ptr % next + end do + + ! Determine global min and max values. + call mpas_dmpar_min_real(domain % dminfo, yMin, yMinGlobal) + call mpas_dmpar_max_real(domain % dminfo, yMax, yMaxGlobal) + call mpas_dmpar_min_real(domain % dminfo, xMin, xMinGlobal) + call mpas_dmpar_max_real(domain % dminfo, xMax, xMaxGlobal) + call mpas_dmpar_min_real(domain % dminfo, dcEdgeMin, dcEdgeMinGlobal) + + yMidGlobal = (yMinGlobal + yMaxGlobal) * 0.5_RKIND + xPerturbationMin = xMinGlobal + 4.0_RKIND * (xMaxGlobal - xMinGlobal) / 6.0_RKIND + xPerturbationMax = xMinGlobal + 5.0_RKIND * (xMaxGlobal - xMinGlobal) / 6.0_RKIND + if(config_baroclinic_channel_use_distances) then + perturbationWidth = config_baroclinic_channel_gradient_width_dist + else + perturbationWidth = (yMaxGlobal - yMinGlobal) * config_baroclinic_channel_gradient_width_frac + end if + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'fCell', fCell) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + call mpas_pool_get_array(meshPool, 'fVertex', fVertex) + + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + call ocn_mark_north_boundary(meshPool, yMaxGlobal, dcEdgeMinGlobal, iErr) + call ocn_mark_south_boundary(meshPool, yMinGlobal, dcEdgeMinGlobal, iErr) + + ! Set refBottomDepth and refZMid + do k = 1, nVertLevels + refBottomDepth(k) = config_baroclinic_channel_bottom_depth * interfaceLocations(k+1) + refZMid(k) = - 0.5_RKIND * (interfaceLocations(k+1) + interfaceLocations(k)) * config_baroclinic_channel_bottom_depth + end do + + ! Set vertCoordMovementWeights + vertCoordMovementWeights(:) = 1.0_RKIND + + do iCell = 1, nCellsSolve + ! Determine cutoff location for large sin wave + yOffset = perturbationWidth * sin (6.0_RKIND * pii * (xCell(iCell) - xMinGlobal) / (xMaxGlobal - xMinGlobal)) + + ! Set stratification based on northern half of domain temperature + idx = index_temperature + do k = nVertLevels, 1, -1 + temperature = config_baroclinic_channel_bottom_temperature & + + (config_baroclinic_channel_surface_temperature - config_baroclinic_channel_bottom_temperature) & + * ( (refZMid(k) + refBottomDepth(nVertLevels)) / refBottomDepth(nVertLevels) ) + tracers(idx, k, iCell) = temperature + end do + + if(yCell(iCell) < yMidGlobal - yOffset) then + ! If cell is in the southern half, outside the sin width, subtract temperature difference + tracers(idx, :, iCell) = tracers(idx, :, iCell) - config_baroclinic_channel_temperature_difference + else if(yCell(iCell) >= yMidGlobal - yOffset .and. & + yCell(iCell) < yMidGlobal - yOffset + perturbationWidth) then + tracers(idx, :, iCell) = tracers(idx, :, iCell) - config_baroclinic_channel_temperature_difference * ( 1.0_RKIND - ( yCell(iCell) & + - ((yMaxGlobal + yMinGlobal) * 0.5 - yOffset)) / perturbationWidth) + end if + + ! Determine yOffset for 3rd crest in sin wave. + yOffset = 0.5_RKIND * perturbationWidth * sin(pii * (xCell(iCell) - xPerturbationMin)/(xPerturbationMax - xPerturbationMin)) + + if ( yCell(iCell) >= yMidGlobal - yOffset - 0.5_RKIND * perturbationWidth .and. & + yCell(iCell) <= yMidGlobal - yOffset + 0.5_RKIND * perturbationWidth .and. & + xCell(iCell) >= xPerturbationMin .and. & + xCell(iCell) <= xPerturbationMax) then + + + do k = 1, nVertLevels + tracers(idx, k, iCell) = tracers(idx, k, iCell) + & + 0.3_RKIND * ( 1.0_RKIND - ( ( yCell(iCell) - (yMidGlobal - yOffset)) /(0.5_RKIND * perturbationWidth))) + end do + end if + + ! Set salinity + idx = index_salinity + tracers(idx, :, iCell) = config_baroclinic_channel_salinity + + ! Set layerThickness and restingThickness + do k = 1, nVertLevels + layerThickness(k, iCell) = config_baroclinic_channel_bottom_depth * ( interfaceLocations(k+1) - interfaceLocations(k) ) + restingThickness(k, iCell) = config_baroclinic_channel_bottom_depth * ( interfaceLocations(k+1) - interfaceLocations(k) ) + + end do + + ! Set bottomDepth + bottomDepth(iCell) = config_baroclinic_channel_bottom_depth + + ! Set maxLevelCell + maxLevelCell(iCell) = nVertLevels + end do + + ! Set Coriolis parameters + fCell(:) = config_baroclinic_channel_coriolis_parameter + fEdge(:) = config_baroclinic_channel_coriolis_parameter + fVertex(:) = config_baroclinic_channel_coriolis_parameter + + block_ptr => block_ptr % next + end do + + deallocate(interfaceLocations) + + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_baroclinic_channel!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_baroclinic_channel +! +!> \brief Validation for baroclinic channel test case +!> \author Doug Jacobsen +!> \date 02/20/2014 +!> \details +!> This routine validates the configuration options for the baroclinic channel test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_baroclinic_channel(configPool, packagePool, iErr)!{{{ + + !-------------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: configPool, packagePool + + integer, intent(out) :: iErr + + character (len=StrKIND), pointer :: config_init_configuration + integer, pointer :: config_vert_levels, config_baroclinic_channel_vert_levels + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('baroclinic_channel')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_baroclinic_channel_vert_levels', config_baroclinic_channel_vert_levels) + + if(config_vert_levels <= 0 .and. config_baroclinic_channel_vert_levels > 0) then + config_vert_levels = config_baroclinic_channel_vert_levels + else if (config_vert_levels <= 0) then + write(stderrUnit,*) 'ERROR: Validation failed for baroclinic channel. Not given a usable value for vertical levels.' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_baroclinic_channel!}}} + +!*********************************************************************** + +end module ocn_init_baroclinic_channel + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 3beae566d7..912e2b78cc 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -38,6 +38,7 @@ module ocn_init_mode use ocn_init_spherical_utils !use ocn_init_TEMPLATE + use ocn_init_baroclinic_channel implicit none private @@ -205,7 +206,7 @@ end function ocn_init_mode_setup_clock!}}} !----------------------------------------------------------------------- function ocn_init_mode_run(domain) result(iErr)!{{{ - + type (domain_type), intent(inout) :: domain integer :: iErr @@ -237,6 +238,7 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) write(stderrUnit, *) ' Generating configuration: ' // trim(config_init_configuration) + call ocn_init_setup_baroclinic_channel(domain, ierr) !call ocn_init_setup_TEMPLATE(domain, ierr) call mpas_timer_start('io_write', .false.) @@ -308,6 +310,8 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, iErr)!{ cullCellsActive = .true. end if + call ocn_init_validate_baroclinic_channel(configPool, packagePool, iErr=err_tmp) + iErr = ior(iErr, err_tmp) ! call ocn_config_TEMPLATE_validate(configPool, iErr=err_tmp) ! iErr = ior(iErr, err_tmp) end subroutine ocn_init_mode_validate_configuration!}}} From 86eb641f1f25e45c53089c6d7fbc9db6871cf414 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Fri, 3 Apr 2015 12:06:53 -0600 Subject: [PATCH 0092/1724] Adding the lock exchange configuration This commit adds the lock exchange configuration from Ilicak 2011. --- src/core_ocean/Makefile | 1 + src/core_ocean/mode_init/Makefile | 3 + src/core_ocean/mode_init/Registry.xml | 1 + .../mode_init/Registry_lock_exchange.xml | 30 ++ .../mode_init/mpas_ocn_init_lock_exchange.F | 310 ++++++++++++++++++ src/core_ocean/mode_init/mpas_ocn_init_mode.F | 4 + 6 files changed, 349 insertions(+) create mode 100644 src/core_ocean/mode_init/Registry_lock_exchange.xml create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index 2ee37d8e1d..d65e24d807 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -24,6 +24,7 @@ core_input_gen: (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.analysis mode=analysis ) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init mode=init ) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.baroclinic_channel mode=init configuration=baroclinic_channel) + (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.lock_exchange mode=init configuration=lock_exchange) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean stream_list.ocean. mutable ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.forward stream_list.ocean.forward. mutable mode=forward ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis ) diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile index 656fb6d513..6b5de7ae3b 100644 --- a/src/core_ocean/mode_init/Makefile +++ b/src/core_ocean/mode_init/Makefile @@ -7,6 +7,7 @@ UTILS = mpas_ocn_init_spherical_utils.o \ mpas_ocn_init_cell_markers.o TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ + mpas_ocn_init_lock_exchange.o \ #mpas_ocn_init_TEMPLATE.o all: init_mode @@ -23,6 +24,8 @@ mpas_ocn_init_vertical_grids.o: mpas_ocn_init_baroclinic_channel.o: $(UTILS) +mpas_ocn_init_lock_exchange.o: $(UTILS) + #mpas_ocn_init_TEMPLATE.o: $(UTILS) clean: diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml index e6779a827a..d71b4afd94 100644 --- a/src/core_ocean/mode_init/Registry.xml +++ b/src/core_ocean/mode_init/Registry.xml @@ -1,2 +1,3 @@ #include "Registry_baroclinic_channel.xml" +#include "Registry_lock_exchange.xml" // #include "Registry_TEMPLATE.xml" diff --git a/src/core_ocean/mode_init/Registry_lock_exchange.xml b/src/core_ocean/mode_init/Registry_lock_exchange.xml new file mode 100644 index 0000000000..e42bc72046 --- /dev/null +++ b/src/core_ocean/mode_init/Registry_lock_exchange.xml @@ -0,0 +1,30 @@ + + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F b/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F new file mode 100644 index 0000000000..e5eb5e7f9c --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F @@ -0,0 +1,310 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_lock_exchange +! +!> \brief MPAS ocean initialize case -- Lock Exchange +!> \author Doug Jacobsen +!> \date 02/18/2014 +!> \details +!> This module contains the routines for initializing the +!> the lock exchange test case +! +!----------------------------------------------------------------------- + +module ocn_init_lock_exchange + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + + use ocn_constants + use ocn_init_vertical_grids + use ocn_init_cell_markers + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_lock_exchange, & + ocn_init_validate_lock_exchange + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_lock_exchange +! +!> \brief Setup for lock exchange test case +!> \author Doug Jacobsen +!> \date 02/18/2014 +!> \details +!> This routine sets up the initial conditions for the lock exchange test case. +!> It is setup in the y direction, such that everything in the southern half of +!> the domain has a temperature of 5.0C and the northern half has a value of +!> 30.0C. Salinity is setup as a constant 35PSU. +!> No windstress is specified, and layerThickness is constant depending on the input parameter +!> config_lock_exchange_bottom_depth. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_lock_exchange(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + real (kind=RKIND) :: yMin, yMax, xMin, xMax, dcEdgeMin + real (kind=RKIND) :: yMinGlobal, yMaxGlobal, xMinGlobal, xMaxGlobal, dcEdgeMinGlobal + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool, statePool, verticalMeshPool + + character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid, config_lock_exchange_layer_type + + integer, pointer :: nCellsSolve, nEdgesSolve, nVertLevels, nVertLevelsP1, index_temperature, index_salinity + + integer, dimension(:), pointer :: maxLevelCell + + real (kind=RKIND), pointer :: config_lock_exchange_south_temp, config_lock_exchange_north_temp, config_lock_exchange_salinity, & + config_lock_exchange_bottom_depth, config_lock_exchange_isopycnal_min_thickness + + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, bottomDepth, refBottomDepthTopOfCell, refBottomDepth, vertCoordMovementWeights, dcEdge + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + + real (kind=RKIND), dimension(:), pointer :: interfaceLocations + + logical, pointer :: on_a_sphere + + integer :: iCell, k + + iErr = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('lock_exchange')) return + + call mpas_pool_get_config(ocnConfigs, 'config_vertical_grid', config_vertical_grid) + + call mpas_pool_get_config(ocnConfigs, 'config_lock_exchange_south_temp', config_lock_exchange_south_temp) + call mpas_pool_get_config(ocnConfigs, 'config_lock_exchange_north_temp', config_lock_exchange_north_temp) + call mpas_pool_get_config(ocnConfigs, 'config_lock_exchange_salinity', config_lock_exchange_salinity) + call mpas_pool_get_config(ocnConfigs, 'config_lock_exchange_bottom_depth', config_lock_exchange_bottom_depth) + call mpas_pool_get_config(ocnConfigs, 'config_lock_exchange_isopycnal_min_thickness', config_lock_exchange_isopycnal_min_thickness) + call mpas_pool_get_config(ocnConfigs, 'config_lock_exchange_layer_type', config_lock_exchange_layer_type) + + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nVertLevelsP1', nVertLevelsP1) + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + + if ( on_a_sphere ) call mpas_dmpar_global_abort('ERROR: The lock exchange configuration can not be applied to spherical meshes') + + ! Define interface locations + allocate( interfaceLocations( nVertLevelsP1 ) ) + call ocn_generate_vertical_grid( config_vertical_grid, interfaceLocations ) + + ! Initalize y values to large positive and negative values + yMin = 1.0E10_RKIND + yMax = -1.0E10_RKIND + xMin = 1.0E10_RKIND + xMax = -1.0E10_RKIND + dcEdgeMin = 1.0E10_RKIND + + ! Determine local min and max y value. + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + + xMin = min( xMin, minval(xCell(1:nCellssolve))) + xMax = max( xMax, maxval(xCell(1:nCellssolve))) + yMin = min( yMin, minval(yCell(1:nCellssolve))) + yMax = max( yMax, maxval(yCell(1:nCellssolve))) + dcEdgeMin = min( dcEdgeMin, minval(dcEdge(1:nEdgessolve))) + + block_ptr => block_ptr % next + end do + + ! Determine global min and max y value. This is so the domain + ! can be split into north and south. + call mpas_dmpar_min_real(domain % dminfo, xMin, xMinGlobal) + call mpas_dmpar_max_real(domain % dminfo, xMax, xMaxGlobal) + call mpas_dmpar_min_real(domain % dminfo, yMin, yMinGlobal) + call mpas_dmpar_max_real(domain % dminfo, yMax, yMaxGlobal) + call mpas_dmpar_min_real(domain % dminfo, dcEdgeMin, dcEdgeMinGlobal) + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'refBottomDepthTopOfCell', refBottomDepthTopOfCell) + call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) + + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + call ocn_mark_north_boundary(meshPool, yMaxGlobal, dcEdgeMinGlobal, iErr) + call ocn_mark_south_boundary(meshPool, yMinGlobal, dcEdgeMinGlobal, iErr) + call ocn_mark_east_boundary(meshPool, xMaxGlobal, dcEdgeMinGlobal, iErr) + call ocn_mark_west_boundary(meshPool, xMinGlobal, dcEdgeMinGlobal, iErr) + + do iCell = 1, nCellsSolve + ! Set temperature, layerThickness, and restingThickness + if ( trim(config_lock_exchange_layer_type) == 'z-level' ) then + if(yCell(iCell) < (yMaxGlobal - yMinGlobal) * 0.5_RKIND) then + tracers(index_temperature, :, iCell) = config_lock_exchange_south_temp + else + tracers(index_temperature, :, iCell) = config_lock_exchange_north_temp + end if + + ! Set layerThickness and restingThickness + do k = 1, nVertLevels + layerThickness(k, iCell) = config_lock_exchange_bottom_depth * ( interfaceLocations(k+1) - interfaceLocations(k) ) + restingThickness(k, iCell) = layerThickness(k, iCell) + end do + else if ( trim(config_lock_exchange_layer_type) == 'isopycnal' ) then + tracers(index_temperature, 1, iCell) = config_lock_exchange_north_temp + tracers(index_temperature, 2:nVertLevels, iCell) = config_lock_exchange_south_temp + + if(yCell(iCell) < (yMaxGlobal - yMinGlobal) * 0.5_RKIND) then + layerThickness(1, iCell) = config_lock_exchange_isopycnal_min_thickness + layerThickness(2:nVertLevels, iCell) = config_lock_exchange_bottom_depth - config_lock_exchange_isopycnal_min_thickness + else + layerThickness(1, iCell) = config_lock_exchange_bottom_depth - config_lock_exchange_isopycnal_min_thickness + layerThickness(2:nVertLevels, iCell) = config_lock_exchange_isopycnal_min_thickness + end if + else + call mpas_dmpar_global_abort('Error: wrong choice of config_lock_exchange_layer_type') + end if + + ! Set salinity + tracers(index_salinity, :, iCell) = config_lock_exchange_salinity + + + ! Set bottomDepth + bottomDepth(iCell) = config_lock_exchange_bottom_depth + + ! Set maxLevelCell + maxLevelCell(iCell) = nVertLevels + end do + + ! Set refBottomDepth and refBottomDepthTopOfCell + do k = 1, nVertLevels + refBottomDepth(k) = config_lock_exchange_bottom_depth * interfaceLocations(k+1) + refBottomDepthTopOfCell(k) = config_lock_exchange_bottom_depth * interfaceLocations(k) + end do + + refBottomDepthTopOfCell(nVertLevels+1) = interfaceLocations(nVertLevels+1) * config_lock_exchange_bottom_depth + + ! Set vertCoordMovementWeights + vertCoordMovementWeights(:) = 1.0_RKIND + + block_ptr => block_ptr % next + end do + + deallocate(interfaceLocations) + + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_lock_exchange!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_lock_exchange +! +!> \brief Validation for lock exchange test case +!> \author Doug Jacobsen +!> \date 02/20/2014 +!> \details +!> This routine validates the configuration options for the lock exchange test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_lock_exchange(configPool, packagePool, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (mpaS_pool_type), intent(in) :: configPool + type (mpaS_pool_type), intent(in) :: packagePool + + integer, intent(out) :: iErr + + integer, pointer :: config_vert_levels, config_lock_exchange_vert_levels + character (len=StrKIND), pointer :: config_init_configuration + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('lock_exchange')) return + + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_lock_exchange_vert_levels', config_lock_exchange_vert_levels) + + if(config_vert_levels <= 0 .and. config_lock_exchange_vert_levels > 0) then + config_vert_levels = config_lock_exchange_vert_levels + else if(config_vert_levels <= 0) then + write(stderrUnit,*) 'ERROR: Validation failed for lock exchange test case. Not given a usable value for vertical levels.' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_lock_exchange!}}} + +!*********************************************************************** + +end module ocn_init_lock_exchange + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 912e2b78cc..ba22524b7e 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -39,6 +39,7 @@ module ocn_init_mode !use ocn_init_TEMPLATE use ocn_init_baroclinic_channel + use ocn_init_lock_exchange implicit none private @@ -239,6 +240,7 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ write(stderrUnit, *) ' Generating configuration: ' // trim(config_init_configuration) call ocn_init_setup_baroclinic_channel(domain, ierr) + call ocn_init_setup_lock_exchange(domain, ierr) !call ocn_init_setup_TEMPLATE(domain, ierr) call mpas_timer_start('io_write', .false.) @@ -312,6 +314,8 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, iErr)!{ call ocn_init_validate_baroclinic_channel(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) + call ocn_init_validate_lock_exchange(configPool, packagePool, iErr=err_tmp) + iErr = ior(iErr, err_tmp) ! call ocn_config_TEMPLATE_validate(configPool, iErr=err_tmp) ! iErr = ior(iErr, err_tmp) end subroutine ocn_init_mode_validate_configuration!}}} From 0cba4480e5a4b6e48bd8af2d8e9fceb8d020705e Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Fri, 3 Apr 2015 12:33:33 -0600 Subject: [PATCH 0093/1724] Adding internal waves configuration This commit adds the internal waves configuration from Ilicak 2011. --- src/core_ocean/Makefile | 1 + src/core_ocean/mode_init/Makefile | 3 + src/core_ocean/mode_init/Registry.xml | 1 + .../mode_init/Registry_internal_waves.xml | 47 +++ .../mode_init/mpas_ocn_init_internal_waves.F | 363 ++++++++++++++++++ src/core_ocean/mode_init/mpas_ocn_init_mode.F | 4 + 6 files changed, 419 insertions(+) create mode 100644 src/core_ocean/mode_init/Registry_internal_waves.xml create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index d65e24d807..80b24949f3 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -25,6 +25,7 @@ core_input_gen: (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init mode=init ) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.baroclinic_channel mode=init configuration=baroclinic_channel) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.lock_exchange mode=init configuration=lock_exchange) + (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.internal_waves mode=init configuration=internal_waves) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean stream_list.ocean. mutable ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.forward stream_list.ocean.forward. mutable mode=forward ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis ) diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile index 6b5de7ae3b..98c452bdac 100644 --- a/src/core_ocean/mode_init/Makefile +++ b/src/core_ocean/mode_init/Makefile @@ -8,6 +8,7 @@ UTILS = mpas_ocn_init_spherical_utils.o \ TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ mpas_ocn_init_lock_exchange.o \ + mpas_ocn_init_internal_waves.o \ #mpas_ocn_init_TEMPLATE.o all: init_mode @@ -26,6 +27,8 @@ mpas_ocn_init_baroclinic_channel.o: $(UTILS) mpas_ocn_init_lock_exchange.o: $(UTILS) +mpas_ocn_init_internal_waves.o: $(UTILS) + #mpas_ocn_init_TEMPLATE.o: $(UTILS) clean: diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml index d71b4afd94..085ddb2e15 100644 --- a/src/core_ocean/mode_init/Registry.xml +++ b/src/core_ocean/mode_init/Registry.xml @@ -1,3 +1,4 @@ #include "Registry_baroclinic_channel.xml" #include "Registry_lock_exchange.xml" +#include "Registry_internal_waves.xml" // #include "Registry_TEMPLATE.xml" diff --git a/src/core_ocean/mode_init/Registry_internal_waves.xml b/src/core_ocean/mode_init/Registry_internal_waves.xml new file mode 100644 index 0000000000..71067d5a1e --- /dev/null +++ b/src/core_ocean/mode_init/Registry_internal_waves.xml @@ -0,0 +1,47 @@ + + + + + + + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F b/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F new file mode 100644 index 0000000000..98a7919230 --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F @@ -0,0 +1,363 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_internal_waves +! +!> \brief MPAS ocean initialize case -- Internal waves +!> \author Doug Jacobsen +!> \date 02/18/2014 +!> \details +!> This module contains the routines for initializing the +!> the internal waves test case +! +!----------------------------------------------------------------------- + +module ocn_init_internal_waves + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + + use ocn_init_vertical_grids + use ocn_init_cell_markers + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_internal_waves, & + ocn_init_validate_internal_waves + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_internal_waves +! +!> \brief Setup for internal waves test case +!> \author Doug Jacobsen +!> \date 02/19/2014 +!> \details +!> This routine sets up the initial conditions for the internal waves test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + ! Define pool pointers + type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool + + ! Define dimension pointers + integer, pointer :: nVertLevels, nVertLevelsP1, nCells, nEdges, nVertices + integer, pointer :: nCellsSolve, nEdgesSolve, index_temperature, index_salinity + + ! Define array pointers + integer, dimension(:), pointer :: maxLevelCell + + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, bottomDepth, dcEdge + real (kind=RKIND), dimension(:), pointer :: refBottomDepth, refZMid, vertCoordMovementWeights + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + + + real (kind=RKIND) :: yMin, yMax, xMin, xMax, dcEdgeMin + real (kind=RKIND) :: yMinGlobal, yMaxGlobal, yMidGlobal, xMinGlobal, xMaxGlobal, dcEdgeMinGlobal + real (kind=RKIND) :: temperature, yOffset, perturbationWidth + + ! Define config pointers + character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid, config_internal_waves_layer_type + logical, pointer :: config_internal_waves_use_distances + real (kind=RKIND), pointer :: config_internal_waves_amplitude_width_frac, config_internal_waves_amplitude_width_dist + real (kind=RKIND), pointer :: config_internal_waves_bottom_depth, config_internal_waves_bottom_temperature + real (kind=RKIND), pointer :: config_internal_waves_surface_temperature, config_internal_waves_temperature_difference + real (kind=RKIND), pointer :: config_internal_waves_salinity, config_internal_waves_isopycnal_displacement + + type (block_type), pointer :: block_ptr + + integer :: iCell, k, idx + + real (kind=RKIND) :: deltaTemperature + real (kind=RKIND), dimension(:), pointer :: zTop, refTemperature, refTemperatureTop, refZTop + real (kind=RKIND), dimension(:), pointer :: interfaceLocations + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('internal_waves')) return + + ! Initalize min/max values to large positive and negative values + yMin = 1.0E10_RKIND + yMax = -1.0E10_RKIND + xMin = 1.0E10_RKIND + xMax = -1.0E10_RKIND + dcEdgEMin = 1.0E10_RKIND + + ! Define locations of layer interfaces + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nVertLevelsP1', nVertLevelsP1) + call mpas_pool_get_config(domain % configs, 'config_vertical_grid', config_vertical_grid) + allocate( interfaceLocations( nVertLevelsP1 ) ) + + call ocn_generate_vertical_grid( config_vertical_grid, interfaceLocations ) + + call mpas_pool_get_config(domain % configs, 'config_internal_waves_use_distances', config_internal_waves_use_distances) + call mpas_pool_get_config(domain % configs, 'config_internal_waves_amplitude_width_frac', config_internal_waves_amplitude_width_frac) + call mpas_pool_get_config(domain % configs, 'config_internal_waves_amplitude_width_dist', config_internal_waves_amplitude_width_dist) + call mpas_pool_get_config(domain % configs, 'config_internal_waves_bottom_depth', config_internal_waves_bottom_depth) + call mpas_pool_get_config(domain % configs, 'config_internal_waves_bottom_temperature', config_internal_waves_bottom_temperature) + call mpas_pool_get_config(domain % configs, 'config_internal_waves_surface_temperature', config_internal_waves_surface_temperature) + call mpas_pool_get_config(domain % configs, 'config_internal_waves_temperature_difference', config_internal_waves_temperature_difference) + call mpas_pool_get_config(domain % configs, 'config_internal_waves_salinity', config_internal_waves_salinity) + call mpas_pool_get_config(domain % configs, 'config_internal_waves_isopycnal_displacement', config_internal_waves_isopycnal_displacement) + call mpas_pool_get_config(domain % configs, 'config_internal_waves_layer_type', config_internal_waves_layer_type) + + ! Determine local min and max values. + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + + xMin = min( xMin, minval(xCell(1:nCellssolve))) + xMax = max( xMax, maxval(xCell(1:nCellssolve))) + yMin = min( yMin, minval(yCell(1:nCellssolve))) + yMax = max( yMax, maxval(yCell(1:nCellssolve))) + dcEdgeMin = min( dcEdgeMin, minval(dcEdge(1:nEdgesSolve))) + + block_ptr => block_ptr % next + end do + + ! Determine global min and max values. + call mpas_dmpar_min_real(domain % dminfo, yMin, yMinGlobal) + call mpas_dmpar_max_real(domain % dminfo, yMax, yMaxGlobal) + call mpas_dmpar_min_real(domain % dminfo, xMin, xMinGlobal) + call mpas_dmpar_max_real(domain % dminfo, xMax, xMaxGlobal) + call mpas_dmpar_min_real(domain % dminfo, dcEdgEMin, dcEdgeMinGlobal) + + yMidGlobal = (yMinGlobal + yMaxGlobal) * 0.5_RKIND + if(config_internal_waves_use_distances) then + perturbationWidth = config_internal_waves_amplitude_width_dist + else + perturbationWidth = (yMaxGlobal - yMinGlobal) * config_internal_waves_amplitude_width_frac + end if + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + + call ocn_mark_north_boundary(meshPool, yMaxGlobal, dcEdgeMinGlobal, iErr) + call ocn_mark_south_boundary(meshPool, yMinGlobal, dcEdgeMinGlobal, iErr) + call ocn_mark_east_boundary(meshPool, xMaxGlobal, dcEdgeMinGlobal, iErr) + call ocn_mark_west_boundary(meshPool, xMinGlobal, dcEdgeMinGlobal, iErr) + + allocate(zTop(nVertLevels+1), refTemperature(nVertLevels), refTemperatureTop(nVertLevels+1), refZTop(nVertLevels+1)) + + ! Set refBottomDepth and refBottomDepthTopOfCell + do k = 1, nVertLevels + refBottomDepth(k) = config_internal_waves_bottom_depth * interfaceLocations(k+1) + refZMid(k) = -0.5_RKIND * config_internal_waves_bottom_depth * (interfaceLocations(k) + interfaceLocations(k+1)) + end do + + if ( trim(config_internal_waves_layer_type) == 'isopycnal' ) then + + refTemperatureTop(1) = config_internal_waves_surface_temperature + refTemperatureTop(nVertLevels+1) = config_internal_waves_bottom_temperature + deltaTemperature = (config_internal_waves_surface_temperature - config_internal_waves_bottom_temperature)/nVertLevels + refTemperature(1) = config_internal_waves_surface_temperature - deltaTemperature/2.0 + refZTop(1) = 0.0_RKIND + do k = 2, nVertLevels + refTemperatureTop(k) = refTemperatureTop(1) - (k-1)*deltaTemperature + refTemperature(k) = refTemperature(1) - (k-1)*deltaTemperature + refZTop(k) = refZTop(k-1) - config_internal_waves_bottom_depth / nVertLevels + end do + + endif + + ! Set vertCoordMovementWeights + vertCoordMovementWeights(:) = 1.0_RKIND + + do iCell = 1, nCellsSolve + + if ( trim(config_internal_waves_layer_type) == 'z-level' ) then + + ! Set stratified temperature + do k = nVertLevels, 1, -1 + temperature = config_internal_waves_bottom_temperature & + + (config_internal_waves_surface_temperature - config_internal_waves_bottom_temperature) & + * ( (refZMid(k) - refZMid(nVertLevels)) / (-refZMid(nVertLevels) )) + tracers(index_temperature, k, iCell) = temperature + end do + + if ( abs(yCell(iCell) - yMidGlobal) < perturbationWidth ) then + ! If cell is in the southern half, outside the sin width, subtract temperature difference + do k = 2, nVertLevels + temperature = -config_internal_waves_temperature_difference * cos(0.5_RKIND * pii * (yCell(iCell) - yMidGlobal) / perturbationWidth) & + * sin ( pii * refBottomDepth(k-1) / refBottomDepth(nVertLevels-1) ) + + tracers(index_temperature, k, iCell) = tracers(index_temperature, k, iCell) + temperature + end do + end if + + ! Set layerThickness + layerThickness(:, iCell) = refBottomDepth(:) + restingThickness(:, iCell) = layerThickness(:, iCell) + + else if ( trim(config_internal_waves_layer_type) == 'isopycnal' ) then + + ! Set stratified temperature + tracers(index_temperature, :, iCell) = refTemperature(:) + + ! Set layerThickness + if ( abs(yCell(iCell) - yMidGlobal) < perturbationWidth) then + ! If cell is in the southern half, outside the sin width, subtract temperature difference + zTop(1) = 0.0_RKIND + do k = 2, nVertLevels + zTop(k) = refZTop(k) + & + config_internal_waves_isopycnal_displacement * sin(pii * (k-1) / (nVertLevels+4)) & + * cos(0.5_RKIND * pii * (yCell(iCell) - yMidGlobal) / perturbationWidth) + end do + zTop(nVertLevels+1) = -config_internal_waves_bottom_depth + + do k = 1, nVertLevels + layerThickness(k, iCell) = zTop(k) - zTop(k+1) + restingThickness(k, iCell) = layerThickness(k, iCell) + end do + else + layerThickness(:, iCell) = config_internal_waves_bottom_depth / nVertLevels + restingThickness(:, iCell) = layerThickness(:, iCell) + end if + else + call mpas_dmpar_global_abort('Error: wrong choice of config_internal_waves_layer_type') + endif + + ! Set salinity + tracers(index_salinity, :, iCell) = config_internal_waves_salinity + + ! Set bottomDepth + bottomDepth(iCell) = config_internal_waves_bottom_depth + + ! Set maxLevelCell + maxLevelCell(iCell) = nVertLevels + end do + + deallocate(zTop, refTemperature, refTemperatureTop, refZTop) + + block_ptr => block_ptr % next + end do + + + + deallocate(interfaceLocations) + + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_internal_waves!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_internal_waves +! +!> \brief Validation for internal waves test case +!> \author Doug Jacobsen +!> \date 02/20/2014 +!> \details +!> This routine validates the configuration options for the internal waves test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_internal_waves(configPool, packagePool, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + + integer, intent(out) :: iErr + + character (len=StrKIND), pointer :: config_init_configuration + integer, pointer :: config_vert_levels, config_internal_waves_vert_levels + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('internal_waves')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_internal_waves_vert_levels', config_internal_waves_vert_levels) + + if(config_vert_levels <= 0 .and. config_internal_waves_vert_levels > 0) then + config_vert_levels = config_internal_waves_vert_levels + else if(config_vert_levels <= 0) then + write(0,*) 'ERROR: Validation failed for internal waves. Not given a usable value for vertical levels.' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_internal_waves!}}} + +!*********************************************************************** + +end module ocn_init_internal_waves + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index ba22524b7e..73eb2af0ab 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -40,6 +40,7 @@ module ocn_init_mode !use ocn_init_TEMPLATE use ocn_init_baroclinic_channel use ocn_init_lock_exchange + use ocn_init_internal_waves implicit none private @@ -241,6 +242,7 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call ocn_init_setup_baroclinic_channel(domain, ierr) call ocn_init_setup_lock_exchange(domain, ierr) + call ocn_init_setup_internal_waves(domain, ierr) !call ocn_init_setup_TEMPLATE(domain, ierr) call mpas_timer_start('io_write', .false.) @@ -316,6 +318,8 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, iErr)!{ iErr = ior(iErr, err_tmp) call ocn_init_validate_lock_exchange(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) + call ocn_init_validate_internal_waves(configPool, packagePool, iErr=err_tmp) + iErr = ior(iErr, err_tmp) ! call ocn_config_TEMPLATE_validate(configPool, iErr=err_tmp) ! iErr = ior(iErr, err_tmp) end subroutine ocn_init_mode_validate_configuration!}}} From 874524e1d8f250f519045149f3b07a17ace25a1c Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Fri, 3 Apr 2015 12:41:15 -0600 Subject: [PATCH 0094/1724] Adding overflow configuration This commit adds the overflow configuration from Ilicak 2011. --- src/core_ocean/Makefile | 1 + src/core_ocean/mode_init/Makefile | 3 + src/core_ocean/mode_init/Registry.xml | 1 + .../mode_init/Registry_overflow.xml | 63 ++++ src/core_ocean/mode_init/mpas_ocn_init_mode.F | 4 + .../mode_init/mpas_ocn_init_overflow.F | 340 ++++++++++++++++++ 6 files changed, 412 insertions(+) create mode 100644 src/core_ocean/mode_init/Registry_overflow.xml create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_overflow.F diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index 80b24949f3..9f558d1695 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -26,6 +26,7 @@ core_input_gen: (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.baroclinic_channel mode=init configuration=baroclinic_channel) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.lock_exchange mode=init configuration=lock_exchange) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.internal_waves mode=init configuration=internal_waves) + (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.overflow mode=init configuration=overflow) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean stream_list.ocean. mutable ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.forward stream_list.ocean.forward. mutable mode=forward ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis ) diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile index 98c452bdac..1ce2b5be14 100644 --- a/src/core_ocean/mode_init/Makefile +++ b/src/core_ocean/mode_init/Makefile @@ -9,6 +9,7 @@ UTILS = mpas_ocn_init_spherical_utils.o \ TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ mpas_ocn_init_lock_exchange.o \ mpas_ocn_init_internal_waves.o \ + mpas_ocn_init_overflow.o \ #mpas_ocn_init_TEMPLATE.o all: init_mode @@ -29,6 +30,8 @@ mpas_ocn_init_lock_exchange.o: $(UTILS) mpas_ocn_init_internal_waves.o: $(UTILS) +mpas_ocn_init_overflow.o: $(UTILS) + #mpas_ocn_init_TEMPLATE.o: $(UTILS) clean: diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml index 085ddb2e15..eeb5314525 100644 --- a/src/core_ocean/mode_init/Registry.xml +++ b/src/core_ocean/mode_init/Registry.xml @@ -1,4 +1,5 @@ #include "Registry_baroclinic_channel.xml" #include "Registry_lock_exchange.xml" #include "Registry_internal_waves.xml" +#include "Registry_overflow.xml" // #include "Registry_TEMPLATE.xml" diff --git a/src/core_ocean/mode_init/Registry_overflow.xml b/src/core_ocean/mode_init/Registry_overflow.xml new file mode 100644 index 0000000000..a8f03927f3 --- /dev/null +++ b/src/core_ocean/mode_init/Registry_overflow.xml @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 73eb2af0ab..cb4a36b783 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -41,6 +41,7 @@ module ocn_init_mode use ocn_init_baroclinic_channel use ocn_init_lock_exchange use ocn_init_internal_waves + use ocn_init_overflow implicit none private @@ -243,6 +244,7 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call ocn_init_setup_baroclinic_channel(domain, ierr) call ocn_init_setup_lock_exchange(domain, ierr) call ocn_init_setup_internal_waves(domain, ierr) + call ocn_init_setup_overflow(domain, ierr) !call ocn_init_setup_TEMPLATE(domain, ierr) call mpas_timer_start('io_write', .false.) @@ -320,6 +322,8 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, iErr)!{ iErr = ior(iErr, err_tmp) call ocn_init_validate_internal_waves(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) + call ocn_init_validate_overflow(configPool, packagePool, iErr=err_tmp) + iErr = ior(iErr, err_tmp) ! call ocn_config_TEMPLATE_validate(configPool, iErr=err_tmp) ! iErr = ior(iErr, err_tmp) end subroutine ocn_init_mode_validate_configuration!}}} diff --git a/src/core_ocean/mode_init/mpas_ocn_init_overflow.F b/src/core_ocean/mode_init/mpas_ocn_init_overflow.F new file mode 100644 index 0000000000..f86bbfa322 --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_overflow.F @@ -0,0 +1,340 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_overflow +! +!> \brief MPAS ocean initialize case -- Overflow +!> \author Doug Jacobsen +!> \date 02/18/2014 +!> \details +!> This module contains the routines for initializing the +!> the overflow test case +! +!----------------------------------------------------------------------- + +module ocn_init_overflow + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + + use ocn_constants + use ocn_init_vertical_grids + use ocn_init_cell_markers + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_overflow, & + ocn_init_validate_overflow + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_overflow +! +!> \brief Setup for overflow test case +!> \author Doug Jacobsen +!> \date 02/18/2014 +!> \details +!> This routine sets up the initial conditions for the overflow test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_overflow(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + real (kind=RKIND) :: yMin, yMax, dcEdgeMin + real (kind=RKIND) :: yMinGlobal, yMaxGlobal, dcEdgeMinGlobal + real (kind=RKIND) :: plugWidth + real (kind=RKIND) :: slopeCenter, slopeWidth + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: verticalMeshPool + + integer :: iCell, k + + ! Define dimensions + integer, pointer :: nCellsSolve, nEdgesSolve, nVertLevels, nVertLevelsP1 + integer, pointer :: index_temperature, index_salinity + + ! Define arrays + integer, dimension(:), pointer :: maxLevelCell + real (kind=RKIND), dimension(:), pointer :: yCell, refBottomDepth, bottomDepth, vertCoordMovementWeights, dcEdge + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + + ! Define configs + character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid, config_overflow_layer_type + logical, pointer :: config_overflow_use_distances + real (kind=RKIND), pointer :: config_overflow_plug_width_dist, config_overflow_slope_center_dist, & + config_overflow_slope_width_dist, config_overflow_plug_width_frac, & + config_overflow_slope_center_frac, config_overflow_slope_width_frac, & + config_overflow_bottom_depth, config_overflow_ridge_depth, & + config_overflow_plug_temperature, config_overflow_domain_temperature, config_overflow_salinity, & + config_overflow_isopycnal_min_thickness + + + real (kind=RKIND), dimension(:), pointer :: interfaceLocations + + iErr = 0 + + + call mpas_pool_get_config(ocnConfigs, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('overflow')) return + + call mpas_pool_get_config(ocnConfigs, 'config_vertical_grid', config_vertical_grid) + + call mpas_pool_get_config(ocnConfigs, 'config_overflow_use_distances', config_overflow_use_distances) + call mpas_pool_get_config(ocnConfigs, 'config_overflow_plug_width_dist', config_overflow_plug_width_dist) + call mpas_pool_get_config(ocnConfigs, 'config_overflow_slope_center_dist', config_overflow_slope_center_dist) + call mpas_pool_get_config(ocnConfigs, 'config_overflow_slope_width_dist', config_overflow_slope_width_dist) + call mpas_pool_get_config(ocnConfigs, 'config_overflow_plug_width_frac', config_overflow_plug_width_frac) + call mpas_pool_get_config(ocnConfigs, 'config_overflow_slope_center_frac', config_overflow_slope_center_frac) + call mpas_pool_get_config(ocnConfigs, 'config_overflow_slope_width_frac', config_overflow_slope_width_frac) + call mpas_pool_get_config(ocnConfigs, 'config_overflow_bottom_depth', config_overflow_bottom_depth) + call mpas_pool_get_config(ocnConfigs, 'config_overflow_ridge_depth', config_overflow_ridge_depth) + call mpas_pool_get_config(ocnConfigs, 'config_overflow_plug_temperature', config_overflow_plug_temperature) + call mpas_pool_get_config(ocnConfigs, 'config_overflow_domain_temperature', config_overflow_domain_temperature) + call mpas_pool_get_config(ocnConfigs, 'config_overflow_salinity', config_overflow_salinity) + call mpas_pool_get_config(ocnConfigs, 'config_overflow_layer_type', config_overflow_layer_type) + call mpas_pool_get_config(ocnConfigs, 'config_overflow_isopycnal_min_thickness', config_overflow_isopycnal_min_thickness) + + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nVertLevelsP1', nVertLevelsP1) + + allocate(interfaceLocations(nVertLevelsP1)) + call ocn_generate_vertical_grid(config_vertical_grid, interfaceLocations) + + ! Initalize y values to large positive and negative values + yMin = 1.0E10_RKIND + yMax = -1.0E10_RKIND + dcEdgeMin = 1.0E10_RKIND + + ! Determine local min and max y value. + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + + yMin = min( yMin, minval(yCell(1:nCellssolve))) + yMax = max( yMax, maxval(yCell(1:nCellssolve))) + dcEdgeMin = min( dcEdgeMin, minval(dcEdge(1:nEdgessolve))) + + block_ptr => block_ptr % next + end do + + ! Determine global min and max y value. This is so the domain + ! can be split into north and south. + call mpas_dmpar_min_real(domain % dminfo, yMin, yMinGlobal) + call mpas_dmpar_max_real(domain % dminfo, yMax, yMaxGlobal) + call mpas_dmpar_min_real(domain % dminfo, dcEdgeMin, dcEdgeMinGlobal) + + if ( config_overflow_use_distances ) then + plugWidth = config_overflow_plug_width_dist + slopeCenter = yMinGlobal + config_overflow_slope_center_dist + slopeWidth = config_overflow_slope_width_dist + else + plugWidth = (yMaxGlobal - yMinGlobal) * config_overflow_plug_width_frac + slopeCenter = yMinGlobal + (yMaxGlobal - yMinGlobal) * config_overflow_slope_center_frac + slopeWidth = (yMaxGlobal - yMinGlobal) * config_overflow_slope_width_frac + end if + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) + + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + call ocn_mark_north_boundary(meshPool, yMaxGlobal, dcEdgeMinGlobal, iErr) + call ocn_mark_south_boundary(meshPool, yMinGlobal, dcEdgeMinGlobal, iErr) + + ! Set refBottomDepth, bottomDepth, and maxLevelCell + do k = 1, nVertLevels + refBottomDepth(k) = config_overflow_bottom_depth * interfaceLocations(k+1) + end do + + do iCell = 1, nCellsSolve + ! From Mehmet Ilicak: + ! depth=2000 + ! val1 = 500 is top of ridge + ! h(i,j) = val1 + 0.5*(depth-val1) * (1.0+TANH((lon(i,j)-40000.0)/7000.0)) + bottomDepth(iCell) = config_overflow_ridge_depth & + + 0.5_RKIND*(config_overflow_bottom_depth - config_overflow_ridge_depth) & + * (1.0_RKIND+tanh((yCell(iCell) - slopeCenter)/slopeWidth)) + + if ( trim(config_overflow_layer_type) == 'sigma' .or. trim(config_overflow_layer_type) == 'isopycnal' ) then + maxLevelCell(iCell) = nVertLevels + else if ( trim(config_overflow_layer_type) == 'z-level' ) then + maxLevelCell(iCell) = -1 + do k = 1, nVertLevels + if (bottomDepth(iCell) .le. refBottomDepth(k) .and. & + maxLevelCell(iCell) == -1) then + + maxLevelCell(iCell) = k + end if + end do + end if + end do + + do iCell = 1, nCellsSolve + ! Set temperature + if ( trim(config_overflow_layer_type) == 'sigma' .or. trim(config_overflow_layer_type) == 'z-level' ) then + do k = 1, maxLevelCell(iCell) + if(yCell(iCell) < yMinGlobal + plugWidth) then + tracers(index_temperature, k, iCell) = config_overflow_plug_temperature + else + tracers(index_temperature, k, iCell) = config_overflow_domain_temperature + end if + end do + else if ( trim(config_overflow_layer_type) == 'isopycnal' ) then + tracers(index_temperature, 1, :) = config_overflow_domain_temperature + tracers(index_temperature, 2:nVertLevels, :) = config_overflow_plug_temperature + end if + + ! Set layerThickness and restingThickness + if ( trim(config_overflow_layer_type) == 'z-level' ) then + do k = 1, maxLevelCell(iCell) + layerThickness(k, iCell) = config_overflow_bottom_depth * (interfaceLocations(k+1) - interfaceLocations(k)) + restingThickness(k, iCell) = layerThickness(k, iCell) + end do + else if ( trim(config_overflow_layer_type) == 'sigma' ) then + do k = 1, nVertLevels + layerThickness(k, iCell) = bottomDepth(iCell) / nVertLevels + restingThickness(k, iCell) = layerThickness(k, iCell) + end do + else if ( trim(config_overflow_layer_type) == 'isopycnal' ) then + ! Set layerThickness. Normally isopycnal overflow has only two layers. + if ( yCell(iCell) < yMinGlobal + plugWidth) then + layerThickness(1, iCell) = config_overflow_isopycnal_min_thickness + layerThickness(2:nVertLevels, iCell) = bottomDepth(iCell) - config_overflow_isopycnal_min_thickness + restingThickness(:, iCell) = layerThickness(:, iCell) + else + layerThickness(1, iCell) = bottomDepth(iCell) - config_overflow_isopycnal_min_thickness + layerThickness(2:nVertLevels, iCell) = config_overflow_isopycnal_min_thickness + restingThickness(:, iCell) = layerThickness(:, iCell) + end if + end if + + ! Set salinity + tracers(index_salinity, :, iCell) = config_overflow_salinity + end do + + ! Set vertCoordMovementWeights + vertCoordMovementWeights(:) = 1.0_RKIND + + block_ptr => block_ptr % next + end do + + deallocate(interfaceLocations) + + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_overflow!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_overflow +! +!> \brief Validation for overflow test case +!> \author Doug Jacobsen +!> \date 02/20/2014 +!> \details +!> This routine validates the configuration options for the overflow test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_overflow(configPool, packagePool, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: configPool, packagePool + + integer, intent(out) :: iErr + + character (len=StrKIND), pointer :: config_init_configuration + integer, pointer :: config_overflow_vert_levels, config_vert_levels + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('overflow')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_overflow_vert_levels', config_overflow_vert_levels) + + if(config_vert_levels <= 0 .and. config_overflow_vert_levels > 0) then + config_vert_levels = config_overflow_vert_levels + else if(config_vert_levels <= 0) then + write(stderrUnit,*) 'ERROR: Validation failed for overflow test case. Not given a usable value for vertical levels.' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_overflow!}}} + +!*********************************************************************** + +end module ocn_init_overflow + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker From 82fef45797fa49def252820bbc3aca28f8abda8d Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Fri, 3 Apr 2015 12:46:41 -0600 Subject: [PATCH 0095/1724] Adding cvmix convecton unit test configuration This commit adds the configuration for the cvmix convection unit test. --- src/core_ocean/Makefile | 1 + src/core_ocean/mode_init/Makefile | 3 + src/core_ocean/mode_init/Registry.xml | 1 + .../Registry_cvmix_convection_unit_test.xml | 27 ++ ...mpas_ocn_init_cvmix_convection_unit_test.F | 265 ++++++++++++++++++ src/core_ocean/mode_init/mpas_ocn_init_mode.F | 4 + 6 files changed, 301 insertions(+) create mode 100644 src/core_ocean/mode_init/Registry_cvmix_convection_unit_test.xml create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_cvmix_convection_unit_test.F diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index 9f558d1695..96aa63dbd8 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -27,6 +27,7 @@ core_input_gen: (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.lock_exchange mode=init configuration=lock_exchange) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.internal_waves mode=init configuration=internal_waves) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.overflow mode=init configuration=overflow) + (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.cvmix_convection_unit_test mode=init configuration=cvmix_convection_unit_test) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean stream_list.ocean. mutable ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.forward stream_list.ocean.forward. mutable mode=forward ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis ) diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile index 1ce2b5be14..1ee54c52a6 100644 --- a/src/core_ocean/mode_init/Makefile +++ b/src/core_ocean/mode_init/Makefile @@ -10,6 +10,7 @@ TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ mpas_ocn_init_lock_exchange.o \ mpas_ocn_init_internal_waves.o \ mpas_ocn_init_overflow.o \ + mpas_ocn_init_cvmix_convection_unit_test.o \ #mpas_ocn_init_TEMPLATE.o all: init_mode @@ -32,6 +33,8 @@ mpas_ocn_init_internal_waves.o: $(UTILS) mpas_ocn_init_overflow.o: $(UTILS) +mpas_ocn_init_cvmix_convection_unit_test.o: $(UTILS) + #mpas_ocn_init_TEMPLATE.o: $(UTILS) clean: diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml index eeb5314525..97a2376266 100644 --- a/src/core_ocean/mode_init/Registry.xml +++ b/src/core_ocean/mode_init/Registry.xml @@ -2,4 +2,5 @@ #include "Registry_lock_exchange.xml" #include "Registry_internal_waves.xml" #include "Registry_overflow.xml" +#include "Registry_cvmix_convection_unit_test.xml" // #include "Registry_TEMPLATE.xml" diff --git a/src/core_ocean/mode_init/Registry_cvmix_convection_unit_test.xml b/src/core_ocean/mode_init/Registry_cvmix_convection_unit_test.xml new file mode 100644 index 0000000000..d3a3468ccb --- /dev/null +++ b/src/core_ocean/mode_init/Registry_cvmix_convection_unit_test.xml @@ -0,0 +1,27 @@ + + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_convection_unit_test.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_convection_unit_test.F new file mode 100644 index 0000000000..3cd3b65d16 --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_convection_unit_test.F @@ -0,0 +1,265 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_cvmix_convection_unit_test +! +!> \brief MPAS ocean initialize case -- CVMix Convective Mixing Unit Test +!> \author Doug Jacobsen +!> \date 04/01/2015 +!> \details +!> This module contains the routines for initializing the +!> the cvmix convective mixing unit test case +! +!----------------------------------------------------------------------- + +module ocn_init_cvmix_convection_unit_test + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + + use ocn_init_vertical_grids + use ocn_init_cell_markers + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_cvmix_convection_unit_test, & + ocn_init_validate_cvmix_convection_unit_test + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_cvmix_convection_unit_test +! +!> \brief Setup for cvmix convective mixing unit test case +!> \author Doug Jacobsen +!> \date 04/01/2015 +!> \details +!> This routine sets up the initial conditions for the cvmix convective mixing unit test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_cvmix_convection_unit_test(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + real (kind=RKIND) :: maxMidDepth, temperature + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool + type (mpas_pool_type), pointer :: diagnosticsPool, forcingPool + + integer :: iCell, iEdge, k, idx + integer, pointer :: nCellsSolve, nEdgesSolve, nVertLevels, nVertLevelsP1 + integer, pointer :: index_temperature, index_salinity + + integer, dimension(:), pointer :: maxLevelCell + + real (kind=RKIND), dimension(:), pointer :: yCell, dcEdge, refBottomDepth, vertCoordMovementWeights + real (kind=RKIND), dimension(:), pointer :: temperatureRestore, salinityRestore, bottomDepth, boundaryLayerDepth + real (kind=RKIND), dimension(:), pointer :: surfaceWindStress, angleEdge, refZMid + real (kind=RKIND), dimension(:, :), pointer :: layerThickness, restingThickness + real (kind=RKIND), dimension(:, :, :), pointer :: tracers + + real (kind=RKIND), dimension(:), pointer :: interfaceLocations + + character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid + real (kind=RKIND), pointer :: config_cvmix_convection_unit_test_bottom_depth, config_cvmix_convection_unit_test_bottom_temperature, & + config_cvmix_convection_unit_test_surface_temperature, config_cvmix_convection_unit_test_salinity, & + config_cvmix_convection_unit_test_max_windstress + + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('cvmix_convection_unit_test')) return + + call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) + call mpas_pool_get_config(domain % configs, 'config_vertical_grid', config_vertical_grid) + call mpas_pool_get_config(domain % configs, 'config_cvmix_convection_unit_test_bottom_depth', config_cvmix_convection_unit_test_bottom_depth) + call mpas_pool_get_config(domain % configs, 'config_cvmix_convection_unit_test_bottom_temperature', config_cvmix_convection_unit_test_bottom_temperature) + call mpas_pool_get_config(domain % configs, 'config_cvmix_convection_unit_test_surface_temperature', config_cvmix_convection_unit_test_surface_temperature) + call mpas_pool_get_config(domain % configs, 'config_cvmix_convection_unit_test_salinity', config_cvmix_convection_unit_test_salinity) + call mpas_pool_get_config(domain % configs, 'config_cvmix_convection_unit_test_max_windstress', config_cvmix_convection_unit_test_max_windstress) + + ! Determine vertical mesh interface locations + call mpas_pool_get_config(domain % configs, 'config_vertical_grid', config_vertical_grid) + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nVertLevelsP1', nVertLevelsP1) + allocate(interfaceLocations(nVertLevelsP1)) + call ocn_generate_vertical_grid(config_vertical_grid, interfaceLocations) + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) + call mpas_pool_get_array(meshPool, 'temperatureRestore', temperatureRestore) + call mpas_pool_get_array(meshPool, 'salinityRestore', salinityRestore) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) + + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + + call mpas_pool_get_array(diagnosticsPool, 'boundaryLayerDepth', boundaryLayerDepth) + + call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) + + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + + ! Set refBottomDepth and refBottomDepthTopOfCell + do k = 1, nVertLevels + refBottomDepth(k) = config_cvmix_convection_unit_test_bottom_depth * interfaceLocations(k+1) + refZMid(k) = - config_cvmix_convection_unit_test_bottom_depth * ( interfaceLocations(k) + interfaceLocations(k+1) ) * 0.5_RKIND + end do + + maxMidDepth = -minval(refZMid(:)) + + ! Set vertCoordMovementWeights + vertCoordMovementWeights(:) = 1.0_RKIND + + do iCell = 1, nCellsSolve + ! Set stratified temperature + do k = nVertLevels, 1, -1 + temperature = config_cvmix_convection_unit_test_bottom_temperature & + + (config_cvmix_convection_unit_test_surface_temperature - config_cvmix_convection_unit_test_bottom_temperature) & + * ( (refZMid(k) - refZMid(nVertLevels)) / (-refZMid(nVertLevels) )) + tracers(index_temperature, k, iCell) = temperature + end do + + ! Set salinity + tracers(index_salinity, :, iCell) = config_cvmix_convection_unit_test_salinity + + ! Set layerThickness and restingThickness + do k = 1, nVertLevels + layerThickness(k, iCell) = config_cvmix_convection_unit_test_bottom_depth * ( interfaceLocations(k+1) - interfaceLocations(k) ) + restingThickness(k, iCell) = layerThickness(k, iCell) + end do + + ! Set temperatureRestore + temperatureRestore(iCell) = config_cvmix_convection_unit_test_surface_temperature - 10.0_RKIND + + ! Set salinityRestore + salinityRestore(iCell) = config_cvmix_convection_unit_test_salinity + + ! Set boundary layer depth + boundaryLayerDepth(iCell) = 2.0_RKIND * (config_cvmix_convection_unit_test_bottom_depth / nVertLevels) - 1.0-4_RKIND + + ! Set bottomDepth + bottomDepth(iCell) = config_cvmix_convection_unit_test_bottom_depth + + ! Set maxLevelCell + maxLevelCell(iCell) = nVertLevels + end do + + do iEdge = 1, nEdgesSolve + surfaceWindStress(iEdge) = config_cvmix_convection_unit_test_max_windstress * cos(angleEdge(iEdge)) + end do + + block_ptr => block_ptr % next + end do + + deallocate(interfaceLocations) + + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_cvmix_convection_unit_test!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_cvmix_convection_unit_test +! +!> \brief Validation for cvmix convection unit test case +!> \author Doug Jacobsen +!> \date 04/01/2015 +!> \details +!> This routine validates the configuration options for the CVMix convective mixing unit test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_cvmix_convection_unit_test(configPool, packagePool, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + integer, intent(out) :: iErr + + character(len=StrKIND), pointer :: config_init_configuration + integer, pointer :: config_vert_levels, config_cvmix_convection_unit_test_vert_levels + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('cvmix_convection_unit_test')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_cvmix_convection_unit_test_vert_levels', config_cvmix_convection_unit_test_vert_levels) + + if(config_vert_levels <= 0 .and. config_cvmix_convection_unit_test_vert_levels > 0) then + config_vert_levels = config_cvmix_convection_unit_test_vert_levels + else if(config_vert_levels <= 0) then + write(stderrUnit,*) 'ERROR: Validation failed for CVMix convection unit test case. Not given a usable value for vertical levels.' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_cvmix_convection_unit_test!}}} + +!*********************************************************************** + +end module ocn_init_cvmix_convection_unit_test + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index cb4a36b783..040d917396 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -42,6 +42,7 @@ module ocn_init_mode use ocn_init_lock_exchange use ocn_init_internal_waves use ocn_init_overflow + use ocn_init_cvmix_convection_unit_test implicit none private @@ -245,6 +246,7 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call ocn_init_setup_lock_exchange(domain, ierr) call ocn_init_setup_internal_waves(domain, ierr) call ocn_init_setup_overflow(domain, ierr) + call ocn_init_setup_cvmix_convection_unit_test(domain, ierr) !call ocn_init_setup_TEMPLATE(domain, ierr) call mpas_timer_start('io_write', .false.) @@ -324,6 +326,8 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, iErr)!{ iErr = ior(iErr, err_tmp) call ocn_init_validate_overflow(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) + call ocn_init_validate_cvmix_convection_unit_test(configPool, packagePool, iErr=err_tmp) + iErr = ior(iErr, err_tmp) ! call ocn_config_TEMPLATE_validate(configPool, iErr=err_tmp) ! iErr = ior(iErr, err_tmp) end subroutine ocn_init_mode_validate_configuration!}}} From 933e103208aa3ef9110cdf67d5521be47eeb4699 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Fri, 3 Apr 2015 13:34:16 -0600 Subject: [PATCH 0096/1724] Adding cvmix shear unit test configuration This commit adds the configuration for the cvmix shear unit test. --- src/core_ocean/Makefile | 1 + src/core_ocean/mode_init/Makefile | 3 + src/core_ocean/mode_init/Registry.xml | 1 + .../Registry_cvmix_shear_unit_test.xml | 27 ++ .../mpas_ocn_init_cvmix_shear_unit_test.F | 262 ++++++++++++++++++ src/core_ocean/mode_init/mpas_ocn_init_mode.F | 4 + 6 files changed, 298 insertions(+) create mode 100644 src/core_ocean/mode_init/Registry_cvmix_shear_unit_test.xml create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_cvmix_shear_unit_test.F diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index 96aa63dbd8..58b23340f7 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -28,6 +28,7 @@ core_input_gen: (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.internal_waves mode=init configuration=internal_waves) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.overflow mode=init configuration=overflow) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.cvmix_convection_unit_test mode=init configuration=cvmix_convection_unit_test) + (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.cvmix_shear_unit_test mode=init configuration=cvmix_shear_unit_test) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean stream_list.ocean. mutable ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.forward stream_list.ocean.forward. mutable mode=forward ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis ) diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile index 1ee54c52a6..8297955c39 100644 --- a/src/core_ocean/mode_init/Makefile +++ b/src/core_ocean/mode_init/Makefile @@ -11,6 +11,7 @@ TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ mpas_ocn_init_internal_waves.o \ mpas_ocn_init_overflow.o \ mpas_ocn_init_cvmix_convection_unit_test.o \ + mpas_ocn_init_cvmix_shear_unit_test.o #mpas_ocn_init_TEMPLATE.o all: init_mode @@ -35,6 +36,8 @@ mpas_ocn_init_overflow.o: $(UTILS) mpas_ocn_init_cvmix_convection_unit_test.o: $(UTILS) +mpas_ocn_init_cvmix_shear_unit_test.o: $(UTILS) + #mpas_ocn_init_TEMPLATE.o: $(UTILS) clean: diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml index 97a2376266..f378a3c97e 100644 --- a/src/core_ocean/mode_init/Registry.xml +++ b/src/core_ocean/mode_init/Registry.xml @@ -3,4 +3,5 @@ #include "Registry_internal_waves.xml" #include "Registry_overflow.xml" #include "Registry_cvmix_convection_unit_test.xml" +#include "Registry_cvmix_shear_unit_test.xml" // #include "Registry_TEMPLATE.xml" diff --git a/src/core_ocean/mode_init/Registry_cvmix_shear_unit_test.xml b/src/core_ocean/mode_init/Registry_cvmix_shear_unit_test.xml new file mode 100644 index 0000000000..748a13b7d3 --- /dev/null +++ b/src/core_ocean/mode_init/Registry_cvmix_shear_unit_test.xml @@ -0,0 +1,27 @@ + + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_shear_unit_test.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_shear_unit_test.F new file mode 100644 index 0000000000..846e64d764 --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_shear_unit_test.F @@ -0,0 +1,262 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_cvmix_shear_unit_test +! +!> \brief MPAS ocean initialize case -- CVMix shear Mixing Unit Test +!> \author Doug Jacobsen +!> \date 04/01/2015 +!> \details +!> This module contains the routines for initializing the +!> the cvmix shear mixing unit test configuration +! +!----------------------------------------------------------------------- + +module ocn_init_cvmix_shear_unit_test + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + + use ocn_init_cell_markers + use ocn_init_vertical_grids + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_cvmix_shear_unit_test, & + ocn_init_validate_cvmix_shear_unit_test + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_cvmix_shear_unit_test +! +!> \brief Setup for cvmix shear mixing unit test configuration +!> \author Doug Jacobsen +!> \date 04/01/2015 +!> \details +!> This routine sets up the initial conditions for the cvmix shear mixing unit test configuration. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_cvmix_shear_unit_test(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + real (kind=RKIND) :: maxMidDepth, temperature + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool + type (mpas_pool_type), pointer :: diagnosticsPool, forcingPool + + integer, pointer :: nVertLevels, nVertLevelsP1, nCellsSolve, nEdgesSolve + integer, pointer :: index_temperature, index_salinity + + integer, dimension(:), pointer :: maxLevelCell + real (kind=RKIND), dimension(:), pointer :: refBottomDepth, refZMid, vertCoordMovementWeights + real (kind=RKIND), dimension(:), pointer :: surfaceWindStress, boundaryLayerDepth, temperatureRestore + real (kind=RKIND), dimension(:), pointer :: salinityRestore, bottomDepth, angleEdge + real (kind=RKIND), dimension(:, :), pointer :: layerThickness, restingThickness + real (kind=RKIND), dimension(:, :, :), pointer :: tracers + + real (kind=RKIND), dimension(:), pointer :: interfaceLocations + + integer :: iCell, iEdge, k, idx + + character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid + real (kind=RKIND), pointer :: config_cvmix_shear_unit_test_bottom_depth, config_cvmix_shear_unit_test_bottom_temperature, & + config_cvmix_shear_unit_test_surface_temperature, config_cvmix_shear_unit_test_salinity, & + config_cvmix_shear_unit_test_max_windstress + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('cvmix_shear_unit_test')) return + + + call mpas_pool_get_config(domain % configs, 'config_cvmix_shear_unit_test_bottom_depth', config_cvmix_shear_unit_test_bottom_depth) + call mpas_pool_get_config(domain % configs, 'config_cvmix_shear_unit_test_bottom_temperature', config_cvmix_shear_unit_test_bottom_temperature) + call mpas_pool_get_config(domain % configs, 'config_cvmix_shear_unit_test_surface_temperature', config_cvmix_shear_unit_test_surface_temperature) + call mpas_pool_get_config(domain % configs, 'config_cvmix_shear_unit_test_salinity', config_cvmix_shear_unit_test_salinity) + call mpas_pool_get_config(domain % configs, 'config_cvmix_shear_unit_test_max_windstress', config_cvmix_shear_unit_test_max_windstress) + + call mpas_pool_get_config(domain % configs, 'config_vertical_grid', config_vertical_grid) + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nVertLevelsP1', nVertLevelsP1) + allocate(interfaceLocations(nVertLevelsP1)) + call ocn_generate_vertical_grid(config_vertical_grid, interfaceLocations) + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'temperatureRestore', temperatureRestore) + call mpas_pool_get_array(meshPool, 'salinityRestore', salinityRestore) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) + + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + + call mpas_pool_get_array(diagnosticsPool, 'boundaryLayerDepth', boundaryLayerDepth) + + call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) + + ! Set refBottomDepth and refBottomDepthTopOfCell + do k = 1, nVertLevels + refBottomDepth(k) = config_cvmix_shear_unit_test_bottom_depth * interfaceLocations(k+1) + refZMid(k) = - 0.5_RKIND * config_cvmix_shear_unit_test_bottom_depth * (interfaceLocations(k) + interfaceLocations(k+1)) + end do + + maxMidDepth = -minval(refZMid(:)) + + ! Set vertCoordMovementWeights + vertCoordMovementWeights(:) = 1.0_RKIND + + do iCell = 1, nCellsSolve + ! Set stratified temperature + do k = nVertLevels, 1, -1 + temperature = config_cvmix_shear_unit_test_bottom_temperature & + + (config_cvmix_shear_unit_test_surface_temperature - config_cvmix_shear_unit_test_bottom_temperature) & + * ( (refZMid(k) - refZMid(nVertLevels)) / ( - refZMid(nVertLevels) )) + tracers(index_temperature, k, iCell) = temperature + end do + + ! Set salinity + tracers(index_salinity, :, iCell) = config_cvmix_shear_unit_test_salinity + + ! Set layerThickness + do k = 1, nVertLevels + layerThickness(k, iCell) = config_cvmix_shear_unit_test_bottom_depth * (interfaceLocations(k+1) - interfaceLocations(k)) + restingThickness(k, iCell) = layerThickness(k, iCell) + end do + + ! Set temperatureRestore + temperatureRestore(iCell) = config_cvmix_shear_unit_test_surface_temperature + 10.0_RKIND + + ! Set salinityRestore + salinityRestore(iCell) = config_cvmix_shear_unit_test_salinity + + ! Set boundary layer depth + boundaryLayerDepth(iCell) = 2.0_RKIND * (config_cvmix_shear_unit_test_bottom_depth / nVertLevels) - 1.0-4_RKIND + + ! Set bottomDepth + bottomDepth(iCell) = config_cvmix_shear_unit_test_bottom_depth + + ! Set maxLevelCell + maxLevelCell(iCell) = nVertLevels + end do + + do iEdge = 1, nEdgesSolve + surfaceWindStress(iEdge) = config_cvmix_shear_unit_test_max_windstress * cos(angleEdge(iEdge)) + end do + + block_ptr => block_ptr % next + end do + + deallocate(interfaceLocations) + + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_cvmix_shear_unit_test!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_cvmix_shear_unit_test +! +!> \brief Validation for CVMix shear mixing unit test case +!> \author Doug Jacobsen +!> \date 04/01/2015 +!> \details +!> This routine validates the configuration options for the CVMix shear mixing unit test configuration. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_cvmix_shear_unit_test(configPool, packagePool, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + integer, intent(out) :: iErr + + character (len=StrKIND), pointer :: config_init_configuration + integer, pointer :: config_vert_levels, config_cvmix_shear_unit_test_vert_levels + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('cvmix_shear_unit_test')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_cvmix_shear_unit_test_vert_levels', config_cvmix_shear_unit_test_vert_levels) + + if(config_vert_levels <= 0 .and. config_cvmix_shear_unit_test_vert_levels > 0) then + config_vert_levels = config_cvmix_shear_unit_test_vert_levels + else if(config_vert_levels <= 0) then + write(stderrUnit,*) 'ERROR: Validation failed for CVMix shear mixing unit test case. Not given a usable value for vertical levels.' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_cvmix_shear_unit_test!}}} + +!*********************************************************************** + +end module ocn_init_cvmix_shear_unit_test + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 040d917396..8c7487d518 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -43,6 +43,7 @@ module ocn_init_mode use ocn_init_internal_waves use ocn_init_overflow use ocn_init_cvmix_convection_unit_test + use ocn_init_cvmix_shear_unit_test implicit none private @@ -247,6 +248,7 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call ocn_init_setup_internal_waves(domain, ierr) call ocn_init_setup_overflow(domain, ierr) call ocn_init_setup_cvmix_convection_unit_test(domain, ierr) + call ocn_init_setup_cvmix_shear_unit_test(domain, ierr) !call ocn_init_setup_TEMPLATE(domain, ierr) call mpas_timer_start('io_write', .false.) @@ -328,6 +330,8 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, iErr)!{ iErr = ior(iErr, err_tmp) call ocn_init_validate_cvmix_convection_unit_test(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) + call ocn_init_validate_cvmix_shear_unit_test(configPool, packagePool, iErr=err_tmp) + iErr = ior(iErr, err_tmp) ! call ocn_config_TEMPLATE_validate(configPool, iErr=err_tmp) ! iErr = ior(iErr, err_tmp) end subroutine ocn_init_mode_validate_configuration!}}} From 15d510740f5f64dd46b14200853c89f007f510cc Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Tue, 14 Apr 2015 14:08:58 -0600 Subject: [PATCH 0097/1724] Adding global realistic configuration This commit adds the global realistic configuration to the init mode. --- src/core_ocean/Makefile | 1 + src/core_ocean/mode_init/Makefile | 5 +- src/core_ocean/mode_init/Registry.xml | 1 + .../mode_init/Registry_global_realistic.xml | 177 ++ .../mpas_ocn_init_global_realistic.F | 1697 +++++++++++++++++ src/core_ocean/mode_init/mpas_ocn_init_mode.F | 6 +- 6 files changed, 1885 insertions(+), 2 deletions(-) create mode 100644 src/core_ocean/mode_init/Registry_global_realistic.xml create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index 58b23340f7..27e1f483dd 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -29,6 +29,7 @@ core_input_gen: (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.overflow mode=init configuration=overflow) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.cvmix_convection_unit_test mode=init configuration=cvmix_convection_unit_test) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.cvmix_shear_unit_test mode=init configuration=cvmix_shear_unit_test) + (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.global_realistic mode=init configuration=global_realistic) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean stream_list.ocean. mutable ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.forward stream_list.ocean.forward. mutable mode=forward ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis ) diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile index 8297955c39..6a02878e01 100644 --- a/src/core_ocean/mode_init/Makefile +++ b/src/core_ocean/mode_init/Makefile @@ -11,7 +11,8 @@ TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ mpas_ocn_init_internal_waves.o \ mpas_ocn_init_overflow.o \ mpas_ocn_init_cvmix_convection_unit_test.o \ - mpas_ocn_init_cvmix_shear_unit_test.o + mpas_ocn_init_cvmix_shear_unit_test.o \ + mpas_ocn_init_global_realistic.o #mpas_ocn_init_TEMPLATE.o all: init_mode @@ -38,6 +39,8 @@ mpas_ocn_init_cvmix_convection_unit_test.o: $(UTILS) mpas_ocn_init_cvmix_shear_unit_test.o: $(UTILS) +mpas_ocn_init_global_realistic.o: $(UTILS) + #mpas_ocn_init_TEMPLATE.o: $(UTILS) clean: diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml index f378a3c97e..65b6e0938f 100644 --- a/src/core_ocean/mode_init/Registry.xml +++ b/src/core_ocean/mode_init/Registry.xml @@ -4,4 +4,5 @@ #include "Registry_overflow.xml" #include "Registry_cvmix_convection_unit_test.xml" #include "Registry_cvmix_shear_unit_test.xml" +#include "Registry_global_realistic.xml" // #include "Registry_TEMPLATE.xml" diff --git a/src/core_ocean/mode_init/Registry_global_realistic.xml b/src/core_ocean/mode_init/Registry_global_realistic.xml new file mode 100644 index 0000000000..1154c13062 --- /dev/null +++ b/src/core_ocean/mode_init/Registry_global_realistic.xml @@ -0,0 +1,177 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F b/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F new file mode 100644 index 0000000000..05450f3391 --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F @@ -0,0 +1,1697 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_global_realistic +! +!> \brief MPAS ocean initialize case -- Global Realistic +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This module contains the routines for initializing the +!> the global realistic test case +! +!----------------------------------------------------------------------- + +module ocn_init_global_realistic + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + use mpas_io + use mpas_io_streams + use mpas_dmpar + + use ocn_init_cell_markers + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_global_realistic, & + ocn_init_validate_global_realistic + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + integer :: nDepth + integer :: nLatTracer, nLonTracer + integer :: nLatWind, nLonWind + integer :: nLatTopo, nLonTopo + type (field1DReal) :: depthIC + type (field1DReal) :: windLat, windLon + type (field1DReal) :: topoLat, topoLon + type (field1DReal) :: tracerLat, tracerLon + type (field2DReal) :: topoIC, zonalWindIC, meridionalWindIC + type (field3DReal) :: temperatureIC, salinityIC + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_global_realistic +! +!> \brief Setup for global realistic test case +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine sets up the initial conditions for the global realistic test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_realistic(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + type (mpas_pool_type), pointer :: meshPool + integer, intent(out) :: iErr + + character (len=StrKIND), pointer :: config_init_configuration + logical, pointer :: config_global_realistic_cull_inland_seas + + logical, pointer :: on_a_sphere + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) + + if (trim(config_init_configuration) /= "global_realistic") return + + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + + if ( .not. on_a_sphere ) call mpas_dmpar_global_abort('ERROR: The global realistic configuration can only be applied to a spherical mesh. Exiting...') + + call mpas_pool_get_config(domain % configs, 'config_global_realistic_cull_inland_seas', config_global_realistic_cull_inland_seas) + + write(stderrUnit,*) 'Reading depth levels.' + call ocn_init_setup_global_realistic_read_depth_levels(domain, iErr) + + write(stderrUnit,*) 'Reading topography data.' + call ocn_init_setup_global_realistic_read_topo(domain, iErr) + write(stderrUnit,*) 'Interpolating topography data.' + call ocn_init_setup_global_realistic_interpolate_topo(domain, iErr) + write(stderrUnit,*) 'Cleaning up topography IC fields' + call ocn_init_global_realistic_destroy_topo_fields() + + if (config_global_realistic_cull_inland_seas) then + write(stderrUnit,*) 'Removing inland seas.' + call ocn_init_setup_global_realistic_cull_inland_seas(domain, iErr) + end if + + + write(stderrUnit,*) 'Reading temperature IC.' + call ocn_init_setup_global_realistic_read_temperature(domain, iErr) + write(stderrUnit,*) 'Reading salinity IC.' + call ocn_init_setup_global_realistic_read_salinity(domain, iErr) + write(stderrUnit,*) 'Reading Lat/Lon tracer coordinates' + call ocn_init_setup_global_realistic_read_tracer_lat_lon(domain, iErr) + write(stderrUnit,*) 'Interpolating tracers' + call ocn_init_setup_global_realistic_interpolate_tracers(domain, iErr) + write(stderrUnit,*) 'Cleaning up tracer IC fields' + call ocn_init_global_realistic_destroy_tracer_fields() + + write(stderrUnit,*) 'Reading windstress IC.' + call ocn_init_setup_global_realistic_read_windstress(domain, iErr) + write(stderrUnit,*) 'Interpolating windstress.' + call ocn_init_setup_global_realistic_interpolate_windstress(domain, iErr) + write(stderrUnit,*) 'Destroying windstress fields' + call ocn_init_global_realistic_destroy_windstress_fields() + + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_global_realistic!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_realistic_read_topo +! +!> \brief Read the topography IC file +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine reads the topography IC file, including latitude and longitude +!> information for topography data. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_realistic_read_topo(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (MPAS_Stream_type) :: topographyStream + + character (len=StrKIND), pointer :: config_global_realistic_topography_file, config_global_realistic_topography_lat_varname, & + config_global_realistic_topography_nlat_dimname, config_global_realistic_topography_lon_varname, & + config_global_realistic_topography_nlon_dimname, config_global_realistic_topography_varname + + logical, pointer :: config_global_realistic_topography_latlon_degrees + + integer :: iLat, iLon + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_file', config_global_realistic_topography_file) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_lat_varname', config_global_realistic_topography_lat_varname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_nlat_dimname', config_global_realistic_topography_nlat_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_lon_varname', config_global_realistic_topography_lon_varname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_nlon_dimname', config_global_realistic_topography_nlon_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_varname', config_global_realistic_topography_varname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_latlon_degrees', config_global_realistic_topography_latlon_degrees) + + ! Define stream for depth levels + call MPAS_createStream(topographyStream, config_global_realistic_topography_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) + + ! Setup topoLat, topoLon, and topoIC fields for stream to be read in + topoLat % fieldName = trim(config_global_realistic_topography_lat_varname) + topoLat % dimSizes(1) = nLatTopo + topoLat % dimNames(1) = trim(config_global_realistic_topography_nlat_dimname) + topoLat % isVarArray = .false. + topoLat % isPersistent = .true. + topoLat % isActive = .true. + topoLat % hasTimeDimension = .false. + topoLat % block => domain % blocklist + allocate(topoLat % array(nLatTopo)) + + topoLon % fieldName = trim(config_global_realistic_topography_lon_varname) + topoLon % dimSizes(1) = nLonTopo + topoLon % dimNames(1) = trim(config_global_realistic_topography_nlon_dimname) + topoLon % isVarArray = .false. + topoLon % isPersistent = .true. + topoLon % isActive = .true. + topoLon % hasTimeDimension = .false. + topoLon % block => domain % blocklist + allocate(topoLon % array(nLonTopo)) + + topoIC % fieldName = trim(config_global_realistic_topography_varname) + topoIC % dimSizes(1) = nLonTopo + topoIC % dimSizes(2) = nLatTopo + topoIC % dimNames(1) = trim(config_global_realistic_topography_nlon_dimname) + topoIC % dimNames(2) = trim(config_global_realistic_topography_nlat_dimname) + topoIC % isVarArray = .false. + topoIC % isPersistent = .true. + topoIC % isActive = .true. + topoIC % hasTimeDimension = .false. + topoIC % block => domain % blocklist + allocate(topoIC % array(nLonTopo, nLatTopo)) + + ! Add topoLat, topoLon, and topoIC fields to stream + call MPAS_streamAddField(topographyStream, topoLat, iErr) + call MPAS_streamAddField(topographyStream, topoLon, iErr) + call MPAS_streamAddField(topographyStream, topoIC, iErr) + + ! Read stream + call MPAS_readStream(topographyStream, 1, iErr) + + ! Close stream + call MPAS_closeStream(topographyStream) + + if (config_global_realistic_topography_latlon_degrees) then + topoLat % array(:) = topoLat % array(:) * pii / 180.0_RKIND + topoLon % array(:) = topoLon % array(:) * pii / 180.0_RKIND + end if + + do iLon = 1, nLonTopo + if (topoLon % array(iLon) < 0.0_RKIND) then + topoLon % array(iLon) = 2.0_RKIND * pii + topoLon % array(iLon) + end if + end do + + end subroutine ocn_init_setup_global_realistic_read_topo!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_realistic_interpolate_topo +! +!> \brief Interpolate the topography IC to MPAS mesh +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine interpolates topography data to the MPAS mesh. Currently it +!> uses a bilinear interpolation +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_realistic_interpolate_topo(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool, scratchPool, statePool, verticalMeshPool + + real (kind=RKIND) :: currentLat, currentLon + real (kind=RKIND) :: dist, minDist, depth + real (kind=RKIND) :: alpha, beta, depthLat1, depthLat2, proposedDepth + + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell, bottomDepth, refBottomDepth + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness + + integer, pointer :: nCells, nCellsSolve, nVertLevels + + type (field1DInteger), pointer :: maxLevelCellField, smoothedLevelsField + integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell + integer, dimension(:, :), pointer :: cellsOnCell + + integer :: latSearch, lonSearch, searchIdx + integer :: iCell, coc, j, k, maxLevel + + logical, pointer :: config_global_realistic_smooth_topography + integer, pointer :: config_global_realistic_minimum_levels + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_realistic_minimum_levels', config_global_realistic_minimum_levels) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_smooth_topography', config_global_realistic_smooth_topography) + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + do iCell = 1, nCells + currentLat = latCell(iCell) + currentLon = lonCell(iCell) + + lonSearch = 1 + minDist = 2.0_RKIND * pii + do searchIdx = 1, nLonTopo + dist = abs(currentLon - topoLon % array(searchIdx)) + if (dist < minDist) then + minDist = dist + lonSearch = searchIdx + end if + end do + + latSearch = 1 + minDist = 2.0_RKIND * pii + do searchIdx = 1, nLatTopo + dist = abs(currentLat - topoLat % array(searchIdx)) + if (dist < minDist) then + minDist = dist + latSearch = searchIdx + end if + end do + + if (topoIC % array(lonSearch, latSearch) < 0.0_RKIND) then + bottomDepth(iCell) = abs(topoIC % array(lonSearch, latSearch)) + maxLevelCell(iCell) = -1 + do k = 1, nVertLevels + depth = refBottomDepth(k) + + if (depth > bottomDepth(iCell) .and. maxLevelCell(iCell) == -1) then + maxLevelCell(iCell) = k + end if + end do + + if (maxLevelCell(iCell) == -1) then + maxLevelCell(iCell) = nVertLevels + bottomDepth(iCell) = refBottomDepth( nVertLevels ) + else if (maxLevelCell(iCell) <= config_global_realistic_minimum_levels) then + maxLevelCell(iCell) = config_global_realistic_minimum_levels + bottomDepth(iCell) = refBottomDepth( config_global_realistic_minimum_levels ) + end if + + + + else + bottomDepth(iCell) = 0.0_RKIND + maxLevelCell(iCell) = -1 + end if + end do + + ! Smooth depth levels. Enforce different in maxLevelCell to only be a maximum + ! of 1 vertical level between two neighboring cells. + if (config_global_realistic_smooth_topography) then + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call mpas_pool_get_field(scratchPool, 'smoothedLevels', smoothedLevelsField) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + + call mpas_allocate_scratch_field(smoothedLevelsField, .true.) + + maxLevelCell(nCells+1) = -1 + smoothedLevelsField % array = maxLevelCell + + do iCell = 1, nCellsSolve + maxLevel = 0 + do j = 1, nEdgesOnCell(iCell) + coc = cellsOnCell(j, iCell) + maxLevel = max(maxLevel, maxLevelCell(coc)) + end do + + if (maxLevel < maxLevelCell(iCell) ) then + smoothedLevelsField % array(iCell) = maxLevel + 1 + bottomDepth(iCell) = refBottomDepth(maxLevel + 1) + end if + end do + + maxLevelCell(:) = smoothedLevelsField % array(:) + + call mpas_deallocate_scratch_field(smoothedLevelsField, .true.) + end if + + ! Enforce minimum number of layers in ocean cells. + do iCell = 1, nCells + if (maxLevelCell(iCell) > 0 .and. maxLevelCell(iCell) < config_global_realistic_minimum_levels) then + maxLevelCell(iCell) = config_global_realistic_minimum_levels + bottomDepth(iCell) = refBottomDepth(config_global_realistic_minimum_levels) + end if + end do + + block_ptr => block_ptr % next + end do + + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_field(meshPool, 'maxLevelCell', maxLevelCellField) + call mpas_dmpar_exch_halo_field(maxLevelCellField) + + ! Set layerThickness based on refBottomDepth and bottomDepth + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + + do iCell = 1, nCellsSolve + if (maxLevelCell(iCell) > 0) then + + ! By going to maxLevelCell, this loop sets the layer Thickness as the full cell at the bottom. + layerThickness(1, iCell) = refBottomDepth(1) + do k = 2, maxLevelCell(iCell) + layerThickness(k, iCell) = refBottomDepth(k) - refBottomDepth(k-1) + end do + + ! The following lines could be used for partial bottom cells, but only if the temperature is interpolated in the vertical as well. + ! In version 3.0, one may alter the IC for partial bottom cells on start-up in MPAS. + !k = maxLevelCell(iCell) + !layerThickness(k, iCell) = bottomDepth(iCell) - refBottomDepth(k-1) + + restingThickness(:, iCell) = layerThickness(:, iCell) + end if + end do + + block_ptr => block_ptr % next + end do + + end subroutine ocn_init_setup_global_realistic_interpolate_topo!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_realistic_cull_inland_seas +! +!> \brief Read the topography IC file +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine removes all inland seas. These are defined as isolated ocean cells. +!> It uses a parallel version of an advancing front algorithm which might not be +!> optimal for this purpose. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_realistic_cull_inland_seas(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: scratchPool, meshPool + + type (field1DInteger), pointer :: cullStackField, touchedCellField, oceanCellField + + real, dimension(:), pointer :: latCell, lonCell, bottomDepth + integer, dimension(:), pointer :: stack, oceanMask, touchMask + integer, pointer :: stackSize + + real (kind=RKIND) :: currentLat, currentLon + real (kind=RKIND) :: dist, minDist + + integer :: iCell + integer :: localStackSize, globalStackSize + integer :: j, coc + integer :: touched + + integer, pointer :: nCells, nCellsSolve, nVertLevels + integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell + integer, dimension(:, :), pointer :: cellsOnCell + + iErr = 0 + + call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) + + call mpas_pool_get_field(scratchPool, 'cullStack', cullStackField) + call mpas_pool_get_field(scratchPool, 'touchedCell', touchedCellField) + call mpas_pool_get_field(scratchPool, 'oceanCell', oceanCellField) + + call mpas_allocate_scratch_field(cullStackField, .false.) + call mpas_allocate_scratch_field(touchedCellField, .false.) + call mpas_allocate_scratch_field(oceanCellField, .false.) + + ! Seed all deepest points for advancing front algorithm + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + call mpas_pool_get_array(scratchPool, 'cullStack', stack) + call mpas_pool_get_array(scratchPool, 'oceanCell', oceanMask) + call mpas_pool_get_array(scratchPool, 'touchedCell', touchMask) + call mpas_pool_get_array(scratchPool, 'cullStackSize', stackSize) + + stack(:) = 0 + oceanMask(:) = 0 + touchMask(:) = 0 + stackSize = 0 + + ! Add all cells that have maxLevelCell == nVertLevels to stack + do iCell = 1, nCellsSolve + if (maxLevelCell(iCell) == nVertLevels) then + stackSize = stackSize + 1 + stack(stackSize) = iCell + touchMask(iCell) = 1 + oceanMask(iCell) = 1 + end if + end do + + block_ptr => block_ptr % next + end do + + ! Advancing front algorithm continues until all stacks on all processes are empty. + globalStackSize = 1 + do while(globalStackSize /= 0) + ! Advance front on each block with a non-zero stack until stack is empty. + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + + call mpas_pool_get_array(scratchPool, 'cullStack', stack) + call mpas_pool_get_array(scratchPool, 'oceanCell', oceanMask) + call mpas_pool_get_array(scratchPool, 'touchedCell', touchMask) + call mpas_pool_get_array(scratchPool, 'cullStackSize', stackSize) + + touched = 0 + do while(stackSize > 0) + iCell = stack(stackSize) + stackSize = stackSize - 1 + do j = 1, nEdgesOnCell(iCell) + coc = cellsOnCell(j, iCell) + if (touchMask(coc) == 0 .and. bottomDepth(coc) > 0.0_RKIND) then + oceanMask(coc) = 1 + stackSize = stackSize + 1 + stack(stackSize) = coc + end if + touchMask(coc) = 1 + touched = touched + 1 + end do + end do + + block_ptr => block_ptr % next + end do + + ! Perform a halo exchange on oceanMask + call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) + call mpas_pool_get_field(scratchPool, 'oceanCell', oceanCellField) + call mpas_dmpar_exch_halo_field(oceanCellField) + + ! Check to see if any cells have been masked as ocean in the halo that have not been touched. + ! If there are any, add them to the stack. Also, compute globalStackSize + localStackSize = 0 + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_array(scratchPool, 'cullStack', stack) + call mpas_pool_get_array(scratchPool, 'oceanCell', oceanMask) + call mpas_pool_get_array(scratchPool, 'touchedCell', touchMask) + call mpas_pool_get_array(scratchPool, 'cullStackSize', stackSize) + + do iCell = nCellsSolve, nCells + if (oceanMask(iCell) == 1 .and. touchMask(iCell) == 0) then + stackSize = stackSize + 1 + stack(stackSize) = iCell + touchMask(iCell) = 1 + end if + end do + + localStackSize = localStackSize + stackSize + block_ptr => block_ptr % next + end do + + call mpas_dmpar_sum_int(domain % dminfo, localStackSize, globalStackSize) + end do + + ! Mark all cells that aren't ocean cells for removal + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + call mpas_pool_get_array(scratchPool, 'oceanCell', oceanMask) + + do iCell = 1, nCellsSolve + if (oceanMask(iCell) == 0) then + maxLevelCell(iCell) = -1 + end if + end do + block_ptr => block_ptr % next + end do + + call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) + + call mpas_pool_get_field(scratchPool, 'cullStack', cullStackField) + call mpas_pool_get_field(scratchPool, 'touchedCell', touchedCellField) + call mpas_pool_get_field(scratchPool, 'oceanCell', oceanCellField) + + call mpas_deallocate_scratch_field(cullStackField, .false.) + call mpas_deallocate_scratch_field(touchedCellField, .false.) + call mpas_deallocate_scratch_field(oceanCellField, .false.) + + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call ocn_mark_maxlevelcell(meshPool, iErr) + block_ptr => block_ptr % next + end do + + end subroutine ocn_init_setup_global_realistic_cull_inland_seas!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_realistic_read_depth_levels +! +!> \brief Read depth levels for global realistic test case +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine reads the depth levels from the temperature IC file and sets +!> refBottomDepth accordingly +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_realistic_read_depth_levels(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (MPAS_Stream_type) :: depthStream + + type (mpas_pool_type), pointer :: meshPool + + character (len=StrKIND), pointer :: config_global_realistic_depth_file, config_global_realistic_depth_varname, & + config_global_realistic_depth_dimname + + real (kind=RKIND), pointer :: config_global_realistic_depth_conversion_factor + + integer :: k, iCell + + real (kind=RKIND), dimension(:), pointer :: refBottomDepth + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_realistic_depth_file', config_global_realistic_depth_file) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_depth_varname', config_global_realistic_depth_varname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_depth_dimname', config_global_realistic_depth_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_depth_conversion_factor', config_global_realistic_depth_conversion_factor) + + ! Define stream for depth levels + call MPAS_createStream(depthStream, config_global_realistic_depth_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) + + ! Setup depth field for stream to be read in + depthIC % fieldName = trim(config_global_realistic_depth_varname) + depthIC % dimSizes(1) = nDepth + depthIC % dimNames(1) = trim(config_global_realistic_depth_dimname) + depthIC % isVarArray = .false. + depthIC % isPersistent = .true. + depthIC % isActive = .true. + depthIC % hasTimeDimension = .false. + depthIC % block => domain % blocklist + allocate(depthIC % array(nDepth)) + + ! Add depth field to stream + call MPAS_streamAddField(depthStream, depthIC, iErr) + + ! Read stream + call MPAS_readStream(depthStream, 1, iErr) + + ! Close stream + call MPAS_closeStream(depthStream) + depthIC % array(:) = depthIC % array(:) * config_global_realistic_depth_conversion_factor + + ! Set refBottomDepth depending on depth levels. And convert appropriately + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + refBottomDepth(:) = depthIC % array(:) + + block_ptr => block_ptr % next + end do + + end subroutine ocn_init_setup_global_realistic_read_depth_levels!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_realistic_read_tracer_lat_lon +! +!> \brief Read Lat/Lon for tracers in global realistic test case +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine reads the latitude and longitude coordinats for tracers from the temperature IC file. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_realistic_read_tracer_lat_lon(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (MPAS_Stream_type) :: tracerStream + + character (len=StrKIND), pointer :: config_global_realistic_temperature_file, config_global_realistic_tracer_lat_varname, & + config_global_realistic_tracer_nlat_dimname, config_global_realistic_tracer_lon_varname, & + config_global_realistic_tracer_nlon_dimname + + logical, pointer :: config_global_realistic_tracer_latlon_degrees + + integer :: iLat, iLon + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_realistic_temperature_file', config_global_realistic_temperature_file) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_lat_varname', config_global_realistic_tracer_lat_varname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_nlat_dimname', config_global_realistic_tracer_nlat_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_lon_varname', config_global_realistic_tracer_lon_varname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_nlon_dimname', config_global_realistic_tracer_nlon_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_latlon_degrees', config_global_realistic_tracer_latlon_degrees) + + ! Define stream for depth levels + call MPAS_createStream(tracerStream, config_global_realistic_temperature_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) + + ! Setup tracerLat and tracerLon fields for stream to be read in + tracerLat % fieldName = trim(config_global_realistic_tracer_lat_varname) + tracerLat % dimSizes(1) = nLatTracer + tracerLat % dimNames(1) = trim(config_global_realistic_tracer_nlat_dimname) + tracerLat % isVarArray = .false. + tracerLat % isPersistent = .true. + tracerLat % isActive = .true. + tracerLat % hasTimeDimension = .false. + tracerLat % block => domain % blocklist + allocate(tracerLat % array(nLatTracer)) + + tracerLon % fieldName = trim(config_global_realistic_tracer_lon_varname) + tracerLon % dimSizes(1) = nLonTracer + tracerLon % dimNames(1) = trim(config_global_realistic_tracer_nlon_dimname) + tracerLon % isVarArray = .false. + tracerLon % isPersistent = .true. + tracerLon % isActive = .true. + tracerLon % hasTimeDimension = .false. + tracerLon % block => domain % blocklist + allocate(tracerLon % array(nLonTracer)) + + ! Add tracerLat and tracerLon fields to stream + call MPAS_streamAddField(tracerStream, tracerLat, iErr) + call MPAS_streamAddField(tracerStream, tracerLon, iErr) + + ! Read stream + call MPAS_readStream(tracerStream, 1, iErr) + + ! Close stream + call MPAS_closeStream(tracerStream) + + if (config_global_realistic_tracer_latlon_degrees) then + do iLat = 1, nLatTracer + tracerLat % array(iLat) = tracerLat % array(iLat) * pii / 180.0_RKIND + end do + + do iLon = 1, nLonTracer + tracerLon % array(iLon) = tracerLon % array(iLon) * pii / 180.0_RKIND + end do + end if + + do iLon = 1, nLonTracer + if (tracerLon % array(iLon) < 0.0_RKIND) then + tracerLon % array(iLon) = 2.0_RKIND * pii + tracerLon % array(iLon) + end if + end do + + end subroutine ocn_init_setup_global_realistic_read_tracer_lat_lon!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_realistic_read_temperature +! +!> \brief Read temperature ICs for global realistic test case +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine reads the temperature field from the temperature IC file. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_realistic_read_temperature(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (MPAS_Stream_type) :: temperatureStream + + character (len=StrKIND), pointer :: config_global_realistic_temperature_file, config_global_realistic_temperature_varname, & + config_global_realistic_tracer_nlon_dimname, config_global_realistic_tracer_nlat_dimname, & + config_global_realistic_depth_dimname + + integer :: k + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_realistic_temperature_file', config_global_realistic_temperature_file) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_temperature_varname', config_global_realistic_temperature_varname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_nlon_dimname', config_global_realistic_tracer_nlon_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_nlat_dimname', config_global_realistic_tracer_nlat_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_depth_dimname', config_global_realistic_depth_dimname) + + ! Define stream for temperature IC + call MPAS_createStream(temperatureStream, config_global_realistic_temperature_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) + + ! Setup temperature field for stream to be read in + temperatureIC % fieldName = trim(config_global_realistic_temperature_varname) + temperatureIC % dimSizes(1) = nLonTracer + temperatureIC % dimSizes(2) = nLatTracer + temperatureIC % dimSizes(3) = nDepth + temperatureIC % dimNames(1) = trim(config_global_realistic_tracer_nlon_dimname) + temperatureIC % dimNames(2) = trim(config_global_realistic_tracer_nlat_dimname) + temperatureIC % dimNames(3) = trim(config_global_realistic_depth_dimname) + temperatureIC % isVarArray = .false. + temperatureIC % isPersistent = .true. + temperatureIC % isActive = .true. + temperatureIC % hasTimeDimension = .false. + temperatureIC % block => domain % blocklist + allocate(temperatureIC % array(nLonTracer, nLatTracer, nDepth)) + + ! Add temperature field to stream + call MPAS_streamAddField(temperatureStream, temperatureIC, iErr) + + ! Read stream + call MPAS_readStream(temperatureStream, 1, iErr) + + ! Close stream + call MPAS_closeStream(temperatureStream) + + end subroutine ocn_init_setup_global_realistic_read_temperature!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_realistic_read_salinity +! +!> \brief Read salinity ICs for global realistic test case +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine reads the salinity field from the salinity IC file. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_realistic_read_salinity(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (MPAS_Stream_type) :: salinityStream + + character (len=StrKIND), pointer :: config_global_realistic_salinity_file, config_global_realistic_salinity_varname, & + config_global_realistic_tracer_nlon_dimname, config_global_realistic_tracer_nlat_dimname, & + config_global_realistic_depth_dimname + + integer :: k + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_realistic_salinity_file', config_global_realistic_salinity_file) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_salinity_varname', config_global_realistic_salinity_varname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_nlon_dimname', config_global_realistic_tracer_nlon_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_nlat_dimname', config_global_realistic_tracer_nlat_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_depth_dimname', config_global_realistic_depth_dimname) + + ! Define stream for salinity IC + call MPAS_createStream(salinityStream, config_global_realistic_salinity_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) + + ! Setup salinity field for stream to be read in + salinityIC % fieldName = trim(config_global_realistic_salinity_varname) + salinityIC % dimSizes(1) = nLonTracer + salinityIC % dimSizes(2) = nLatTracer + salinityIC % dimSizes(3) = nDepth + salinityIC % dimNames(1) = trim(config_global_realistic_tracer_nlon_dimname) + salinityIC % dimNames(2) = trim(config_global_realistic_tracer_nlat_dimname) + salinityIC % dimNames(3) = trim(config_global_realistic_depth_dimname) + salinityIC % isVarArray = .false. + salinityIC % isPersistent = .true. + salinityIC % isActive = .true. + salinityIC % hasTimeDimension = .false. + salinityIC % block => domain % blocklist + allocate(salinityIC % array(nLonTracer, nLatTracer, nDepth)) + + ! Add salinity field to stream + call MPAS_streamAddField(salinityStream, salinityIC, iErr) + + ! Read stream + call MPAS_readStream(salinityStream, 1, iErr) + + ! Close stream + call MPAS_closeStream(salinityStream) + + end subroutine ocn_init_setup_global_realistic_read_salinity!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_realistic_interoplate_tracers +! +!> \brief Interpolate tracer quantities to MPAS grid +!> \author Doug Jacobsen +!> \date 03/05/2014 +!> \details +!> This routine interpolates the temperature/salinity data read in from the +!> initial condition file to the MPAS grid. Currently it uses a nearest neighbor interpolation. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_realistic_interpolate_tracers(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + type (mpas_pool_type), pointer :: meshPool, statePool, scratchPool + + real (kind=RKIND) :: currentLat, currentLon, counter + real (kind=RKIND) :: minDist, dist + real (kind=RKIND) :: x, x1, x2, y, y1, y2, coef, coef11, coef12, coef21, coef22 + integer :: iLat, iLon, iSmooth, j, coc + integer :: latSearch, lonSearch + integer :: iCell, k + integer :: xInd1, xInd2, yInd1, yInd2 + integer, pointer :: idxSalinity, idxTemperature, nCells, nCellsSolve + + type (field2DReal), pointer :: smoothedTemperatureField, smoothedSalinityField + type (field3DReal), pointer :: tracersField + + integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell + integer, dimension(:, :), pointer :: cellsOnCell + + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell, temperatureRestore, salinityRestore + real (kind=RKIND), dimension(:, :), pointer :: smoothedTemperature, smoothedSalinity + real (kind=RKIND), dimension(:, :, :), pointer :: tracers + + character (len=StrKIND), pointer :: config_global_realistic_tracer_method + logical, pointer :: config_global_realistic_tracer_restore + integer, pointer :: config_global_realistic_smooth_TS_iterations + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_method', config_global_realistic_tracer_method) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_restore', config_global_realistic_tracer_restore) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_smooth_TS_iterations', config_global_realistic_smooth_TS_iterations) + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_dimension(statePool, 'index_temperature', idxTemperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', idxSalinity) + + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'temperatureRestore', temperatureRestore) + call mpas_pool_get_array(meshPool, 'salinityRestore', salinityRestore) + + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + + if (config_global_realistic_tracer_method .eq. "nearest_neighbor") then + do iCell = 1, nCells + currentLat = latCell(iCell) + currentLon = lonCell(iCell) + + lonSearch = 1 + minDist = 2.0_RKIND * pii + do iLon = 1, nLonTracer + dist = abs(currentLon - tracerLon % array(iLon)) + if (dist < minDist) then + minDist = dist + lonSearch = iLon + end if + end do + + latSearch = 1 + minDist = 2.0_RKIND * pii + do iLat = 1, nLatTracer + dist = abs(currentLat - tracerLat % array(iLat)) + if (dist < minDist) then + minDist = dist + latSearch = iLat + end if + end do + + do k = 1, maxLevelCell(iCell) + tracers(idxTemperature, k, iCell) = temperatureIC % array(lonSearch, latSearch, k) + tracers(idxSalinity, k, iCell) = salinityIC % array(lonSearch, latSearch, k) + end do + end do + + elseif (config_global_realistic_tracer_method .eq. "bilinear_interpolation") then + + do iCell = 1, nCells + x = lonCell(iCell) + y = latCell(iCell) + + ! Set up bilinear interpolation indices in longitude, watching for periodic boundary at 0 and 2 pi + xInd1 = 0 + if (x .le. tracerLon % array(1)) then + xInd1 = nLonTracer + xInd2 = 1 + x1 = tracerLon % array(xInd1) - 2.0*pii + x2 = tracerLon % array(xInd2) + elseif (x .ge. tracerLon % array(nLonTracer)) then + xInd1 = nLonTracer + xInd2 = 1 + x1 = tracerLon % array(xInd1) + x2 = tracerLon % array(xInd2) + 2.0*pii + else + do iLon = 1, nLonTracer-1 + if (x .le. tracerLon % array(iLon+1)) then + xInd1 = iLon + xInd2 = iLon+1 + x1 = tracerLon % array(xInd1) + x2 = tracerLon % array(xInd2) + exit + end if + end do + endif + + yInd1 = 0 + if (y .le. tracerLat % array(1)) then + ! if south of the southernmost data point, extrapolate as a constant in latitude + yInd1 = 1 + yInd2 = 1 + coef = 1.0_RKIND/(x2-x1) + coef11 = 1.0_RKIND*(x2-x ) + coef21 = 1.0_RKIND*(x -x1) + coef12 = 0.0_RKIND + coef22 = 0.0_RKIND + elseif (y .ge. tracerLat % array(nLatTracer)) then + ! if north of the northernmost data point, extrapolate as a constant in latitude + yInd1 = nLatTracer + yInd2 = nLatTracer + coef = 1.0_RKIND/(x2-x1) + coef11 = 1.0_RKIND*(x2-x ) + coef21 = 1.0_RKIND*(x -x1) + coef12 = 0.0_RKIND + coef22 = 0.0_RKIND + else + ! Set up bilinear interpolation coefficients in latitude + do iLat = 1, nLatTracer-1 + if (y .le. tracerLat % array(iLat+1)) then + yInd1 = iLat + yInd2 = iLat+1 + exit + end if + end do + y1 = tracerLat % array(yInd1) + y2 = tracerLat % array(yInd2) + coef = 1.0_RKIND/(x2-x1)/(y2-y1) + coef11 = 1.0_RKIND*(x2-x )*(y2-y ) + coef21 = 1.0_RKIND*(x -x1)*(y2-y ) + coef12 = 1.0_RKIND*(x2-x )*(y -y1) + coef22 = 1.0_RKIND*(x -x1)*(y -y1) + endif + + ! Assign T&S using bilinear interpolation + ! formulas from http://en.wikipedia.org/wiki/Bilinear_interpolation + do k = 1, maxLevelCell(iCell) + + tracers(idxTemperature, k, iCell) = coef*( & + coef11* temperatureIC % array(xInd1,yInd1, k) & + + coef21* temperatureIC % array(xInd2,yInd1, k) & + + coef12* temperatureIC % array(xInd1,yInd2, k) & + + coef22* temperatureIC % array(xInd2,yInd2, k) ) + + tracers(idxSalinity, k, iCell) = coef*( & + coef11* salinityIC % array(xInd1,yInd1, k) & + + coef21* salinityIC % array(xInd2,yInd1, k) & + + coef12* salinityIC % array(xInd1,yInd2, k) & + + coef22* salinityIC % array(xInd2,yInd2, k) ) + + end do + end do + + else + write(stderrUnit,*) 'ERROR: Invalid choice of config_global_realistic_tracer_method.' + iErr = 1 + call mpas_dmpar_finalize(domain % dminfo) + endif + + if (config_global_realistic_tracer_restore) then + do iCell = 1, nCellsSolve + temperatureRestore(iCell) = tracers(idxTemperature, 1, iCell) + salinityRestore(iCell) = tracers(idxSalinity, 1, iCell) + end do + endif + + block_ptr => block_ptr % next + end do + + ! Smooth temperature and salinity. + if (config_global_realistic_smooth_TS_iterations .gt. 0) then + call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) + + call mpas_pool_get_field(scratchPool, 'smoothedTemperature', smoothedTemperatureField) + call mpas_pool_get_field(scratchPool, 'smoothedSalinity', smoothedSalinityField) + + call mpas_allocate_scratch_field(smoothedTemperatureField, .false.) + call mpas_allocate_scratch_field(smoothedSalinityField, .false.) + + do iSmooth = 1,config_global_realistic_smooth_TS_iterations + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_dimension(statePool, 'index_temperature', idxTemperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', idxSalinity) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + + call mpas_pool_get_array(scratchPool, 'smoothedTemperature', smoothedTemperature) + call mpas_pool_get_array(scratchPool, 'smoothedSalinity', smoothedSalinity) + + maxLevelCell(nCells+1) = -1 + + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + smoothedtemperature(k, iCell) = tracers(idxTemperature, k, iCell) + smoothedsalinity(k, iCell) = tracers(idxSalinity, k, iCell) + counter = 1 + + do j = 1, nEdgesOnCell(iCell) + coc = cellsOnCell(j, iCell) + ! check if coc not 0 (or nCells+1)? + if (k .le. maxLevelCell(coc)) then + + smoothedtemperature(k, iCell) = smoothedtemperature(k, iCell) + tracers (idxTemperature, k, coc) + smoothedsalinity(k, iCell) = smoothedsalinity(k, iCell) + tracers(idxSalinity, k, coc) + counter = counter + 1 + + end if + end do ! edgesOnCell + + smoothedtemperature(k, iCell) = smoothedtemperature(k, iCell) / counter + smoothedsalinity(k, iCell) = smoothedsalinity(k, iCell) / counter + + end do ! k level + + end do ! iCell + + tracers(idxTemperature, :, :) = smoothedtemperature(:,:) + tracers(idxSalinity, :, :) = smoothedsalinity(:,:) + + block_ptr => block_ptr % next + end do + + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_field(statePool, 'tracers', tracersField, 1) + + call mpas_dmpar_exch_halo_field(tracersField) + + end do ! iSmooth + + call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) + call mpas_pool_get_field(scratchPool, 'smoothedTemperature', smoothedTemperatureField) + call mpas_pool_get_field(scratchPool, 'smoothedSalinity', smoothedSalinityField) + call mpas_deallocate_scratch_field(smoothedTemperatureField, .false.) + call mpas_deallocate_scratch_field(smoothedSalinityField, .false.) + endif + + end subroutine ocn_init_setup_global_realistic_interpolate_tracers!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_realistic_read_windstress +! +!> \brief Read the windstress IC file +!> \author Doug Jacobsen +!> \date 03/07/2014 +!> \details +!> This routine reads the windstress IC file, including latitude and longitude +!> information for windstress data. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_realistic_read_windstress(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (MPAS_Stream_type) :: windstressStream + + integer :: iLat, iLon + + character (len=StrKIND), pointer :: config_global_realistic_windstress_file, config_global_realistic_windstress_lat_varname, & + config_global_realistic_windstress_nlat_dimname, config_global_realistic_windstress_lon_varname, & + config_global_realistic_windstress_nlon_dimname, config_global_realistic_windstress_zonal_varname, & + config_global_realistic_windstress_meridional_varname + + logical, pointer :: config_global_realistic_windstress_latlon_degrees + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_file', config_global_realistic_windstress_file) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_lat_varname', config_global_realistic_windstress_lat_varname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_nlat_dimname', config_global_realistic_windstress_nlat_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_lon_varname', config_global_realistic_windstress_lon_varname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_nlon_dimname', config_global_realistic_windstress_nlon_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_zonal_varname', config_global_realistic_windstress_zonal_varname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_meridional_varname', config_global_realistic_windstress_meridional_varname) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_latlon_degrees', config_global_realistic_windstress_latlon_degrees) + + ! Define stream for depth levels + call MPAS_createStream(windstressStream, config_global_realistic_windstress_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) + + ! Setup windLat, windLon, and windIC fields for stream to be read in + windLat % fieldName = trim(config_global_realistic_windstress_lat_varname) + windLat % dimSizes(1) = nLatWind + windLat % dimNames(1) = trim(config_global_realistic_windstress_nlat_dimname) + windLat % isVarArray = .false. + windLat % isPersistent = .true. + windLat % isActive = .true. + windLat % hasTimeDimension = .false. + windLat % block => domain % blocklist + allocate(windLat % array(nLatWind)) + + windLon % fieldName = trim(config_global_realistic_windstress_lon_varname) + windLon % dimSizes(1) = nLonWind + windLon % dimNames(1) = trim(config_global_realistic_windstress_nlon_dimname) + windLon % isVarArray = .false. + windLon % isPersistent = .true. + windLon % isActive = .true. + windLon % hasTimeDimension = .false. + windLon % block => domain % blocklist + allocate(windLon % array(nLonWind)) + + zonalWindIC % fieldName = trim(config_global_realistic_windstress_zonal_varname) + zonalWindIC % dimSizes(1) = nLonWind + zonalWindIC % dimSizes(2) = nLatWind + zonalWindIC % dimNames(1) = trim(config_global_realistic_windstress_nlon_dimname) + zonalWindIC % dimNames(2) = trim(config_global_realistic_windstress_nlat_dimname) + zonalWindIC % isVarArray = .false. + zonalWindIC % isPersistent = .true. + zonalWindIC % isActive = .true. + zonalWindIC % hasTimeDimension = .false. + zonalWindIC % block => domain % blocklist + allocate(zonalWindIC % array(nLonWind, nLatWind)) + + meridionalWindIC % fieldName = trim(config_global_realistic_windstress_meridional_varname) + meridionalWindIC % dimSizes(1) = nLonWind + meridionalWindIC % dimSizes(2) = nLatWind + meridionalWindIC % dimNames(1) = trim(config_global_realistic_windstress_nlon_dimname) + meridionalWindIC % dimNames(2) = trim(config_global_realistic_windstress_nlat_dimname) + meridionalWindIC % isVarArray = .false. + meridionalWindIC % isPersistent = .true. + meridionalWindIC % isActive = .true. + meridionalWindIC % hasTimeDimension = .false. + meridionalWindIC % block => domain % blocklist + allocate(meridionalWindIC % array(nLonWind, nLatWind)) + + ! Add windLat, windLon, and windIC fields to stream + call MPAS_streamAddField(windstressStream, windLat, iErr) + call MPAS_streamAddField(windstressStream, windLon, iErr) + call MPAS_streamAddField(windstressStream, zonalWindIC, iErr) + call MPAS_streamAddField(windstressStream, meridionalWindIC, iErr) + + ! Read stream + call MPAS_readStream(windstressStream, 1, iErr) + + ! Close stream + call MPAS_closeStream(windstressStream) + + if (config_global_realistic_windstress_latlon_degrees) then + windLat % array(:) = windLat % array(:) * pii / 180.0_RKIND + windLon % array(:) = windLon % array(:) * pii / 180.0_RKIND + end if + + do iLon = 1, nLonWind + if (windLon % array(iLon) < 0.0_RKIND) then + windLon % array(iLon) = 2.0_RKIND * pii + windLon % array(iLon) + end if + end do + + end subroutine ocn_init_setup_global_realistic_read_windstress!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_realistic_interpolate_windstress +! +!> \brief Interpolate the windstress IC to MPAS mesh +!> \author Doug Jacobsen +!> \date 03/07/2014 +!> \details +!> This routine interpolates windstress data to the MPAS mesh. Currently it +!> uses a bilinear interpolation +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_realistic_interpolate_windstress(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool, forcingPool + + real (kind=RKIND) :: currentLat, currentLon + real (kind=RKIND) :: zonalWind, meridionalWind + real (kind=RKIND) :: angle + real (kind=RKIND) :: dist, minDist + real (kind=RKIND) :: x, x1, x2, y, y1, y2, coef, coef11, coef12, coef21, coef22 + + integer :: ilat, iLon + integer :: latSearch, lonSearch + integer :: iEdge + integer :: xInd1, xInd2, yInd1, yInd2 + + real (kind=RKIND), dimension(:), pointer :: latEdge, lonEdge, angleEdge, surfaceWindStress + + integer, pointer :: nEdgesSolve, nEdges + + character (len=StrKIND), pointer :: config_global_realistic_windstress_method + real (kind=RKIND), pointer :: config_global_realistic_windstress_conversion_factor + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_method', config_global_realistic_windstress_method) + call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_conversion_factor', config_global_realistic_windstress_conversion_factor) + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(meshPool, 'latEdge', latEdge) + call mpas_pool_get_array(meshPool, 'lonEdge', lonEdge) + call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) + + call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) + + if (config_global_realistic_windstress_method .eq. "nearest_neighbor") then + do iEdge = 1, nEdgesSolve + currentLat = latEdge(iEdge) + currentLon = lonEdge(iEdge) + angle = angleEdge(iEdge) + + minDist = 2.0_RKIND * pii + lonSearch = 1 + do iLon = 1, nLonWind + dist = abs(currentLon - windLon % array(iLon)) + if (dist < minDist) then + minDist = dist + lonSearch = iLon + end if + end do + + minDist = 2.0_RKIND * pii + latSearch = 1 + do iLat = 1, nLatWind + dist = abs(currentLat - windLat % array(iLat)) + if (dist < minDist) then + minDist = dist + latSearch = iLat + end if + end do + + zonalWind = zonalWindIC % array(lonSearch, latSearch) * config_global_realistic_windstress_conversion_factor + meridionalWind = meridionalWindIC % array(lonSearch, latSearch) * config_global_realistic_windstress_conversion_factor + + surfaceWindStress(iEdge) = zonalWind * cos(angle) + meridionalWind * sin(angle) + end do + + elseif (config_global_realistic_windstress_method .eq. "bilinear_interpolation") then + + do iEdge = 1, nEdges + x = lonEdge(iEdge) + y = latEdge(iEdge) + angle = angleEdge(iEdge) + + ! Set up bilinear interpolation indices in longitude, watching for periodic boundary at 0 and 2 pi + xInd1 = 0 + if (x .le. windLon % array(1)) then + xInd1 = nLonWind + xInd2 = 1 + x1 = windLon % array(xInd1) - 2.0_RKIND*pii + x2 = windLon % array(xInd2) + elseif (x .ge. windLon % array(nLonWind)) then + xInd1 = nLonWind + xInd2 = 1 + x1 = windLon % array(xInd1) + x2 = windLon % array(xInd2) + 2.0_RKIND*pii + else + do iLon = 1, nLonWind-1 + if (x .le. windLon % array(iLon+1)) then + xInd1 = iLon + xInd2 = iLon+1 + x1 = windLon % array(xInd1) + x2 = windLon % array(xInd2) + exit + end if + end do + endif + + yInd1 = 0 + if (y .le. windLat % array(1)) then + ! if south of the southernmost data point, extrapolate as a constant in latitude + yInd1 = 1 + yInd2 = 1 + coef = 1.0_RKIND/(x2-x1) + coef11 = 1.0_RKIND*(x2-x ) + coef21 = 1.0_RKIND*(x -x1) + coef12 = 0.0_RKIND + coef22 = 0.0_RKIND + elseif (y .ge. windLat % array(nLatWind)) then + ! if north of the northernmost data point, extrapolate as a constant in latitude + yInd1 = nLatWind + yInd2 = nLatWind + coef = 1.0_RKIND/(x2-x1) + coef11 = 1.0_RKIND*(x2-x ) + coef21 = 1.0_RKIND*(x -x1) + coef12 = 0.0_RKIND + coef22 = 0.0_RKIND + else + ! Set up bilinear interpolation coefficients in latitude + do iLat = 1, nLatWind-1 + if (y .le. windLat % array(iLat+1)) then + yInd1 = iLat + yInd2 = iLat+1 + exit + end if + end do + y1 = windLat % array(yInd1) + y2 = windLat % array(yInd2) + coef = 1.0_RKIND/(x2-x1)/(y2-y1) + coef11 = 1.0_RKIND*(x2-x )*(y2-y ) + coef21 = 1.0_RKIND*(x -x1)*(y2-y ) + coef12 = 1.0_RKIND*(x2-x )*(y -y1) + coef22 = 1.0_RKIND*(x -x1)*(y -y1) + endif + + zonalWind = coef*config_global_realistic_windstress_conversion_factor*( & + coef11* zonalWindIC % array(xInd1, yInd1) & + + coef21* zonalWindIC % array(xInd2, yInd1) & + + coef12* zonalWindIC % array(xInd1, yInd2) & + + coef22* zonalWindIC % array(xInd2, yInd2) ) + + meridionalWind = coef*config_global_realistic_windstress_conversion_factor*( & + coef11* meridionalWindIC % array(xInd1, yInd1) & + + coef21* meridionalWindIC % array(xInd2, yInd1) & + + coef12* meridionalWindIC % array(xInd1, yInd2) & + + coef22* meridionalWindIC % array(xInd2, yInd2) ) + + surfaceWindStress(iEdge) = zonalWind * cos(angle) + meridionalWind * sin(angle) + + end do + + else + write(stderrUnit,*) 'ERROR: Invalid choice of config_global_realistic_windstress_method.' + iErr = 1 + call mpas_dmpar_finalize(domain % dminfo) + endif + + block_ptr => block_ptr % next + end do + + end subroutine ocn_init_setup_global_realistic_interpolate_windstress!}}} + +!*********************************************************************** +! +! routine ocn_init_global_realistic_destroy_tracer_fields +! +!> \brief Tracer field cleanup routine +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine destroys the fields that were created to hold tracer +!> initial condition information +! +!----------------------------------------------------------------------- + + subroutine ocn_init_global_realistic_destroy_tracer_fields()!{{{ + deallocate(temperatureIC % array) + deallocate(salinityIC % array) + deallocate(tracerLat % array) + deallocate(tracerLon % array) + end subroutine ocn_init_global_realistic_destroy_tracer_fields!}}} + +!*********************************************************************** +! +! routine ocn_init_global_realistic_destroy_topo_fields +! +!> \brief Topography field cleanup routine +!> \author Doug Jacobsen +!> \date 03/07/2014 +!> \details +!> This routine destroys the fields that were created to hold topography +!> initial condition information +! +!----------------------------------------------------------------------- + + subroutine ocn_init_global_realistic_destroy_topo_fields()!{{{ + deallocate(topoIC % array) + deallocate(topoLat % array) + deallocate(topoLon % array) + end subroutine ocn_init_global_realistic_destroy_topo_fields!}}} + +!*********************************************************************** +! +! routine ocn_init_global_realistic_destroy_windstress_fields +! +!> \brief Windstress field cleanup routine +!> \author Doug Jacobsen +!> \date 03/07/2014 +!> \details +!> This routine destroys the fields that were created to hold windstress +!> initial condition information +! +!----------------------------------------------------------------------- + + subroutine ocn_init_global_realistic_destroy_windstress_fields()!{{{ + deallocate(zonalWindIC % array) + deallocate(meridionalWindIC % array) + deallocate(windLat % array) + deallocate(windLon % array) + end subroutine ocn_init_global_realistic_destroy_windstress_fields!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_global_realistic +! +!> \brief Validation for global realistic test case +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine validates the configuration options for the global realistic test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_global_realistic(configPool, packagePool, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: configPool, packagePool + integer, intent(out) :: iErr + type (MPAS_IO_Handle_type) :: inputFile + + character (len=StrKIND), pointer :: config_init_configuration, config_global_realistic_depth_file, & + config_global_realistic_depth_dimname, config_global_realistic_temperature_file, & + config_global_realistic_salinity_file, config_global_realistic_tracer_nlat_dimname, & + config_global_realistic_tracer_nlon_dimname, config_global_realistic_topography_file, & + config_global_realistic_topography_nlat_dimname, config_global_realistic_topography_nlon_dimname, & + config_global_realistic_windstress_file, config_global_realistic_windstress_nlat_dimname, & + config_global_realistic_windstress_nlon_dimname + + integer, pointer :: config_vert_levels + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('global_realistic')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_global_realistic_depth_file', config_global_realistic_depth_file) + call mpas_pool_get_config(configPool, 'config_global_realistic_depth_dimname', config_global_realistic_depth_dimname) + call mpas_pool_get_config(configPool, 'config_global_realistic_temperature_file', config_global_realistic_temperature_file) + call mpas_pool_get_config(configPool, 'config_global_realistic_salinity_file', config_global_realistic_salinity_file) + call mpas_pool_get_config(configPool, 'config_global_realistic_tracer_nlat_dimname', config_global_realistic_tracer_nlat_dimname) + call mpas_pool_get_config(configPool, 'config_global_realistic_tracer_nlon_dimname', config_global_realistic_tracer_nlon_dimname) + call mpas_pool_get_config(configPool, 'config_global_realistic_topography_file', config_global_realistic_topography_file) + call mpas_pool_get_config(configPool, 'config_global_realistic_topography_nlat_dimname', config_global_realistic_topography_nlat_dimname) + call mpas_pool_get_config(configPool, 'config_global_realistic_topography_nlon_dimname', config_global_realistic_topography_nlon_dimname) + call mpas_pool_get_config(configPool, 'config_global_realistic_windstress_file', config_global_realistic_windstress_file) + call mpas_pool_get_config(configPool, 'config_global_realistic_windstress_nlat_dimname', config_global_realistic_windstress_nlat_dimname) + call mpas_pool_get_config(configPool, 'config_global_realistic_windstress_nlon_dimname', config_global_realistic_windstress_nlon_dimname) + + inputFile = MPAS_io_open(config_global_realistic_depth_file, MPAS_IO_READ, MPAS_IO_NETCDF, ierr=iErr) + + call MPAS_io_inq_dim(inputFile, config_global_realistic_depth_dimname, nDepth, iErr) + + call MPAS_io_close(inputFile, iErr) + + inputFile = MPAS_io_open(config_global_realistic_temperature_file, MPAS_IO_READ, MPAS_IO_NETCDF, ierr=iErr) + + call MPAS_io_inq_dim(inputFile, config_global_realistic_tracer_nlat_dimname, nLatTracer, iErr) + call MPAS_io_inq_dim(inputFile, config_global_realistic_tracer_nlon_dimname, nLonTracer, iErr) + + call MPAS_io_close(inputFile, iErr) + + inputFile = MPAS_io_open(config_global_realistic_topography_file, MPAS_IO_READ, MPAS_IO_NETCDF, ierr=iErr) + + call MPAS_io_inq_dim(inputFile, config_global_realistic_topography_nlat_dimname, nLatTopo, iErr) + call MPAS_io_inq_dim(inputFile, config_global_realistic_topography_nlon_dimname, nLonTopo, iErr) + + call MPAS_io_close(inputFile, iErr) + + inputFile = MPAS_io_open(config_global_realistic_windstress_file, MPAS_IO_READ, MPAS_IO_NETCDF, ierr=iErr) + + call MPAS_io_inq_dim(inputFile, config_global_realistic_windstress_nlat_dimname, nLatWind, iErr) + call MPAS_io_inq_dim(inputFile, config_global_realistic_windstress_nlon_dimname, nLonWind, iErr) + + call MPAS_io_close(inputFile, iErr) + + if (config_vert_levels <= 0 .and. nDepth > 0) then + config_vert_levels = nDepth + else if(config_vert_levels <= 0) then + write(stderrUnit,*) 'ERROR: Validation failed for global realistic. Not given a usable value for vertical levels.' + iErr = 1 + end if + + if (trim(config_global_realistic_temperature_file) == 'none') then + write(stderrUnit,*) 'ERROR: Validation failed for global realistic. Invalid filename for config_global_realistic_temperature_file' + iErr = 1 + end if + + if (trim(config_global_realistic_salinity_file) == 'none') then + write(stderrUnit,*) 'ERROR: Validation failed for global realistic. Invalid filename for config_global_realistic_salinity_file' + iErr = 1 + end if + + if (trim(config_global_realistic_depth_file) == 'none') then + write(stderrUnit,*) 'ERROR: Validation failed for global realistic. Invalid filename for config_global_realistic_depth_file' + iErr = 1 + end if + + if (trim(config_global_realistic_topography_file) == 'none') then + write(stderrUnit,*) 'ERROR: Validation failed for global realistic. Invalid filename for config_global_realistic_topography_file' + iErr = 1 + end if + + if (trim(config_global_realistic_windstress_file) == 'none') then + write(stderrUnit,*) 'ERROR: Validation failed for global realistic. Invalid filename for config_global_realistic_windstress_file' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_global_realistic!}}} + +!*********************************************************************** + +end module ocn_init_global_realistic + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 8c7487d518..7aca01c894 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -44,6 +44,7 @@ module ocn_init_mode use ocn_init_overflow use ocn_init_cvmix_convection_unit_test use ocn_init_cvmix_shear_unit_test + use ocn_init_global_realistic implicit none private @@ -249,6 +250,7 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call ocn_init_setup_overflow(domain, ierr) call ocn_init_setup_cvmix_convection_unit_test(domain, ierr) call ocn_init_setup_cvmix_shear_unit_test(domain, ierr) + call ocn_init_setup_global_realistic(domain, ierr) !call ocn_init_setup_TEMPLATE(domain, ierr) call mpas_timer_start('io_write', .false.) @@ -332,7 +334,9 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, iErr)!{ iErr = ior(iErr, err_tmp) call ocn_init_validate_cvmix_shear_unit_test(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) - ! call ocn_config_TEMPLATE_validate(configPool, iErr=err_tmp) + call ocn_init_validate_global_realistic(configPool, packagePool, iErr=err_tmp) + iErr = ior(iErr, err_tmp) + ! call ocn_config_TEMPLATE_validate(configPool, packagePool, iErr=err_tmp) ! iErr = ior(iErr, err_tmp) end subroutine ocn_init_mode_validate_configuration!}}} From 32ccb7e6df607549b994b3212b586c646d8abfdb Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Fri, 17 Apr 2015 11:27:38 -0600 Subject: [PATCH 0098/1724] Disable Okubo Weiss stream in init mode This commit adds the: mode="forward;analysis" line to the OKubo Weiss analysis member stream, to disable writing it to the init mode's stream file. --- src/core_ocean/analysis_members/Registry_okubo_weiss.xml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core_ocean/analysis_members/Registry_okubo_weiss.xml b/src/core_ocean/analysis_members/Registry_okubo_weiss.xml index a6ebf6208f..1e98f36c1e 100644 --- a/src/core_ocean/analysis_members/Registry_okubo_weiss.xml +++ b/src/core_ocean/analysis_members/Registry_okubo_weiss.xml @@ -77,6 +77,7 @@ filename_interval="01-00-00_00:00:00" packages="amOkuboWeiss" clobber_mode="truncate" + mode="forward;analysis" runtime_format="single_file"> From 1fdb0d3ebdb5b04454259b00eec79e2a556ffcc3 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Tue, 21 Apr 2015 15:10:46 -0600 Subject: [PATCH 0099/1724] Add Coriolis flag to Registry. --- src/core_ocean/Registry.xml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 8b1fea153c..24fdf28528 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -145,6 +145,10 @@ description="Logical flag that controls if a spherical mesh is expanded to an earth sized sphere or not." possible_values=".true. or .false." /> + Date: Thu, 23 Apr 2015 20:48:23 -0600 Subject: [PATCH 0100/1724] added pre-defined vertical grid called "100layerACMEv1" this grid matched that used in the PHCx100 obs dataset produced by Mat Maltrud --- .../mode_init/mpas_ocn_init_vertical_grids.F | 135 ++++++++++++++++++ 1 file changed, 135 insertions(+) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F index e5b1079c12..1384cae89a 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F @@ -81,6 +81,8 @@ subroutine ocn_generate_vertical_grid(gridType, layerInterfaces)!{{{ call ocn_generate_60layerPHC_vertical_grid(layerInterfaces) else if ( trim(gridType) == '42layerWOCE' ) then call ocn_generate_42layerWOCE_vertical_grid(layerInterfaces) + else if ( trim(gridType) == '100layerACMEv1' ) then + call ocn_generate_100layerACMEv1_vertical_grid(layerInterfaces) else write(stderrUnit, *) ' WARNING: '//trim(gridType)//' is an invalid vertical grid choice. No vertical grid will be generated.' end if @@ -288,6 +290,139 @@ subroutine ocn_generate_42layerWOCE_vertical_grid(layerInterfaces)!{{{ end subroutine ocn_generate_42layerWOCE_vertical_grid!}}} + !*********************************************************************** + ! + ! routine ocn_generate_100layerACMEv1_vertical_grid + ! + !> \brief 100 vertical layer vertical grid generator for ACME v1 + !> \author Todd Ringler + !> \date 04/23/2015 + !> \details + !> This routine generates a 100 layer grid + ! + !----------------------------------------------------------------------- + subroutine ocn_generate_100layerACMEv1_vertical_grid(layerInterfaces)!{{{ + implicit none + + real (kind=RKIND), dimension(:), intent(out) :: layerInterfaces + + real (kind=RKIND) :: maxInterfaceLocation + integer :: nInterfaces, iInterface + + nInterfaces = size(layerInterfaces, dim=1) + + if ( nInterfaces /= 101 ) then + call mpas_dmpar_global_abort("ERROR: Vertical grid must have 100 layers to apply 100 Layer PHC grid. Exiting...") + end if + + layerInterfaces( 1) = 0.0000E+00_RKIND + layerInterfaces( 2) = 0.1510E+01_RKIND + layerInterfaces( 3) = 0.3135E+01_RKIND + layerInterfaces( 4) = 0.4882E+01_RKIND + layerInterfaces( 5) = 0.6761E+01_RKIND + layerInterfaces( 6) = 0.8779E+01_RKIND + layerInterfaces( 7) = 0.1095E+02_RKIND + layerInterfaces( 8) = 0.1327E+02_RKIND + layerInterfaces( 9) = 0.1577E+02_RKIND + layerInterfaces( 10) = 0.1845E+02_RKIND + layerInterfaces( 11) = 0.2132E+02_RKIND + layerInterfaces( 12) = 0.2440E+02_RKIND + layerInterfaces( 13) = 0.2769E+02_RKIND + layerInterfaces( 14) = 0.3122E+02_RKIND + layerInterfaces( 15) = 0.3500E+02_RKIND + layerInterfaces( 16) = 0.3904E+02_RKIND + layerInterfaces( 17) = 0.4335E+02_RKIND + layerInterfaces( 18) = 0.4797E+02_RKIND + layerInterfaces( 19) = 0.5289E+02_RKIND + layerInterfaces( 20) = 0.5815E+02_RKIND + layerInterfaces( 21) = 0.6377E+02_RKIND + layerInterfaces( 22) = 0.6975E+02_RKIND + layerInterfaces( 23) = 0.7614E+02_RKIND + layerInterfaces( 24) = 0.8294E+02_RKIND + layerInterfaces( 25) = 0.9018E+02_RKIND + layerInterfaces( 26) = 0.9790E+02_RKIND + layerInterfaces( 27) = 0.1061E+03_RKIND + layerInterfaces( 28) = 0.1148E+03_RKIND + layerInterfaces( 29) = 0.1241E+03_RKIND + layerInterfaces( 30) = 0.1340E+03_RKIND + layerInterfaces( 31) = 0.1445E+03_RKIND + layerInterfaces( 32) = 0.1556E+03_RKIND + layerInterfaces( 33) = 0.1674E+03_RKIND + layerInterfaces( 34) = 0.1799E+03_RKIND + layerInterfaces( 35) = 0.1932E+03_RKIND + layerInterfaces( 36) = 0.2072E+03_RKIND + layerInterfaces( 37) = 0.2221E+03_RKIND + layerInterfaces( 38) = 0.2379E+03_RKIND + layerInterfaces( 39) = 0.2546E+03_RKIND + layerInterfaces( 40) = 0.2722E+03_RKIND + layerInterfaces( 41) = 0.2909E+03_RKIND + layerInterfaces( 42) = 0.3106E+03_RKIND + layerInterfaces( 43) = 0.3314E+03_RKIND + layerInterfaces( 44) = 0.3534E+03_RKIND + layerInterfaces( 45) = 0.3766E+03_RKIND + layerInterfaces( 46) = 0.4011E+03_RKIND + layerInterfaces( 47) = 0.4269E+03_RKIND + layerInterfaces( 48) = 0.4541E+03_RKIND + layerInterfaces( 49) = 0.4827E+03_RKIND + layerInterfaces( 50) = 0.5128E+03_RKIND + layerInterfaces( 51) = 0.5445E+03_RKIND + layerInterfaces( 52) = 0.5779E+03_RKIND + layerInterfaces( 53) = 0.6130E+03_RKIND + layerInterfaces( 54) = 0.6498E+03_RKIND + layerInterfaces( 55) = 0.6885E+03_RKIND + layerInterfaces( 56) = 0.7291E+03_RKIND + layerInterfaces( 57) = 0.7717E+03_RKIND + layerInterfaces( 58) = 0.8164E+03_RKIND + layerInterfaces( 59) = 0.8633E+03_RKIND + layerInterfaces( 60) = 0.9124E+03_RKIND + layerInterfaces( 61) = 0.9638E+03_RKIND + layerInterfaces( 62) = 0.1018E+04_RKIND + layerInterfaces( 63) = 0.1074E+04_RKIND + layerInterfaces( 64) = 0.1133E+04_RKIND + layerInterfaces( 65) = 0.1194E+04_RKIND + layerInterfaces( 66) = 0.1259E+04_RKIND + layerInterfaces( 67) = 0.1326E+04_RKIND + layerInterfaces( 68) = 0.1396E+04_RKIND + layerInterfaces( 69) = 0.1469E+04_RKIND + layerInterfaces( 70) = 0.1546E+04_RKIND + layerInterfaces( 71) = 0.1625E+04_RKIND + layerInterfaces( 72) = 0.1708E+04_RKIND + layerInterfaces( 73) = 0.1794E+04_RKIND + layerInterfaces( 74) = 0.1884E+04_RKIND + layerInterfaces( 75) = 0.1978E+04_RKIND + layerInterfaces( 76) = 0.2075E+04_RKIND + layerInterfaces( 77) = 0.2176E+04_RKIND + layerInterfaces( 78) = 0.2281E+04_RKIND + layerInterfaces( 79) = 0.2390E+04_RKIND + layerInterfaces( 80) = 0.2503E+04_RKIND + layerInterfaces( 81) = 0.2620E+04_RKIND + layerInterfaces( 82) = 0.2742E+04_RKIND + layerInterfaces( 83) = 0.2868E+04_RKIND + layerInterfaces( 84) = 0.2998E+04_RKIND + layerInterfaces( 85) = 0.3134E+04_RKIND + layerInterfaces( 86) = 0.3274E+04_RKIND + layerInterfaces( 87) = 0.3418E+04_RKIND + layerInterfaces( 88) = 0.3568E+04_RKIND + layerInterfaces( 89) = 0.3723E+04_RKIND + layerInterfaces( 90) = 0.3882E+04_RKIND + layerInterfaces( 91) = 0.4047E+04_RKIND + layerInterfaces( 92) = 0.4218E+04_RKIND + layerInterfaces( 93) = 0.4393E+04_RKIND + layerInterfaces( 94) = 0.4574E+04_RKIND + layerInterfaces( 95) = 0.4761E+04_RKIND + layerInterfaces( 96) = 0.4953E+04_RKIND + layerInterfaces( 97) = 0.5151E+04_RKIND + layerInterfaces( 98) = 0.5354E+04_RKIND + layerInterfaces( 99) = 0.5564E+04_RKIND + layerInterfaces(100) = 0.5779E+04_RKIND + layerInterfaces(101) = 0.6000E+04_RKIND + + maxInterfaceLocation = maxval(layerInterfaces) + + layerInterfaces(:) = layerInterfaces(:) / maxInterfaceLocation + + end subroutine ocn_generate_100layerACMEv1_vertical_grid!}}} + !*********************************************************************** end module ocn_init_vertical_grids From 6722888e347dbd18f5990ebdcdc839b6527794d6 Mon Sep 17 00:00:00 2001 From: toddringler Date: Fri, 24 Apr 2015 08:37:34 -0600 Subject: [PATCH 0101/1724] new test case for CVMix Wind Stress with Surface Buoyancy Forcing --- src/core_ocean/mode_init/Makefile | 5 +- src/core_ocean/mode_init/Registry.xml | 1 + .../mode_init/Registry_cvmix_WSwSBF.xml | 66 +++ .../mode_init/mpas_ocn_init_cvmix_WSwSBF.F | 333 ++++++++++++ src/core_ocean/mode_init/mpas_ocn_init_mode.F | 4 + .../mode_init/mpas_ocn_init_vertical_grids.F | 478 +++++++++--------- 6 files changed, 647 insertions(+), 240 deletions(-) create mode 100644 src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile index 6a02878e01..e170051234 100644 --- a/src/core_ocean/mode_init/Makefile +++ b/src/core_ocean/mode_init/Makefile @@ -3,7 +3,7 @@ OBJS = mpas_ocn_init_mode.o UTILS = mpas_ocn_init_spherical_utils.o \ - mpas_ocn_init_vertical_grids.o \ + mpas_ocn_init_vertical_grids.o \ mpas_ocn_init_cell_markers.o TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ @@ -12,6 +12,7 @@ TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ mpas_ocn_init_overflow.o \ mpas_ocn_init_cvmix_convection_unit_test.o \ mpas_ocn_init_cvmix_shear_unit_test.o \ + mpas_ocn_init_cvmix_WSwSBF.o \ mpas_ocn_init_global_realistic.o #mpas_ocn_init_TEMPLATE.o @@ -41,6 +42,8 @@ mpas_ocn_init_cvmix_shear_unit_test.o: $(UTILS) mpas_ocn_init_global_realistic.o: $(UTILS) +mpas_ocn_init_cvmix_WSwSBF.o: $(UTILS) + #mpas_ocn_init_TEMPLATE.o: $(UTILS) clean: diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml index 65b6e0938f..34421ca0c7 100644 --- a/src/core_ocean/mode_init/Registry.xml +++ b/src/core_ocean/mode_init/Registry.xml @@ -5,4 +5,5 @@ #include "Registry_cvmix_convection_unit_test.xml" #include "Registry_cvmix_shear_unit_test.xml" #include "Registry_global_realistic.xml" +#include "Registry_cvmix_WSwSBF.xml" // #include "Registry_TEMPLATE.xml" diff --git a/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml b/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml new file mode 100644 index 0000000000..6cb2a04e92 --- /dev/null +++ b/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F new file mode 100644 index 0000000000..32066d93d7 --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F @@ -0,0 +1,333 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_cvmix_WSwSBF +! +!> \brief MPAS ocean initialize case -- CVMix Unit Test +!> WSwSBF means Wind Stress with Surface Buoyancy Forcing +!> \author Todd Ringler +!> \date 04/23/2015 +!> \details +!> This module contains the routines for initializing the +!> the cvmix WSwSBF unit test configuration. This in a +!> single column configuration +! +!----------------------------------------------------------------------- + +module ocn_init_cvmix_WSwSBF + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + + use ocn_init_cell_markers + use ocn_init_vertical_grids + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_cvmix_WSwSBF, & + ocn_init_validate_cvmix_WSwSBF + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_cvmix_WSwSBF +! +!> \brief Setup for cvmix WSwSBF unit test configuration +!> \author Todd Ringler +!> \date 04/23/2015 +!> \details +!> This routine sets up the initial conditions for the cvmix WSwSBF unit test configuration. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + real (kind=RKIND) :: temperature, salinity + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool + type (mpas_pool_type), pointer :: diagnosticsPool, forcingPool + + integer, pointer :: nVertLevels, nVertLevelsP1, nCellsSolve, nEdgesSolve, nVerticesSolve + integer, pointer :: index_temperature, index_salinity + + integer, dimension(:), pointer :: maxLevelCell + real (kind=RKIND), dimension(:), pointer :: refBottomDepth, refZMid, vertCoordMovementWeights + real (kind=RKIND), dimension(:), pointer :: surfaceWindStress, boundaryLayerDepth, temperatureRestore + real (kind=RKIND), dimension(:), pointer :: latentHeatFlux, sensibleHeatFlux, shortWaveHeatFlux + real (kind=RKIND), dimension(:), pointer :: evaporationFlux, rainFlux + real (kind=RKIND), dimension(:), pointer :: salinityRestore, bottomDepth, angleEdge + real (kind=RKIND), dimension(:), pointer :: fCell, fEdge, fVertex + real (kind=RKIND), dimension(:, :), pointer :: layerThickness, restingThickness + real (kind=RKIND), dimension(:, :, :), pointer :: tracers + + real (kind=RKIND), dimension(:), pointer :: interfaceLocations + + integer :: iCell, iEdge, iVertex, k + + character (len=StrKIND), pointer :: config_init_configuration, & + config_cvmix_WSwSBF_vertical_grid + + integer, pointer :: config_cvmix_WSwSBF_vert_levels + + real (kind=RKIND), pointer :: config_cvmix_WSwSBF_surface_temperature, & + config_cvmix_WSwSBF_surface_salinity, & + config_cvmix_WSwSBF_surface_restoring_temperature, & + config_cvmix_WSwSBF_surface_restoring_salinity, & + config_cvmix_WSwSBF_sensible_heat_flux, & + config_cvmix_WSwSBF_latent_heat_flux, & + config_cvmix_WSwSBF_shortwave_heat_flux, & + config_cvmix_WSwSBF_rain_flux, & + config_cvmix_WSwSBF_evaporation_flux, & + config_cvmix_WSwSBF_temperature_gradient, & + config_cvmix_WSwSBF_salinity_gradient, & + config_cvmix_WSwSBF_bottom_depth, & + config_cvmix_WSwSBF_max_windstress, & + config_cvmix_WSwSBF_coriolis_parameter + ! assume no error + iErr = 0 + + ! get and test if this is the configuration specified + call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) + if(config_init_configuration .ne. trim('cvmix_WSwSBF')) return + + ! build the vertical grid + ! intent(out) is interfaceLocations. An array ranging from 0 to 1 + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_vertical_grid', config_cvmix_WSwSBF_vertical_grid) + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nVertLevelsP1', nVertLevelsP1) + allocate(interfaceLocations(nVertLevelsP1)) + call ocn_generate_vertical_grid(config_cvmix_WSwSBF_vertical_grid, interfaceLocations) + + ! load the remaining configuration parameters + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_temperature', config_cvmix_WSwSBF_surface_temperature) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_salinity', config_cvmix_WSwSBF_surface_salinity) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_restoring_temperature', config_cvmix_WSwSBF_surface_restoring_temperature) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_restoring_salinity', config_cvmix_WSwSBF_surface_restoring_salinity) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_sensible_heat_flux', config_cvmix_WSwSBF_sensible_heat_flux) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_latent_heat_flux', config_cvmix_WSwSBF_latent_heat_flux) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_shortwave_heat_flux', config_cvmix_WSwSBF_shortwave_heat_flux) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_rain_flux', config_cvmix_WSwSBF_rain_flux) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_evaporation_flux', config_cvmix_WSwSBF_evaporation_flux) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_temperature_gradient', config_cvmix_WSwSBF_temperature_gradient) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_salinity_gradient', config_cvmix_WSwSBF_salinity_gradient) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_bottom_depth', config_cvmix_WSwSBF_bottom_depth) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_max_windstress', config_cvmix_WSwSBF_max_windstress) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_coriolis_parameter', config_cvmix_WSwSBF_coriolis_parameter) + + write(6,*) config_cvmix_WSwSBF_surface_temperature, config_cvmix_WSwSBF_surface_salinity, & + config_cvmix_WSwSBF_surface_salinity, config_cvmix_WSwSBF_surface_restoring_salinity + + ! load data that required to initialize the ocean simulation + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nVerticesSolve', nVerticesSolve) + + write(6,*) nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve + + call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + + write(6,*) index_temperature, index_salinity + + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'temperatureRestore', temperatureRestore) + call mpas_pool_get_array(meshPool, 'salinityRestore', salinityRestore) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) + + call mpas_pool_get_array(meshPool, 'fCell', fCell) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + call mpas_pool_get_array(meshPool, 'fVertex', fVertex) + + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + + ! should be removed + ! call mpas_pool_get_array(diagnosticsPool, 'boundaryLayerDepth', boundaryLayerDepth) + + call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) + call mpas_pool_get_array(forcingPool, 'latentHeatFlux', latentHeatFlux) + call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) + call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) + call mpas_pool_get_array(forcingPool, 'evaporationFlux', evaporationFlux) + call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) + + ! Set refBottomDepth and refBottomDepthTopOfCell + do k = 1, nVertLevels + refBottomDepth(k) = config_cvmix_WSwSBF_bottom_depth * interfaceLocations(k+1) + refZMid(k) = - 0.5_RKIND * config_cvmix_WSwSBF_bottom_depth * (interfaceLocations(k) + interfaceLocations(k+1)) + end do + + ! Set vertCoordMovementWeights + vertCoordMovementWeights(:) = 1.0_RKIND + + do iCell = 1, nCellsSolve + ! Set temperature and salinity + do k = 1, nVertLevels + temperature = config_cvmix_WSwSBF_surface_temperature + refZMid(k) * config_cvmix_WSwSBF_temperature_gradient + tracers(index_temperature, k, iCell) = temperature + salinity = config_cvmix_WSwSBF_surface_salinity + refZMid(k) * config_cvmix_WSwSBF_salinity_gradient + tracers(index_salinity, :, iCell) = salinity + end do + + write(6,*) ' maxval ', maxval(tracers) + + ! Set layerThickness + do k = 1, nVertLevels + layerThickness(k, iCell) = config_cvmix_WSwSBF_bottom_depth * (interfaceLocations(k+1) - interfaceLocations(k)) + restingThickness(k, iCell) = layerThickness(k, iCell) + end do + + write(6,*) maxval(layerThickness) + + ! Set temperatureRestore + temperatureRestore(iCell) = config_cvmix_WSwSBF_surface_restoring_temperature + + ! Set salinityRestore + salinityRestore(iCell) = config_cvmix_WSwSBF_surface_restoring_salinity + + ! Set sensible heat flux + ! sensibleHeatFlux(iCell) = config_cvmix_WSwSBF_sensible_heat_flux + + ! Set latent heat flux + ! latentHeatFlux(iCell) = config_cvmix_WSwSBF_latent_heat_flux + + ! Set shortwave heat flux + ! shortWaveHeatFlux(iCell) = config_cvmix_WSwSBF_shortwave_heat_flux + + ! Set precipation and evaporation + ! rainFlux(iCell) = config_cvmix_WSwSBF_rain_flux + ! evaporationFlux(iCell) = config_cvmix_WSwSBF_evaporation_flux + + ! Set Coriolis parameter + fCell(iCell) = config_cvmix_WSwSBF_coriolis_parameter + + ! to be removed + ! Set boundary layer depth + ! boundaryLayerDepth(iCell) = 2.0_RKIND * (config_cvmix_shear_unit_test_bottom_depth / nVertLevels) - 1.0-4_RKIND + + ! Set bottomDepth + bottomDepth(iCell) = config_cvmix_WSwSBF_bottom_depth + + ! Set maxLevelCell + maxLevelCell(iCell) = nVertLevels + end do + + do iEdge = 1, nEdgesSolve + surfaceWindStress(iEdge) = config_cvmix_WSwSBF_max_windstress * cos(angleEdge(iEdge)) + fEdge(iEdge) = config_cvmix_WSwSBF_coriolis_parameter + end do + + do iVertex=1, nVerticesSolve + fVertex(iVertex) = config_cvmix_WSwSBF_coriolis_parameter + end do + + block_ptr => block_ptr % next + end do + + deallocate(interfaceLocations) + + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_cvmix_WSwSBF!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_cvmix_WSwSBF +! +!> \brief Validation for CVMix WSwSBF mixing unit test case +!> \author Doug Jacobsen +!> \date 04/01/2015 +!> \details +!> This routine validates the configuration options for the CVMix WSwSBF mixing unit test configuration. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_cvmix_WSwSBF(configPool, packagePool, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + integer, intent(out) :: iErr + + character (len=StrKIND), pointer :: config_init_configuration + integer, pointer :: config_vert_levels, config_cvmix_WSwSBF_vert_levels + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('cvmix_WSwSBF')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_cvmix_WSwSBF_vert_levels', config_cvmix_WSwSBF_vert_levels) + + if(config_vert_levels <= 0 .and. config_cvmix_WSwSBF_vert_levels > 0) then + config_vert_levels = config_cvmix_WSwSBF_vert_levels + else if(config_vert_levels <= 0) then + write(stderrUnit,*) 'ERROR: Validation failed for CVMix WSwSBF unit test case. Not given a usable value for vertical levels.' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_cvmix_WSwSBF!}}} + +!*********************************************************************** + +end module ocn_init_cvmix_WSwSBF + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 7aca01c894..3317fcd7cc 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -45,6 +45,7 @@ module ocn_init_mode use ocn_init_cvmix_convection_unit_test use ocn_init_cvmix_shear_unit_test use ocn_init_global_realistic + use ocn_init_cvmix_WSwSBF implicit none private @@ -251,6 +252,7 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call ocn_init_setup_cvmix_convection_unit_test(domain, ierr) call ocn_init_setup_cvmix_shear_unit_test(domain, ierr) call ocn_init_setup_global_realistic(domain, ierr) + call ocn_init_setup_cvmix_WSwSBF(domain, ierr) !call ocn_init_setup_TEMPLATE(domain, ierr) call mpas_timer_start('io_write', .false.) @@ -336,6 +338,8 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, iErr)!{ iErr = ior(iErr, err_tmp) call ocn_init_validate_global_realistic(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) + call ocn_init_validate_cvmix_WSwSBF(configPool, packagePool, iErr=err_tmp) + iErr = ior(iErr, err_tmp) ! call ocn_config_TEMPLATE_validate(configPool, packagePool, iErr=err_tmp) ! iErr = ior(iErr, err_tmp) end subroutine ocn_init_mode_validate_configuration!}}} diff --git a/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F index 1384cae89a..ed4cb87146 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F @@ -65,24 +65,24 @@ module ocn_init_vertical_grids !> \details !> This routine is a driver for generating vertical grids. It calls a private !> module routine based on the value of the input argument gridType. - !> The output array layerInterfaces will contain values between 1 and 0 - !> representing the relative locations of layer interfaces. + !> The output array interfaceLocations will contain values between + !> 0 being the top of top layer and 1 being the bottom of bottom layer ! !----------------------------------------------------------------------- - subroutine ocn_generate_vertical_grid(gridType, layerInterfaces)!{{{ + subroutine ocn_generate_vertical_grid(gridType, interfaceLocations)!{{{ implicit none character (len=*), intent(in) :: gridType - real (kind=RKIND), dimension(:), intent(out) :: layerInterfaces + real (kind=RKIND), dimension(:), intent(out) :: interfaceLocations if ( trim(gridType) == 'uniform' ) then - call ocn_generate_uniform_vertical_grid(layerInterfaces) + call ocn_generate_uniform_vertical_grid(interfaceLocations) else if ( trim(gridType) == '60layerPHC' ) then - call ocn_generate_60layerPHC_vertical_grid(layerInterfaces) + call ocn_generate_60layerPHC_vertical_grid(interfaceLocations) else if ( trim(gridType) == '42layerWOCE' ) then - call ocn_generate_42layerWOCE_vertical_grid(layerInterfaces) + call ocn_generate_42layerWOCE_vertical_grid(interfaceLocations) else if ( trim(gridType) == '100layerACMEv1' ) then - call ocn_generate_100layerACMEv1_vertical_grid(layerInterfaces) + call ocn_generate_100layerACMEv1_vertical_grid(interfaceLocations) else write(stderrUnit, *) ' WARNING: '//trim(gridType)//' is an invalid vertical grid choice. No vertical grid will be generated.' end if @@ -100,23 +100,23 @@ end subroutine ocn_generate_vertical_grid!}}} !> This routine generates a uniform vertical grid. ! !----------------------------------------------------------------------- - subroutine ocn_generate_uniform_vertical_grid(layerInterfaces)!{{{ + subroutine ocn_generate_uniform_vertical_grid(interfaceLocations)!{{{ implicit none - real (kind=RKIND), dimension(:), intent(out) :: layerInterfaces + real (kind=RKIND), dimension(:), intent(out) :: interfaceLocations real (kind=RKIND) :: layerSpacing integer :: nInterfaces, iInterface write(stderrUnit,* ) ' ---- Generating uniform vertical grid ---- ' - nInterfaces = size(layerInterfaces, dim=1) + nInterfaces = size(interfaceLocations, dim=1) layerSpacing = 1.0_RKIND / (nInterfaces - 1) - layerInterfaces(1) = 0.0_RKIND + interfaceLocations(1) = 0.0_RKIND do iInterface = 2, nInterfaces - layerInterfaces(iInterface) = layerInterfaces(iInterface-1) + layerSpacing + interfaceLocations(iInterface) = interfaceLocations(iInterface-1) + layerSpacing end do end subroutine ocn_generate_uniform_vertical_grid!}}} @@ -132,85 +132,85 @@ end subroutine ocn_generate_uniform_vertical_grid!}}} !> This routine generates a 60 layer vertical grid based on the PHC data set. ! !----------------------------------------------------------------------- - subroutine ocn_generate_60layerPHC_vertical_grid(layerInterfaces)!{{{ + subroutine ocn_generate_60layerPHC_vertical_grid(interfaceLocations)!{{{ implicit none - real (kind=RKIND), dimension(:), intent(out) :: layerInterfaces + real (kind=RKIND), dimension(:), intent(out) :: interfaceLocations real (kind=RKIND) :: maxInterfaceLocation integer :: nInterfaces, iInterface - nInterfaces = size(layerInterfaces, dim=1) + nInterfaces = size(interfaceLocations, dim=1) if ( nInterfaces /= 61 ) then call mpas_dmpar_global_abort("ERROR: Vertical grid must have 60 layers to apply 60 Layer PHC grid. Exiting...") end if - layerInterfaces(1) = 0.0_RKIND - layerInterfaces(2) = 500_RKIND - layerInterfaces(3) = 1500_RKIND - layerInterfaces(4) = 2500_RKIND - layerInterfaces(5) = 3500_RKIND - layerInterfaces(6) = 4500_RKIND - layerInterfaces(7) = 5500_RKIND - layerInterfaces(8) = 6500_RKIND - layerInterfaces(9) = 7500_RKIND - layerInterfaces(10) = 8500_RKIND - layerInterfaces(11) = 9500_RKIND - layerInterfaces(12) = 10500_RKIND - layerInterfaces(13) = 11500_RKIND - layerInterfaces(14) = 12500_RKIND - layerInterfaces(15) = 13500_RKIND - layerInterfaces(16) = 14500_RKIND - layerInterfaces(17) = 15500_RKIND - layerInterfaces(18) = 16509.83984375_RKIND - layerInterfaces(19) = 17547.904296875_RKIND - layerInterfaces(20) = 18629.125_RKIND - layerInterfaces(21) = 19766.025390625_RKIND - layerInterfaces(22) = 20971.134765625_RKIND - layerInterfaces(23) = 22257.826171875_RKIND - layerInterfaces(24) = 23640.880859375_RKIND - layerInterfaces(25) = 25137.013671875_RKIND - layerInterfaces(26) = 26765.416015625_RKIND - layerInterfaces(27) = 28548.361328125_RKIND - layerInterfaces(28) = 30511.91796875_RKIND - layerInterfaces(29) = 32686.794921875_RKIND - layerInterfaces(30) = 35109.34375_RKIND - layerInterfaces(31) = 37822.75390625_RKIND - layerInterfaces(32) = 40878.4609375_RKIND - layerInterfaces(33) = 44337.765625_RKIND - layerInterfaces(34) = 48273.66796875_RKIND - layerInterfaces(35) = 52772.796875_RKIND - layerInterfaces(36) = 57937.28515625_RKIND - layerInterfaces(37) = 63886.2578125_RKIND - layerInterfaces(38) = 70756.328125_RKIND - layerInterfaces(39) = 78700.25_RKIND - layerInterfaces(40) = 87882.5234375_RKIND - layerInterfaces(41) = 98470.5859375_RKIND - layerInterfaces(42) = 110620.421875_RKIND - layerInterfaces(43) = 124456.6953125_RKIND - layerInterfaces(44) = 140049.71875_RKIND - layerInterfaces(45) = 157394.640625_RKIND - layerInterfaces(46) = 176400.328125_RKIND - layerInterfaces(47) = 196894.421875_RKIND - layerInterfaces(48) = 218645.65625_RKIND - layerInterfaces(49) = 241397.15625_RKIND - layerInterfaces(50) = 264900.125_RKIND - layerInterfaces(51) = 288938.46875_RKIND - layerInterfaces(52) = 313340.46875_RKIND - layerInterfaces(53) = 337979.375_RKIND - layerInterfaces(54) = 362767.0625_RKIND - layerInterfaces(55) = 387645.21875_RKIND - layerInterfaces(56) = 412576.84375_RKIND - layerInterfaces(57) = 437539.28125_RKIND - layerInterfaces(58) = 462519.0625_RKIND - layerInterfaces(59) = 487508.375_RKIND - layerInterfaces(60) = 512502.84375_RKIND - layerInterfaces(61) = 537500_RKIND - - maxInterfaceLocation = maxval(layerInterfaces) - - layerInterfaces(:) = layerInterfaces(:) / maxInterfaceLocation + interfaceLocations(1) = 0.0_RKIND + interfaceLocations(2) = 500_RKIND + interfaceLocations(3) = 1500_RKIND + interfaceLocations(4) = 2500_RKIND + interfaceLocations(5) = 3500_RKIND + interfaceLocations(6) = 4500_RKIND + interfaceLocations(7) = 5500_RKIND + interfaceLocations(8) = 6500_RKIND + interfaceLocations(9) = 7500_RKIND + interfaceLocations(10) = 8500_RKIND + interfaceLocations(11) = 9500_RKIND + interfaceLocations(12) = 10500_RKIND + interfaceLocations(13) = 11500_RKIND + interfaceLocations(14) = 12500_RKIND + interfaceLocations(15) = 13500_RKIND + interfaceLocations(16) = 14500_RKIND + interfaceLocations(17) = 15500_RKIND + interfaceLocations(18) = 16509.83984375_RKIND + interfaceLocations(19) = 17547.904296875_RKIND + interfaceLocations(20) = 18629.125_RKIND + interfaceLocations(21) = 19766.025390625_RKIND + interfaceLocations(22) = 20971.134765625_RKIND + interfaceLocations(23) = 22257.826171875_RKIND + interfaceLocations(24) = 23640.880859375_RKIND + interfaceLocations(25) = 25137.013671875_RKIND + interfaceLocations(26) = 26765.416015625_RKIND + interfaceLocations(27) = 28548.361328125_RKIND + interfaceLocations(28) = 30511.91796875_RKIND + interfaceLocations(29) = 32686.794921875_RKIND + interfaceLocations(30) = 35109.34375_RKIND + interfaceLocations(31) = 37822.75390625_RKIND + interfaceLocations(32) = 40878.4609375_RKIND + interfaceLocations(33) = 44337.765625_RKIND + interfaceLocations(34) = 48273.66796875_RKIND + interfaceLocations(35) = 52772.796875_RKIND + interfaceLocations(36) = 57937.28515625_RKIND + interfaceLocations(37) = 63886.2578125_RKIND + interfaceLocations(38) = 70756.328125_RKIND + interfaceLocations(39) = 78700.25_RKIND + interfaceLocations(40) = 87882.5234375_RKIND + interfaceLocations(41) = 98470.5859375_RKIND + interfaceLocations(42) = 110620.421875_RKIND + interfaceLocations(43) = 124456.6953125_RKIND + interfaceLocations(44) = 140049.71875_RKIND + interfaceLocations(45) = 157394.640625_RKIND + interfaceLocations(46) = 176400.328125_RKIND + interfaceLocations(47) = 196894.421875_RKIND + interfaceLocations(48) = 218645.65625_RKIND + interfaceLocations(49) = 241397.15625_RKIND + interfaceLocations(50) = 264900.125_RKIND + interfaceLocations(51) = 288938.46875_RKIND + interfaceLocations(52) = 313340.46875_RKIND + interfaceLocations(53) = 337979.375_RKIND + interfaceLocations(54) = 362767.0625_RKIND + interfaceLocations(55) = 387645.21875_RKIND + interfaceLocations(56) = 412576.84375_RKIND + interfaceLocations(57) = 437539.28125_RKIND + interfaceLocations(58) = 462519.0625_RKIND + interfaceLocations(59) = 487508.375_RKIND + interfaceLocations(60) = 512502.84375_RKIND + interfaceLocations(61) = 537500_RKIND + + maxInterfaceLocation = maxval(interfaceLocations) + + interfaceLocations(:) = interfaceLocations(:) / maxInterfaceLocation end subroutine ocn_generate_60layerPHC_vertical_grid!}}} @@ -225,67 +225,67 @@ end subroutine ocn_generate_60layerPHC_vertical_grid!}}} !> This routine generates a 42 layer vertical grid based on the WOCE data set. ! !----------------------------------------------------------------------- - subroutine ocn_generate_42layerWOCE_vertical_grid(layerInterfaces)!{{{ + subroutine ocn_generate_42layerWOCE_vertical_grid(interfaceLocations)!{{{ implicit none - real (kind=RKIND), dimension(:), intent(out) :: layerInterfaces + real (kind=RKIND), dimension(:), intent(out) :: interfaceLocations real (kind=RKIND) :: maxInterfaceLocation integer :: nInterfaces, iInterface - nInterfaces = size(layerInterfaces, dim=1) + nInterfaces = size(interfaceLocations, dim=1) if ( nInterfaces /= 43 ) then call mpas_dmpar_global_abort("ERROR: Vertical grid must have 60 layers to apply 60 Layer PHC grid. Exiting...") end if - layerInterfaces(1) = 0.0_RKIND - layerInterfaces(2) = 5.00622_RKIND - layerInterfaces(3) = 15.06873_RKIND - layerInterfaces(4) = 25.28343_RKIND - layerInterfaces(5) = 35.75849_RKIND - layerInterfaces(6) = 46.61269_RKIND - layerInterfaces(7) = 57.98099_RKIND - layerInterfaces(8) = 70.02139_RKIND - layerInterfaces(9) = 82.92409_RKIND - layerInterfaces(10) = 96.92413_RKIND - layerInterfaces(11) = 112.3189_RKIND - layerInterfaces(12) = 129.4936_RKIND - layerInterfaces(13) = 148.9582_RKIND - layerInterfaces(14) = 171.4044_RKIND - layerInterfaces(15) = 197.7919_RKIND - layerInterfaces(16) = 229.4842_RKIND - layerInterfaces(17) = 268.4617_RKIND - layerInterfaces(18) = 317.6501_RKIND - layerInterfaces(19) = 381.3864_RKIND - layerInterfaces(20) = 465.9132_RKIND - layerInterfaces(21) = 579.3073_RKIND - layerInterfaces(22) = 729.3513_RKIND - layerInterfaces(23) = 918.3723_RKIND - layerInterfaces(24) = 1139.153_RKIND - layerInterfaces(25) = 1378.574_RKIND - layerInterfaces(26) = 1625.7_RKIND - layerInterfaces(27) = 1875.106_RKIND - layerInterfaces(28) = 2125.011_RKIND - layerInterfaces(29) = 2375_RKIND - layerInterfaces(30) = 2624.999_RKIND - layerInterfaces(31) = 2874.999_RKIND - layerInterfaces(32) = 3124.999_RKIND - layerInterfaces(33) = 3374.999_RKIND - layerInterfaces(34) = 3624.999_RKIND - layerInterfaces(35) = 3874.999_RKIND - layerInterfaces(36) = 4124.999_RKIND - layerInterfaces(37) = 4374.999_RKIND - layerInterfaces(38) = 4624.999_RKIND - layerInterfaces(39) = 4874.999_RKIND - layerInterfaces(40) = 5124.999_RKIND - layerInterfaces(41) = 5374.999_RKIND - layerInterfaces(42) = 5624.999_RKIND - layerInterfaces(43) = 5874.999_RKIND - - maxInterfaceLocation = maxval(layerInterfaces) - - layerInterfaces(:) = layerInterfaces(:) / maxInterfaceLocation + interfaceLocations(1) = 0.0_RKIND + interfaceLocations(2) = 5.00622_RKIND + interfaceLocations(3) = 15.06873_RKIND + interfaceLocations(4) = 25.28343_RKIND + interfaceLocations(5) = 35.75849_RKIND + interfaceLocations(6) = 46.61269_RKIND + interfaceLocations(7) = 57.98099_RKIND + interfaceLocations(8) = 70.02139_RKIND + interfaceLocations(9) = 82.92409_RKIND + interfaceLocations(10) = 96.92413_RKIND + interfaceLocations(11) = 112.3189_RKIND + interfaceLocations(12) = 129.4936_RKIND + interfaceLocations(13) = 148.9582_RKIND + interfaceLocations(14) = 171.4044_RKIND + interfaceLocations(15) = 197.7919_RKIND + interfaceLocations(16) = 229.4842_RKIND + interfaceLocations(17) = 268.4617_RKIND + interfaceLocations(18) = 317.6501_RKIND + interfaceLocations(19) = 381.3864_RKIND + interfaceLocations(20) = 465.9132_RKIND + interfaceLocations(21) = 579.3073_RKIND + interfaceLocations(22) = 729.3513_RKIND + interfaceLocations(23) = 918.3723_RKIND + interfaceLocations(24) = 1139.153_RKIND + interfaceLocations(25) = 1378.574_RKIND + interfaceLocations(26) = 1625.7_RKIND + interfaceLocations(27) = 1875.106_RKIND + interfaceLocations(28) = 2125.011_RKIND + interfaceLocations(29) = 2375_RKIND + interfaceLocations(30) = 2624.999_RKIND + interfaceLocations(31) = 2874.999_RKIND + interfaceLocations(32) = 3124.999_RKIND + interfaceLocations(33) = 3374.999_RKIND + interfaceLocations(34) = 3624.999_RKIND + interfaceLocations(35) = 3874.999_RKIND + interfaceLocations(36) = 4124.999_RKIND + interfaceLocations(37) = 4374.999_RKIND + interfaceLocations(38) = 4624.999_RKIND + interfaceLocations(39) = 4874.999_RKIND + interfaceLocations(40) = 5124.999_RKIND + interfaceLocations(41) = 5374.999_RKIND + interfaceLocations(42) = 5624.999_RKIND + interfaceLocations(43) = 5874.999_RKIND + + maxInterfaceLocation = maxval(interfaceLocations) + + interfaceLocations(:) = interfaceLocations(:) / maxInterfaceLocation end subroutine ocn_generate_42layerWOCE_vertical_grid!}}} @@ -301,125 +301,125 @@ end subroutine ocn_generate_42layerWOCE_vertical_grid!}}} !> This routine generates a 100 layer grid ! !----------------------------------------------------------------------- - subroutine ocn_generate_100layerACMEv1_vertical_grid(layerInterfaces)!{{{ + subroutine ocn_generate_100layerACMEv1_vertical_grid(interfaceLocations)!{{{ implicit none - real (kind=RKIND), dimension(:), intent(out) :: layerInterfaces + real (kind=RKIND), dimension(:), intent(out) :: interfaceLocations real (kind=RKIND) :: maxInterfaceLocation integer :: nInterfaces, iInterface - nInterfaces = size(layerInterfaces, dim=1) + nInterfaces = size(interfaceLocations, dim=1) if ( nInterfaces /= 101 ) then call mpas_dmpar_global_abort("ERROR: Vertical grid must have 100 layers to apply 100 Layer PHC grid. Exiting...") end if - layerInterfaces( 1) = 0.0000E+00_RKIND - layerInterfaces( 2) = 0.1510E+01_RKIND - layerInterfaces( 3) = 0.3135E+01_RKIND - layerInterfaces( 4) = 0.4882E+01_RKIND - layerInterfaces( 5) = 0.6761E+01_RKIND - layerInterfaces( 6) = 0.8779E+01_RKIND - layerInterfaces( 7) = 0.1095E+02_RKIND - layerInterfaces( 8) = 0.1327E+02_RKIND - layerInterfaces( 9) = 0.1577E+02_RKIND - layerInterfaces( 10) = 0.1845E+02_RKIND - layerInterfaces( 11) = 0.2132E+02_RKIND - layerInterfaces( 12) = 0.2440E+02_RKIND - layerInterfaces( 13) = 0.2769E+02_RKIND - layerInterfaces( 14) = 0.3122E+02_RKIND - layerInterfaces( 15) = 0.3500E+02_RKIND - layerInterfaces( 16) = 0.3904E+02_RKIND - layerInterfaces( 17) = 0.4335E+02_RKIND - layerInterfaces( 18) = 0.4797E+02_RKIND - layerInterfaces( 19) = 0.5289E+02_RKIND - layerInterfaces( 20) = 0.5815E+02_RKIND - layerInterfaces( 21) = 0.6377E+02_RKIND - layerInterfaces( 22) = 0.6975E+02_RKIND - layerInterfaces( 23) = 0.7614E+02_RKIND - layerInterfaces( 24) = 0.8294E+02_RKIND - layerInterfaces( 25) = 0.9018E+02_RKIND - layerInterfaces( 26) = 0.9790E+02_RKIND - layerInterfaces( 27) = 0.1061E+03_RKIND - layerInterfaces( 28) = 0.1148E+03_RKIND - layerInterfaces( 29) = 0.1241E+03_RKIND - layerInterfaces( 30) = 0.1340E+03_RKIND - layerInterfaces( 31) = 0.1445E+03_RKIND - layerInterfaces( 32) = 0.1556E+03_RKIND - layerInterfaces( 33) = 0.1674E+03_RKIND - layerInterfaces( 34) = 0.1799E+03_RKIND - layerInterfaces( 35) = 0.1932E+03_RKIND - layerInterfaces( 36) = 0.2072E+03_RKIND - layerInterfaces( 37) = 0.2221E+03_RKIND - layerInterfaces( 38) = 0.2379E+03_RKIND - layerInterfaces( 39) = 0.2546E+03_RKIND - layerInterfaces( 40) = 0.2722E+03_RKIND - layerInterfaces( 41) = 0.2909E+03_RKIND - layerInterfaces( 42) = 0.3106E+03_RKIND - layerInterfaces( 43) = 0.3314E+03_RKIND - layerInterfaces( 44) = 0.3534E+03_RKIND - layerInterfaces( 45) = 0.3766E+03_RKIND - layerInterfaces( 46) = 0.4011E+03_RKIND - layerInterfaces( 47) = 0.4269E+03_RKIND - layerInterfaces( 48) = 0.4541E+03_RKIND - layerInterfaces( 49) = 0.4827E+03_RKIND - layerInterfaces( 50) = 0.5128E+03_RKIND - layerInterfaces( 51) = 0.5445E+03_RKIND - layerInterfaces( 52) = 0.5779E+03_RKIND - layerInterfaces( 53) = 0.6130E+03_RKIND - layerInterfaces( 54) = 0.6498E+03_RKIND - layerInterfaces( 55) = 0.6885E+03_RKIND - layerInterfaces( 56) = 0.7291E+03_RKIND - layerInterfaces( 57) = 0.7717E+03_RKIND - layerInterfaces( 58) = 0.8164E+03_RKIND - layerInterfaces( 59) = 0.8633E+03_RKIND - layerInterfaces( 60) = 0.9124E+03_RKIND - layerInterfaces( 61) = 0.9638E+03_RKIND - layerInterfaces( 62) = 0.1018E+04_RKIND - layerInterfaces( 63) = 0.1074E+04_RKIND - layerInterfaces( 64) = 0.1133E+04_RKIND - layerInterfaces( 65) = 0.1194E+04_RKIND - layerInterfaces( 66) = 0.1259E+04_RKIND - layerInterfaces( 67) = 0.1326E+04_RKIND - layerInterfaces( 68) = 0.1396E+04_RKIND - layerInterfaces( 69) = 0.1469E+04_RKIND - layerInterfaces( 70) = 0.1546E+04_RKIND - layerInterfaces( 71) = 0.1625E+04_RKIND - layerInterfaces( 72) = 0.1708E+04_RKIND - layerInterfaces( 73) = 0.1794E+04_RKIND - layerInterfaces( 74) = 0.1884E+04_RKIND - layerInterfaces( 75) = 0.1978E+04_RKIND - layerInterfaces( 76) = 0.2075E+04_RKIND - layerInterfaces( 77) = 0.2176E+04_RKIND - layerInterfaces( 78) = 0.2281E+04_RKIND - layerInterfaces( 79) = 0.2390E+04_RKIND - layerInterfaces( 80) = 0.2503E+04_RKIND - layerInterfaces( 81) = 0.2620E+04_RKIND - layerInterfaces( 82) = 0.2742E+04_RKIND - layerInterfaces( 83) = 0.2868E+04_RKIND - layerInterfaces( 84) = 0.2998E+04_RKIND - layerInterfaces( 85) = 0.3134E+04_RKIND - layerInterfaces( 86) = 0.3274E+04_RKIND - layerInterfaces( 87) = 0.3418E+04_RKIND - layerInterfaces( 88) = 0.3568E+04_RKIND - layerInterfaces( 89) = 0.3723E+04_RKIND - layerInterfaces( 90) = 0.3882E+04_RKIND - layerInterfaces( 91) = 0.4047E+04_RKIND - layerInterfaces( 92) = 0.4218E+04_RKIND - layerInterfaces( 93) = 0.4393E+04_RKIND - layerInterfaces( 94) = 0.4574E+04_RKIND - layerInterfaces( 95) = 0.4761E+04_RKIND - layerInterfaces( 96) = 0.4953E+04_RKIND - layerInterfaces( 97) = 0.5151E+04_RKIND - layerInterfaces( 98) = 0.5354E+04_RKIND - layerInterfaces( 99) = 0.5564E+04_RKIND - layerInterfaces(100) = 0.5779E+04_RKIND - layerInterfaces(101) = 0.6000E+04_RKIND - - maxInterfaceLocation = maxval(layerInterfaces) - - layerInterfaces(:) = layerInterfaces(:) / maxInterfaceLocation + interfaceLocations( 1) = 0.0000E+00_RKIND + interfaceLocations( 2) = 0.1510E+01_RKIND + interfaceLocations( 3) = 0.3135E+01_RKIND + interfaceLocations( 4) = 0.4882E+01_RKIND + interfaceLocations( 5) = 0.6761E+01_RKIND + interfaceLocations( 6) = 0.8779E+01_RKIND + interfaceLocations( 7) = 0.1095E+02_RKIND + interfaceLocations( 8) = 0.1327E+02_RKIND + interfaceLocations( 9) = 0.1577E+02_RKIND + interfaceLocations( 10) = 0.1845E+02_RKIND + interfaceLocations( 11) = 0.2132E+02_RKIND + interfaceLocations( 12) = 0.2440E+02_RKIND + interfaceLocations( 13) = 0.2769E+02_RKIND + interfaceLocations( 14) = 0.3122E+02_RKIND + interfaceLocations( 15) = 0.3500E+02_RKIND + interfaceLocations( 16) = 0.3904E+02_RKIND + interfaceLocations( 17) = 0.4335E+02_RKIND + interfaceLocations( 18) = 0.4797E+02_RKIND + interfaceLocations( 19) = 0.5289E+02_RKIND + interfaceLocations( 20) = 0.5815E+02_RKIND + interfaceLocations( 21) = 0.6377E+02_RKIND + interfaceLocations( 22) = 0.6975E+02_RKIND + interfaceLocations( 23) = 0.7614E+02_RKIND + interfaceLocations( 24) = 0.8294E+02_RKIND + interfaceLocations( 25) = 0.9018E+02_RKIND + interfaceLocations( 26) = 0.9790E+02_RKIND + interfaceLocations( 27) = 0.1061E+03_RKIND + interfaceLocations( 28) = 0.1148E+03_RKIND + interfaceLocations( 29) = 0.1241E+03_RKIND + interfaceLocations( 30) = 0.1340E+03_RKIND + interfaceLocations( 31) = 0.1445E+03_RKIND + interfaceLocations( 32) = 0.1556E+03_RKIND + interfaceLocations( 33) = 0.1674E+03_RKIND + interfaceLocations( 34) = 0.1799E+03_RKIND + interfaceLocations( 35) = 0.1932E+03_RKIND + interfaceLocations( 36) = 0.2072E+03_RKIND + interfaceLocations( 37) = 0.2221E+03_RKIND + interfaceLocations( 38) = 0.2379E+03_RKIND + interfaceLocations( 39) = 0.2546E+03_RKIND + interfaceLocations( 40) = 0.2722E+03_RKIND + interfaceLocations( 41) = 0.2909E+03_RKIND + interfaceLocations( 42) = 0.3106E+03_RKIND + interfaceLocations( 43) = 0.3314E+03_RKIND + interfaceLocations( 44) = 0.3534E+03_RKIND + interfaceLocations( 45) = 0.3766E+03_RKIND + interfaceLocations( 46) = 0.4011E+03_RKIND + interfaceLocations( 47) = 0.4269E+03_RKIND + interfaceLocations( 48) = 0.4541E+03_RKIND + interfaceLocations( 49) = 0.4827E+03_RKIND + interfaceLocations( 50) = 0.5128E+03_RKIND + interfaceLocations( 51) = 0.5445E+03_RKIND + interfaceLocations( 52) = 0.5779E+03_RKIND + interfaceLocations( 53) = 0.6130E+03_RKIND + interfaceLocations( 54) = 0.6498E+03_RKIND + interfaceLocations( 55) = 0.6885E+03_RKIND + interfaceLocations( 56) = 0.7291E+03_RKIND + interfaceLocations( 57) = 0.7717E+03_RKIND + interfaceLocations( 58) = 0.8164E+03_RKIND + interfaceLocations( 59) = 0.8633E+03_RKIND + interfaceLocations( 60) = 0.9124E+03_RKIND + interfaceLocations( 61) = 0.9638E+03_RKIND + interfaceLocations( 62) = 0.1018E+04_RKIND + interfaceLocations( 63) = 0.1074E+04_RKIND + interfaceLocations( 64) = 0.1133E+04_RKIND + interfaceLocations( 65) = 0.1194E+04_RKIND + interfaceLocations( 66) = 0.1259E+04_RKIND + interfaceLocations( 67) = 0.1326E+04_RKIND + interfaceLocations( 68) = 0.1396E+04_RKIND + interfaceLocations( 69) = 0.1469E+04_RKIND + interfaceLocations( 70) = 0.1546E+04_RKIND + interfaceLocations( 71) = 0.1625E+04_RKIND + interfaceLocations( 72) = 0.1708E+04_RKIND + interfaceLocations( 73) = 0.1794E+04_RKIND + interfaceLocations( 74) = 0.1884E+04_RKIND + interfaceLocations( 75) = 0.1978E+04_RKIND + interfaceLocations( 76) = 0.2075E+04_RKIND + interfaceLocations( 77) = 0.2176E+04_RKIND + interfaceLocations( 78) = 0.2281E+04_RKIND + interfaceLocations( 79) = 0.2390E+04_RKIND + interfaceLocations( 80) = 0.2503E+04_RKIND + interfaceLocations( 81) = 0.2620E+04_RKIND + interfaceLocations( 82) = 0.2742E+04_RKIND + interfaceLocations( 83) = 0.2868E+04_RKIND + interfaceLocations( 84) = 0.2998E+04_RKIND + interfaceLocations( 85) = 0.3134E+04_RKIND + interfaceLocations( 86) = 0.3274E+04_RKIND + interfaceLocations( 87) = 0.3418E+04_RKIND + interfaceLocations( 88) = 0.3568E+04_RKIND + interfaceLocations( 89) = 0.3723E+04_RKIND + interfaceLocations( 90) = 0.3882E+04_RKIND + interfaceLocations( 91) = 0.4047E+04_RKIND + interfaceLocations( 92) = 0.4218E+04_RKIND + interfaceLocations( 93) = 0.4393E+04_RKIND + interfaceLocations( 94) = 0.4574E+04_RKIND + interfaceLocations( 95) = 0.4761E+04_RKIND + interfaceLocations( 96) = 0.4953E+04_RKIND + interfaceLocations( 97) = 0.5151E+04_RKIND + interfaceLocations( 98) = 0.5354E+04_RKIND + interfaceLocations( 99) = 0.5564E+04_RKIND + interfaceLocations(100) = 0.5779E+04_RKIND + interfaceLocations(101) = 0.6000E+04_RKIND + + maxInterfaceLocation = maxval(interfaceLocations) + + interfaceLocations(:) = interfaceLocations(:) / maxInterfaceLocation end subroutine ocn_generate_100layerACMEv1_vertical_grid!}}} From cfdebfdc4be4b013546d098a16d86efd8a912082 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Wed, 15 Jul 2015 08:33:08 -0600 Subject: [PATCH 0102/1724] Update namelist migration for the ocean When building the ocean core, only populate the top level directory with 4 namelists. The other namelists and streams files will be placed within the default_inputs directory. --- src/core_ocean/Makefile | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index 27e1f483dd..8c0ba0ea12 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -45,7 +45,14 @@ gen_includes: post_build: if [ ! -e $(ROOT_DIR)/default_inputs ]; then mkdir $(ROOT_DIR)/default_inputs; fi cp default_inputs/* $(ROOT_DIR)/default_inputs/. - ( cd $(ROOT_DIR)/default_inputs; for FILE in `ls -1`; do if [ ! -e ../$$FILE ]; then cp $$FILE ../.; fi; done ) + ( cp $(ROOT_DIR)/default_inputs/namelist.ocean $(ROOT_DIR)/namelist.ocean ) + ( cp $(ROOT_DIR)/default_inputs/namelist.ocean.forward $(ROOT_DIR)/namelist.ocean.forward ) + ( cp $(ROOT_DIR)/default_inputs/namelist.ocean.analysis $(ROOT_DIR)/namelist.ocean.analysis ) + ( cp $(ROOT_DIR)/default_inputs/namelist.ocean.init $(ROOT_DIR)/namelist.ocean.init ) + ( cp $(ROOT_DIR)/default_inputs/streams.ocean $(ROOT_DIR)/streams.ocean ) + ( cp $(ROOT_DIR)/default_inputs/streams.ocean.forward $(ROOT_DIR)/streams.ocean.forward ) + ( cp $(ROOT_DIR)/default_inputs/streams.ocean.analysis $(ROOT_DIR)/streams.ocean.analysis ) + ( cp $(ROOT_DIR)/default_inputs/streams.ocean.init $(ROOT_DIR)/streams.ocean.init ) cvmix_source: get_cvmix.sh (chmod a+x get_cvmix.sh; ./get_cvmix.sh) From 074c831ece8602aee3e853802e6aa4759fd043a3 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Wed, 15 Jul 2015 08:43:39 -0600 Subject: [PATCH 0103/1724] Adding correct default values for config_init_configuration This commit updates the ocean's registry file to ensure correct values are set for the config_init_configuration namelist option for each configuration's default namelist file. --- src/core_ocean/Registry.xml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 24fdf28528..78ba5a44ea 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -140,6 +140,14 @@ Date: Wed, 15 Jul 2015 11:53:52 -0600 Subject: [PATCH 0104/1724] Update build_options.mk for use in standalone or ACME --- src/core_landice/build_options.mk | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/core_landice/build_options.mk b/src/core_landice/build_options.mk index ccccacd5dc..8e39817813 100644 --- a/src/core_landice/build_options.mk +++ b/src/core_landice/build_options.mk @@ -1,6 +1,9 @@ -PWD=$(shell pwd) +ifeq "$(ROOT_DIR)" "" + ROOT_DIR=$(shell pwd)/src +endif EXE_NAME=landice_model NAMELIST_SUFFIX=landice +FCINCLUDES += -I$(ROOT_DIR)/core_landice override CPPFLAGS += -DCORE_LANDICE report_builds: From 3e01ae77b0ba5f741164c217840b5397d8bae2af Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Wed, 15 Jul 2015 12:52:18 -0600 Subject: [PATCH 0105/1724] diagnosing elements of eke instead of eke itself. This way, eke can be constructed with this output, but also can the EPFT. --- .../Registry_eliassen_palm.xml | 40 ++++- .../analysis_members/mpas_ocn_eliassen_palm.F | 156 +++++++++++++++++- 2 files changed, 192 insertions(+), 4 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index f1f48bc233..d346fd37d1 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -484,13 +484,13 @@ type="real" dimensions="nBuoyancyLayers nCells Time" units="s^{-1}" - description="Derivative of thickness weighted zonal velocity with respect to z." + description="Derivative of thickness weighted zonal velocity with respect to z (vertical coordinate)." /> @@ -501,6 +501,42 @@ units="m^2 s^{-2}" description="Eliassen-Palm flux tensor" /> + + + + + + \brief MPAS ocean analysis core member: epft +!> \brief MPAS ocean analysis core member: Eliassen-Palm Flux Tensor !> \author Juan A. Saenz, Todd Ringler !> \date May 2015 !> \details @@ -458,6 +458,12 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ real(KIND=RKIND), dimension(:,:), pointer :: divEPFTshear2 real(KIND=RKIND), dimension(:,:), pointer :: divEPFTdrag1 real(KIND=RKIND), dimension(:,:), pointer :: divEPFTdrag2 + real(KIND=RKIND), dimension(:,:), pointer :: uuTWACorr + real(KIND=RKIND), dimension(:,:), pointer :: vvTWACorr + real(KIND=RKIND), dimension(:,:), pointer :: uvTWACorr + real(KIND=RKIND), dimension(:,:), pointer :: epeTWA + real(KIND=RKIND), dimension(:,:), pointer :: eddyFormDragZonal + real(KIND=RKIND), dimension(:,:), pointer :: eddyFormDragMerid !----------------------------------------------------------------- ! define scratch fields used as work variables and for testing @@ -842,6 +848,13 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ call mpas_pool_get_array(am_epftPool, 'divEPFTshear2', divEPFTshear2) call mpas_pool_get_array(am_epftPool, 'divEPFTdrag1', divEPFTdrag1) call mpas_pool_get_array(am_epftPool, 'divEPFTdrag2', divEPFTdrag2) + call mpas_pool_get_array(am_epftPool, 'uuTWACorr', uuTWACorr) + call mpas_pool_get_array(am_epftPool, 'vvTWACorr', vvTWACorr) + call mpas_pool_get_array(am_epftPool, 'uvTWACorr', uvTWACorr) + call mpas_pool_get_array(am_epftPool, 'epeTWA', epeTWA) + call mpas_pool_get_array(am_epftPool, 'eddyFormDragZonal', eddyFormDragZonal) + call mpas_pool_get_array(am_epftPool, 'eddyFormDragMerid', eddyFormDragMerid) + call mpas_pool_get_array(am_epftPool, 'ErtelPVFlux' , ErtelPVFlux) call mpas_pool_get_array(am_epftPool, 'ErtelPVFlux1', ErtelPVFlux1) call mpas_pool_get_array(am_epftPool, 'ErtelPVFlux2', ErtelPVFlux2) @@ -1171,6 +1184,22 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ heightMidBuoyCoorSqEA, montgPotGradZonalEA, montgPotGradMeridEA, & heightMGradZonalEA, heightMGradMeridEA, uTWA, vTWA, varpiTWA, & uusigmaEA, vvsigmaEA, uvsigmaEA, uvarpisigmaEA, vvarpisigmaEA, EPFT) + + !------------------------------------------------------------- + ! Calculate eddy correlations + !------------------------------------------------------------- + call calculateCorrelationfromTWA(nBuoyancyLayers, nCells, & + sigmaEA, uTWA, uTWA, uuSigmaEA, uuTWACorr) + call calculateCorrelationfromTWA(nBuoyancyLayers, nCells, & + sigmaEA, vTWA, vTWA, vvSigmaEA, vvTWACorr) + call calculateCorrelationfromTWA(nBuoyancyLayers, nCells, & + sigmaEA, uTWA, vTWA, uvSigmaEA, uvTWACorr) + call calculateEPEfromTWA(nBuoyancyLayers, nCells, & + sigmaEA, heightMidBuoyCoorEA, heightMidBuoyCoorSqEA, epeTWA) + call calculateEddyFormDragFromTWA(nBuoyancyLayers, nCells, sigmaEA, & + heightMidBuoyCoorEA, montgPotGradZonalEA, heightMGradZonalEA, eddyFormDragZonal) + call calculateEddyFormDragFromTWA(nBuoyancyLayers, nCells, sigmaEA, & + heightMidBuoyCoorEA, montgPotGradMeridEA, heightMGradMeridEA, eddyFormDragMerid) !------------------------------------------------------------- ! compute the total force from the EPFT: div(EPFT) @@ -2174,6 +2203,129 @@ subroutine calculateEPFTfromTWA(nLayers, nCells, & end subroutine calculateEPFTfromTWA!}}} +!*********************************************************************** +! +! subroutine calculateCorrelationfromTWA +! +!> \brief Calculate the eddy correlation from TWAs +!> \author Juan A. Saenz +!> \date July 2015 +!> \details +!> This subroutine calculates the eddy kinetic energy from thickness +!> weighted averages. +!----------------------------------------------------------------------- + + subroutine calculateCorrelationfromTWA(nLayers, nCells, & + sigmaEA, uTWA, vTWA, uvSigmaEA, uvCorr)!{{{ + implicit none + integer, intent(in) :: nLayers, nCells + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: sigmaEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: uTWA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: vTWA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: uvSigmaEA + real (kind=RKIND), dimension(nLayers, nCells), intent(out) :: uvCorr + + ! local variables + integer :: iCell, kLayer + real (kind=RKIND) :: sigma + real (kind=RKIND) :: uppupp, vppvpp + + uvCorr = 0.0 ! jas issue: assign a mask value instead + + do iCell = 1, nCells + do kLayer = 1,nLayers + sigma = max(sigmaEA(kLayer,iCell), epsilonEPFT) + uvCorr(kLayer, iCell) = uvSigmaEA(kLayer,iCell) / sigma - uTWA(kLayer,iCell)*vTWA(kLayer,iCell) + enddo + enddo + + end subroutine calculateCorrelationfromTWA!}}} + + +!*********************************************************************** +! +! subroutine calculateEPEfromTWA +! +!> \brief Calculate the eddy potential energy from TWAs +!> \author Juan A. Saenz +!> \date July 2015 +!> \details +!> This subroutine calculates the eddy potential energy from thickness +!> weighted averages. +!----------------------------------------------------------------------- + + subroutine calculateEPEfromTWA(nLayers, nCells, & + sigmaEA, heightEA, heightSqEA, epe)!{{{ + implicit none + integer, intent(in) :: nLayers, nCells + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: sigmaEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: heightEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: heightSqEA + real (kind=RKIND), dimension(nLayers, nCells), intent(out) :: epe + + ! local variables + integer :: iCell, kLayer + real (kind=RKIND) :: sigma + real (kind=RKIND) :: HpHp + + epe = 0.0 + + do iCell = 1, nCells + do kLayer = 1,nLayers + + sigma = max(sigmaEA(kLayer,iCell), epsilonEPFT) + HpHp = heightSqEA(kLayer,iCell) - heightEA(kLayer,iCell)*heightEA(kLayer,iCell) + + epe(kLayer,iCell) = 0.5 * HpHp / sigma + + enddo + enddo + + end subroutine calculateEPEfromTWA!}}} + + +!*********************************************************************** +! +! subroutine calculateEddyFormDragfromTWA +! +!> \brief Calculate the eddy form drag from TWAs +!> \author Juan A. Saenz +!> \date July 2015 +!> \details +!> This subroutine calculates the eddy form drag from thickness +!> weighted averages. +!----------------------------------------------------------------------- + + subroutine calculateEddyFormDragfromTWA(nLayers, nCells, & + sigmaEA, heightEA, MxEA, HMxEA, formDragX)!{{{ + implicit none + integer, intent(in) :: nLayers, nCells + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: sigmaEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: heightEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: MxEA + real (kind=RKIND), dimension(nLayers, nCells), intent(in) :: HMxEA + real (kind=RKIND), dimension(nLayers, nCells), intent(out) :: formDragX + + ! local variables + integer :: iCell, kLayer + real (kind=RKIND) :: sigma + real (kind=RKIND) :: HpMxp + + formDragX = 0.0 + + do iCell = 1, nCells + do kLayer = 1,nLayers + + sigma = max(sigmaEA(kLayer,iCell), epsilonEPFT) + HpMxp = HMxEA(kLayer,iCell) - heightEA(kLayer,iCell) * MxEA(kLayer,iCell) + + formDragX(kLayer,iCell) = HpMxp / sigma + enddo + enddo + + end subroutine calculateEddyFormDragfromTWA!}}} + + !*********************************************************************** ! ! subroutine calculateDivEPFT From 00d098d82871770c88dda5832dc8169189c2c5ed Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Wed, 15 Jul 2015 15:24:00 -0600 Subject: [PATCH 0106/1724] changed name of fluctuating velocity correlations --- src/core_ocean/analysis_members/Registry_eliassen_palm.xml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index d346fd37d1..e8b5ac40ab 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -501,19 +501,19 @@ units="m^2 s^{-2}" description="Eliassen-Palm flux tensor" /> - - - Date: Thu, 16 Jul 2015 12:29:03 -0600 Subject: [PATCH 0107/1724] removed config_eliassen_palm_reset --- .../analysis_members/Registry_eliassen_palm.xml | 7 ------- src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F | 8 +++----- 2 files changed, 3 insertions(+), 12 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index e8b5ac40ab..1033ad50b7 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -13,13 +13,6 @@ description="If true, all EPfT fields are initialized using a restart file" possible_values=".true. or .false." /> - Date: Thu, 16 Jul 2015 14:36:08 -0600 Subject: [PATCH 0108/1724] added restart capability for eliassen_palm AM doing this temporarily inside src/core_ocean/mode_forward/mpas_ocn_forward_mode.F --- src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F | 2 +- src/core_ocean/mode_forward/mpas_ocn_forward_mode.F | 9 +++++++++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index f549a880f8..15ad9ad61d 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -216,7 +216,7 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ config_eliassen_palm_rhomin_buoycoor) call mpas_pool_get_config(domain % configs, 'config_density0', config_density0) - + block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'amEliassenPalm', amEPFTPool) diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index 0af74aaa75..396c9afefe 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -112,6 +112,7 @@ subroutine ocn_forward_mode_init(domain, stream_manager, startTimeStamp)!{{{ type (MPAS_Time_Type) :: startTime type (MPAS_TimeInterval_type) :: timeStep + logical, pointer :: config_eliassen_palm_do_restart logical, pointer :: config_do_restart, config_filter_btr_mode, config_conduct_tests logical, pointer :: config_write_stats_on_startup character (len=StrKIND), pointer :: config_vert_coord_movement, config_pressure_gradient_type @@ -137,6 +138,7 @@ subroutine ocn_forward_mode_init(domain, stream_manager, startTimeStamp)!{{{ dminfo = domain % dminfo call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) + call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_do_restart', config_eliassen_palm_do_restart) call mpas_pool_get_config(domain % configs, 'config_vert_coord_movement', config_vert_coord_movement) call mpas_pool_get_config(domain % configs, 'config_pressure_gradient_type', config_pressure_gradient_type) call mpas_pool_get_config(domain % configs, 'config_filter_btr_mode', config_filter_btr_mode) @@ -147,6 +149,13 @@ subroutine ocn_forward_mode_init(domain, stream_manager, startTimeStamp)!{{{ ! ! Read input data for model ! + + ! Read in a restart file for the eliassen_palm analysis member + if ( config_eliassen_palm_do_restart ) then + call mpas_timer_start('io_read', .false.) + call MPAS_stream_mgr_read(stream_manager, streamID='eliassenPalmRestart', ierr=err) + call mpas_timer_stop('io_read') + end if if ( config_do_restart ) then call mpas_timer_start('io_read', .false.) call MPAS_stream_mgr_read(stream_manager, streamID='restart', ierr=err) From 37b54dada153bd22a1a301c314bee404f768991a Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 16 Jul 2015 15:38:11 -0600 Subject: [PATCH 0109/1724] Shorten long lines in mpas_li_velocity.F A handful of lines are too long for PGI - this fixes that. --- src/core_landice/mpas_li_velocity.F | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mpas_li_velocity.F index 6ddca7a1ab..ef6abb8f98 100644 --- a/src/core_landice/mpas_li_velocity.F +++ b/src/core_landice/mpas_li_velocity.F @@ -399,7 +399,10 @@ subroutine li_velocity_solve(domain, err) if ( (li_mask_is_dynamic_ice(cellMask(cell3))) .and. & (li_mask_is_dynamic_ice(cellMask(cell4))) ) then if (config_print_velocity_cleanup_details) then - write (stderrUnit,*) "Notice: External velocity solver returned a nonzero normalVelocity on a non-dynamic edge, but this is ok because the location is in a non-dynamic 'inlet'. normalVelocity has been set to 0 at this location. Location is edge index:", indexToEdgeID(iEdge) + write (stderrUnit,*) "Notice: External velocity solver returned a nonzero normalVelocity on a non-dynamic " & + // "edge, but this is ok because the location is in a non-dynamic 'inlet'. " & + // "normalVelocity has been set to 0 at this location. Location is edge " & + // "index:", indexToEdgeID(iEdge) endif normalVelocity(:,iEdge) = 0.0_RKIND inletEdgesFixed = inletEdgesFixed + 1 @@ -448,10 +451,14 @@ subroutine li_velocity_solve(domain, err) end do if (inletEdgesFixed > 0) then - write (stderrUnit,*) "Notice: External velocity solver returned a nonzero normalVelocity on non-dynamic edge(s), but this is ok because the location is in a non-dynamic 'inlet'. normalVelocity has been set to 0 at these location(s). Number of edges affected on this processor:", inletEdgesFixed + write (stderrUnit,*) "Notice: External velocity solver returned a nonzero normalVelocity on non-dynamic edge(s), but " & + // "this is ok because the location is in a non-dynamic 'inlet'. normalVelocity has been set to 0 " & + // "at these location(s). Number of edges affected on this processor:", inletEdgesFixed endif if (uphillMarginEdgesFixed > 0) then - write (stderrUnit,*) "Notice: Nonzero velocity has been calculated on 'uphill' margin edge(s). normalVelocity has been set to 0 at these location(s). Number of edges affected on this processor:", uphillMarginEdgesFixed + write (stderrUnit,*) "Notice: Nonzero velocity has been calculated on 'uphill' margin edge(s). normalVelocity has " & + // "been set to 0 at these location(s). Number of edges affected on this processor:", & + uphillMarginEdgesFixed endif ! --- From cac6665ec6643eb7562990f9d66a4593670bedab Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Wed, 4 Mar 2015 16:05:26 -0700 Subject: [PATCH 0110/1724] Time averaging analysis member. This is a new analysis member that does time reductions (averages, mins, and maxes) over any arbitrary field in the Registry. The temporal windows for reduction are in the name list: accumulation duration, when to start accumulation, when to reset accumulation buffers, and when to repeat accumulation. (It supports many different modes, such as daily, monthly, yearly, seasonally, climatology, etc. through time window configuration.) The fields to be "averaged" are listed in the stream, and the analysis member will modify the stream to produce averaged versions of those fields. It is mostly feature complete, and there are three additions to be made before it can be merged into ocean/develop: 1. restart capability (don't know how to do this yet) 2. ability to add the mesh to the stream (add_stream_fields didn't seem to work correctly for me, needs help.) 3. replication of the analysis member to allow for more than one stream (originally, the analysis member allowed for multiple stream, but the way the analysis member driver is written, I had to revert the analysis member to supporting only one stream. This means we need to duplicate the analysis member (macros? cut-and-paste?) a few times.) --- src/core_ocean/analysis_members/Makefile | 3 +- .../Registry_analysis_members.xml | 1 + .../Registry_time_averages.xml | 122 ++ .../mpas_ocn_analysis_driver.F | 26 +- .../analysis_members/mpas_ocn_time_averages.F | 1074 +++++++++++++++++ 5 files changed, 1217 insertions(+), 9 deletions(-) create mode 100644 src/core_ocean/analysis_members/Registry_time_averages.xml create mode 100644 src/core_ocean/analysis_members/mpas_ocn_time_averages.F diff --git a/src/core_ocean/analysis_members/Makefile b/src/core_ocean/analysis_members/Makefile index 1b6097cabb..85cbee0ca5 100644 --- a/src/core_ocean/analysis_members/Makefile +++ b/src/core_ocean/analysis_members/Makefile @@ -10,7 +10,8 @@ MEMBERS = mpas_ocn_global_stats.o \ mpas_ocn_meridional_heat_transport.o \ mpas_ocn_test_compute_interval.o \ mpas_ocn_high_frequency_output.o \ - mpas_ocn_zonal_mean.o + mpas_ocn_zonal_mean.o \ + mpas_ocn_time_averages.o all: $(OBJS) diff --git a/src/core_ocean/analysis_members/Registry_analysis_members.xml b/src/core_ocean/analysis_members/Registry_analysis_members.xml index 8359f533a9..11f7d79cd8 100644 --- a/src/core_ocean/analysis_members/Registry_analysis_members.xml +++ b/src/core_ocean/analysis_members/Registry_analysis_members.xml @@ -7,3 +7,4 @@ #include "Registry_meridional_heat_transport.xml" #include "Registry_test_compute_interval.xml" #include "Registry_high_frequency_output.xml" +#include "Registry_time_averages.xml" diff --git a/src/core_ocean/analysis_members/Registry_time_averages.xml b/src/core_ocean/analysis_members/Registry_time_averages.xml new file mode 100644 index 0000000000..0d39370c77 --- /dev/null +++ b/src/core_ocean/analysis_members/Registry_time_averages.xml @@ -0,0 +1,122 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F index 5503c7144d..57f6cb6fa5 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -35,6 +35,7 @@ module ocn_analysis_driver use ocn_meridional_heat_transport use ocn_test_compute_interval use ocn_high_frequency_output + use ocn_time_averages ! use ocn_TEM_PLATE implicit none @@ -145,6 +146,7 @@ subroutine ocn_analysis_setup_packages(configPool, packagePool, err)!{{{ call mpas_pool_add_config(analysisMemberList, 'waterMassCensus', 1) call mpas_pool_add_config(analysisMemberList, 'zonalMean', 1) call mpas_pool_add_config(analysisMemberList, 'highFrequencyOutput', 1) + call mpas_pool_add_config(analysisMemberList, 'timeAverages', 1) ! call mpas_pool_add_config(analysisMemberList, 'temPlate', 1) ! DON'T EDIT BELOW HERE @@ -738,8 +740,10 @@ subroutine ocn_init_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_init_water_mass_census(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'zonalMean' ) then call ocn_init_zonal_mean(domain, err_tmp) - else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then - call ocn_init_high_frequency_output(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then + call ocn_init_high_frequency_output(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'timeAverages' ) then + call ocn_init_time_averages(domain, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_init_TEM_PLATE(domain, err_tmp) end if @@ -787,8 +791,10 @@ subroutine ocn_compute_analysis_members(domain, timeLevel, analysisMemberName, i call ocn_compute_water_mass_census(domain, timeLevel, err_tmp) else if ( analysisMemberName(1:nameLength) == 'zonalMean' ) then call ocn_compute_zonal_mean(domain, timeLevel, err_tmp) - else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then - call ocn_compute_high_frequency_output(domain, timeLevel, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then + call ocn_compute_high_frequency_output(domain, timeLevel, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'timeAverages' ) then + call ocn_compute_time_averages(domain, timeLevel, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_compute_TEM_PLATE(domain, timeLevel, err_tmp) end if @@ -835,8 +841,10 @@ subroutine ocn_restart_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_restart_water_mass_census(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'zonalMean' ) then call ocn_restart_zonal_mean(domain, err_tmp) - else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then - call ocn_restart_high_frequency_output(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then + call ocn_restart_high_frequency_output(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'timeAverages' ) then + call ocn_restart_time_averages(domain, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_restart_TEM_PLATE(domain, err_tmp) end if @@ -883,8 +891,10 @@ subroutine ocn_finalize_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_finalize_water_mass_census(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'zonalMean' ) then call ocn_finalize_zonal_mean(domain, err_tmp) - else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then - call ocn_finalize_high_frequency_output(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then + call ocn_finalize_high_frequency_output(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'timeAverages' ) then + call ocn_finalize_time_averages(domain, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_finalize_TEM_PLATE(domain, err_tmp) end if diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_averages.F b/src/core_ocean/analysis_members/mpas_ocn_time_averages.F new file mode 100644 index 0000000000..36d448beb0 --- /dev/null +++ b/src/core_ocean/analysis_members/mpas_ocn_time_averages.F @@ -0,0 +1,1074 @@ +! Copyright (c) 2015, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! ocn_time_averages +! +!> \brief MPAS ocean analysis core member: time_averages +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> Flexible time averaging, mins, and maxes of fields. +!----------------------------------------------------------------------- +module ocn_time_averages + use mpas_derived_types + use mpas_pool_routines + use mpas_dmpar + use mpas_timekeeping + use mpas_stream_manager + + use ocn_constants + use ocn_diagnostics_routines + + implicit none + private + save + + ! Public parameters + !-------------------------------------------------------------------- + + ! Public member functions + !-------------------------------------------------------------------- + public :: ocn_init_time_averages, & + ocn_compute_time_averages, & + ocn_restart_time_averages, & + ocn_finalize_time_averages + + ! Private module variables + !-------------------------------------------------------------------- + + ! startup, interval, and restart is done in the outer analysis driver + + ! time buffer type + ! this keeps track of timers and if and when they need to accumulate + type time_buffer_type + ! internal state + logical :: started_flag, accumulate_flag, reset_flag + integer :: total_accum + + type (MPAS_Time_type) :: start_time + type (MPAS_TimeInterval_type) :: duration_interval + type (MPAS_TimeInterval_type) :: repeat_interval + type (MPAS_TimeInterval_type) :: reset_interval + + ! alarm IDs + character (len=StrKIND) :: start_alarm_ID + character (len=StrKIND) :: repeat_alarm_ID + character (len=StrKIND) :: duration_alarm_ID + character (len=StrKIND) :: reset_alarm_ID + end type time_buffer_type + + ! time variable type + ! this keeps track of arrays, array types, and names + type time_variable_type + type (mpas_pool_field_info_type) :: info + character (len=StrKIND) :: input_name + ! either you have to put a number of buffers per variable + ! or put the output variables in the buffers (I decided to put it here) + character (len=StrKIND), dimension(:), allocatable :: output_names + end type time_variable_type + + ! operation + integer :: operation + + ! stream name + character (len=StrKIND), pointer :: stream_name + + ! information per variable + type (time_variable_type), dimension(:), allocatable :: variables + + ! information per buffer + type (time_buffer_type), dimension(:), allocatable :: buffers + + ! enum of ops and types + integer, parameter :: AVG_OP = 1 + integer, parameter :: MIN_OP = 2 + integer, parameter :: MAX_OP = 3 + + integer, parameter :: START_TIMES = 5 + integer, parameter :: DURATION_INTERVALS = 6 + integer, parameter :: REPEAT_INTERVALS = 7 + integer, parameter :: RESET_INTERVALS = 8 + +!*********************************************************************** +contains + + + +!*********************************************************************** +! routine walk_string +! +!> \brief Walk a space delimited string to find substrings +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> Walk a string delimited by spaces and return the first substring +!> from start index, and modify start to point at the next candidate. +!----------------------------------------------------------------------- + subroutine walk_string(next, substr, ok)!{{{ + ! input variables + !----------------------------------------------------------------- + + ! input/output variables + !----------------------------------------------------------------- + character (len=StrKIND), intent(inout) :: next + + ! output variables + !----------------------------------------------------------------- + character (len=StrKIND), intent(out) :: substr + logical, intent(out) :: ok + + ! local variables + !----------------------------------------------------------------- + integer :: i + character (len=StrKIND) :: copy + + ! find the first substring that isn't whitespace + i = verify(next, ' ') + ok = i > 0 + ! if we can't find one, stop + if (.not. ok) then + return + end if + + ! make a new string and find the first whitespace + copy = next(i:) + i = scan(copy, ' ') + + ! return that substring and the remainder + substr = copy(1:i-1) + next = copy(i:) + + end subroutine walk_string!}}} + +!*********************************************************************** +! routine set_times +! +!> \brief Set a list of times +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> Walk a list of times delimited by spaces and set the time info +!> for the buffer structure so that alarms can be set. +!----------------------------------------------------------------------- + subroutine set_times(buffers, number_of_buffers, clock, & + which, config_str, inv_str, ok, err) + ! input variables + !----------------------------------------------------------------- + integer, intent(in) :: number_of_buffers, which + character (len=StrKIND), pointer, intent(in) :: config_str + character (len=StrKIND), intent(in) :: inv_str + + ! input/output variables + !----------------------------------------------------------------- + type (time_buffer_type), dimension(:), intent(inout) :: buffers + type (MPAS_Clock_type), intent(inout) :: clock + + ! output variables + !----------------------------------------------------------------- + logical, intent(out) :: ok + integer, intent(out) :: err + + ! local variables + !----------------------------------------------------------------- + character (len=StrKIND) :: next_str, time_str + integer :: b + + ! find the first time in the list + next_str = config_str + b = 1 + call walk_string(next_str, time_str, ok) + ! while the time string is ok + do while (ok) + ! exit if we went over + if (b .gt. number_of_buffers) then + exit + end if + + ! set the time + if (which .eq. START_TIMES) then + if (time_str .eq. 'same_as_simulation') then + buffers(b) % start_time = mpas_get_clock_time(clock, & + MPAS_NOW, err) + else + call mpas_set_time(buffers(b) % start_time, & + dateTimeString=time_str, ierr=err) + end if + else if (which .eq. DURATION_INTERVALS) then + if (time_str .eq. 'same_as_repeat') then + buffers(b) % duration_interval = buffers(b) % repeat_interval + else + call mpas_set_timeInterval(buffers(b) % duration_interval, & + timeString=time_str, ierr=err) + end if + else if (which .eq. REPEAT_INTERVALS) then + if (time_str .eq. 'same_as_reset') then + buffers(b) % repeat_interval = buffers(b) % reset_interval + else + call mpas_set_timeInterval(buffers(b) % repeat_interval, & + timeString=time_str, ierr=err) + end if + else + if (time_str .eq. 'same_as_output') then + call mpas_set_timeInterval(buffers(b) % reset_interval, & + timeString=inv_str, ierr=err) + else + call mpas_set_timeInterval(buffers(b) % reset_interval, & + timeString=time_str, ierr=err) + end if + end if + ! get the next time string + b = b + 1 + call walk_string(next_str, time_str, ok) + end do + + ! only ok if we parsed out as many as there are number of buffers + ok = number_of_buffers .eq. (b - 1) + end subroutine set_times + + + +!*********************************************************************** +! routine add_new_field +! +!> \brief Function to create a new field from an existing field +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> This routine conducts all initializations required for +!> duplicating a field and adding it to the allFields pool. +!----------------------------------------------------------------------- + subroutine add_new_field(info, inname, prefix, pool)!{{{ + ! input variables + !----------------------------------------------------------------- + type (mpas_pool_field_info_type), intent(in) :: info + character (len=StrKIND), intent(in) :: inname, prefix + + ! input/output variables + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: pool + + ! output variables + !----------------------------------------------------------------- + + ! local variables + !----------------------------------------------------------------- + type (field0DReal), pointer :: r0i, or0 + type (field1DReal), pointer :: r1i, or1 + type (field2DReal), pointer :: r2i, or2 + type (field3DReal), pointer :: r3i, or3 + type (field4DReal), pointer :: r4i, or4 + type (field5DReal), pointer :: r5i, or5 + type (field0DInteger), pointer :: i0i, oi0 + type (field1DInteger), pointer :: i1i, oi1 + type (field2DInteger), pointer :: i2i, oi2 + type (field3DInteger), pointer :: i3i, oi3 + integer :: i + + ! start procedure + !----------------------------------------------------------------- + +! macro +#define COPY_FIELDS(SRC, DST) \ +call mpas_pool_get_field(pool, inname, SRC, 1) ;\ +call mpas_duplicate_field(SRC, DST) ;\ +DST % fieldName = trim(prefix) // DST % fieldName ;\ +if (DST % isVarArray) then ;\ + do i = 1, size(DST % constituentNames) ;\ + DST % constituentNames(i) = trim(prefix) // \ + DST % constituentNames(i) ;\ + end do ;\ +end if ;\ +call mpas_pool_add_field(pool, DST % fieldName, DST) +! end macro + + ! duplicate field and add new field to pool + if (info % fieldType .eq. MPAS_POOL_REAL) then + if (info % nDims .eq. 0) then + COPY_FIELDS(r0i, or0) + else if (info % nDims .eq. 1) then + COPY_FIELDS(r1i, or1) + else if (info % nDims .eq. 2) then + COPY_FIELDS(r2i, or2) + else if (info % nDims .eq. 3) then + COPY_FIELDS(r3i, or3) + else if (info % nDims .eq. 4) then + COPY_FIELDS(r4i, or4) + else + COPY_FIELDS(r5i, or5) + end if + else + if (info % nDims .eq. 0) then + COPY_FIELDS(i0i, oi0) + else if (info % nDims .eq. 1) then + COPY_FIELDS(i1i, oi1) + else if (info % nDims .eq. 2) then + COPY_FIELDS(i2i, oi2) + else + COPY_FIELDS(i3i, oi3) + end if + end if + + end subroutine add_new_field!}}} + +#undef COPY_FIELDS + + + +!*********************************************************************** +! routine ocn_init_time_averages +! +!> \brief Initialize MPAS-Ocean analysis member +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> This routine conducts all initializations required for the +!> MPAS-Ocean analysis member. +!----------------------------------------------------------------------- + subroutine ocn_init_time_averages(domain, err)!{{{ + + ! input variables + !----------------------------------------------------------------- + + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain + + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + ! local variables + !----------------------------------------------------------------- + integer :: v, b + character (len=StrKIND), pointer :: config_results + integer, pointer :: number_of_buffers + integer :: number_of_variables + character (len=StrKIND) :: stream_str, prefix_str, & + config_str, buffer_str, op_str, var_str, field, inv_time + logical :: ok + + ! start procedure + !----------------------------------------------------------------- + err = 0 + + ! string representation + ! TODO placeholder for some unique ID if this code is replicated + ! per multiple AMs for multiple streams + stream_str = '' + prefix_str = 'config_AM_timeAverages' // trim(stream_str) + + ! get our operation + config_str = trim(prefix_str) // '_operation' + call mpas_pool_get_config(domain % configs, config_str, config_results) + if (config_results .eq. 'avg') then + operation = AVG_OP + op_str = 'avg' + else if (config_results .eq. 'min') then + operation = MIN_OP + op_str = 'min' + else if (config_results .eq. 'max') then + operation = MAX_OP + op_str = 'max' + else + ! error if unknown operation + call mpas_dmpar_global_abort('Error: unknown operation in time averaging analysis member configuration.') + end if + + ! get the number of individual buffers and set up timers + config_str = trim(prefix_str) // '_number_of_buffers' + call mpas_pool_get_config(domain % configs, config_str, number_of_buffers) + + ! assert number_of_buffers > 0 + if (number_of_buffers .lt. 1) then + call mpas_dmpar_global_abort('Error: number of buffers < 0 in time averaging analysis member configuration.') + end if + + ! get the stream name + config_str = trim(prefix_str) // '_stream_name' + call mpas_pool_get_config(domain % configs, config_str, stream_name) + + if (stream_name .eq. 'none') then + call mpas_dmpar_global_abort('Error: stream cannot be "none" for time averages.') + end if + + ! set up all of the timing + ! + ! order matters, don't reorder these! + ! it matters because times/intervals can be configured to be equal + + ! allocate the state for the buffers + allocate(buffers(number_of_buffers)) + + ! get the interval time + call mpas_stream_mgr_get_property(domain % streamManager, & + stream_name, MPAS_STREAM_PROPERTY_FILENAME_INTV, & + inv_time, err) + + ! configure reset intervals + config_str = trim(prefix_str) // '_reset_intervals' + call mpas_pool_get_config(domain % configs, config_str, config_results) + call set_times(buffers, number_of_buffers, domain % clock, & + RESET_INTERVALS, config_results, inv_time, ok, err) + if (.not. ok) then + call mpas_dmpar_global_abort('Error: number_of_buffers != number of reset_intervals in time averaging member analysis member configuration.') + end if + + ! configure repeat intervals + config_str = trim(prefix_str) // '_repeat_intervals' + call mpas_pool_get_config(domain % configs, config_str, config_results) + call set_times(buffers, number_of_buffers, domain % clock, & + REPEAT_INTERVALS, config_results, inv_time, ok, err) + if (.not. ok) then + call mpas_dmpar_global_abort('Error: number_of_buffers != number of repeat_intervals in time averaging member analysis member configuration.') + end if + + ! configure duration intervals + config_str = trim(prefix_str) // '_duration_intervals' + call mpas_pool_get_config(domain % configs, config_str, config_results) + call set_times(buffers, number_of_buffers, domain % clock, & + DURATION_INTERVALS, config_results, inv_time, ok, err) + if (.not. ok) then + call mpas_dmpar_global_abort('Error: number_of_buffers != number of duration_intervals in time averaging member analysis member configuration.') + end if + + ! configure start times + config_str = trim(prefix_str) // '_initial_times' + call mpas_pool_get_config(domain % configs, config_str, config_results) + call set_times(buffers, number_of_buffers, domain % clock, & + START_TIMES, config_results, inv_time, ok, err) + if (.not. ok) then + call mpas_dmpar_global_abort('Error: number_of_buffers != number of initial_times in time averaging member analysis member configuration.') + end if + + ! check if the configuration is sensible + do b = 1, number_of_buffers + if (buffers(b) % repeat_interval .gt. & + buffers(b) % reset_interval) then + write(stderrUnit,*) 'Warning: repeat_interval > reset_interval in time averaging analysis member configuration. Truncating repeat_interval.' + buffers(b) % repeat_interval = buffers(b) % reset_interval + end if + + if (buffers(b) % duration_interval .gt. & + buffers(b) % repeat_interval) then + write(stderrUnit,*) 'Warning: duration_interval > repeat_interval in time averaging analysis member configuration. Truncating duration_interval.' + buffers(b) % repeat_interval = buffers(b) % reset_interval + end if + end do + + ! + ! OK, if we got this far, then we should be able to allocate memory + ! and set up the timers and variables that we will average + ! + + ! count the number of variables + call mpas_stream_mgr_begin_iteration(domain % streamManager, & + stream_name, err) + number_of_variables = 0 + do while (mpas_stream_mgr_get_next_field(domain % streamManager, & + stream_name, field)) + number_of_variables = number_of_variables + 1 + end do + + ! allocate the variable information + allocate(variables(number_of_variables)) + + ! get the old field names + call mpas_stream_mgr_begin_iteration(domain % streamManager, & + stream_name, err) + v = 1 + do while (mpas_stream_mgr_get_next_field(domain % streamManager, & + stream_name, field)) + variables(v) % input_name = field + v = v + 1 + end do + + ! remove the old ones from the stream + do v = 1, number_of_variables + call mpas_stream_mgr_remove_field(domain % streamManager, & + stream_name, variables(v) % input_name) + end do + + ! add xtime to the stream + call mpas_stream_mgr_add_field(domain % streamManager, & + stream_name, 'xtime', ierr=err) + + ! + ! TODO How to add mesh to stream? + ! + !! optionally add mesh to stream + !call mpas_pool_get_config(domain % configs, & + ! 'config_time_averages_copy_mesh', copy_mesh) + !if (copy_mesh) then + ! call mpas_stream_mgr_add_stream_fields(manager, stream_name, & + ! 'mesh', err) + !end if + + ! set up the variables + call mpas_stream_mgr_begin_iteration(domain % streamManager, & + stream_name, err) + do v = 1, number_of_variables + ! allocate space for the names of the outputs + allocate(variables(v) % output_names(number_of_buffers)) + write(var_str, '(I0)') v + + ! get the info of the field + call mpas_pool_get_field_info(domain % blocklist % allFields, & + variables(v) % input_name, variables(v) % info) + + ! check if we can handle it + if(.not. & + ((variables(v) % info % fieldType .eq. MPAS_POOL_REAL) & + .or. & + (variables(v) % info % fieldType .eq. MPAS_POOL_INTEGER))) & + then + call mpas_dmpar_global_abort('Error: a field listed in the output stream is not real or integer in time averaging analysis member configuration.') + end if + + ! allocate a number of fields and add field + do b = 1, number_of_buffers + ! create the name of the new field + write(buffer_str, '(I0)') b + field = 'time' // trim(stream_str) // '_' // & + trim(op_str) // '_' // trim(buffer_str) // '_' + variables(v) % output_names(b) = trim(field) // & + variables(v) % input_name + + ! create the field and add to pool + call add_new_field(variables(v) % info, & + variables(v) % input_name, field, & + domain % blocklist % allFields) + + ! add the field to the stream + call mpas_stream_mgr_add_field(domain % streamManager, & + stream_name, variables(v) % output_names(b), ierr=err) + end do + + end do ! number_of_variables + + ! configure alarms + do b = 1, number_of_buffers + write(buffer_str, '(I0)') b + buffers(b) % start_alarm_ID = & + 'tavg_start' // trim(stream_str) // '_' // buffer_str + call mpas_add_clock_alarm(domain % clock, & + buffers(b) % start_alarm_ID, & + buffers(b) % start_time, ierr=err) + + buffers(b) % repeat_alarm_ID = & + 'tavg_repeat' // trim(stream_str) // '_' // buffer_str + call mpas_add_clock_alarm(domain % clock, & + buffers(b) % repeat_alarm_ID, & + buffers(b) % start_time, & + buffers(b) % repeat_interval, ierr=err) + + buffers(b) % duration_alarm_ID = & + 'tavg_duration' // trim(stream_str) // '_' // buffer_str + call mpas_add_clock_alarm(domain % clock, & + buffers(b) % duration_alarm_ID, & + buffers(b) % start_time + & + buffers(b) % duration_interval, & + buffers(b) % repeat_interval, ierr=err) + + buffers(b) % reset_alarm_ID = & + 'tavg_reset' // trim(stream_str) // '_' // buffer_str + call mpas_add_clock_alarm(domain % clock, & + buffers(b) % reset_alarm_ID, & + buffers(b) % start_time, & + buffers(b) % reset_interval, ierr=err) + end do + + ! set initial flags + do b = 1, number_of_buffers + buffers(b) % started_flag = .false. + buffers(b) % reset_flag = .false. + buffers(b) % accumulate_flag = .false. + end do + + end subroutine ocn_init_time_averages!}}} + + + +!*********************************************************************** +! routine timer_checking +! +!> \brief Timer functions to determine when to run +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> This routine conducts timer checking to determine if it +!> needs to run at this particular time. +!----------------------------------------------------------------------- + subroutine timer_checking(clock, err)!{{{ + ! input variables + !----------------------------------------------------------------- + + ! input/output variables + !----------------------------------------------------------------- + type (MPAS_Clock_type), intent(inout) :: clock + + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err + + ! local variables + !----------------------------------------------------------------- + integer :: b + + ! start procedure + !----------------------------------------------------------------- + err = 0 + + do b = 1, size(buffers) + ! always disable reset + buffers(b) % reset_flag = .false. + + ! see if the started alarm is ringing + if (mpas_is_alarm_ringing(clock, & + buffers(b) % start_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(clock, & + buffers(b) % start_alarm_ID, ierr=err) + buffers(b) % started_flag = .true. + end if + + ! if we aren't started, continue to next buffer + if (.not. buffers(b) % started_flag) then + buffers(b) % accumulate_flag = .false. + continue + end if + + ! check various other alarms + ! see if we need to reset + if (mpas_is_alarm_ringing(clock, & + buffers(b) % reset_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(clock, & + buffers(b) % reset_alarm_ID, ierr=err) + buffers(b) % reset_flag = .true. + end if + + ! turn off accumulation + if (mpas_is_alarm_ringing(clock, & + buffers(b) % duration_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(clock, & + buffers(b) % duration_alarm_ID, ierr=err) + buffers(b) % accumulate_flag = .false. + end if + + ! turn on accumulation + ! (this is second, in case the duration/reset + ! overlaps on the same timer) + if (mpas_is_alarm_ringing(clock, & + buffers(b) % repeat_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(clock, & + buffers(b) % repeat_alarm_ID, ierr=err) + buffers(b) % accumulate_flag = .true. + end if + end do + + end subroutine timer_checking!}}} + +!*********************************************************************** +! macro OPERATE +! +!> \brief A macro to support operations on different run-time types +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> This macro encapsulates the different opertions that can occur +!> based on the run-time types. It is written as a macro to cut down +!> on copy-pasting and duplication errors. (This would likely be +!> instantiated generics/templates in other languages.) +!----------------------------------------------------------------------- + +! first half of the macro +#define FIRST_HALF(SUBNAME) \ +subroutine operate ## SUBNAME (start_block, tvar) ;\ +type (block_type), pointer, intent(in) :: start_block ;\ +\ +type (time_variable_type), intent(inout) :: tvar ;\ +\ +integer :: b ;\ +type (block_type), pointer :: block ; + +! second half of the macro +#define SECOND_HALF \ +block => start_block ;\ +do while (associated(block)) ;\ + call mpas_pool_get_array(block % allFields, \ + tvar % input_name, in_array, 1) ;\ +\ + do b = 1, size(buffers) ;\ + if (buffers(b) % reset_flag) then ;\ + call mpas_pool_get_array(block % allFields, \ + tvar % output_names(b), out_array, 1) ;\ + out_array = in_array ;\ + else if (buffers(b) % accumulate_flag) then ;\ + call mpas_pool_get_array(block % allFields, \ + tvar % output_names(b), out_array, 1) ; + +! averaging is done by multiplying out and dividing such that +! the average state is always in a normalized form -- while +! this could (will) cause more error in the long run, it does +! mean that other AMs will be able to use this data and it will +! always be prenormalized (it also means that we don't have to +! have a special case of normalizing the data before writing it +! to disk) +#define AVG_MAC \ + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; + +#define MIN_MAC \ + out_array = min(out_array, in_array) ; + +#define MAX_MAC \ + out_array = max(out_array, in_array) ; + +#define END_CAP(SUBNAME) \ + end if ;\ + end do ;\ +\ + block => block % next ;\ +end do ;\ +\ +end subroutine operate ## SUBNAME ; + +! had to create this as a two part macro because of the comma differences +! and type declaration in 0d vs nd data +! (fpp doesn't seem to like to parse "," correctly as an argument even +! if you "#define COMMA ,". It was only able to do the commas in the middle +! of dimension(...) because the , are in a (). Therefore to have two +! different types of functions, I had to separate them into two macros +! with different arguments, i.e., I wasn't able to pass one argument +! to the macro to expand the type definition, because fpp wasn't +! able to figure out that it was one argument due to ","s. Also, +! I wasn't able to pass a macro function with an argument for the same +! reason, as the preprocessor would expand it and get confused by +! the commas. Quite frequently, I would get an empty argument.) +#define OPERATE_MULTI_AVG(S, A, B) \ +FIRST_HALF(S) A, B, pointer :: in_array, out_array ; \ +SECOND_HALF AVG_MAC END_CAP(S) +#define OPERATE_SCALAR_AVG(S, A) \ +FIRST_HALF(S) A, pointer :: in_array, out_array ; \ +SECOND_HALF AVG_MAC END_CAP(S) +#define OPERATE_MULTI_MIN(S, A, B) \ +FIRST_HALF(S) A, B, pointer :: in_array, out_array ; \ +SECOND_HALF MIN_MAC END_CAP(S) +#define OPERATE_SCALAR_MIN(S, A) \ +FIRST_HALF(S) A, pointer :: in_array, out_array ; \ +SECOND_HALF MIN_MAC END_CAP(S) +#define OPERATE_MULTI_MAX(S, A, B) \ +FIRST_HALF(S) A, B, pointer :: in_array, out_array ; \ +SECOND_HALF MAX_MAC END_CAP(S) +#define OPERATE_SCALAR_MAX(S, A) \ +FIRST_HALF(S) A, pointer :: in_array, out_array ; \ +SECOND_HALF MAX_MAC END_CAP(S) + +! here are all the instantiations +OPERATE_SCALAR_AVG(0r_avg, real(kind=RKIND)) +OPERATE_MULTI_AVG(1r_avg, real(kind=RKIND), dimension(:)) +OPERATE_MULTI_AVG(2r_avg, real(kind=RKIND), dimension(:, :)) +OPERATE_MULTI_AVG(3r_avg, real(kind=RKIND), dimension(:, :, :)) +OPERATE_MULTI_AVG(4r_avg, real(kind=RKIND), dimension(:, :, :, :)) +OPERATE_MULTI_AVG(5r_avg, real(kind=RKIND), dimension(:, :, :, :, :)) +OPERATE_SCALAR_AVG(0i_avg, integer) +OPERATE_MULTI_AVG(1i_avg, integer, dimension(:)) +OPERATE_MULTI_AVG(2i_avg, integer, dimension(:, :)) +OPERATE_MULTI_AVG(3i_avg, integer, dimension(:, :, :)) + +OPERATE_SCALAR_MIN(0r_min, real(kind=RKIND)) +OPERATE_MULTI_MIN(1r_min, real(kind=RKIND), dimension(:)) +OPERATE_MULTI_MIN(2r_min, real(kind=RKIND), dimension(:, :)) +OPERATE_MULTI_MIN(3r_min, real(kind=RKIND), dimension(:, :, :)) +OPERATE_MULTI_MIN(4r_min, real(kind=RKIND), dimension(:, :, :, :)) +OPERATE_MULTI_MIN(5r_min, real(kind=RKIND), dimension(:, :, :, :, :)) +OPERATE_SCALAR_MIN(0i_min, integer) +OPERATE_MULTI_MIN(1i_min, integer, dimension(:)) +OPERATE_MULTI_MIN(2i_min, integer, dimension(:, :)) +OPERATE_MULTI_MIN(3i_min, integer, dimension(:, :, :)) + +OPERATE_SCALAR_MAX(0r_max, real(kind=RKIND)) +OPERATE_MULTI_MAX(1r_max, real(kind=RKIND), dimension(:)) +OPERATE_MULTI_MAX(2r_max, real(kind=RKIND), dimension(:, :)) +OPERATE_MULTI_MAX(3r_max, real(kind=RKIND), dimension(:, :, :)) +OPERATE_MULTI_MAX(4r_max, real(kind=RKIND), dimension(:, :, :, :)) +OPERATE_MULTI_MAX(5r_max, real(kind=RKIND), dimension(:, :, :, :, :)) +OPERATE_SCALAR_MAX(0i_max, integer) +OPERATE_MULTI_MAX(1i_max, integer, dimension(:)) +OPERATE_MULTI_MAX(2i_max, integer, dimension(:, :)) +OPERATE_MULTI_MAX(3i_max, integer, dimension(:, :, :)) + +#undef FIRST_HALF +#undef SECOND_HALF +#undef AVG +#undef MIN +#undef MAX +#undef END_CAP +#undef OPERATE_MULTI_AVG +#undef OPERATE_SCALAR_AVG +#undef OPERATE_MULTI_MIN +#undef OPERATE_SCALAR_MIN +#undef OPERATE_MULTI_MAX +#undef OPERATE_SCALAR_MAX + + + +!*********************************************************************** +! routine typed_operate +! +!> \brief Do the averaging, but switch on run-time type +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> Since we don't know the type of the array, we need to do some +!> run-time type switching based on the type of the array. +!----------------------------------------------------------------------- + subroutine typed_operate(block, tvar, operation)!{{{ + ! input variables + !----------------------------------------------------------------- + type (block_type), pointer, intent(in) :: block + integer, intent(in) :: operation + + ! input/output variables + !----------------------------------------------------------------- + type (time_variable_type), intent(inout) :: tvar + + ! output variables + !----------------------------------------------------------------- + + ! local variables + !----------------------------------------------------------------- + + ! switch based on the type, dimensionality, and operation + if (tvar % info % fieldType == MPAS_POOL_REAL) then + if (tvar % info % nDims == 0) then + if (operation .eq. AVG_OP) then + call operate0r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate0r_min(block, tvar) + else + call operate0r_max(block, tvar) + end if + else if (tvar % info % nDims == 1) then + if (operation .eq. AVG_OP) then + call operate1r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate1r_min(block, tvar) + else + call operate1r_max(block, tvar) + end if + else if (tvar % info % nDims == 2) then + if (operation .eq. AVG_OP) then + call operate2r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate2r_min(block, tvar) + else + call operate2r_max(block, tvar) + end if + else if (tvar % info % nDims == 3) then + if (operation .eq. AVG_OP) then + call operate3r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate3r_min(block, tvar) + else + call operate3r_max(block, tvar) + end if + else if (tvar % info % nDims == 4) then + if (operation .eq. AVG_OP) then + call operate4r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate4r_min(block, tvar) + else + call operate4r_max(block, tvar) + end if + else + if (operation .eq. AVG_OP) then + call operate5r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate5r_min(block, tvar) + else + call operate5r_max(block, tvar) + end if + end if + else + if (tvar % info % nDims == 0) then + if (operation .eq. AVG_OP) then + call operate0i_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate0i_min(block, tvar) + else + call operate0i_max(block, tvar) + end if + else if (tvar % info % nDims == 1) then + if (operation .eq. AVG_OP) then + call operate1i_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate1i_min(block, tvar) + else + call operate1i_max(block, tvar) + end if + else if (tvar % info % nDims == 2) then + if (operation .eq. AVG_OP) then + call operate2i_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate2i_min(block, tvar) + else + call operate2i_max(block, tvar) + end if + else + if (operation .eq. AVG_OP) then + call operate3i_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate3i_min(block, tvar) + else + call operate3i_max(block, tvar) + end if + end if + end if + + end subroutine typed_operate!}}} + +!*********************************************************************** +! routine ocn_compute_time_averages +! +!> \brief Compute MPAS-Ocean analysis member +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> This routine conducts all computation required for this +!> MPAS-Ocean analysis member. +!----------------------------------------------------------------------- + subroutine ocn_compute_time_averages(domain, timeLevel, err)!{{{ + ! input variables + !----------------------------------------------------------------- + integer, intent(in) :: timeLevel + + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain + + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + ! local variables + !----------------------------------------------------------------- + integer :: i, v, b + + ! start procedure + !----------------------------------------------------------------- + err = 0 + + ! do all of the time checking and flag setting + call timer_checking(domain % clock, err) + + do b = 1, size(buffers) + ! update number of accumulations, once only + if (buffers(b) % reset_flag) then + buffers(b) % total_accum = 1 + else + buffers(b) % total_accum = buffers(b) % total_accum + 1 + end if + end do + + do v = 1, size(variables) + ! do all of the operations + call typed_operate(domain % blocklist, variables(v), operation) + end do + + end subroutine ocn_compute_time_averages!}}} + + + +!*********************************************************************** +! routine ocn_restart_time_averages +! +!> \brief Save restart for MPAS-Ocean analysis member +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> This routine conducts computation required to save a restart state +!> for the MPAS-Ocean analysis member. +!----------------------------------------------------------------------- + subroutine ocn_restart_time_averages(domain, err)!{{{ + + ! input variables + !----------------------------------------------------------------- + + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain + + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + ! local variables + !----------------------------------------------------------------- + + ! start procedure + !----------------------------------------------------------------- + err = 0 + + ! TODO save data to restart and accumulate + + end subroutine ocn_restart_time_averages!}}} + + + +!*********************************************************************** +! routine ocn_finalize_time_averages +! +!> \brief Finalize MPAS-Ocean analysis member +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> This routine conducts all finalizations required for this +!> MPAS-Ocean analysis member. +!----------------------------------------------------------------------- + subroutine ocn_finalize_time_averages(domain, err)!{{{ + + ! input variables + !----------------------------------------------------------------- + + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain + + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + ! local variables + !----------------------------------------------------------------- + integer :: i, v + + ! start procedure + !----------------------------------------------------------------- + err = 0 + + ! clean up memory + if (allocated(buffers)) then + deallocate(buffers) + end if + if (allocated(variables)) then + do v = 1, size(variables) + if (allocated(variables(v) % output_names)) & + then + deallocate(variables(v) % output_names) + end if + end do + deallocate(variables) + end if + + end subroutine ocn_finalize_time_averages!}}} + + + +end module ocn_time_averages +! vim: foldmethod=marker From b7ab8de4063357d35b7480e700189b16eb58d0fe Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 23 Jul 2015 13:31:40 -0600 Subject: [PATCH 0111/1724] Add a call to ocn_analysis_restart in the forward mode This commit adds a call to ocn_analysis_restart after ocn_analysis_compute but before ocn_analysis_write. This allows an analysis member to ensure that it's data is correct before writing it out for a restart file. --- src/core_ocean/mode_forward/mpas_ocn_forward_mode.F | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index 250279eb69..23d7c0757e 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -456,6 +456,7 @@ function ocn_forward_mode_run(domain) result(ierr)!{{{ end do call ocn_analysis_compute(domain, err) + call ocn_analysis_restart(domain, err) call ocn_analysis_write(domain, err) call mpas_timer_start('io_write', .false.) From bf2974248c6765e152d1f84b252e7c6ff9d9a0a4 Mon Sep 17 00:00:00 2001 From: Phillip Wolfram Date: Fri, 17 Jul 2015 16:55:37 -0600 Subject: [PATCH 0112/1724] Recursive time filter for normal velocity. Analysis member implements a time filtering (high and low pass) for normalVelocity. Time filtering uses the equation vf[n] = vf[n-1]*(1-dt/tau) + dt/tau*v[n] and is derived from impulse frequency response: d vl / dt = (v - vl)/tau, for low-pass filtered vl of signal v with time scale tau. The high-pass velocity vh is vh = v - vl. A reference on the filter design can be found at http://www.dspguide.com/ch19.htm. The design document is located at oceanLPTs/documents/timeFilterDesign on the oceanLPTs branch of git@github.com:pwolfram/MPAS-Scratch.git. Code was tested using the baroclinic_channel_10000m_20levs with a timeFiltersOutput frequency corresponding to the timestep (namelist and stream contained below in gist). Filter was then checked via the scripts at https://gist.github.com/f986cc982d50ea69f2c9, calling ./test_filter.py analysis_members/timeFilters.0000-01-01.nc Implemented filter is comparable, once spun up, to the exponential moving average. --- src/core_ocean/analysis_members/Makefile | 3 +- .../Registry_analysis_members.xml | 1 + .../Registry_time_filters.xml | 60 +++ .../mpas_ocn_analysis_driver.F | 10 + .../analysis_members/mpas_ocn_time_filters.F | 362 ++++++++++++++++++ 5 files changed, 435 insertions(+), 1 deletion(-) create mode 100644 src/core_ocean/analysis_members/Registry_time_filters.xml create mode 100644 src/core_ocean/analysis_members/mpas_ocn_time_filters.F diff --git a/src/core_ocean/analysis_members/Makefile b/src/core_ocean/analysis_members/Makefile index 1b6097cabb..6ad1a1281a 100644 --- a/src/core_ocean/analysis_members/Makefile +++ b/src/core_ocean/analysis_members/Makefile @@ -10,7 +10,8 @@ MEMBERS = mpas_ocn_global_stats.o \ mpas_ocn_meridional_heat_transport.o \ mpas_ocn_test_compute_interval.o \ mpas_ocn_high_frequency_output.o \ - mpas_ocn_zonal_mean.o + mpas_ocn_zonal_mean.o \ + mpas_ocn_time_filters.o all: $(OBJS) diff --git a/src/core_ocean/analysis_members/Registry_analysis_members.xml b/src/core_ocean/analysis_members/Registry_analysis_members.xml index 8359f533a9..8bf29c81cf 100644 --- a/src/core_ocean/analysis_members/Registry_analysis_members.xml +++ b/src/core_ocean/analysis_members/Registry_analysis_members.xml @@ -7,3 +7,4 @@ #include "Registry_meridional_heat_transport.xml" #include "Registry_test_compute_interval.xml" #include "Registry_high_frequency_output.xml" +#include "Registry_time_filters.xml" diff --git a/src/core_ocean/analysis_members/Registry_time_filters.xml b/src/core_ocean/analysis_members/Registry_time_filters.xml new file mode 100644 index 0000000000..24d4f97227 --- /dev/null +++ b/src/core_ocean/analysis_members/Registry_time_filters.xml @@ -0,0 +1,60 @@ + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F index 5503c7144d..2b44615984 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -35,6 +35,7 @@ module ocn_analysis_driver use ocn_meridional_heat_transport use ocn_test_compute_interval use ocn_high_frequency_output + use ocn_time_filters ! use ocn_TEM_PLATE implicit none @@ -145,6 +146,7 @@ subroutine ocn_analysis_setup_packages(configPool, packagePool, err)!{{{ call mpas_pool_add_config(analysisMemberList, 'waterMassCensus', 1) call mpas_pool_add_config(analysisMemberList, 'zonalMean', 1) call mpas_pool_add_config(analysisMemberList, 'highFrequencyOutput', 1) + call mpas_pool_add_config(analysisMemberList, 'timeFilters', 1) ! call mpas_pool_add_config(analysisMemberList, 'temPlate', 1) ! DON'T EDIT BELOW HERE @@ -740,6 +742,8 @@ subroutine ocn_init_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_init_zonal_mean(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then call ocn_init_high_frequency_output(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'timeFilters' ) then + call ocn_init_time_filters(domain, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_init_TEM_PLATE(domain, err_tmp) end if @@ -789,6 +793,8 @@ subroutine ocn_compute_analysis_members(domain, timeLevel, analysisMemberName, i call ocn_compute_zonal_mean(domain, timeLevel, err_tmp) else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then call ocn_compute_high_frequency_output(domain, timeLevel, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'timeFilters' ) then + call ocn_compute_time_filters(domain, timeLevel, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_compute_TEM_PLATE(domain, timeLevel, err_tmp) end if @@ -837,6 +843,8 @@ subroutine ocn_restart_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_restart_zonal_mean(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then call ocn_restart_high_frequency_output(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'timeFilters' ) then + call ocn_restart_time_filters(domain, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_restart_TEM_PLATE(domain, err_tmp) end if @@ -885,6 +893,8 @@ subroutine ocn_finalize_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_finalize_zonal_mean(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then call ocn_finalize_high_frequency_output(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'timeFilters' ) then + call ocn_finalize_time_filters(domain, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_finalize_TEM_PLATE(domain, err_tmp) end if diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_filters.F b/src/core_ocean/analysis_members/mpas_ocn_time_filters.F new file mode 100644 index 0000000000..fdb4e2c8ff --- /dev/null +++ b/src/core_ocean/analysis_members/mpas_ocn_time_filters.F @@ -0,0 +1,362 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_time_filters +! +!> \brief MPAS ocean analysis mode member: time_filters +!> \author Phillip J. Wolfram +!> \date 07/17/2015 +!> \details +!> Performs time high and low pass filtering. +!> +!----------------------------------------------------------------------- + +module ocn_time_filters + + use mpas_derived_types + use mpas_pool_routines + use mpas_dmpar + use mpas_timekeeping + use mpas_stream_manager + + use ocn_constants + use ocn_diagnostics_routines + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_time_filters, & + ocn_compute_time_filters, & + ocn_restart_time_filters, & + ocn_finalize_time_filters + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_time_filters +! +!> \brief Initialize MPAS-Ocean analysis member +!> \author Phillip J. Wolfram +!> \date 07/17/2015 +!> \details +!> This routine conducts all initializations required for the +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_time_filters(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + type (block_type), pointer :: block + logical, pointer :: initializeFilters + type (mpas_pool_type), pointer :: timeFiltersAMPool, statePool + real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, normalVelocityLowPass, normalVelocityHighPass + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_AM_timeFilters_initialize_filters', initializeFilters) + if (initializeFilters) then +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'initializing time filters' +#endif + + ! loop over all blocks and make assignments + block => domain % blocklist + do while (associated(block)) + + ! get high and low pass velocity components + call mpas_pool_get_subpool(block % structs, 'timeFiltersAM', timeFiltersAMPool) + call mpas_pool_get_array(timeFiltersAMPool, 'normalVelocityLowPass', normalVelocityLowPass) + call mpas_pool_get_array(timeFiltersAMPool, 'normalVelocityHighPass', normalVelocityHighPass) + + ! get normal velocity + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=1) + + ! initialize normal velocities + normalVelocityLowPass(:,:) = normalVelocity(:,:) + normalVelocityHighPass(:,:) = normalVelocity(:,:) + + block => block % next + end do + + end if + +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'finished initializing time filters' +#endif + + end subroutine ocn_init_time_filters!}}} + +!*********************************************************************** +! +! routine ocn_compute_time_filters +! +!> \brief Compute MPAS-Ocean analysis member +!> \author Phillip J. Wolfram +!> \date 07/17/2015 +!> \details +!> This routine conducts all computation required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_compute_time_filters(domain, timeLevel, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + integer, intent(in) :: timeLevel + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: timeFiltersAMPool + type (dm_info) :: dminfo + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: scratchPool + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: timeFiltersAM + real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, normalVelocityLowPass, normalVelocityHighPass, normalVelocityTest + integer, pointer :: nVertLevels, nEdgesSolve + integer :: k, iEdge + integer, dimension(:), pointer :: maxLevelEdgeBot + + type (MPAS_timeInterval_type) :: timeStepESMF + character(len=StrKIND), pointer :: config_dt + real (kind=RKIND) :: dt, tau + + err = 0 + + dminfo = domain % dminfo + +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'start computing time filters' +#endif + + ! get dt + call mpas_pool_get_config(domain % configs, 'config_dt', config_dt) + call mpas_set_timeInterval(timeStepESMF, timeString=config_dt, ierr=err) + call mpas_get_timeInterval(timeStepESMF, dt=dt) + ! get tau + call mpas_pool_get_config(domain % configs, 'config_AM_timeFilters_tau', config_dt) + call mpas_set_timeInterval(timeStepESMF, timeString=config_dt, ierr=err) + call mpas_get_timeInterval(timeStepESMF, dt=tau) + +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'dt = ', dt, ' tau = ', tau +#endif + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'timeFiltersAM', timeFiltersAMPool) + + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(block % dimensions, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeBot', maxLevelEdgeBot) + + ! get high and low pass velocity components + call mpas_pool_get_array(timeFiltersAMPool, 'normalVelocityLowPass', normalVelocityLowPass) + call mpas_pool_get_array(timeFiltersAMPool, 'normalVelocityHighPass', normalVelocityHighPass) + call mpas_pool_get_array(timeFiltersAMPool, 'normalVelocityFilterTest', normalVelocityTest) + ! get normal velocity + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=1) + + ! perform filter computations (in place) + do iEdge = 1,nEdgesSolve + do k = 1, maxLevelEdgeBot(iEdge) + normalVelocityLowPass(k,iEdge) = normalVelocityLowPass(k,iEdge)*(1.0_RKIND - dt/tau) + dt/tau*normalVelocity(k,iEdge) + normalVelocityHighPass(k,iEdge) = normalVelocity(k,iEdge) - normalVelocityLowPass(k,iEdge) + ! normalVelocityTest line can possibly be removed (needed for testing purposes) + normalVelocityTest(k,iEdge) = normalVelocity(k,iEdge) + end do + end do + + block => block % next + end do + +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'finished computing time filters' +#endif + + end subroutine ocn_compute_time_filters!}}} + +!*********************************************************************** +! +! routine ocn_restart_time_filters +! +!> \brief Save restart for MPAS-Ocean analysis member +!> \author Phillip J. Wolfram +!> \date 07/17/2015 +!> \details +!> This routine conducts computation required to save a restart state +!> for the MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_restart_time_filters(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_restart_time_filters!}}} + +!*********************************************************************** +! +! routine ocn_finalize_time_filters +! +!> \brief Finalize MPAS-Ocean analysis member +!> \author Phillip J. Wolfram +!> \date 07/17/2015 +!> \details +!> This routine conducts all finalizations required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_finalize_time_filters(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_finalize_time_filters!}}} + +end module ocn_time_filters + +! vim: foldmethod=marker From 03853cd6099fb25c7504db2b1c392b31f9ed337c Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Tue, 21 Jul 2015 18:13:46 -0600 Subject: [PATCH 0113/1724] added restart capability to time filters tested with brb and restarts using baroclinic channel testing cases for brb and restarts * baroclinic_channel_10000m_20levs_brb- bit for bit reproducible testing via brb.sh * baroclinic_channel_10000m_20levs_restart- restart bit for bit reproducible via restart.sh test case files located at /turquoise/usr/projects/climate/pwolfram/test_cases --- .../Registry_time_filters.xml | 20 ++++++++++++++++++- .../analysis_members/mpas_ocn_time_filters.F | 7 +++++++ 2 files changed, 26 insertions(+), 1 deletion(-) diff --git a/src/core_ocean/analysis_members/Registry_time_filters.xml b/src/core_ocean/analysis_members/Registry_time_filters.xml index 24d4f97227..6fb671b955 100644 --- a/src/core_ocean/analysis_members/Registry_time_filters.xml +++ b/src/core_ocean/analysis_members/Registry_time_filters.xml @@ -19,6 +19,10 @@ description="Logical flag determining if an analysis member write occurs on start-up." possible_values=".true. or .false." /> + + + + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_filters.F b/src/core_ocean/analysis_members/mpas_ocn_time_filters.F index fdb4e2c8ff..784af8c16a 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_filters.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_filters.F @@ -105,9 +105,16 @@ subroutine ocn_init_time_filters(domain, err)!{{{ logical, pointer :: initializeFilters type (mpas_pool_type), pointer :: timeFiltersAMPool, statePool real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, normalVelocityLowPass, normalVelocityHighPass + logical, pointer :: config_AM_timeFilters_do_restart err = 0 + ! read in data on restart + call mpas_pool_get_config(domain % configs, 'config_AM_timeFilters_do_restart', config_AM_timeFilters_do_restart) + if ( config_AM_timeFilters_do_restart ) then + call MPAS_stream_mgr_read(domain % streamManager, streamID='timeFiltersRestart', ierr=err) + end if + call mpas_pool_get_config(ocnConfigs, 'config_AM_timeFilters_initialize_filters', initializeFilters) if (initializeFilters) then #ifdef MPAS_DEBUG From bfeafd7e9f57d400a3067e97b31f9a00cf17862d Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Wed, 22 Jul 2015 15:02:14 -0600 Subject: [PATCH 0114/1724] debug ability to output time series at particular point --- .../analysis_members/mpas_ocn_time_filters.F | 64 ++++++++++++++++++- 1 file changed, 63 insertions(+), 1 deletion(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_filters.F b/src/core_ocean/analysis_members/mpas_ocn_time_filters.F index 784af8c16a..281ea05c90 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_filters.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_filters.F @@ -27,6 +27,9 @@ module ocn_time_filters use ocn_constants use ocn_diagnostics_routines +#ifdef MPAS_DEBUG + use mpas_constants +#endif implicit none private @@ -54,6 +57,10 @@ module ocn_time_filters ! Private module variables ! !-------------------------------------------------------------------- +#ifdef MPAS_DEBUG + integer :: iEdgeOutput = 0, iBlockOutput = 0, iklevel = 1 + real (kind=RKIND) :: lonEdgePoint = (360.0_RKIND-7.5_RKIND)*pii/180.0_RKIND, latEdgePoint = 32.5_RKIND*pii/180.0_RKIND +#endif !*********************************************************************** @@ -107,6 +114,13 @@ subroutine ocn_init_time_filters(domain, err)!{{{ real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, normalVelocityLowPass, normalVelocityHighPass logical, pointer :: config_AM_timeFilters_do_restart +#ifdef MPAS_DEBUG + real (kind=RKIND), dimension(:), pointer :: lonEdge, latEdge + real (kind=RKIND) :: dist, distmax = 1e9 + integer :: i, iBlock + integer, pointer :: nEdgesSolve +#endif + err = 0 ! read in data on restart @@ -143,6 +157,40 @@ subroutine ocn_init_time_filters(domain, err)!{{{ end if +#ifdef MPAS_DEBUG + ! get index for edge nearest to a location + block => domain % blocklist + iBlock = 0 + do while (associated(block)) + iBlock = iBlock + 1 + call mpas_pool_get_subpool(block % structs, 'mesh', statePool) + call mpas_pool_get_array(statePool, 'latEdge', latEdge) + call mpas_pool_get_array(statePool, 'lonEdge', lonEdge) + call mpas_pool_get_dimension(block % dimensions, 'nEdgesSolve', nEdgesSolve) + + do i=1,nEdgesSolve + dist = sqrt((latEdge(i) - latEdgePoint)**2 + (lonEdge(i) - lonEdgePoint)**2) + if (dist < distmax) then + distmax = dist + iEdgeOutput = i + iBlockOutput = iBlock + end if + end do + + block => block % next + end do + + block => domain % blocklist + ! get the right block number + do i=1,iBlockOutput-1 + block => block % next + end do + call mpas_pool_get_subpool(block % structs, 'mesh', statePool) + call mpas_pool_get_array(statePool, 'latEdge', latEdge) + call mpas_pool_get_array(statePool, 'lonEdge', lonEdge) + write(stderrUnit,*) 'lon = ', 180.0_RKIND/pii*lonEdge(iEdgeOutput), ' lat = ', 180.0_RKIND/pii*latEdge(iEdgeOutput), ' iklevel=',iklevel +#endif + #ifdef MPAS_DEBUG write(stderrUnit,*) 'finished initializing time filters' #endif @@ -210,6 +258,9 @@ subroutine ocn_compute_time_filters(domain, timeLevel, err)!{{{ type (MPAS_timeInterval_type) :: timeStepESMF character(len=StrKIND), pointer :: config_dt real (kind=RKIND) :: dt, tau +#ifdef MPAS_DEBUG + integer :: iBlock +#endif err = 0 @@ -229,11 +280,17 @@ subroutine ocn_compute_time_filters(domain, timeLevel, err)!{{{ call mpas_get_timeInterval(timeStepESMF, dt=tau) #ifdef MPAS_DEBUG - write(stderrUnit,*) 'dt = ', dt, ' tau = ', tau + !write(stderrUnit,*) 'dt = ', dt, ' tau = ', tau #endif block => domain % blocklist +#ifdef MPAS_DEBUG + iBlock = 0 +#endif do while (associated(block)) +#ifdef MPAS_DEBUG + iBlock = iBlock + 1 +#endif call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) @@ -259,6 +316,11 @@ subroutine ocn_compute_time_filters(domain, timeLevel, err)!{{{ ! normalVelocityTest line can possibly be removed (needed for testing purposes) normalVelocityTest(k,iEdge) = normalVelocity(k,iEdge) end do +#ifdef MPAS_DEBUG + if (iEdge == iEdgeOutput .and. iBlock == iBlockOutput) then + write(stderrUnit,*) 'vl=', normalVelocityLowPass(iklevel, iEdge), ' v=', normalVelocity(iklevel, iEdge) + end if +#endif end do block => block % next From f67f386e88a42ec7636c03d0db5c8b33f89cb86e Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Fri, 24 Jul 2015 16:09:21 -0600 Subject: [PATCH 0115/1724] Fixed the timer logic such that the averages should be correct, now. --- .../Registry_time_averages.xml | 12 +-- .../analysis_members/mpas_ocn_time_averages.F | 87 +++++++++++++------ 2 files changed, 67 insertions(+), 32 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_time_averages.xml b/src/core_ocean/analysis_members/Registry_time_averages.xml index 0d39370c77..b02b580d57 100644 --- a/src/core_ocean/analysis_members/Registry_time_averages.xml +++ b/src/core_ocean/analysis_members/Registry_time_averages.xml @@ -25,7 +25,7 @@ default_value="dt" units="unitless" description="Interval that determines frequency of computation for the time_averages analysis member." - possible_values="Any valid time stamp, 'dt', or 'output_interval'" + possible_values="Any valid time stamp or 'dt'. This must also be <= output_interval / 2, such that output_interval must be >= 2 * dt (at least two samples in a series)." /> diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_averages.F b/src/core_ocean/analysis_members/mpas_ocn_time_averages.F index 36d448beb0..738d943e35 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_averages.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_averages.F @@ -48,7 +48,8 @@ module ocn_time_averages ! this keeps track of timers and if and when they need to accumulate type time_buffer_type ! internal state - logical :: started_flag, accumulate_flag, reset_flag + logical :: started_flag, accumulate_flag, reset_flag, delay_reset_flag + logical :: reset_alarm_armed integer :: total_accum type (MPAS_Time_type) :: start_time @@ -215,11 +216,11 @@ subroutine set_times(buffers, number_of_buffers, clock, & end if else if (time_str .eq. 'same_as_output') then - call mpas_set_timeInterval(buffers(b) % reset_interval, & - timeString=inv_str, ierr=err) + buffers(b) % reset_alarm_armed = .false. else call mpas_set_timeInterval(buffers(b) % reset_interval, & timeString=time_str, ierr=err) + buffers(b) % reset_alarm_armed = .true. end if end if ! get the next time string @@ -418,6 +419,7 @@ subroutine ocn_init_time_averages(domain, err)!{{{ if (.not. ok) then call mpas_dmpar_global_abort('Error: number_of_buffers != number of reset_intervals in time averaging member analysis member configuration.') end if + ! TODO? sanity check that it is <= output_interval ! configure repeat intervals config_str = trim(prefix_str) // '_repeat_intervals' @@ -436,6 +438,7 @@ subroutine ocn_init_time_averages(domain, err)!{{{ if (.not. ok) then call mpas_dmpar_global_abort('Error: number_of_buffers != number of duration_intervals in time averaging member analysis member configuration.') end if + ! TODO sanity check to see if >= compute_interval * 2 ! configure start times config_str = trim(prefix_str) // '_initial_times' @@ -450,12 +453,14 @@ subroutine ocn_init_time_averages(domain, err)!{{{ do b = 1, number_of_buffers if (buffers(b) % repeat_interval .gt. & buffers(b) % reset_interval) then + ! TODO error out write(stderrUnit,*) 'Warning: repeat_interval > reset_interval in time averaging analysis member configuration. Truncating repeat_interval.' buffers(b) % repeat_interval = buffers(b) % reset_interval end if if (buffers(b) % duration_interval .gt. & buffers(b) % repeat_interval) then + ! TODO error out write(stderrUnit,*) 'Warning: duration_interval > repeat_interval in time averaging analysis member configuration. Truncating duration_interval.' buffers(b) % repeat_interval = buffers(b) % reset_interval end if @@ -588,6 +593,7 @@ subroutine ocn_init_time_averages(domain, err)!{{{ buffers(b) % started_flag = .false. buffers(b) % reset_flag = .false. buffers(b) % accumulate_flag = .false. + buffers(b) % delay_reset_flag = .false. end do end subroutine ocn_init_time_averages!}}} @@ -604,13 +610,13 @@ end subroutine ocn_init_time_averages!}}} !> This routine conducts timer checking to determine if it !> needs to run at this particular time. !----------------------------------------------------------------------- - subroutine timer_checking(clock, err)!{{{ + subroutine timer_checking(domain, err)!{{{ ! input variables !----------------------------------------------------------------- ! input/output variables !----------------------------------------------------------------- - type (MPAS_Clock_type), intent(inout) :: clock + type (domain_type), intent(inout) :: domain ! output variables !----------------------------------------------------------------- @@ -625,49 +631,67 @@ subroutine timer_checking(clock, err)!{{{ err = 0 do b = 1, size(buffers) - ! always disable reset - buffers(b) % reset_flag = .false. - ! see if the started alarm is ringing - if (mpas_is_alarm_ringing(clock, & + if (mpas_is_alarm_ringing(domain % clock, & buffers(b) % start_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(clock, & + call mpas_reset_clock_alarm(domain % clock, & buffers(b) % start_alarm_ID, ierr=err) buffers(b) % started_flag = .true. + ! TODO only reset if not restart + buffers(b) % reset_flag = .true. end if ! if we aren't started, continue to next buffer if (.not. buffers(b) % started_flag) then - buffers(b) % accumulate_flag = .false. continue end if ! check various other alarms ! see if we need to reset - if (mpas_is_alarm_ringing(clock, & + if (buffers(b) % reset_alarm_armed) then + if(mpas_is_alarm_ringing(domain % clock, & buffers(b) % reset_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(clock, & - buffers(b) % reset_alarm_ID, ierr=err) - buffers(b) % reset_flag = .true. + call mpas_reset_clock_alarm(domain % clock, & + buffers(b) % reset_alarm_ID, ierr=err) + buffers(b) % reset_flag = .true. + end if + else + if(mpas_stream_mgr_ringing_alarms(domain % streamManager, & + stream_name)) then + buffers(b) % reset_flag = .true. + end if end if ! turn off accumulation - if (mpas_is_alarm_ringing(clock, & + ! + ! duration needs to be >= 2 * compute_interval + ! (a series can only be 2 or more) + if (mpas_is_alarm_ringing(domain % clock, & buffers(b) % duration_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(clock, & + call mpas_reset_clock_alarm(domain % clock, & buffers(b) % duration_alarm_ID, ierr=err) buffers(b) % accumulate_flag = .false. end if ! turn on accumulation - ! (this is second, in case the duration/reset + ! (this is second, in case the duration and repeat ! overlaps on the same timer) - if (mpas_is_alarm_ringing(clock, & + if (mpas_is_alarm_ringing(domain % clock, & buffers(b) % repeat_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(clock, & + call mpas_reset_clock_alarm(domain % clock, & buffers(b) % repeat_alarm_ID, ierr=err) buffers(b) % accumulate_flag = .true. end if + + ! see if we need to delay resetting to the next time around, + ! when the reset is on the same time as an output + ! (we don't want to clear if we are outputting) + if (buffers(b) % reset_flag) then + if(mpas_stream_mgr_ringing_alarms(domain % streamManager, & + stream_name)) then + buffers(b) % delay_reset_flag = .true. + end if + end if end do end subroutine timer_checking!}}} @@ -703,7 +727,8 @@ subroutine operate ## SUBNAME (start_block, tvar) ;\ tvar % input_name, in_array, 1) ;\ \ do b = 1, size(buffers) ;\ - if (buffers(b) % reset_flag) then ;\ + if (buffers(b) % reset_flag .and. \ + (.not. buffers(b) % delay_reset_flag)) then ;\ call mpas_pool_get_array(block % allFields, \ tvar % output_names(b), out_array, 1) ;\ out_array = in_array ;\ @@ -965,22 +990,32 @@ subroutine ocn_compute_time_averages(domain, timeLevel, err)!{{{ err = 0 ! do all of the time checking and flag setting - call timer_checking(domain % clock, err) + call timer_checking(domain, err) + ! update number of accumulations, once only do b = 1, size(buffers) - ! update number of accumulations, once only - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then buffers(b) % total_accum = 1 - else + else if (buffers(b) % accumulate_flag) then buffers(b) % total_accum = buffers(b) % total_accum + 1 end if end do + ! do all of the operations do v = 1, size(variables) - ! do all of the operations call typed_operate(domain % blocklist, variables(v), operation) end do + ! clear resets + do b = 1, size(buffers) + if (buffers(b) % delay_reset_flag) then + buffers(b) % delay_reset_flag = .false. + else + buffers(b) % reset_flag = .false. + end if + end do + end subroutine ocn_compute_time_averages!}}} From e4ff0c12c5f0e6bc344e5a8ad700e2045f73f87d Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Fri, 24 Jul 2015 16:17:12 -0600 Subject: [PATCH 0116/1724] Edited description of a namelist parameter. --- src/core_ocean/analysis_members/Registry_time_averages.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/analysis_members/Registry_time_averages.xml b/src/core_ocean/analysis_members/Registry_time_averages.xml index b02b580d57..f3712d8afe 100644 --- a/src/core_ocean/analysis_members/Registry_time_averages.xml +++ b/src/core_ocean/analysis_members/Registry_time_averages.xml @@ -25,7 +25,7 @@ default_value="dt" units="unitless" description="Interval that determines frequency of computation for the time_averages analysis member." - possible_values="Any valid time stamp or 'dt'. This must also be <= output_interval / 2, such that output_interval must be >= 2 * dt (at least two samples in a series)." + possible_values="Any valid time stamp or 'dt'. This must also be <= output_interval / 2 (at least two samples in a series)." /> Date: Mon, 27 Jul 2015 06:44:58 -0600 Subject: [PATCH 0117/1724] Remove write statements from analysis member --- .../analysis_members/mpas_ocn_water_mass_census.F | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F b/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F index 423b4b8a8c..287a0e4dfc 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F +++ b/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F @@ -429,20 +429,17 @@ subroutine compute_mask(maxLevelCell, nCells, nCellsSolve, iRegion, lonCell, lat do iCell=1,nCellsSolve if(latCell(iCell).lt. 60.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND enddo - write(6,*) ' Arctic ', sum(workMask) elseif (iRegion.eq.2) then ! Equatorial do iCell=1,nCellsSolve if(latCell(iCell).gt. 15.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND if(latCell(iCell).lt.-15.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND enddo - write(6,*) ' Equatorial ', sum(workMask) elseif (iRegion.eq.3) then ! Southern Ocean do iCell=1,nCellsSolve if(latCell(iCell).gt.-50.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND enddo - write(6,*) ' Southern Ocean ', sum(workMask) elseif (iRegion.eq.4) then ! Nino 3 do iCell=1,nCellsSolve @@ -451,7 +448,6 @@ subroutine compute_mask(maxLevelCell, nCells, nCellsSolve, iRegion, lonCell, lat if(lonCell(iCell).lt.210.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND if(lonCell(iCell).gt.270.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND enddo - write(6,*) ' Nino 3 ', sum(workMask) elseif (iRegion.eq.5) then ! Nino 4 do iCell=1,nCellsSolve @@ -460,7 +456,6 @@ subroutine compute_mask(maxLevelCell, nCells, nCellsSolve, iRegion, lonCell, lat if(lonCell(iCell).lt.160.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND if(lonCell(iCell).gt.210.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND enddo - write(6,*) ' Nino 4 ', sum(workMask) elseif (iRegion.eq.6) then ! Nino 3.4 do iCell=1,nCellsSolve @@ -469,10 +464,8 @@ subroutine compute_mask(maxLevelCell, nCells, nCellsSolve, iRegion, lonCell, lat if(lonCell(iCell).lt.190.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND if(lonCell(iCell).gt.240.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND enddo - write(6,*) ' Nino 3.4 ', sum(workMask) else ! global (do nothing!) - write(6,*) ' Global ', sum(workMask) endif end subroutine compute_mask From a3727f7119ad07dc7eb11ec2e2812e0409de0e62 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Mon, 27 Jul 2015 12:15:07 -0600 Subject: [PATCH 0118/1724] Correct global init bug in refBottomDepth Previously, refBottomDepth was initialized incorrectly, resulting in incorrect layerThickness. The input file variable config_global_realistic_depth_varname is the mid-depth of the layers. The init core had treated these as tbe bottom-depth. This revision fixes this problem, so that refBottomDepth is correct. --- src/core_ocean/mode_init/Registry_global_realistic.xml | 2 +- src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/mode_init/Registry_global_realistic.xml b/src/core_ocean/mode_init/Registry_global_realistic.xml index 1154c13062..628a8212b5 100644 --- a/src/core_ocean/mode_init/Registry_global_realistic.xml +++ b/src/core_ocean/mode_init/Registry_global_realistic.xml @@ -12,7 +12,7 @@ possible_values="Dim name from input files." /> block_ptr % next end do From b62ade4b6b62fcadc8dc2c5f6f01a026ebac98d2 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Mon, 27 Jul 2015 07:15:16 -0600 Subject: [PATCH 0119/1724] Add flag to read from nearest restart record. Flag is default false. When true, add whence=MPAS_STREAM_NEAREST to restart read. This is needed at high resolution on mustang and wolf, where xtime is often written incorrectly to restart files. --- src/core_ocean/Registry.xml | 4 ++++ src/core_ocean/mode_forward/mpas_ocn_forward_mode.F | 9 +++++++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 77e445d081..51c177a3f4 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -857,6 +857,10 @@ description="Disables tendencies on the tracer fields from CVMix/KPP nonlocal fluxes." possible_values=".true. or .false." /> + diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index 23d7c0757e..42a798e464 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -113,7 +113,7 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ type (MPAS_Time_Type) :: startTime type (MPAS_TimeInterval_type) :: timeStep - logical, pointer :: config_do_restart, config_filter_btr_mode, config_conduct_tests + logical, pointer :: config_do_restart, config_read_nearest_restart, config_filter_btr_mode, config_conduct_tests character (len=StrKIND), pointer :: config_vert_coord_movement, config_pressure_gradient_type real (kind=RKIND), pointer :: config_maxMeshDensity @@ -130,6 +130,7 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ call ocn_constants_init(domain % configs, domain % packages) call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) + call mpas_pool_get_config(domain % configs, 'config_read_nearest_restart', config_read_nearest_restart) call mpas_pool_get_config(domain % configs, 'config_vert_coord_movement', config_vert_coord_movement) call mpas_pool_get_config(domain % configs, 'config_pressure_gradient_type', config_pressure_gradient_type) call mpas_pool_get_config(domain % configs, 'config_filter_btr_mode', config_filter_btr_mode) @@ -142,7 +143,11 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ call mpas_timer_start('io_read', .false.) call MPAS_stream_mgr_read(domain % streamManager, streamID='mesh', whence=MPAS_STREAM_NEAREST, ierr=err_tmp) if ( config_do_restart ) then - call MPAS_stream_mgr_read(domain % streamManager, streamID='restart', ierr=err_tmp) + if ( config_read_nearest_restart ) then + call MPAS_stream_mgr_read(domain % streamManager, streamID='restart', whence=MPAS_STREAM_NEAREST, ierr=err_tmp) + else + call MPAS_stream_mgr_read(domain % streamManager, streamID='restart', ierr=err_tmp) + end if else call MPAS_stream_mgr_read(domain % streamManager, streamID='input', ierr=err_tmp) end if From 13bd1384993d51e934621f3e66546cca6ec1cb46 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 27 Jul 2015 13:30:45 -0600 Subject: [PATCH 0120/1724] Fix temperature units in C++ interface Previously 273.15 was being added to the temperature passed from MPAS-LI but MPAS-LI is already using Kelvin so this was an error. This commit removes that conversion. --- src/core_landice/Interface_velocity_solver.cpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_landice/Interface_velocity_solver.cpp b/src/core_landice/Interface_velocity_solver.cpp index f4bcb4dfe3..f581b1795d 100644 --- a/src/core_landice/Interface_velocity_solver.cpp +++ b/src/core_landice/Interface_velocity_solver.cpp @@ -208,7 +208,7 @@ void velocity_solver_solve_l1l2(double const* lowerSurface_F, int iCell = vertexToFCell[index]; for (int il = 0; il < nLayers; il++) { temperatureData[index + il * nVertices] = temperature_F[iCell * nLayers - + (nLayers - il - 1)] + T0; + + (nLayers - il - 1)]; } } @@ -1330,7 +1330,7 @@ void importP0Temperature(double const * temperature_F) { if (nPoints == 0) temperature = T0; else - temperature = temperature / nPoints + T0; + temperature = temperature / nPoints; for (int k = 0; k < 3; k++) temperatureOnTetra[index * elemLayerShift + il * lElemColumnShift + k] = temperature; From 39f808b7f1f48796e440c5fd2bc6baec39f02cbb Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Tue, 28 Jul 2015 14:38:57 -0600 Subject: [PATCH 0121/1724] Ensure gradSSH is computed over all owned edges This commit ensures that gradSSH is computed over all owned edges. Later we use the RBF routines to reconstruct cell centered SSH gradient values. Owned cells that have non-owned edges will end up having the wrong value without this change, resulting in incorrect fields from a coupler that depend on grad SSH. --- src/core_ocean/shared/mpas_ocn_diagnostics.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index 7542d5c004..1e43b6e658 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -658,7 +658,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic call computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, timeLevel) endif - do iEdge = 1, nEdgesSolve + do iEdge = 1, nEdges cell1 = cellsOnEdge(1, iEdge) cell2 = cellsOnEdge(2, iEdge) From 725970996f687f6968a2f0a94a72bd0975027fe8 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Wed, 29 Jul 2015 09:47:12 -0600 Subject: [PATCH 0122/1724] Adding a summary of ocean package states This commit adds printing of a summary of all packages defined within the ocean core. Each package is then written to tell the user if it is off or on. --- .../driver/mpas_ocn_core_interface.F | 21 +++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/src/core_ocean/driver/mpas_ocn_core_interface.F b/src/core_ocean/driver/mpas_ocn_core_interface.F index 5caff85304..b9e96427b0 100644 --- a/src/core_ocean/driver/mpas_ocn_core_interface.F +++ b/src/core_ocean/driver/mpas_ocn_core_interface.F @@ -111,6 +111,9 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ logical, pointer :: frazilIceActive logical, pointer :: inSituEOSActive + type (mpas_pool_iterator_type) :: pkgItr + logical, pointer :: packageActive + logical, pointer :: config_use_freq_filtered_thickness logical, pointer :: config_frazil_ice_formation character (len=StrKIND), pointer :: config_time_integrator, config_forcing_type @@ -175,6 +178,24 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ call ocn_analysis_setup_packages(configPool, packagePool, ierr) call ocn_init_mode_validate_configuration(configPool, packagePool, ierr) + + write(stderrUnit, *) '' + write(stderrUnit, *) ' **** Summary of ocean packages ****' + call mpas_pool_begin_iteration(packagePool) + do while ( mpas_pool_get_next_member(packagePool, pkgItr) ) + + if ( pkgItr % memberType == MPAS_POOL_PACKAGE ) then + call mpas_pool_get_package(packagePool, pkgItr % memberName, packageActive) + if ( packageActive ) then + write(stderrUnit, *) ' ' // trim(pkgItr % memberName) // ' = ON' + else + write(stderrUnit, *) ' ' // trim(pkgItr % memberName) // ' = OFF' + end if + end if + end do + write(stderrUnit, *) ' ***********************************' + write(stderrUnit, *) '' + end function ocn_setup_packages!}}} From f2602e4f5b66b80999cdf6f6ddaa085f07767407 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Mon, 27 Jul 2015 08:53:29 -0600 Subject: [PATCH 0123/1724] Change minimum levels to minimum depth on init mode global realistic. It is more convenient to specify a thickness than an index. --- .../mode_init/Registry_global_realistic.xml | 6 ++-- .../mpas_ocn_init_global_realistic.F | 28 ++++++++++++------- 2 files changed, 21 insertions(+), 13 deletions(-) diff --git a/src/core_ocean/mode_init/Registry_global_realistic.xml b/src/core_ocean/mode_init/Registry_global_realistic.xml index 628a8212b5..1d709e1324 100644 --- a/src/core_ocean/mode_init/Registry_global_realistic.xml +++ b/src/core_ocean/mode_init/Registry_global_realistic.xml @@ -1,7 +1,7 @@ - domain % blocklist @@ -305,6 +306,15 @@ subroutine ocn_init_setup_global_realistic_interpolate_topo(domain, iErr)!{{{ call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + do k = 1, nVertLevels + if (refBottomDepth(k).gt.config_global_realistic_minimum_depth) then + minimum_levels = k + write (stdoutUnit,'(a,f8.2,2a,i5,a,f8.2,a)') 'config_global_realistic_minimum_depth=',config_global_realistic_minimum_depth,' m. ', & + 'Setting minimum layer index to ',minimum_levels, ' with a bottom depth of ', refBottomDepth(k), ' m.' + exit + end if + end do + do iCell = 1, nCells currentLat = latCell(iCell) currentLon = lonCell(iCell) @@ -343,13 +353,11 @@ subroutine ocn_init_setup_global_realistic_interpolate_topo(domain, iErr)!{{{ if (maxLevelCell(iCell) == -1) then maxLevelCell(iCell) = nVertLevels bottomDepth(iCell) = refBottomDepth( nVertLevels ) - else if (maxLevelCell(iCell) <= config_global_realistic_minimum_levels) then - maxLevelCell(iCell) = config_global_realistic_minimum_levels - bottomDepth(iCell) = refBottomDepth( config_global_realistic_minimum_levels ) + else if (maxLevelCell(iCell) <= minimum_levels) then + maxLevelCell(iCell) = minimum_levels + bottomDepth(iCell) = refBottomDepth( minimum_levels ) end if - - else bottomDepth(iCell) = 0.0_RKIND maxLevelCell(iCell) = -1 @@ -391,9 +399,9 @@ subroutine ocn_init_setup_global_realistic_interpolate_topo(domain, iErr)!{{{ ! Enforce minimum number of layers in ocean cells. do iCell = 1, nCells - if (maxLevelCell(iCell) > 0 .and. maxLevelCell(iCell) < config_global_realistic_minimum_levels) then - maxLevelCell(iCell) = config_global_realistic_minimum_levels - bottomDepth(iCell) = refBottomDepth(config_global_realistic_minimum_levels) + if (maxLevelCell(iCell) > 0 .and. maxLevelCell(iCell) < minimum_levels) then + maxLevelCell(iCell) = minimum_levels + bottomDepth(iCell) = refBottomDepth(minimum_levels) end if end do From 4ba61a179adc1409e9d7a857953a9e104fa1f301 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Thu, 30 Jul 2015 07:24:22 -0600 Subject: [PATCH 0124/1724] Add bottomDepthObserved variable Enforce minimum layer depth using bottomDepth variable, rather than maxLevelCell. --- src/core_ocean/Registry.xml | 4 +++ .../mpas_ocn_init_global_realistic.F | 28 ++++++++----------- 2 files changed, 15 insertions(+), 17 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 51c177a3f4..bd7ccb3390 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -982,6 +982,7 @@ + @@ -1503,6 +1504,9 @@ + bottomDepth(iCell) .and. maxLevelCell(iCell) == -1) then + if (refBottomDepth(k) >= bottomDepth(iCell)) then maxLevelCell(iCell) = k + exit end if end do if (maxLevelCell(iCell) == -1) then maxLevelCell(iCell) = nVertLevels bottomDepth(iCell) = refBottomDepth( nVertLevels ) - else if (maxLevelCell(iCell) <= minimum_levels) then - maxLevelCell(iCell) = minimum_levels - bottomDepth(iCell) = refBottomDepth( minimum_levels ) end if else @@ -397,14 +399,6 @@ subroutine ocn_init_setup_global_realistic_interpolate_topo(domain, iErr)!{{{ call mpas_deallocate_scratch_field(smoothedLevelsField, .true.) end if - ! Enforce minimum number of layers in ocean cells. - do iCell = 1, nCells - if (maxLevelCell(iCell) > 0 .and. maxLevelCell(iCell) < minimum_levels) then - maxLevelCell(iCell) = minimum_levels - bottomDepth(iCell) = refBottomDepth(minimum_levels) - end if - end do - block_ptr => block_ptr % next end do From c74c596a9a9a2edf253508b94db3324b4925434b Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Tue, 4 Aug 2015 14:39:52 -0600 Subject: [PATCH 0125/1724] Fix a missing deallocate in ocean init routines This commit adds a missing deallocate within the ocean init routines. It is needed when running with multiple blocks, but in general prevents a small memory leak. --- src/core_ocean/shared/mpas_ocn_init_routines.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/shared/mpas_ocn_init_routines.F b/src/core_ocean/shared/mpas_ocn_init_routines.F index 29ae889050..40773e3516 100644 --- a/src/core_ocean/shared/mpas_ocn_init_routines.F +++ b/src/core_ocean/shared/mpas_ocn_init_routines.F @@ -501,7 +501,7 @@ subroutine ocn_init_routines_vert_coord(domain)!{{{ enddo - deallocate(minBottomDepth,zMidZLevel) + deallocate(minBottomDepth,minBottomDepthMid,zMidZLevel) elseif (config_pbc_alteration_type .eq. 'full_cell') then From 6c535f658a842458e1a6eadc5d8a47fa485c8495 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Fri, 7 Aug 2015 12:48:42 -0600 Subject: [PATCH 0126/1724] Add kind definition to some reals This commit adds a kind type definition to three real pointers in the global_realistic configuration init module. Previously, they were missing the kind type definition, would would cause some compilers to fail to build as pool routines (such as get_array) were not built for the same type. --- src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F b/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F index 676276e205..eb29558de7 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F @@ -470,7 +470,7 @@ subroutine ocn_init_setup_global_realistic_cull_inland_seas(domain, iErr)!{{{ type (field1DInteger), pointer :: cullStackField, touchedCellField, oceanCellField - real, dimension(:), pointer :: latCell, lonCell, bottomDepth + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell, bottomDepth integer, dimension(:), pointer :: stack, oceanMask, touchMask integer, pointer :: stackSize From 5ae6e2977a8789129b8a8dd7740bfa0808f46962 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Fri, 7 Aug 2015 14:41:41 -0600 Subject: [PATCH 0127/1724] Cleanup some timers in MPAS-O Okubo weiss has timers with mismatched names, and GM has timers within a tridiagonal solve. This commit fixes these issues. --- src/core_ocean/analysis_members/mpas_ocn_okubo_weiss.F | 2 +- src/core_ocean/shared/mpas_ocn_gm.F | 4 ---- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_okubo_weiss.F b/src/core_ocean/analysis_members/mpas_ocn_okubo_weiss.F index cb31488064..abcebc133f 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_okubo_weiss.F +++ b/src/core_ocean/analysis_members/mpas_ocn_okubo_weiss.F @@ -663,7 +663,7 @@ subroutine ocn_compute_OW_component_IDs(dminfo, block, meshPool, processorId, nV call mpas_timer_start("CC eddy stats", .false., CCStatsTimer) call ocn_compute_eddy_stats(dminfo, block, nVertLevels, nCells, nCellsSolve, nLocalCCs, & nEdgesOnCell, cellsOnCell, OW_cc_id, OW_thresh) - call mpas_timer_stop("CC local", CCStatsTimer) + call mpas_timer_stop("CC eddy stats", CCStatsTimer) end subroutine ocn_compute_OW_component_IDs!}}} diff --git a/src/core_ocean/shared/mpas_ocn_gm.F b/src/core_ocean/shared/mpas_ocn_gm.F index c06c9f1ef6..8fa1c0b275 100644 --- a/src/core_ocean/shared/mpas_ocn_gm.F +++ b/src/core_ocean/shared/mpas_ocn_gm.F @@ -499,8 +499,6 @@ subroutine tridiagonal_solve(a,b,c,r,x,n) !{{{ real (KIND=RKIND) :: m integer i - call mpas_timer_start("tridiagonal_solve") - ! Use work variables for b and r bTemp(1) = b(1) rTemp(1) = r(1) @@ -518,8 +516,6 @@ subroutine tridiagonal_solve(a,b,c,r,x,n) !{{{ x(i) = (rTemp(i) - c(i)*x(i+1))/bTemp(i) end do - call mpas_timer_stop("tridiagonal_solve") - end subroutine tridiagonal_solve !}}} !*********************************************************************** From 3fda2f827295f43376294b2264a1f683a1824d42 Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Fri, 7 Aug 2015 15:46:39 -0600 Subject: [PATCH 0128/1724] Multiple changes to partially satisfy pull request. Changes listed below. The following changes have been made: - Timer logic should be more correct. Verified with average SSH over 3 months. Max error was ~1e-15 and min error was 0. - Adding mesh to stream output via namelist. - Renamed member to timeSeriesStats. - Removed number_of_buffers from namelist and sanity check is now based on time list lengths. - Semicolon (;) rather than whitespace as time list separator. - Tab-ified the registry. - Change the names of namelist time constants, such as same_as_initial to initial_time. - Removed the output_interval constant for reset_intervals. - Make sure all lines are less than 132 characters. --- src/core_ocean/analysis_members/Makefile | 2 +- .../Registry_analysis_members.xml | 2 +- .../Registry_time_averages.xml | 122 -------- .../Registry_time_series_stats.xml | 113 +++++++ .../mpas_ocn_analysis_driver.F | 20 +- ...verages.F => mpas_ocn_time_series_stats.F} | 281 +++++++++--------- 6 files changed, 273 insertions(+), 267 deletions(-) delete mode 100644 src/core_ocean/analysis_members/Registry_time_averages.xml create mode 100644 src/core_ocean/analysis_members/Registry_time_series_stats.xml rename src/core_ocean/analysis_members/{mpas_ocn_time_averages.F => mpas_ocn_time_series_stats.F} (85%) diff --git a/src/core_ocean/analysis_members/Makefile b/src/core_ocean/analysis_members/Makefile index 85cbee0ca5..ea3fa070b4 100644 --- a/src/core_ocean/analysis_members/Makefile +++ b/src/core_ocean/analysis_members/Makefile @@ -11,7 +11,7 @@ MEMBERS = mpas_ocn_global_stats.o \ mpas_ocn_test_compute_interval.o \ mpas_ocn_high_frequency_output.o \ mpas_ocn_zonal_mean.o \ - mpas_ocn_time_averages.o + mpas_ocn_time_series_stats.o all: $(OBJS) diff --git a/src/core_ocean/analysis_members/Registry_analysis_members.xml b/src/core_ocean/analysis_members/Registry_analysis_members.xml index 11f7d79cd8..c24aac9e25 100644 --- a/src/core_ocean/analysis_members/Registry_analysis_members.xml +++ b/src/core_ocean/analysis_members/Registry_analysis_members.xml @@ -7,4 +7,4 @@ #include "Registry_meridional_heat_transport.xml" #include "Registry_test_compute_interval.xml" #include "Registry_high_frequency_output.xml" -#include "Registry_time_averages.xml" +#include "Registry_time_series_stats.xml" diff --git a/src/core_ocean/analysis_members/Registry_time_averages.xml b/src/core_ocean/analysis_members/Registry_time_averages.xml deleted file mode 100644 index f3712d8afe..0000000000 --- a/src/core_ocean/analysis_members/Registry_time_averages.xml +++ /dev/null @@ -1,122 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/src/core_ocean/analysis_members/Registry_time_series_stats.xml b/src/core_ocean/analysis_members/Registry_time_series_stats.xml new file mode 100644 index 0000000000..839f3cd64a --- /dev/null +++ b/src/core_ocean/analysis_members/Registry_time_series_stats.xml @@ -0,0 +1,113 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F index 57f6cb6fa5..2c35b31c09 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -35,7 +35,7 @@ module ocn_analysis_driver use ocn_meridional_heat_transport use ocn_test_compute_interval use ocn_high_frequency_output - use ocn_time_averages + use ocn_time_series_stats ! use ocn_TEM_PLATE implicit none @@ -146,7 +146,7 @@ subroutine ocn_analysis_setup_packages(configPool, packagePool, err)!{{{ call mpas_pool_add_config(analysisMemberList, 'waterMassCensus', 1) call mpas_pool_add_config(analysisMemberList, 'zonalMean', 1) call mpas_pool_add_config(analysisMemberList, 'highFrequencyOutput', 1) - call mpas_pool_add_config(analysisMemberList, 'timeAverages', 1) + call mpas_pool_add_config(analysisMemberList, 'timeSeriesStats', 1) ! call mpas_pool_add_config(analysisMemberList, 'temPlate', 1) ! DON'T EDIT BELOW HERE @@ -742,8 +742,8 @@ subroutine ocn_init_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_init_zonal_mean(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then call ocn_init_high_frequency_output(domain, err_tmp) - else if ( analysisMemberName(1:nameLength) == 'timeAverages' ) then - call ocn_init_time_averages(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'timeSeriesStats' ) then + call ocn_init_time_series_stats(domain, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_init_TEM_PLATE(domain, err_tmp) end if @@ -793,8 +793,8 @@ subroutine ocn_compute_analysis_members(domain, timeLevel, analysisMemberName, i call ocn_compute_zonal_mean(domain, timeLevel, err_tmp) else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then call ocn_compute_high_frequency_output(domain, timeLevel, err_tmp) - else if ( analysisMemberName(1:nameLength) == 'timeAverages' ) then - call ocn_compute_time_averages(domain, timeLevel, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'timeSeriesStats' ) then + call ocn_compute_time_series_stats(domain, timeLevel, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_compute_TEM_PLATE(domain, timeLevel, err_tmp) end if @@ -843,8 +843,8 @@ subroutine ocn_restart_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_restart_zonal_mean(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then call ocn_restart_high_frequency_output(domain, err_tmp) - else if ( analysisMemberName(1:nameLength) == 'timeAverages' ) then - call ocn_restart_time_averages(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'timeSeriesStats' ) then + call ocn_restart_time_series_stats(domain, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_restart_TEM_PLATE(domain, err_tmp) end if @@ -893,8 +893,8 @@ subroutine ocn_finalize_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_finalize_zonal_mean(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'highFrequencyOutput' ) then call ocn_finalize_high_frequency_output(domain, err_tmp) - else if ( analysisMemberName(1:nameLength) == 'timeAverages' ) then - call ocn_finalize_time_averages(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'timeSeriesStats' ) then + call ocn_finalize_time_series_stats(domain, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_finalize_TEM_PLATE(domain, err_tmp) end if diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_averages.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F similarity index 85% rename from src/core_ocean/analysis_members/mpas_ocn_time_averages.F rename to src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index 738d943e35..3f65151bcf 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_averages.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -7,15 +7,15 @@ ! !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! ocn_time_averages +! ocn_time_series_stats ! -!> \brief MPAS ocean analysis core member: time_averages +!> \brief MPAS ocean analysis core member: time_series_stats !> \author Jon Woodring !> \date March 2, 2015 !> \details -!> Flexible time averaging, mins, and maxes of fields. +!> Flexible time series averaging, mins, and maxes of fields. !----------------------------------------------------------------------- -module ocn_time_averages +module ocn_time_series_stats use mpas_derived_types use mpas_pool_routines use mpas_dmpar @@ -34,10 +34,10 @@ module ocn_time_averages ! Public member functions !-------------------------------------------------------------------- - public :: ocn_init_time_averages, & - ocn_compute_time_averages, & - ocn_restart_time_averages, & - ocn_finalize_time_averages + public :: ocn_init_time_series_stats, & + ocn_compute_time_series_stats, & + ocn_restart_time_series_stats, & + ocn_finalize_time_series_stats ! Private module variables !-------------------------------------------------------------------- @@ -48,8 +48,8 @@ module ocn_time_averages ! this keeps track of timers and if and when they need to accumulate type time_buffer_type ! internal state - logical :: started_flag, accumulate_flag, reset_flag, delay_reset_flag - logical :: reset_alarm_armed + logical :: started_flag, accumulate_flag, reset_flag + logical :: delay_reset_flag, duration_over_flag integer :: total_accum type (MPAS_Time_type) :: start_time @@ -104,11 +104,11 @@ module ocn_time_averages !*********************************************************************** ! routine walk_string ! -!> \brief Walk a space delimited string to find substrings +!> \brief Walk a semicolon delimited string to find substrings !> \author Jon Woodring !> \date March 2, 2015 !> \details -!> Walk a string delimited by spaces and return the first substring +!> Walk a string delimited by semicolons and return the first substring !> from start index, and modify start to point at the next candidate. !----------------------------------------------------------------------- subroutine walk_string(next, substr, ok)!{{{ @@ -128,22 +128,30 @@ subroutine walk_string(next, substr, ok)!{{{ !----------------------------------------------------------------- integer :: i character (len=StrKIND) :: copy - - ! find the first substring that isn't whitespace - i = verify(next, ' ') - ok = i > 0 - ! if we can't find one, stop - if (.not. ok) then - return - end if - ! make a new string and find the first whitespace - copy = next(i:) - i = scan(copy, ' ') + ! make a copy + copy = trim(next) + + ! if there's anything in it other than whitespace, pass through + i = verify(copy, ' ') + ok = i .gt. 0 + if (.not. ok) then + return + end if + copy = trim(next(i:)) + + ! find the first semicolon and split + i = scan(copy, ';') ! return that substring and the remainder - substr = copy(1:i-1) - next = copy(i:) + if (i .gt. 0) then + substr = trim(copy(1:i-1)) + next = trim(copy(i+1:)) + else + substr = trim(copy) + next = '' + end if + end subroutine walk_string!}}} @@ -158,12 +166,11 @@ end subroutine walk_string!}}} !> for the buffer structure so that alarms can be set. !----------------------------------------------------------------------- subroutine set_times(buffers, number_of_buffers, clock, & - which, config_str, inv_str, ok, err) + which, config_str, ok, err) ! input variables !----------------------------------------------------------------- integer, intent(in) :: number_of_buffers, which character (len=StrKIND), pointer, intent(in) :: config_str - character (len=StrKIND), intent(in) :: inv_str ! input/output variables !----------------------------------------------------------------- @@ -182,18 +189,20 @@ subroutine set_times(buffers, number_of_buffers, clock, & ! find the first time in the list next_str = config_str - b = 1 + b = 0 call walk_string(next_str, time_str, ok) + ! while the time string is ok do while (ok) ! exit if we went over + b = b + 1 if (b .gt. number_of_buffers) then exit end if ! set the time if (which .eq. START_TIMES) then - if (time_str .eq. 'same_as_simulation') then + if (time_str .eq. 'initial_time') then buffers(b) % start_time = mpas_get_clock_time(clock, & MPAS_NOW, err) else @@ -201,35 +210,30 @@ subroutine set_times(buffers, number_of_buffers, clock, & dateTimeString=time_str, ierr=err) end if else if (which .eq. DURATION_INTERVALS) then - if (time_str .eq. 'same_as_repeat') then + if (time_str .eq. 'repeat_interval') then buffers(b) % duration_interval = buffers(b) % repeat_interval else call mpas_set_timeInterval(buffers(b) % duration_interval, & timeString=time_str, ierr=err) end if else if (which .eq. REPEAT_INTERVALS) then - if (time_str .eq. 'same_as_reset') then + if (time_str .eq. 'reset_interval') then buffers(b) % repeat_interval = buffers(b) % reset_interval else call mpas_set_timeInterval(buffers(b) % repeat_interval, & timeString=time_str, ierr=err) end if else - if (time_str .eq. 'same_as_output') then - buffers(b) % reset_alarm_armed = .false. - else - call mpas_set_timeInterval(buffers(b) % reset_interval, & - timeString=time_str, ierr=err) - buffers(b) % reset_alarm_armed = .true. - end if + call mpas_set_timeInterval(buffers(b) % reset_interval, & + timeString=time_str, ierr=err) end if + ! get the next time string - b = b + 1 call walk_string(next_str, time_str, ok) end do ! only ok if we parsed out as many as there are number of buffers - ok = number_of_buffers .eq. (b - 1) + ok = number_of_buffers .eq. b end subroutine set_times @@ -322,7 +326,7 @@ end subroutine add_new_field!}}} !*********************************************************************** -! routine ocn_init_time_averages +! routine ocn_init_time_series_stats ! !> \brief Initialize MPAS-Ocean analysis member !> \author Jon Woodring @@ -331,7 +335,7 @@ end subroutine add_new_field!}}} !> This routine conducts all initializations required for the !> MPAS-Ocean analysis member. !----------------------------------------------------------------------- - subroutine ocn_init_time_averages(domain, err)!{{{ + subroutine ocn_init_time_series_stats(domain, err)!{{{ ! input variables !----------------------------------------------------------------- @@ -348,21 +352,23 @@ subroutine ocn_init_time_averages(domain, err)!{{{ !----------------------------------------------------------------- integer :: v, b character (len=StrKIND), pointer :: config_results - integer, pointer :: number_of_buffers - integer :: number_of_variables + logical, pointer :: copy_mesh + integer :: number_of_variables, number_of_buffers character (len=StrKIND) :: stream_str, prefix_str, & - config_str, buffer_str, op_str, var_str, field, inv_time + config_str, buffer_str, op_str, var_str, field logical :: ok ! start procedure !----------------------------------------------------------------- err = 0 + ! TODO do restart + ! string representation ! TODO placeholder for some unique ID if this code is replicated ! per multiple AMs for multiple streams stream_str = '' - prefix_str = 'config_AM_timeAverages' // trim(stream_str) + prefix_str = 'config_AM_timeSeriesStats' // trim(stream_str) ! get our operation config_str = trim(prefix_str) // '_operation' @@ -378,97 +384,105 @@ subroutine ocn_init_time_averages(domain, err)!{{{ op_str = 'max' else ! error if unknown operation - call mpas_dmpar_global_abort('Error: unknown operation in time averaging analysis member configuration.') + call mpas_dmpar_global_abort('Error: unknown operation in time ' // & + 'averaging analysis member configuration.') end if - ! get the number of individual buffers and set up timers - config_str = trim(prefix_str) // '_number_of_buffers' - call mpas_pool_get_config(domain % configs, config_str, number_of_buffers) - - ! assert number_of_buffers > 0 - if (number_of_buffers .lt. 1) then - call mpas_dmpar_global_abort('Error: number of buffers < 0 in time averaging analysis member configuration.') - end if + ! count string tokens + config_str = trim(prefix_str) // '_initial_times' + call mpas_pool_get_config(domain % configs, config_str, config_results) + field = config_results + number_of_buffers = 1 + b = scan(field, ';') + do while (b .gt. 0) + number_of_buffers = number_of_buffers + 1 + field = field(b+1:) + b = scan(field, ';') + end do ! get the stream name config_str = trim(prefix_str) // '_stream_name' call mpas_pool_get_config(domain % configs, config_str, stream_name) if (stream_name .eq. 'none') then - call mpas_dmpar_global_abort('Error: stream cannot be "none" for time averages.') + call mpas_dmpar_global_abort('Error: stream cannot be "none" ' // & + 'for time series stats.') end if ! set up all of the timing ! - ! order matters, don't reorder these! - ! it matters because times/intervals can be configured to be equal ! allocate the state for the buffers allocate(buffers(number_of_buffers)) - ! get the interval time - call mpas_stream_mgr_get_property(domain % streamManager, & - stream_name, MPAS_STREAM_PROPERTY_FILENAME_INTV, & - inv_time, err) + ! configure start times + config_str = trim(prefix_str) // '_initial_times' + call mpas_pool_get_config(domain % configs, config_str, config_results) + call set_times(buffers, number_of_buffers, domain % clock, & + START_TIMES, config_results, ok, err) + + ! order matters, don't reorder these following ones! + ! it matters because times/intervals can be configured to be equal + ! to other ones ! configure reset intervals config_str = trim(prefix_str) // '_reset_intervals' call mpas_pool_get_config(domain % configs, config_str, config_results) call set_times(buffers, number_of_buffers, domain % clock, & - RESET_INTERVALS, config_results, inv_time, ok, err) + RESET_INTERVALS, config_results, ok, err) if (.not. ok) then - call mpas_dmpar_global_abort('Error: number_of_buffers != number of reset_intervals in time averaging member analysis member configuration.') + call mpas_dmpar_global_abort('Error: number of times in ' // & + 'reset_intervals is not consistent with number of times ' // & + 'in initial_times in time series stats analysis member ' // & + 'configuration.') end if - ! TODO? sanity check that it is <= output_interval ! configure repeat intervals config_str = trim(prefix_str) // '_repeat_intervals' call mpas_pool_get_config(domain % configs, config_str, config_results) call set_times(buffers, number_of_buffers, domain % clock, & - REPEAT_INTERVALS, config_results, inv_time, ok, err) + REPEAT_INTERVALS, config_results, ok, err) if (.not. ok) then - call mpas_dmpar_global_abort('Error: number_of_buffers != number of repeat_intervals in time averaging member analysis member configuration.') + call mpas_dmpar_global_abort('Error: number of times in ' // & + 'repeat_intervals is not consistent with number of times ' // & + 'in initial_times in time series stats analysis member ' // & + 'configuration.') end if ! configure duration intervals config_str = trim(prefix_str) // '_duration_intervals' call mpas_pool_get_config(domain % configs, config_str, config_results) call set_times(buffers, number_of_buffers, domain % clock, & - DURATION_INTERVALS, config_results, inv_time, ok, err) + DURATION_INTERVALS, config_results, ok, err) if (.not. ok) then - call mpas_dmpar_global_abort('Error: number_of_buffers != number of duration_intervals in time averaging member analysis member configuration.') - end if - ! TODO sanity check to see if >= compute_interval * 2 - - ! configure start times - config_str = trim(prefix_str) // '_initial_times' - call mpas_pool_get_config(domain % configs, config_str, config_results) - call set_times(buffers, number_of_buffers, domain % clock, & - START_TIMES, config_results, inv_time, ok, err) - if (.not. ok) then - call mpas_dmpar_global_abort('Error: number_of_buffers != number of initial_times in time averaging member analysis member configuration.') + call mpas_dmpar_global_abort('Error: number of times in ' // & + 'duration_intervals is not consistent with number of times ' // & + 'in initial_times in time series stats analysis member ' // & + 'configuration.') end if ! check if the configuration is sensible do b = 1, number_of_buffers if (buffers(b) % repeat_interval .gt. & buffers(b) % reset_interval) then - ! TODO error out - write(stderrUnit,*) 'Warning: repeat_interval > reset_interval in time averaging analysis member configuration. Truncating repeat_interval.' + write(stderrUnit,*) 'Warning: repeat_interval > ' // & + 'reset_interval in time averaging analysis member ' // & + 'configuration. Truncating repeat_interval.' buffers(b) % repeat_interval = buffers(b) % reset_interval end if if (buffers(b) % duration_interval .gt. & buffers(b) % repeat_interval) then - ! TODO error out - write(stderrUnit,*) 'Warning: duration_interval > repeat_interval in time averaging analysis member configuration. Truncating duration_interval.' + write(stderrUnit,*) 'Warning: duration_interval > ' // & + 'repeat_interval in time averaging analysis member ' // & + 'configuration. Truncating duration_interval.' buffers(b) % repeat_interval = buffers(b) % reset_interval end if end do ! ! OK, if we got this far, then we should be able to allocate memory - ! and set up the timers and variables that we will average + ! and set up the timers and variables that we will analyze ! ! count the number of variables @@ -503,16 +517,18 @@ subroutine ocn_init_time_averages(domain, err)!{{{ call mpas_stream_mgr_add_field(domain % streamManager, & stream_name, 'xtime', ierr=err) - ! - ! TODO How to add mesh to stream? - ! - !! optionally add mesh to stream - !call mpas_pool_get_config(domain % configs, & - ! 'config_time_averages_copy_mesh', copy_mesh) - !if (copy_mesh) then - ! call mpas_stream_mgr_add_stream_fields(manager, stream_name, & - ! 'mesh', err) - !end if + ! optionally add mesh to stream + config_str = trim(prefix_str) // '_add_mesh' + call mpas_pool_get_config(domain % configs, config_str, copy_mesh) + if (copy_mesh) then + call mpas_stream_mgr_begin_iteration(domain % streamManager, & + 'mesh', err) + do while (mpas_stream_mgr_get_next_field(domain % streamManager, & + 'mesh', field)) + call mpas_stream_mgr_add_field(domain % streamManager, & + stream_name, field, ierr=err) + end do + end if ! set up the variables call mpas_stream_mgr_begin_iteration(domain % streamManager, & @@ -532,7 +548,10 @@ subroutine ocn_init_time_averages(domain, err)!{{{ .or. & (variables(v) % info % fieldType .eq. MPAS_POOL_INTEGER))) & then - call mpas_dmpar_global_abort('Error: a field listed in the output stream is not real or integer in time averaging analysis member configuration.') + call mpas_dmpar_global_abort('Error: field "' // & + trim(variables(v) % input_name) // '" listed in the ' // & + 'output stream, for time series stats analysis member ' // & + 'stream, is not real or integer.') end if ! allocate a number of fields and add field @@ -569,7 +588,8 @@ subroutine ocn_init_time_averages(domain, err)!{{{ 'tavg_repeat' // trim(stream_str) // '_' // buffer_str call mpas_add_clock_alarm(domain % clock, & buffers(b) % repeat_alarm_ID, & - buffers(b) % start_time, & + buffers(b) % start_time + & + buffers(b) % repeat_interval, & buffers(b) % repeat_interval, ierr=err) buffers(b) % duration_alarm_ID = & @@ -584,7 +604,8 @@ subroutine ocn_init_time_averages(domain, err)!{{{ 'tavg_reset' // trim(stream_str) // '_' // buffer_str call mpas_add_clock_alarm(domain % clock, & buffers(b) % reset_alarm_ID, & - buffers(b) % start_time, & + buffers(b) % start_time + & + buffers(b) % reset_interval, & buffers(b) % reset_interval, ierr=err) end do @@ -594,9 +615,10 @@ subroutine ocn_init_time_averages(domain, err)!{{{ buffers(b) % reset_flag = .false. buffers(b) % accumulate_flag = .false. buffers(b) % delay_reset_flag = .false. + buffers(b) % duration_over_flag = .false. end do - end subroutine ocn_init_time_averages!}}} + end subroutine ocn_init_time_series_stats!}}} @@ -637,6 +659,8 @@ subroutine timer_checking(domain, err)!{{{ call mpas_reset_clock_alarm(domain % clock, & buffers(b) % start_alarm_ID, ierr=err) buffers(b) % started_flag = .true. + buffers(b) % accumulate_flag = .true. + ! TODO only reset if not restart buffers(b) % reset_flag = .true. end if @@ -648,19 +672,13 @@ subroutine timer_checking(domain, err)!{{{ ! check various other alarms ! see if we need to reset - if (buffers(b) % reset_alarm_armed) then - if(mpas_is_alarm_ringing(domain % clock, & - buffers(b) % reset_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(domain % clock, & - buffers(b) % reset_alarm_ID, ierr=err) - buffers(b) % reset_flag = .true. - end if - else - if(mpas_stream_mgr_ringing_alarms(domain % streamManager, & - stream_name)) then - buffers(b) % reset_flag = .true. - end if - end if + if(mpas_is_alarm_ringing(domain % clock, & + buffers(b) % reset_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(domain % clock, & + buffers(b) % reset_alarm_ID, ierr=err) + buffers(b) % reset_flag = .true. + buffers(b) % delay_reset_flag = .true. + end if ! turn off accumulation ! @@ -670,7 +688,7 @@ subroutine timer_checking(domain, err)!{{{ buffers(b) % duration_alarm_ID, ierr=err)) then call mpas_reset_clock_alarm(domain % clock, & buffers(b) % duration_alarm_ID, ierr=err) - buffers(b) % accumulate_flag = .false. + buffers(b) % duration_over_flag = .true. end if ! turn on accumulation @@ -681,17 +699,9 @@ subroutine timer_checking(domain, err)!{{{ call mpas_reset_clock_alarm(domain % clock, & buffers(b) % repeat_alarm_ID, ierr=err) buffers(b) % accumulate_flag = .true. + buffers(b) % duration_over_flag = .false. end if - ! see if we need to delay resetting to the next time around, - ! when the reset is on the same time as an output - ! (we don't want to clear if we are outputting) - if (buffers(b) % reset_flag) then - if(mpas_stream_mgr_ringing_alarms(domain % streamManager, & - stream_name)) then - buffers(b) % delay_reset_flag = .true. - end if - end if end do end subroutine timer_checking!}}} @@ -846,7 +856,7 @@ end subroutine operate ## SUBNAME ; !*********************************************************************** ! routine typed_operate ! -!> \brief Do the averaging, but switch on run-time type +!> \brief Do the operation, but switch on run-time type !> \author Jon Woodring !> \date March 2, 2015 !> \details @@ -959,7 +969,7 @@ subroutine typed_operate(block, tvar, operation)!{{{ end subroutine typed_operate!}}} !*********************************************************************** -! routine ocn_compute_time_averages +! routine ocn_compute_time_series_stats ! !> \brief Compute MPAS-Ocean analysis member !> \author Jon Woodring @@ -968,7 +978,7 @@ end subroutine typed_operate!}}} !> This routine conducts all computation required for this !> MPAS-Ocean analysis member. !----------------------------------------------------------------------- - subroutine ocn_compute_time_averages(domain, timeLevel, err)!{{{ + subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ ! input variables !----------------------------------------------------------------- integer, intent(in) :: timeLevel @@ -1007,21 +1017,26 @@ subroutine ocn_compute_time_averages(domain, timeLevel, err)!{{{ call typed_operate(domain % blocklist, variables(v), operation) end do - ! clear resets + ! clear resets and accumulation do b = 1, size(buffers) if (buffers(b) % delay_reset_flag) then buffers(b) % delay_reset_flag = .false. else buffers(b) % reset_flag = .false. end if + + if (buffers(b) % duration_over_flag) then + buffers(b) % duration_over_flag = .false. + buffers(b) % accumulate_flag = .false. + end if end do - end subroutine ocn_compute_time_averages!}}} + end subroutine ocn_compute_time_series_stats!}}} !*********************************************************************** -! routine ocn_restart_time_averages +! routine ocn_restart_time_series_stats ! !> \brief Save restart for MPAS-Ocean analysis member !> \author Jon Woodring @@ -1030,7 +1045,7 @@ end subroutine ocn_compute_time_averages!}}} !> This routine conducts computation required to save a restart state !> for the MPAS-Ocean analysis member. !----------------------------------------------------------------------- - subroutine ocn_restart_time_averages(domain, err)!{{{ + subroutine ocn_restart_time_series_stats(domain, err)!{{{ ! input variables !----------------------------------------------------------------- @@ -1052,12 +1067,12 @@ subroutine ocn_restart_time_averages(domain, err)!{{{ ! TODO save data to restart and accumulate - end subroutine ocn_restart_time_averages!}}} + end subroutine ocn_restart_time_series_stats!}}} !*********************************************************************** -! routine ocn_finalize_time_averages +! routine ocn_finalize_time_series_stats ! !> \brief Finalize MPAS-Ocean analysis member !> \author Jon Woodring @@ -1066,7 +1081,7 @@ end subroutine ocn_restart_time_averages!}}} !> This routine conducts all finalizations required for this !> MPAS-Ocean analysis member. !----------------------------------------------------------------------- - subroutine ocn_finalize_time_averages(domain, err)!{{{ + subroutine ocn_finalize_time_series_stats(domain, err)!{{{ ! input variables !----------------------------------------------------------------- @@ -1101,9 +1116,9 @@ subroutine ocn_finalize_time_averages(domain, err)!{{{ deallocate(variables) end if - end subroutine ocn_finalize_time_averages!}}} + end subroutine ocn_finalize_time_series_stats!}}} -end module ocn_time_averages +end module ocn_time_series_stats ! vim: foldmethod=marker From 1f46d886adad9b49ee1a709edfcec88053cf81d5 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 6 Aug 2015 14:08:34 -0600 Subject: [PATCH 0129/1724] Modify how bulk richardson number is computed for kpp This commit modifies the bulk richardson number to be computed once per column, after the turbulent scales velocity is computed for each layer. This change reduces the computational expense from this portion of code by ~5x, and removes the load imbalance caused by performing N^2 operations. --- src/core_ocean/shared/mpas_ocn_vmix_cvmix.F | 100 ++++++++------------ 1 file changed, 42 insertions(+), 58 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F b/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F index caf54b5e12..c0d218aaac 100644 --- a/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F +++ b/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F @@ -75,7 +75,7 @@ module ocn_vmix_cvmix !> \brief Computes mixing coefficients using CVMix !> \author Todd Ringler !> \date 04 February 2013 -!> \details +!> \details !> This routine computes the vertical mixing coefficients for momentum !> and tracers by calling CVMix routines. ! @@ -91,7 +91,7 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information - + integer, intent(in), optional :: timeLevelIn !< Input: time level for state pool !----------------------------------------------------------------- @@ -126,7 +126,7 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, real (kind=RKIND), dimension(:), pointer :: & latCell, lonCell, bottomDepth, surfaceBuoyancyForcing, surfaceFrictionVelocity, fCell, & boundaryLayerDepth, ssh, indexBoundaryLayerDepth - + real (kind=RKIND), dimension(:,:), pointer :: & vertViscTopOfCell, vertDiffTopOfCell, layerThickness, & zMid, zTop, density, displacedDensity, potentialDensity, & @@ -145,7 +145,8 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, integer :: k, iCell, jCell, iNeighbor, iter, timeLevel, kIndexOBL integer, pointer :: nVertLevels, nCells real (kind=RKIND) :: r, layerSum, bulkRichardsonNumberStop - real (kind=RKIND), dimension(:), allocatable :: sigma, Nsqr_iface, turbulentScalarVelocityScale, tmp + real (kind=RKIND) :: sigma, turbulentScalarVelocityScalePoint + real (kind=RKIND), dimension(:), allocatable :: Nsqr_iface, turbulentScalarVelocityScale, tmp real (kind=RKIND), dimension(:), allocatable, target :: RiSmoothed, BVFSmoothed logical :: bulkRichardsonFlag @@ -154,11 +155,11 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, !----------------------------------------------------------------- ! ! call relevant routines for computing mixing-related fields - ! note that the user can choose multiple options and the + ! note that the user can choose multiple options and the ! mixing fields have to be added/merged together ! !----------------------------------------------------------------- - + ! ! assume no errors during initialization and set to 1 when error is encountered ! @@ -271,9 +272,7 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, allocate(cvmix_variables % dzt(nVertLevels)) allocate(cvmix_variables % kpp_Tnonlocal_iface(nVertLevels+1)) allocate(cvmix_variables % kpp_Snonlocal_iface(nVertLevels+1)) - allocate(cvmix_variables % BulkRichardson_cntr(nVertLevels)) - allocate(sigma(nVertLevels)) allocate(Nsqr_iface(nVertLevels+1)) allocate(turbulentScalarVelocityScale(nVertLevels)) allocate(tmp(nVertLevels+1)) @@ -296,7 +295,7 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, do k=2,maxLevelCell(iCell) cvmix_variables % zw_iface(k) = cvmix_variables % zw_iface(k-1) - layerThickness(k-1,iCell) cvmix_variables % zt_cntr(k) = cvmix_variables % zw_iface(k) - layerThickness(k,iCell)/2.0 - cvmix_variables % dzw(k) = cvmix_variables % zt_cntr(k-1) - cvmix_variables % zt_cntr(k) + cvmix_variables % dzw(k) = cvmix_variables % zt_cntr(k-1) - cvmix_variables % zt_cntr(k) cvmix_variables % dzt(k) = layerThickness(k,iCell) enddo k = maxLevelCell(iCell)+1 @@ -332,6 +331,7 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, ! fill the intent(in) KPP cvmix_variables % SurfaceFriction = surfaceFrictionVelocity(iCell) cvmix_variables % SurfaceBuoyancyForcing = surfaceBuoyancyForcing(iCell) + cvmix_variables % BulkRichardson_cntr => bulkRichardsonNumber(:, iCell) ! call kpp ocean mixed layer scheme if (cvmixKPPOn) then @@ -358,60 +358,46 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, bulkRichardsonNumber(:,iCell) = bulkRichardsonNumberStop - 1.0 kIndexOBL=1 bulkRichardsonFlag = .false. - do while (.not.bulkRichardsonFlag) + do kIndexOBL = 1, maxLevelCell(iCell) ! set OBL at bottome of kIndexOBL cell for computation of bulk Richardson number cvmix_variables % BoundaryLayerDepth = cvmix_variables % zw_iface(kIndexOBL+1) - - ! define sigma based on assumption of where OBL bottom resides - do k=1,maxLevelCell(iCell) - sigma(k) = -cvmix_variables % zt_cntr(k) / cvmix_variables % BoundaryLayerDepth - enddo - do k=maxLevelCell(iCell)+1,nVertLevels - sigma(k) = sigma(maxLevelCell(iCell)) - enddo - + + sigma = -cvmix_variables % zt_cntr(kIndexOBL) / cvmix_variables % BoundaryLayerDepth + ! compute the turbulent scales in order to compute the bulk Richardson number call cvmix_kpp_compute_turbulent_scales( & - sigma_coord = sigma(1:nVertLevels), & + sigma_coord = sigma, & OBL_depth = cvmix_variables % BoundaryLayerDepth, & surf_buoy_force = cvmix_variables % SurfaceBuoyancyForcing, & surf_fric_vel = cvmix_variables % SurfaceFriction, & - w_s = turbulentScalarVelocityScale(1:nVertLevels)) - - cvmix_variables % BulkRichardson_cntr = cvmix_kpp_compute_bulk_Richardson( & - zt_cntr = cvmix_variables % zt_cntr(1:nVertLevels), & - delta_buoy_cntr = bulkRichardsonNumberBuoy(1:nVertLevels,iCell), & - delta_Vsqr_cntr = bulkRichardsonNumberShear(1:nVertLevels,iCell), & - ws_cntr = turbulentScalarVelocityScale(:), & - Nsqr_iface = Nsqr_iface(1:nVertLevels+1) ) - - unresolvedShear(:,iCell) = cvmix_kpp_compute_unresolved_shear( & - zt_cntr = cvmix_variables % zt_cntr(1:nVertLevels), & - ws_cntr = turbulentScalarVelocityScale(1:nVertLevels), & - Nsqr_iface = Nsqr_iface(1:nVertLevels+1)) - - ! each level of bulk Richardson is computed as if OBL resided at bottom of that level - bulkRichardsonNumber(kIndexOBL,iCell) = cvmix_variables % BulkRichardson_cntr(kIndexOBL) - - ! test to see if search should be ended - if(kIndexOBL.eq.maxLevelCell(iCell)) bulkRichardsonFlag=.true. - if(bulkRichardsonNumber(kIndexOBL,iCell).gt.bulkRichardsonNumberStop) bulkRichardsonFlag=.true. - - ! move downward one level - kIndexOBL = kIndexOBL + 1 - - enddo ! do while (.not.bulkRichardsonFlag) - - call cvmix_kpp_compute_OBL_depth( & - Ri_bulk = bulkRichardsonNumber(1:nVertLevels,iCell), & - zw_iface = cvmix_variables % zw_iface(1:nVertLevels+1), & - OBL_depth = cvmix_variables % BoundaryLayerDepth, & - kOBL_depth = cvmix_variables % kOBL_depth, & - zt_cntr = cvmix_variables % zt_cntr(1:nVertLevels), & + w_s = turbulentScalarVelocityScale(kIndexOBL)) + + enddo ! do kIndexOBL + + cvmix_variables % bulkRichardson_cntr(:) = cvmix_kpp_compute_bulk_Richardson( & + zt_cntr = cvmix_variables % zt_cntr(1:nVertLevels), & + delta_buoy_cntr = bulkRichardsonNumberBuoy(1:nVertLevels,iCell), & + delta_Vsqr_cntr = bulkRichardsonNumberShear(1:nVertLevels,iCell), & + ws_cntr = turbulentScalarVelocityScale(:), & + Nsqr_iface = Nsqr_iface(1:nVertLevels+1) ) + + ! each level of bulk Richardson is computed as if OBL resided at bottom of that level + + unresolvedShear(:,iCell) = cvmix_kpp_compute_unresolved_shear( & + zt_cntr = cvmix_variables % zt_cntr(1:nVertLevels), & + ws_cntr = turbulentScalarVelocityScale(1:nVertLevels), & + Nsqr_iface = Nsqr_iface(1:nVertLevels+1)) + + call cvmix_kpp_compute_OBL_depth( & + Ri_bulk = bulkRichardsonNumber(1:nVertLevels,iCell), & + zw_iface = cvmix_variables % zw_iface(1:nVertLevels+1), & + OBL_depth = cvmix_variables % BoundaryLayerDepth, & + kOBL_depth = cvmix_variables % kOBL_depth, & + zt_cntr = cvmix_variables % zt_cntr(1:nVertLevels), & surf_fric = cvmix_variables % SurfaceFriction, & - surf_buoy = cvmix_variables % SurfaceBuoyancyForcing, & - Coriolis = cvmix_variables % Coriolis) + surf_buoy = cvmix_variables % SurfaceBuoyancyForcing, & + Coriolis = cvmix_variables % Coriolis) endif ! if (config_use_cvmix_fixed_boundary_layer) then @@ -544,9 +530,7 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, deallocate(cvmix_variables % zt_cntr) deallocate(cvmix_variables % dzt) deallocate(cvmix_variables % kpp_Tnonlocal_iface) - deallocate(cvmix_variables % BulkRichardson_cntr) - deallocate(sigma) deallocate(Nsqr_iface) deallocate(turbulentScalarVelocityScale) deallocate(tmp) @@ -565,8 +549,8 @@ end subroutine ocn_vmix_coefs_cvmix_build!}}} !> \ get and puts into CVMix !> \author Todd Ringler !> \date 04 February 2013 -!> \details -!> This routine initializes a variety of quantities related to +!> \details +!> This routine initializes a variety of quantities related to !> vertical mixing in the ocean. Parameters are set by calling into CVMix ! !----------------------------------------------------------------------- From 42bc04b9a7aab16c7fa68f1beea3ed66909c904b Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Wed, 12 Aug 2015 14:15:14 -0600 Subject: [PATCH 0130/1724] correct units of variable sfcMassBal in Registry comments --- src/core_landice/Registry.xml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 159e332905..68f43bcb61 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -626,10 +626,10 @@ is the value of that variable from the *previous* time level! /> - - From 1a55a1961601098d9eea518be8836c279b463e1f Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Thu, 13 Aug 2015 15:50:54 -0600 Subject: [PATCH 0131/1724] Fist stab at altering build system to allow for shared and mode_forward dir structures --- src/core_landice/Makefile | 86 ++++++------------- src/core_landice/build_options.mk | 4 +- .../Interface_velocity_solver.cpp | 0 .../Interface_velocity_solver.hpp | 0 src/core_landice/mode_forward/Makefile | 79 +++++++++++++++++ .../{ => mode_forward}/mpas_li_core.F | 0 .../mpas_li_core_interface.F | 0 .../mpas_li_diagnostic_vars.F | 0 .../{ => mode_forward}/mpas_li_mask.F | 0 .../{ => mode_forward}/mpas_li_setup.F | 0 .../{ => mode_forward}/mpas_li_sia.F | 0 .../{ => mode_forward}/mpas_li_statistics.F | 0 .../{ => mode_forward}/mpas_li_tendency.F | 0 .../mpas_li_time_integration.F | 0 .../mpas_li_time_integration_fe.F | 0 .../{ => mode_forward}/mpas_li_velocity.F | 0 .../mpas_li_velocity_external.F | 0 src/core_landice/shared/Makefile | 23 +++++ .../{ => shared}/mpas_li_constants.F | 0 19 files changed, 128 insertions(+), 64 deletions(-) rename src/core_landice/{ => mode_forward}/Interface_velocity_solver.cpp (100%) rename src/core_landice/{ => mode_forward}/Interface_velocity_solver.hpp (100%) create mode 100644 src/core_landice/mode_forward/Makefile rename src/core_landice/{ => mode_forward}/mpas_li_core.F (100%) rename src/core_landice/{ => mode_forward}/mpas_li_core_interface.F (100%) rename src/core_landice/{ => mode_forward}/mpas_li_diagnostic_vars.F (100%) rename src/core_landice/{ => mode_forward}/mpas_li_mask.F (100%) rename src/core_landice/{ => mode_forward}/mpas_li_setup.F (100%) rename src/core_landice/{ => mode_forward}/mpas_li_sia.F (100%) rename src/core_landice/{ => mode_forward}/mpas_li_statistics.F (100%) rename src/core_landice/{ => mode_forward}/mpas_li_tendency.F (100%) rename src/core_landice/{ => mode_forward}/mpas_li_time_integration.F (100%) rename src/core_landice/{ => mode_forward}/mpas_li_time_integration_fe.F (100%) rename src/core_landice/{ => mode_forward}/mpas_li_velocity.F (100%) rename src/core_landice/{ => mode_forward}/mpas_li_velocity_external.F (100%) create mode 100644 src/core_landice/shared/Makefile rename src/core_landice/{ => shared}/mpas_li_constants.F (100%) diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index e288936fdf..b031562b85 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -41,29 +41,30 @@ override CPPFLAGS += $(EXTERNAL_DYCORE_FLAG) .SUFFIXES: .F .o .cpp -OBJS = mpas_li_core.o \ - mpas_li_core_interface.o \ - mpas_li_time_integration.o \ - mpas_li_time_integration_fe.o \ - mpas_li_diagnostic_vars.o \ - mpas_li_tendency.o \ - mpas_li_setup.o \ - mpas_li_statistics.o \ - mpas_li_velocity.o \ - mpas_li_sia.o \ - mpas_li_mask.o \ - mpas_li_velocity_external.o - -ifeq "$(BUILD_INTERFACE)" "true" - OBJS += Interface_velocity_solver.o -endif - - - -all: core_landice +#OBJS = mpas_li_core.o \ +# mpas_li_core_interface.o \ +# mpas_li_time_integration.o \ +# mpas_li_time_integration_fe.o \ +# mpas_li_diagnostic_vars.o \ +# mpas_li_tendency.o \ +# mpas_li_setup.o \ +# mpas_li_statistics.o \ +# mpas_li_velocity.o \ +# mpas_li_sia.o \ +# mpas_li_mask.o \ +# mpas_li_velocity_external.o +# +#ifeq "$(BUILD_INTERFACE)" "true" +# OBJS += Interface_velocity_solver.o +#endif + + + +all: core_landice shared mode_forward core_landice: $(OBJS) - ar -ru libdycore.a $(OBJS) + ar -ru libdycore.a mode_forward/*.o + ar -ru libdycore.a shared/*.o core_reg: $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml @@ -83,48 +84,9 @@ post_build: cp default_inputs/* $(ROOT_DIR)/default_inputs/. ( cd $(ROOT_DIR)/default_inputs; for FILE in `ls -1`; do if [ ! -e ../$$FILE ]; then cp $$FILE ../.; fi; done ) -mpas_li_core_interface.o: mpas_li_core.o - -mpas_li_core.o: mpas_li_time_integration.o \ - mpas_li_setup.o \ - mpas_li_velocity.o \ - mpas_li_diagnostic_vars.o \ - mpas_li_statistics.o \ - mpas_li_mask.o - -mpas_li_setup.o: - -mpas_li_time_integration.o: mpas_li_time_integration_fe.o - -mpas_li_time_integration_fe.o: mpas_li_velocity.o \ - mpas_li_tendency.o \ - mpas_li_diagnostic_vars.o \ - mpas_li_setup.o - -mpas_li_tendency.o: mpas_li_setup.o - -mpas_li_diagnostic_vars.o: mpas_li_mask.o \ - mpas_li_velocity.o \ - mpas_li_constants.o - -mpas_li_velocity.o: mpas_li_sia.o \ - mpas_li_setup.o \ - mpas_li_velocity_external.o - -mpas_li_sia.o: mpas_li_mask.o \ - mpas_li_setup.o - -mpas_li_statistics.o: mpas_li_mask.o \ - mpas_li_setup.o \ - mpas_li_constants.o - -mpas_li_mask.o: mpas_li_setup.o - -mpas_li_constants.o: - -mpas_li_velocity_external.o: +shared: (cd shared; $(MAKE)) -Interface_velocity_solver.o: +mode_forward: (cd mode_forward; $(MAKE)) clean: $(RM) *.o *.mod *.f90 libdycore.a diff --git a/src/core_landice/build_options.mk b/src/core_landice/build_options.mk index 8e39817813..aeb3d173f4 100644 --- a/src/core_landice/build_options.mk +++ b/src/core_landice/build_options.mk @@ -3,8 +3,8 @@ ifeq "$(ROOT_DIR)" "" endif EXE_NAME=landice_model NAMELIST_SUFFIX=landice -FCINCLUDES += -I$(ROOT_DIR)/core_landice +FCINCLUDES += -I$(ROOT_DIR)/core_landice/forward_model -I$(ROOT_DIR)/core_landice/shared override CPPFLAGS += -DCORE_LANDICE report_builds: - @echo "CORE=landice" + @echo "CORE=landice" diff --git a/src/core_landice/Interface_velocity_solver.cpp b/src/core_landice/mode_forward/Interface_velocity_solver.cpp similarity index 100% rename from src/core_landice/Interface_velocity_solver.cpp rename to src/core_landice/mode_forward/Interface_velocity_solver.cpp diff --git a/src/core_landice/Interface_velocity_solver.hpp b/src/core_landice/mode_forward/Interface_velocity_solver.hpp similarity index 100% rename from src/core_landice/Interface_velocity_solver.hpp rename to src/core_landice/mode_forward/Interface_velocity_solver.hpp diff --git a/src/core_landice/mode_forward/Makefile b/src/core_landice/mode_forward/Makefile new file mode 100644 index 0000000000..823db41bc0 --- /dev/null +++ b/src/core_landice/mode_forward/Makefile @@ -0,0 +1,79 @@ +.SUFFIXES: .F .o .cpp + +OBJS = mpas_li_core.o \ + mpas_li_core_interface.o \ + mpas_li_time_integration.o \ + mpas_li_time_integration_fe.o \ + mpas_li_diagnostic_vars.o \ + mpas_li_tendency.o \ + mpas_li_setup.o \ + mpas_li_statistics.o \ + mpas_li_velocity.o \ + mpas_li_sia.o \ + mpas_li_mask.o \ + mpas_li_velocity_external.o + +ifeq "$(BUILD_INTERFACE)" "true" + OBJS += Interface_velocity_solver.o +endif + +all: $(OBJS) + +mpas_li_core_interface.o: mpas_li_core.o + +mpas_li_core.o: mpas_li_time_integration.o \ + mpas_li_setup.o \ + mpas_li_velocity.o \ + mpas_li_diagnostic_vars.o \ + mpas_li_statistics.o \ + mpas_li_mask.o + +mpas_li_setup.o: + +mpas_li_time_integration.o: mpas_li_time_integration_fe.o + +mpas_li_time_integration_fe.o: mpas_li_velocity.o \ + mpas_li_tendency.o \ + mpas_li_diagnostic_vars.o \ + mpas_li_setup.o + +mpas_li_tendency.o: mpas_li_setup.o + +mpas_li_diagnostic_vars.o: mpas_li_mask.o \ + mpas_li_velocity.o \ + mpas_li_constants.o + +mpas_li_velocity.o: mpas_li_sia.o \ + mpas_li_setup.o \ + mpas_li_velocity_external.o + +mpas_li_sia.o: mpas_li_mask.o \ + mpas_li_setup.o + +mpas_li_statistics.o: mpas_li_mask.o \ + mpas_li_setup.o \ + mpas_li_constants.o + +mpas_li_mask.o: mpas_li_setup.o + +#mpas_li_constants.o: + +mpas_li_velocity_external.o: + +Interface_velocity_solver.o: + +clean: + $(RM) *.o *.mod *.f90 libdycore.a + $(RM) Registry_processed.xml + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i + $(RM) -r default_inputs + +.F.o: + $(RM) $@ $*.mod + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 + +.cpp.o: + $(CXX) $(CXXFLAGS) -c $*.cpp $(CXINCLUDES) $(CPPINCLUDES) -lmpi_cxx -lstdc++ $(CPPFLAGS) diff --git a/src/core_landice/mpas_li_core.F b/src/core_landice/mode_forward/mpas_li_core.F similarity index 100% rename from src/core_landice/mpas_li_core.F rename to src/core_landice/mode_forward/mpas_li_core.F diff --git a/src/core_landice/mpas_li_core_interface.F b/src/core_landice/mode_forward/mpas_li_core_interface.F similarity index 100% rename from src/core_landice/mpas_li_core_interface.F rename to src/core_landice/mode_forward/mpas_li_core_interface.F diff --git a/src/core_landice/mpas_li_diagnostic_vars.F b/src/core_landice/mode_forward/mpas_li_diagnostic_vars.F similarity index 100% rename from src/core_landice/mpas_li_diagnostic_vars.F rename to src/core_landice/mode_forward/mpas_li_diagnostic_vars.F diff --git a/src/core_landice/mpas_li_mask.F b/src/core_landice/mode_forward/mpas_li_mask.F similarity index 100% rename from src/core_landice/mpas_li_mask.F rename to src/core_landice/mode_forward/mpas_li_mask.F diff --git a/src/core_landice/mpas_li_setup.F b/src/core_landice/mode_forward/mpas_li_setup.F similarity index 100% rename from src/core_landice/mpas_li_setup.F rename to src/core_landice/mode_forward/mpas_li_setup.F diff --git a/src/core_landice/mpas_li_sia.F b/src/core_landice/mode_forward/mpas_li_sia.F similarity index 100% rename from src/core_landice/mpas_li_sia.F rename to src/core_landice/mode_forward/mpas_li_sia.F diff --git a/src/core_landice/mpas_li_statistics.F b/src/core_landice/mode_forward/mpas_li_statistics.F similarity index 100% rename from src/core_landice/mpas_li_statistics.F rename to src/core_landice/mode_forward/mpas_li_statistics.F diff --git a/src/core_landice/mpas_li_tendency.F b/src/core_landice/mode_forward/mpas_li_tendency.F similarity index 100% rename from src/core_landice/mpas_li_tendency.F rename to src/core_landice/mode_forward/mpas_li_tendency.F diff --git a/src/core_landice/mpas_li_time_integration.F b/src/core_landice/mode_forward/mpas_li_time_integration.F similarity index 100% rename from src/core_landice/mpas_li_time_integration.F rename to src/core_landice/mode_forward/mpas_li_time_integration.F diff --git a/src/core_landice/mpas_li_time_integration_fe.F b/src/core_landice/mode_forward/mpas_li_time_integration_fe.F similarity index 100% rename from src/core_landice/mpas_li_time_integration_fe.F rename to src/core_landice/mode_forward/mpas_li_time_integration_fe.F diff --git a/src/core_landice/mpas_li_velocity.F b/src/core_landice/mode_forward/mpas_li_velocity.F similarity index 100% rename from src/core_landice/mpas_li_velocity.F rename to src/core_landice/mode_forward/mpas_li_velocity.F diff --git a/src/core_landice/mpas_li_velocity_external.F b/src/core_landice/mode_forward/mpas_li_velocity_external.F similarity index 100% rename from src/core_landice/mpas_li_velocity_external.F rename to src/core_landice/mode_forward/mpas_li_velocity_external.F diff --git a/src/core_landice/shared/Makefile b/src/core_landice/shared/Makefile new file mode 100644 index 0000000000..bdd84d3c64 --- /dev/null +++ b/src/core_landice/shared/Makefile @@ -0,0 +1,23 @@ +.SUFFIXES: .F .o .cpp + +OBJS = mpas_li_constants.o + +all: $(OBJS) + +mpas_li_constants.o: + +clean: + $(RM) *.o *.mod *.f90 libdycore.a + $(RM) Registry_processed.xml + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i + $(RM) -r default_inputs + +.F.o: + $(RM) $@ $*.mod + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 + +.cpp.o: + $(CXX) $(CXXFLAGS) -c $*.cpp $(CXINCLUDES) $(CPPINCLUDES) -lmpi_cxx -lstdc++ $(CPPFLAGS) diff --git a/src/core_landice/mpas_li_constants.F b/src/core_landice/shared/mpas_li_constants.F similarity index 100% rename from src/core_landice/mpas_li_constants.F rename to src/core_landice/shared/mpas_li_constants.F From bd8eae3e0c0d6c8f4aaba7b9dc0d51f99aaef89a Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Thu, 13 Aug 2015 22:13:58 -0600 Subject: [PATCH 0132/1724] More work on modifying land ice core build to allow multiple directories (prep for adding analysis members) --- src/core_landice/Makefile | 103 ++++++++---------- src/core_landice/build_options.mk | 2 +- src/core_landice/mode_forward/Makefile | 22 ++-- .../mode_forward/mpas_li_core_interface.F | 16 +-- src/core_landice/shared/Makefile | 18 ++- 5 files changed, 72 insertions(+), 89 deletions(-) diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index b031562b85..ee684229ac 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -3,71 +3,52 @@ BUILD_INTERFACE=false # This will become true if any of the external libraries are being used. -# LifeV can solve L1L2 or FO -ifeq "$(LIFEV)" "true" - EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_L1L2 - EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER - BUILD_INTERFACE = true -endif # LIFEV IF - -# Albany can only solve FO at present -ifeq "$(ALBANY)" "true" - EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER - BUILD_INTERFACE = true -endif # ALBANY IF - -# Currently LifeV AND Albany is not allowed -ifeq "$(LIFEV)" "true" -ifeq "$(ALBANY)" "true" - $(error Compiling with both LifeV and Albany is not allowed at this time.) -endif -endif - -# PHG currently requires LifeV -ifeq "$(PHG)" "true" -ifneq "$(LIFEV)" "true" - $(error Compiling with PHG requires LifeV at this time.) -endif -endif -# PHG can only Stokes at present -ifeq "$(PHG)" "true" - EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_STOKES - BUILD_INTERFACE = true -endif # PHG IF - -override CPPFLAGS += $(EXTERNAL_DYCORE_FLAG) -# =================================== - - -.SUFFIXES: .F .o .cpp - -#OBJS = mpas_li_core.o \ -# mpas_li_core_interface.o \ -# mpas_li_time_integration.o \ -# mpas_li_time_integration_fe.o \ -# mpas_li_diagnostic_vars.o \ -# mpas_li_tendency.o \ -# mpas_li_setup.o \ -# mpas_li_statistics.o \ -# mpas_li_velocity.o \ -# mpas_li_sia.o \ -# mpas_li_mask.o \ -# mpas_li_velocity_external.o +## LifeV can solve L1L2 or FO +#ifeq "$(LIFEV)" "true" +# EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_L1L2 +# EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER +# BUILD_INTERFACE = true +#endif # LIFEV IF # -#ifeq "$(BUILD_INTERFACE)" "true" -# OBJS += Interface_velocity_solver.o +## Albany can only solve FO at present +#ifeq "$(ALBANY)" "true" +# EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER +# BUILD_INTERFACE = true +#endif # ALBANY IF +# +## Currently LifeV AND Albany is not allowed +#ifeq "$(LIFEV)" "true" +#ifeq "$(ALBANY)" "true" +# $(error Compiling with both LifeV and Albany is not allowed at this time.) +#endif +#endif +# +## PHG currently requires LifeV +#ifeq "$(PHG)" "true" +#ifneq "$(LIFEV)" "true" +# $(error Compiling with PHG requires LifeV at this time.) #endif +#endif +## PHG can only Stokes at present +#ifeq "$(PHG)" "true" +# EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_STOKES +# BUILD_INTERFACE = true +#endif # PHG IF +#override CPPFLAGS += $(EXTERNAL_DYCORE_FLAG) +# =================================== +.SUFFIXES: .F .o .cpp +.PHONY: mode_forward shared all: core_landice shared mode_forward -core_landice: $(OBJS) - ar -ru libdycore.a mode_forward/*.o - ar -ru libdycore.a shared/*.o +core_landice: +# ar -ru libdycore.a mode_forward/*.o +# ar -ru libdycore.a shared/*.o -core_reg: - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml +#core_reg: +# $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml core_input_gen: if [ ! -e default_inputs ]; then mkdir default_inputs; fi @@ -84,12 +65,16 @@ post_build: cp default_inputs/* $(ROOT_DIR)/default_inputs/. ( cd $(ROOT_DIR)/default_inputs; for FILE in `ls -1`; do if [ ! -e ../$$FILE ]; then cp $$FILE ../.; fi; done ) -shared: (cd shared; $(MAKE)) +shared: + (cd shared; $(MAKE)) -mode_forward: (cd mode_forward; $(MAKE)) +mode_forward: + (cd mode_forward; $(MAKE)) clean: $(RM) *.o *.mod *.f90 libdycore.a + $(cd shared; $(MAKE) clean) + $(cd mode_forward; $(MAKE) clean) $(RM) Registry_processed.xml @# Certain systems with intel compilers generate *.i files @# This removes them during the clean process diff --git a/src/core_landice/build_options.mk b/src/core_landice/build_options.mk index aeb3d173f4..dc37623b6a 100644 --- a/src/core_landice/build_options.mk +++ b/src/core_landice/build_options.mk @@ -3,7 +3,7 @@ ifeq "$(ROOT_DIR)" "" endif EXE_NAME=landice_model NAMELIST_SUFFIX=landice -FCINCLUDES += -I$(ROOT_DIR)/core_landice/forward_model -I$(ROOT_DIR)/core_landice/shared +FCINCLUDES += -I$(ROOT_DIR)/core_landice/mode_forward -I$(ROOT_DIR)/core_landice/shared override CPPFLAGS += -DCORE_LANDICE report_builds: diff --git a/src/core_landice/mode_forward/Makefile b/src/core_landice/mode_forward/Makefile index 823db41bc0..f4cbfc5675 100644 --- a/src/core_landice/mode_forward/Makefile +++ b/src/core_landice/mode_forward/Makefile @@ -56,24 +56,24 @@ mpas_li_statistics.o: mpas_li_mask.o \ mpas_li_mask.o: mpas_li_setup.o -#mpas_li_constants.o: +mpas_li_constants.o: mpas_li_velocity_external.o: Interface_velocity_solver.o: clean: - $(RM) *.o *.mod *.f90 libdycore.a - $(RM) Registry_processed.xml - @# Certain systems with intel compilers generate *.i files - @# This removes them during the clean process - $(RM) *.i - $(RM) -r default_inputs + $(RM) *.o *.mod *.f90 libdycore.a + $(RM) Registry_processed.xml + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i + $(RM) -r default_inputs .F.o: - $(RM) $@ $*.mod - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 + $(RM) $@ $*.mod + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../../external/esmf_time_f90 -I../shared .cpp.o: - $(CXX) $(CXXFLAGS) -c $*.cpp $(CXINCLUDES) $(CPPINCLUDES) -lmpi_cxx -lstdc++ $(CPPFLAGS) + $(CXX) $(CXXFLAGS) -c $*.cpp $(CXINCLUDES) $(CPPINCLUDES) -lmpi_cxx -lstdc++ $(CPPFLAGS) diff --git a/src/core_landice/mode_forward/mpas_li_core_interface.F b/src/core_landice/mode_forward/mpas_li_core_interface.F index b41ec9520f..747340e1fa 100644 --- a/src/core_landice/mode_forward/mpas_li_core_interface.F +++ b/src/core_landice/mode_forward/mpas_li_core_interface.F @@ -47,7 +47,7 @@ subroutine li_setup_core(core)!{{{ core % Conventions = 'MPAS' core % source = 'MPAS' -#include "inc/core_variables.inc" +#include "../inc/core_variables.inc" end subroutine li_setup_core!}}} @@ -67,7 +67,7 @@ end subroutine li_setup_core!}}} subroutine li_setup_domain(domain)!{{{ type (domain_type), pointer :: domain -#include "inc/domain_variables.inc" +#include "../inc/domain_variables.inc" end subroutine li_setup_domain!}}} @@ -254,17 +254,17 @@ function li_setup_block(block) result(iErr)!{{{ call li_generate_structs(block, block % structs, block % dimensions, block % packages) end function li_setup_block!}}} -#include "inc/setup_immutable_streams.inc" +#include "../inc/setup_immutable_streams.inc" -#include "inc/block_dimension_routines.inc" +#include "../inc/block_dimension_routines.inc" -#include "inc/define_packages.inc" +#include "../inc/define_packages.inc" -#include "inc/structs_and_variables.inc" +#include "../inc/structs_and_variables.inc" -#include "inc/namelist_call.inc" +#include "../inc/namelist_call.inc" -#include "inc/namelist_defines.inc" +#include "../inc/namelist_defines.inc" end module li_core_interface diff --git a/src/core_landice/shared/Makefile b/src/core_landice/shared/Makefile index bdd84d3c64..d38b3ea913 100644 --- a/src/core_landice/shared/Makefile +++ b/src/core_landice/shared/Makefile @@ -7,17 +7,15 @@ all: $(OBJS) mpas_li_constants.o: clean: - $(RM) *.o *.mod *.f90 libdycore.a - $(RM) Registry_processed.xml - @# Certain systems with intel compilers generate *.i files - @# This removes them during the clean process - $(RM) *.i - $(RM) -r default_inputs + $(RM) *.o *.mod *.f90 + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i .F.o: - $(RM) $@ $*.mod - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 + $(RM) $@ $*.mod + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../../external/esmf_time_f90 .cpp.o: - $(CXX) $(CXXFLAGS) -c $*.cpp $(CXINCLUDES) $(CPPINCLUDES) -lmpi_cxx -lstdc++ $(CPPFLAGS) + $(CXX) $(CXXFLAGS) -c $*.cpp $(CXINCLUDES) $(CPPINCLUDES) -lmpi_cxx -lstdc++ $(CPPFLAGS) From 271ced57357ef7c5a4aec83b91231415d464445f Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Thu, 13 Aug 2015 22:28:23 -0600 Subject: [PATCH 0133/1724] minor fix to main land ice core Makefile; code builds and runs now in SIA mode --- src/core_landice/Makefile | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index ee684229ac..60dd508143 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -44,11 +44,10 @@ BUILD_INTERFACE=false # This will become true if any of the external libraries all: core_landice shared mode_forward core_landice: -# ar -ru libdycore.a mode_forward/*.o -# ar -ru libdycore.a shared/*.o + ar -ru libdycore.a mode_forward/*.o -#core_reg: -# $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml +core_reg: + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml core_input_gen: if [ ! -e default_inputs ]; then mkdir default_inputs; fi From c8ebbbbc806533ec68d2523adac5c1b0779c7ac5 Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Fri, 14 Aug 2015 09:24:32 -0600 Subject: [PATCH 0134/1724] Minor tweaks to main land ice core makefile --- src/core_landice/Makefile | 66 +++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 33 deletions(-) diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index 60dd508143..6035bfe29b 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -3,39 +3,39 @@ BUILD_INTERFACE=false # This will become true if any of the external libraries are being used. -## LifeV can solve L1L2 or FO -#ifeq "$(LIFEV)" "true" -# EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_L1L2 -# EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER -# BUILD_INTERFACE = true -#endif # LIFEV IF -# -## Albany can only solve FO at present -#ifeq "$(ALBANY)" "true" -# EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER -# BUILD_INTERFACE = true -#endif # ALBANY IF -# -## Currently LifeV AND Albany is not allowed -#ifeq "$(LIFEV)" "true" -#ifeq "$(ALBANY)" "true" -# $(error Compiling with both LifeV and Albany is not allowed at this time.) -#endif -#endif -# -## PHG currently requires LifeV -#ifeq "$(PHG)" "true" -#ifneq "$(LIFEV)" "true" -# $(error Compiling with PHG requires LifeV at this time.) -#endif -#endif -## PHG can only Stokes at present -#ifeq "$(PHG)" "true" -# EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_STOKES -# BUILD_INTERFACE = true -#endif # PHG IF - -#override CPPFLAGS += $(EXTERNAL_DYCORE_FLAG) +# LifeV can solve L1L2 or FO +ifeq "$(LIFEV)" "true" + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_L1L2 + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER + BUILD_INTERFACE = true +endif # LIFEV IF + +# Albany can only solve FO at present +ifeq "$(ALBANY)" "true" + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER + BUILD_INTERFACE = true +endif # ALBANY IF + +# Currently LifeV AND Albany is not allowed +ifeq "$(LIFEV)" "true" +ifeq "$(ALBANY)" "true" + $(error Compiling with both LifeV and Albany is not allowed at this time.) +endif +endif + +# PHG currently requires LifeV +ifeq "$(PHG)" "true" +ifneq "$(LIFEV)" "true" + $(error Compiling with PHG requires LifeV at this time.) +endif +endif +# PHG can only Stokes at present +ifeq "$(PHG)" "true" + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_STOKES + BUILD_INTERFACE = true +endif # PHG IF + +override CPPFLAGS += $(EXTERNAL_DYCORE_FLAG) # =================================== .SUFFIXES: .F .o .cpp From 71ee7dddb7bdebb7f7afdf8e1ebc8c7831098d74 Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Fri, 14 Aug 2015 12:35:23 -0600 Subject: [PATCH 0135/1724] final fixes to land ice core make files for new dir structure --- src/core_landice/Makefile | 28 ++++++++++++++------------ src/core_landice/mode_forward/Makefile | 4 +--- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index 6035bfe29b..7f15eefd8c 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -41,19 +41,27 @@ override CPPFLAGS += $(EXTERNAL_DYCORE_FLAG) .SUFFIXES: .F .o .cpp .PHONY: mode_forward shared -all: core_landice shared mode_forward +all: shared mode_forward lib_landice core_landice -core_landice: - ar -ru libdycore.a mode_forward/*.o +shared: + (cd shared; $(MAKE)) -core_reg: - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml +mode_forward: shared + (cd mode_forward; $(MAKE)) + +lib_landice: shared mode_forward + +core_landice: lib_landice + ar -ru libdycore.a mode_forward/*.o core_input_gen: if [ ! -e default_inputs ]; then mkdir default_inputs; fi (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.landice ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.landice stream_list.landice. listed ) +core_reg: + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml + gen_includes: $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files @@ -64,21 +72,15 @@ post_build: cp default_inputs/* $(ROOT_DIR)/default_inputs/. ( cd $(ROOT_DIR)/default_inputs; for FILE in `ls -1`; do if [ ! -e ../$$FILE ]; then cp $$FILE ../.; fi; done ) -shared: - (cd shared; $(MAKE)) - -mode_forward: - (cd mode_forward; $(MAKE)) - clean: $(RM) *.o *.mod *.f90 libdycore.a - $(cd shared; $(MAKE) clean) - $(cd mode_forward; $(MAKE) clean) $(RM) Registry_processed.xml @# Certain systems with intel compilers generate *.i files @# This removes them during the clean process $(RM) *.i $(RM) -r default_inputs + (cd shared; $(MAKE) clean) + (cd mode_forward; $(MAKE) clean) .F.o: $(RM) $@ $*.mod diff --git a/src/core_landice/mode_forward/Makefile b/src/core_landice/mode_forward/Makefile index f4cbfc5675..98a942e384 100644 --- a/src/core_landice/mode_forward/Makefile +++ b/src/core_landice/mode_forward/Makefile @@ -63,12 +63,10 @@ mpas_li_velocity_external.o: Interface_velocity_solver.o: clean: - $(RM) *.o *.mod *.f90 libdycore.a - $(RM) Registry_processed.xml + $(RM) *.o *.mod *.f90 @# Certain systems with intel compilers generate *.i files @# This removes them during the clean process $(RM) *.i - $(RM) -r default_inputs .F.o: $(RM) $@ $*.mod From 3ff9f5e5af0ab4bce36f94fd206b7363e0fd765f Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Fri, 14 Aug 2015 15:02:02 -0600 Subject: [PATCH 0136/1724] a few more tweaks to allow for building w/ external cpp dycores --- src/core_landice/Makefile | 40 +------------------------ src/core_landice/mode_forward/Makefile | 41 ++++++++++++++++++++++++++ src/core_landice/shared/Makefile | 1 + 3 files changed, 43 insertions(+), 39 deletions(-) diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index 7f15eefd8c..d4f596b2ee 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -1,42 +1,3 @@ -# =================================== -# Check if building with LifeV, Albany, and/or PHG external libraries - -BUILD_INTERFACE=false # This will become true if any of the external libraries are being used. - -# LifeV can solve L1L2 or FO -ifeq "$(LIFEV)" "true" - EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_L1L2 - EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER - BUILD_INTERFACE = true -endif # LIFEV IF - -# Albany can only solve FO at present -ifeq "$(ALBANY)" "true" - EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER - BUILD_INTERFACE = true -endif # ALBANY IF - -# Currently LifeV AND Albany is not allowed -ifeq "$(LIFEV)" "true" -ifeq "$(ALBANY)" "true" - $(error Compiling with both LifeV and Albany is not allowed at this time.) -endif -endif - -# PHG currently requires LifeV -ifeq "$(PHG)" "true" -ifneq "$(LIFEV)" "true" - $(error Compiling with PHG requires LifeV at this time.) -endif -endif -# PHG can only Stokes at present -ifeq "$(PHG)" "true" - EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_STOKES - BUILD_INTERFACE = true -endif # PHG IF - -override CPPFLAGS += $(EXTERNAL_DYCORE_FLAG) -# =================================== .SUFFIXES: .F .o .cpp .PHONY: mode_forward shared @@ -89,3 +50,4 @@ clean: .cpp.o: $(CXX) $(CXXFLAGS) -c $*.cpp $(CXINCLUDES) $(CPPINCLUDES) -lmpi_cxx -lstdc++ $(CPPFLAGS) + diff --git a/src/core_landice/mode_forward/Makefile b/src/core_landice/mode_forward/Makefile index 98a942e384..2d458ada56 100644 --- a/src/core_landice/mode_forward/Makefile +++ b/src/core_landice/mode_forward/Makefile @@ -1,3 +1,44 @@ + +# =================================== +# Check if building with LifeV, Albany, and/or PHG external libraries + +BUILD_INTERFACE=false # This will become true if any of the external libraries are being used. + +# LifeV can solve L1L2 or FO +ifeq "$(LIFEV)" "true" + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_L1L2 + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER + BUILD_INTERFACE = true +endif # LIFEV IF + +# Albany can only solve FO at present +ifeq "$(ALBANY)" "true" + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER + BUILD_INTERFACE = true +endif # ALBANY IF + +# Currently LifeV AND Albany is not allowed +ifeq "$(LIFEV)" "true" +ifeq "$(ALBANY)" "true" + $(error Compiling with both LifeV and Albany is not allowed at this time.) +endif +endif + +# PHG currently requires LifeV +ifeq "$(PHG)" "true" +ifneq "$(LIFEV)" "true" + $(error Compiling with PHG requires LifeV at this time.) +endif +endif +# PHG can only Stokes at present +ifeq "$(PHG)" "true" + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_STOKES + BUILD_INTERFACE = true +endif # PHG IF + +override CPPFLAGS += $(EXTERNAL_DYCORE_FLAG) +# =================================== + .SUFFIXES: .F .o .cpp OBJS = mpas_li_core.o \ diff --git a/src/core_landice/shared/Makefile b/src/core_landice/shared/Makefile index d38b3ea913..0ffbc73bad 100644 --- a/src/core_landice/shared/Makefile +++ b/src/core_landice/shared/Makefile @@ -1,3 +1,4 @@ + .SUFFIXES: .F .o .cpp OBJS = mpas_li_constants.o From e3ebfc3fc143ed6dfa5a48db26baad021602dca8 Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Fri, 14 Aug 2015 16:24:03 -0600 Subject: [PATCH 0137/1724] Removed the macros and replaced them with explicit subroutines. --- src/core_ocean/analysis_members/Makefile | 2 +- .../mpas_ocn_time_series_stats.F | 2374 ++++++++++++----- 2 files changed, 1771 insertions(+), 605 deletions(-) diff --git a/src/core_ocean/analysis_members/Makefile b/src/core_ocean/analysis_members/Makefile index ea3fa070b4..590aa32485 100644 --- a/src/core_ocean/analysis_members/Makefile +++ b/src/core_ocean/analysis_members/Makefile @@ -11,7 +11,7 @@ MEMBERS = mpas_ocn_global_stats.o \ mpas_ocn_test_compute_interval.o \ mpas_ocn_high_frequency_output.o \ mpas_ocn_zonal_mean.o \ - mpas_ocn_time_series_stats.o + mpas_ocn_time_series_stats.o all: $(OBJS) diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index 3f65151bcf..af4612b947 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -101,230 +101,6 @@ module ocn_time_series_stats -!*********************************************************************** -! routine walk_string -! -!> \brief Walk a semicolon delimited string to find substrings -!> \author Jon Woodring -!> \date March 2, 2015 -!> \details -!> Walk a string delimited by semicolons and return the first substring -!> from start index, and modify start to point at the next candidate. -!----------------------------------------------------------------------- - subroutine walk_string(next, substr, ok)!{{{ - ! input variables - !----------------------------------------------------------------- - - ! input/output variables - !----------------------------------------------------------------- - character (len=StrKIND), intent(inout) :: next - - ! output variables - !----------------------------------------------------------------- - character (len=StrKIND), intent(out) :: substr - logical, intent(out) :: ok - - ! local variables - !----------------------------------------------------------------- - integer :: i - character (len=StrKIND) :: copy - - ! make a copy - copy = trim(next) - - ! if there's anything in it other than whitespace, pass through - i = verify(copy, ' ') - ok = i .gt. 0 - if (.not. ok) then - return - end if - copy = trim(next(i:)) - - ! find the first semicolon and split - i = scan(copy, ';') - - ! return that substring and the remainder - if (i .gt. 0) then - substr = trim(copy(1:i-1)) - next = trim(copy(i+1:)) - else - substr = trim(copy) - next = '' - end if - - - end subroutine walk_string!}}} - -!*********************************************************************** -! routine set_times -! -!> \brief Set a list of times -!> \author Jon Woodring -!> \date March 2, 2015 -!> \details -!> Walk a list of times delimited by spaces and set the time info -!> for the buffer structure so that alarms can be set. -!----------------------------------------------------------------------- - subroutine set_times(buffers, number_of_buffers, clock, & - which, config_str, ok, err) - ! input variables - !----------------------------------------------------------------- - integer, intent(in) :: number_of_buffers, which - character (len=StrKIND), pointer, intent(in) :: config_str - - ! input/output variables - !----------------------------------------------------------------- - type (time_buffer_type), dimension(:), intent(inout) :: buffers - type (MPAS_Clock_type), intent(inout) :: clock - - ! output variables - !----------------------------------------------------------------- - logical, intent(out) :: ok - integer, intent(out) :: err - - ! local variables - !----------------------------------------------------------------- - character (len=StrKIND) :: next_str, time_str - integer :: b - - ! find the first time in the list - next_str = config_str - b = 0 - call walk_string(next_str, time_str, ok) - - ! while the time string is ok - do while (ok) - ! exit if we went over - b = b + 1 - if (b .gt. number_of_buffers) then - exit - end if - - ! set the time - if (which .eq. START_TIMES) then - if (time_str .eq. 'initial_time') then - buffers(b) % start_time = mpas_get_clock_time(clock, & - MPAS_NOW, err) - else - call mpas_set_time(buffers(b) % start_time, & - dateTimeString=time_str, ierr=err) - end if - else if (which .eq. DURATION_INTERVALS) then - if (time_str .eq. 'repeat_interval') then - buffers(b) % duration_interval = buffers(b) % repeat_interval - else - call mpas_set_timeInterval(buffers(b) % duration_interval, & - timeString=time_str, ierr=err) - end if - else if (which .eq. REPEAT_INTERVALS) then - if (time_str .eq. 'reset_interval') then - buffers(b) % repeat_interval = buffers(b) % reset_interval - else - call mpas_set_timeInterval(buffers(b) % repeat_interval, & - timeString=time_str, ierr=err) - end if - else - call mpas_set_timeInterval(buffers(b) % reset_interval, & - timeString=time_str, ierr=err) - end if - - ! get the next time string - call walk_string(next_str, time_str, ok) - end do - - ! only ok if we parsed out as many as there are number of buffers - ok = number_of_buffers .eq. b - end subroutine set_times - - - -!*********************************************************************** -! routine add_new_field -! -!> \brief Function to create a new field from an existing field -!> \author Jon Woodring -!> \date March 2, 2015 -!> \details -!> This routine conducts all initializations required for -!> duplicating a field and adding it to the allFields pool. -!----------------------------------------------------------------------- - subroutine add_new_field(info, inname, prefix, pool)!{{{ - ! input variables - !----------------------------------------------------------------- - type (mpas_pool_field_info_type), intent(in) :: info - character (len=StrKIND), intent(in) :: inname, prefix - - ! input/output variables - !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: pool - - ! output variables - !----------------------------------------------------------------- - - ! local variables - !----------------------------------------------------------------- - type (field0DReal), pointer :: r0i, or0 - type (field1DReal), pointer :: r1i, or1 - type (field2DReal), pointer :: r2i, or2 - type (field3DReal), pointer :: r3i, or3 - type (field4DReal), pointer :: r4i, or4 - type (field5DReal), pointer :: r5i, or5 - type (field0DInteger), pointer :: i0i, oi0 - type (field1DInteger), pointer :: i1i, oi1 - type (field2DInteger), pointer :: i2i, oi2 - type (field3DInteger), pointer :: i3i, oi3 - integer :: i - - ! start procedure - !----------------------------------------------------------------- - -! macro -#define COPY_FIELDS(SRC, DST) \ -call mpas_pool_get_field(pool, inname, SRC, 1) ;\ -call mpas_duplicate_field(SRC, DST) ;\ -DST % fieldName = trim(prefix) // DST % fieldName ;\ -if (DST % isVarArray) then ;\ - do i = 1, size(DST % constituentNames) ;\ - DST % constituentNames(i) = trim(prefix) // \ - DST % constituentNames(i) ;\ - end do ;\ -end if ;\ -call mpas_pool_add_field(pool, DST % fieldName, DST) -! end macro - - ! duplicate field and add new field to pool - if (info % fieldType .eq. MPAS_POOL_REAL) then - if (info % nDims .eq. 0) then - COPY_FIELDS(r0i, or0) - else if (info % nDims .eq. 1) then - COPY_FIELDS(r1i, or1) - else if (info % nDims .eq. 2) then - COPY_FIELDS(r2i, or2) - else if (info % nDims .eq. 3) then - COPY_FIELDS(r3i, or3) - else if (info % nDims .eq. 4) then - COPY_FIELDS(r4i, or4) - else - COPY_FIELDS(r5i, or5) - end if - else - if (info % nDims .eq. 0) then - COPY_FIELDS(i0i, oi0) - else if (info % nDims .eq. 1) then - COPY_FIELDS(i1i, oi1) - else if (info % nDims .eq. 2) then - COPY_FIELDS(i2i, oi2) - else - COPY_FIELDS(i3i, oi3) - end if - end if - - end subroutine add_new_field!}}} - -#undef COPY_FIELDS - - - !*********************************************************************** ! routine ocn_init_time_series_stats ! @@ -623,18 +399,19 @@ end subroutine ocn_init_time_series_stats!}}} !*********************************************************************** -! routine timer_checking +! routine ocn_compute_time_series_stats ! -!> \brief Timer functions to determine when to run +!> \brief Compute MPAS-Ocean analysis member !> \author Jon Woodring !> \date March 2, 2015 !> \details -!> This routine conducts timer checking to determine if it -!> needs to run at this particular time. +!> This routine conducts all computation required for this +!> MPAS-Ocean analysis member. !----------------------------------------------------------------------- - subroutine timer_checking(domain, err)!{{{ + subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ ! input variables !----------------------------------------------------------------- + integer, intent(in) :: timeLevel ! input/output variables !----------------------------------------------------------------- @@ -642,394 +419,47 @@ subroutine timer_checking(domain, err)!{{{ ! output variables !----------------------------------------------------------------- - integer, intent(out) :: err + integer, intent(out) :: err !< Output: error flag ! local variables !----------------------------------------------------------------- - integer :: b + integer :: i, v, b ! start procedure !----------------------------------------------------------------- err = 0 - do b = 1, size(buffers) - ! see if the started alarm is ringing - if (mpas_is_alarm_ringing(domain % clock, & - buffers(b) % start_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(domain % clock, & - buffers(b) % start_alarm_ID, ierr=err) - buffers(b) % started_flag = .true. - buffers(b) % accumulate_flag = .true. + ! do all of the time checking and flag setting + call timer_checking(domain, err) - ! TODO only reset if not restart - buffers(b) % reset_flag = .true. + ! update number of accumulations, once only + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + buffers(b) % total_accum = 1 + else if (buffers(b) % accumulate_flag) then + buffers(b) % total_accum = buffers(b) % total_accum + 1 end if + end do - ! if we aren't started, continue to next buffer - if (.not. buffers(b) % started_flag) then - continue - end if + ! do all of the operations + do v = 1, size(variables) + call typed_operate(domain % blocklist, variables(v), operation) + end do - ! check various other alarms - ! see if we need to reset - if(mpas_is_alarm_ringing(domain % clock, & - buffers(b) % reset_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(domain % clock, & - buffers(b) % reset_alarm_ID, ierr=err) - buffers(b) % reset_flag = .true. - buffers(b) % delay_reset_flag = .true. + ! clear resets and accumulation + do b = 1, size(buffers) + if (buffers(b) % delay_reset_flag) then + buffers(b) % delay_reset_flag = .false. + else + buffers(b) % reset_flag = .false. + end if + + if (buffers(b) % duration_over_flag) then + buffers(b) % duration_over_flag = .false. + buffers(b) % accumulate_flag = .false. end if - - ! turn off accumulation - ! - ! duration needs to be >= 2 * compute_interval - ! (a series can only be 2 or more) - if (mpas_is_alarm_ringing(domain % clock, & - buffers(b) % duration_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(domain % clock, & - buffers(b) % duration_alarm_ID, ierr=err) - buffers(b) % duration_over_flag = .true. - end if - - ! turn on accumulation - ! (this is second, in case the duration and repeat - ! overlaps on the same timer) - if (mpas_is_alarm_ringing(domain % clock, & - buffers(b) % repeat_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(domain % clock, & - buffers(b) % repeat_alarm_ID, ierr=err) - buffers(b) % accumulate_flag = .true. - buffers(b) % duration_over_flag = .false. - end if - - end do - - end subroutine timer_checking!}}} - -!*********************************************************************** -! macro OPERATE -! -!> \brief A macro to support operations on different run-time types -!> \author Jon Woodring -!> \date March 2, 2015 -!> \details -!> This macro encapsulates the different opertions that can occur -!> based on the run-time types. It is written as a macro to cut down -!> on copy-pasting and duplication errors. (This would likely be -!> instantiated generics/templates in other languages.) -!----------------------------------------------------------------------- - -! first half of the macro -#define FIRST_HALF(SUBNAME) \ -subroutine operate ## SUBNAME (start_block, tvar) ;\ -type (block_type), pointer, intent(in) :: start_block ;\ -\ -type (time_variable_type), intent(inout) :: tvar ;\ -\ -integer :: b ;\ -type (block_type), pointer :: block ; - -! second half of the macro -#define SECOND_HALF \ -block => start_block ;\ -do while (associated(block)) ;\ - call mpas_pool_get_array(block % allFields, \ - tvar % input_name, in_array, 1) ;\ -\ - do b = 1, size(buffers) ;\ - if (buffers(b) % reset_flag .and. \ - (.not. buffers(b) % delay_reset_flag)) then ;\ - call mpas_pool_get_array(block % allFields, \ - tvar % output_names(b), out_array, 1) ;\ - out_array = in_array ;\ - else if (buffers(b) % accumulate_flag) then ;\ - call mpas_pool_get_array(block % allFields, \ - tvar % output_names(b), out_array, 1) ; - -! averaging is done by multiplying out and dividing such that -! the average state is always in a normalized form -- while -! this could (will) cause more error in the long run, it does -! mean that other AMs will be able to use this data and it will -! always be prenormalized (it also means that we don't have to -! have a special case of normalizing the data before writing it -! to disk) -#define AVG_MAC \ - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ - / buffers(b) % total_accum ; - -#define MIN_MAC \ - out_array = min(out_array, in_array) ; - -#define MAX_MAC \ - out_array = max(out_array, in_array) ; - -#define END_CAP(SUBNAME) \ - end if ;\ - end do ;\ -\ - block => block % next ;\ -end do ;\ -\ -end subroutine operate ## SUBNAME ; - -! had to create this as a two part macro because of the comma differences -! and type declaration in 0d vs nd data -! (fpp doesn't seem to like to parse "," correctly as an argument even -! if you "#define COMMA ,". It was only able to do the commas in the middle -! of dimension(...) because the , are in a (). Therefore to have two -! different types of functions, I had to separate them into two macros -! with different arguments, i.e., I wasn't able to pass one argument -! to the macro to expand the type definition, because fpp wasn't -! able to figure out that it was one argument due to ","s. Also, -! I wasn't able to pass a macro function with an argument for the same -! reason, as the preprocessor would expand it and get confused by -! the commas. Quite frequently, I would get an empty argument.) -#define OPERATE_MULTI_AVG(S, A, B) \ -FIRST_HALF(S) A, B, pointer :: in_array, out_array ; \ -SECOND_HALF AVG_MAC END_CAP(S) -#define OPERATE_SCALAR_AVG(S, A) \ -FIRST_HALF(S) A, pointer :: in_array, out_array ; \ -SECOND_HALF AVG_MAC END_CAP(S) -#define OPERATE_MULTI_MIN(S, A, B) \ -FIRST_HALF(S) A, B, pointer :: in_array, out_array ; \ -SECOND_HALF MIN_MAC END_CAP(S) -#define OPERATE_SCALAR_MIN(S, A) \ -FIRST_HALF(S) A, pointer :: in_array, out_array ; \ -SECOND_HALF MIN_MAC END_CAP(S) -#define OPERATE_MULTI_MAX(S, A, B) \ -FIRST_HALF(S) A, B, pointer :: in_array, out_array ; \ -SECOND_HALF MAX_MAC END_CAP(S) -#define OPERATE_SCALAR_MAX(S, A) \ -FIRST_HALF(S) A, pointer :: in_array, out_array ; \ -SECOND_HALF MAX_MAC END_CAP(S) - -! here are all the instantiations -OPERATE_SCALAR_AVG(0r_avg, real(kind=RKIND)) -OPERATE_MULTI_AVG(1r_avg, real(kind=RKIND), dimension(:)) -OPERATE_MULTI_AVG(2r_avg, real(kind=RKIND), dimension(:, :)) -OPERATE_MULTI_AVG(3r_avg, real(kind=RKIND), dimension(:, :, :)) -OPERATE_MULTI_AVG(4r_avg, real(kind=RKIND), dimension(:, :, :, :)) -OPERATE_MULTI_AVG(5r_avg, real(kind=RKIND), dimension(:, :, :, :, :)) -OPERATE_SCALAR_AVG(0i_avg, integer) -OPERATE_MULTI_AVG(1i_avg, integer, dimension(:)) -OPERATE_MULTI_AVG(2i_avg, integer, dimension(:, :)) -OPERATE_MULTI_AVG(3i_avg, integer, dimension(:, :, :)) - -OPERATE_SCALAR_MIN(0r_min, real(kind=RKIND)) -OPERATE_MULTI_MIN(1r_min, real(kind=RKIND), dimension(:)) -OPERATE_MULTI_MIN(2r_min, real(kind=RKIND), dimension(:, :)) -OPERATE_MULTI_MIN(3r_min, real(kind=RKIND), dimension(:, :, :)) -OPERATE_MULTI_MIN(4r_min, real(kind=RKIND), dimension(:, :, :, :)) -OPERATE_MULTI_MIN(5r_min, real(kind=RKIND), dimension(:, :, :, :, :)) -OPERATE_SCALAR_MIN(0i_min, integer) -OPERATE_MULTI_MIN(1i_min, integer, dimension(:)) -OPERATE_MULTI_MIN(2i_min, integer, dimension(:, :)) -OPERATE_MULTI_MIN(3i_min, integer, dimension(:, :, :)) - -OPERATE_SCALAR_MAX(0r_max, real(kind=RKIND)) -OPERATE_MULTI_MAX(1r_max, real(kind=RKIND), dimension(:)) -OPERATE_MULTI_MAX(2r_max, real(kind=RKIND), dimension(:, :)) -OPERATE_MULTI_MAX(3r_max, real(kind=RKIND), dimension(:, :, :)) -OPERATE_MULTI_MAX(4r_max, real(kind=RKIND), dimension(:, :, :, :)) -OPERATE_MULTI_MAX(5r_max, real(kind=RKIND), dimension(:, :, :, :, :)) -OPERATE_SCALAR_MAX(0i_max, integer) -OPERATE_MULTI_MAX(1i_max, integer, dimension(:)) -OPERATE_MULTI_MAX(2i_max, integer, dimension(:, :)) -OPERATE_MULTI_MAX(3i_max, integer, dimension(:, :, :)) - -#undef FIRST_HALF -#undef SECOND_HALF -#undef AVG -#undef MIN -#undef MAX -#undef END_CAP -#undef OPERATE_MULTI_AVG -#undef OPERATE_SCALAR_AVG -#undef OPERATE_MULTI_MIN -#undef OPERATE_SCALAR_MIN -#undef OPERATE_MULTI_MAX -#undef OPERATE_SCALAR_MAX - - - -!*********************************************************************** -! routine typed_operate -! -!> \brief Do the operation, but switch on run-time type -!> \author Jon Woodring -!> \date March 2, 2015 -!> \details -!> Since we don't know the type of the array, we need to do some -!> run-time type switching based on the type of the array. -!----------------------------------------------------------------------- - subroutine typed_operate(block, tvar, operation)!{{{ - ! input variables - !----------------------------------------------------------------- - type (block_type), pointer, intent(in) :: block - integer, intent(in) :: operation - - ! input/output variables - !----------------------------------------------------------------- - type (time_variable_type), intent(inout) :: tvar - - ! output variables - !----------------------------------------------------------------- - - ! local variables - !----------------------------------------------------------------- - - ! switch based on the type, dimensionality, and operation - if (tvar % info % fieldType == MPAS_POOL_REAL) then - if (tvar % info % nDims == 0) then - if (operation .eq. AVG_OP) then - call operate0r_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate0r_min(block, tvar) - else - call operate0r_max(block, tvar) - end if - else if (tvar % info % nDims == 1) then - if (operation .eq. AVG_OP) then - call operate1r_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate1r_min(block, tvar) - else - call operate1r_max(block, tvar) - end if - else if (tvar % info % nDims == 2) then - if (operation .eq. AVG_OP) then - call operate2r_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate2r_min(block, tvar) - else - call operate2r_max(block, tvar) - end if - else if (tvar % info % nDims == 3) then - if (operation .eq. AVG_OP) then - call operate3r_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate3r_min(block, tvar) - else - call operate3r_max(block, tvar) - end if - else if (tvar % info % nDims == 4) then - if (operation .eq. AVG_OP) then - call operate4r_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate4r_min(block, tvar) - else - call operate4r_max(block, tvar) - end if - else - if (operation .eq. AVG_OP) then - call operate5r_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate5r_min(block, tvar) - else - call operate5r_max(block, tvar) - end if - end if - else - if (tvar % info % nDims == 0) then - if (operation .eq. AVG_OP) then - call operate0i_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate0i_min(block, tvar) - else - call operate0i_max(block, tvar) - end if - else if (tvar % info % nDims == 1) then - if (operation .eq. AVG_OP) then - call operate1i_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate1i_min(block, tvar) - else - call operate1i_max(block, tvar) - end if - else if (tvar % info % nDims == 2) then - if (operation .eq. AVG_OP) then - call operate2i_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate2i_min(block, tvar) - else - call operate2i_max(block, tvar) - end if - else - if (operation .eq. AVG_OP) then - call operate3i_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate3i_min(block, tvar) - else - call operate3i_max(block, tvar) - end if - end if - end if - - end subroutine typed_operate!}}} - -!*********************************************************************** -! routine ocn_compute_time_series_stats -! -!> \brief Compute MPAS-Ocean analysis member -!> \author Jon Woodring -!> \date March 2, 2015 -!> \details -!> This routine conducts all computation required for this -!> MPAS-Ocean analysis member. -!----------------------------------------------------------------------- - subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ - ! input variables - !----------------------------------------------------------------- - integer, intent(in) :: timeLevel - - ! input/output variables - !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain - - ! output variables - !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag - - ! local variables - !----------------------------------------------------------------- - integer :: i, v, b - - ! start procedure - !----------------------------------------------------------------- - err = 0 - - ! do all of the time checking and flag setting - call timer_checking(domain, err) - - ! update number of accumulations, once only - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - buffers(b) % total_accum = 1 - else if (buffers(b) % accumulate_flag) then - buffers(b) % total_accum = buffers(b) % total_accum + 1 - end if - end do - - ! do all of the operations - do v = 1, size(variables) - call typed_operate(domain % blocklist, variables(v), operation) - end do - - ! clear resets and accumulation - do b = 1, size(buffers) - if (buffers(b) % delay_reset_flag) then - buffers(b) % delay_reset_flag = .false. - else - buffers(b) % reset_flag = .false. - end if - - if (buffers(b) % duration_over_flag) then - buffers(b) % duration_over_flag = .false. - buffers(b) % accumulate_flag = .false. - end if - end do + end do end subroutine ocn_compute_time_series_stats!}}} @@ -1118,7 +548,1743 @@ subroutine ocn_finalize_time_series_stats(domain, err)!{{{ end subroutine ocn_finalize_time_series_stats!}}} +! +! local subroutines +! + +!*********************************************************************** +! routine walk_string +! +!> \brief Walk a semicolon delimited string to find substrings +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> Walk a string delimited by semicolons and return the first substring +!> from start index, and modify start to point at the next candidate. +!----------------------------------------------------------------------- + subroutine walk_string(next, substr, ok)!{{{ + ! input variables + !----------------------------------------------------------------- + + ! input/output variables + !----------------------------------------------------------------- + character (len=StrKIND), intent(inout) :: next + + ! output variables + !----------------------------------------------------------------- + character (len=StrKIND), intent(out) :: substr + logical, intent(out) :: ok + + ! local variables + !----------------------------------------------------------------- + integer :: i + character (len=StrKIND) :: copy + + ! make a copy + copy = trim(next) + + ! if there's anything in it other than whitespace, pass through + i = verify(copy, ' ') + ok = i .gt. 0 + if (.not. ok) then + return + end if + copy = trim(next(i:)) + + ! find the first semicolon and split + i = scan(copy, ';') + + ! return that substring and the remainder + if (i .gt. 0) then + substr = trim(copy(1:i-1)) + next = trim(copy(i+1:)) + else + substr = trim(copy) + next = '' + end if + + + end subroutine walk_string!}}} + + + +!*********************************************************************** +! routine set_times +! +!> \brief Set a list of times +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> Walk a list of times delimited by spaces and set the time info +!> for the buffer structure so that alarms can be set. +!----------------------------------------------------------------------- + subroutine set_times(buffers, number_of_buffers, clock, & + which, config_str, ok, err) + ! input variables + !----------------------------------------------------------------- + integer, intent(in) :: number_of_buffers, which + character (len=StrKIND), pointer, intent(in) :: config_str + + ! input/output variables + !----------------------------------------------------------------- + type (time_buffer_type), dimension(:), intent(inout) :: buffers + type (MPAS_Clock_type), intent(inout) :: clock + + ! output variables + !----------------------------------------------------------------- + logical, intent(out) :: ok + integer, intent(out) :: err + + ! local variables + !----------------------------------------------------------------- + character (len=StrKIND) :: next_str, time_str + integer :: b + + ! find the first time in the list + next_str = config_str + b = 0 + call walk_string(next_str, time_str, ok) + + ! while the time string is ok + do while (ok) + ! exit if we went over + b = b + 1 + if (b .gt. number_of_buffers) then + exit + end if + + ! set the time + if (which .eq. START_TIMES) then + if (time_str .eq. 'initial_time') then + buffers(b) % start_time = mpas_get_clock_time(clock, & + MPAS_NOW, err) + else + call mpas_set_time(buffers(b) % start_time, & + dateTimeString=time_str, ierr=err) + end if + else if (which .eq. DURATION_INTERVALS) then + if (time_str .eq. 'repeat_interval') then + buffers(b) % duration_interval = buffers(b) % repeat_interval + else + call mpas_set_timeInterval(buffers(b) % duration_interval, & + timeString=time_str, ierr=err) + end if + else if (which .eq. REPEAT_INTERVALS) then + if (time_str .eq. 'reset_interval') then + buffers(b) % repeat_interval = buffers(b) % reset_interval + else + call mpas_set_timeInterval(buffers(b) % repeat_interval, & + timeString=time_str, ierr=err) + end if + else + call mpas_set_timeInterval(buffers(b) % reset_interval, & + timeString=time_str, ierr=err) + end if + + ! get the next time string + call walk_string(next_str, time_str, ok) + end do + + ! only ok if we parsed out as many as there are number of buffers + ok = number_of_buffers .eq. b + end subroutine set_times + + + +!*********************************************************************** +! routine add_new_field +! +!> \brief Function to create a new field from an existing field +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> This routine conducts all initializations required for +!> duplicating a field and adding it to the allFields pool. +!----------------------------------------------------------------------- + subroutine add_new_field(info, inname, prefix, pool)!{{{ + ! input variables + !----------------------------------------------------------------- + type (mpas_pool_field_info_type), intent(in) :: info + character (len=StrKIND), intent(in) :: inname, prefix + + ! input/output variables + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: pool + + ! output variables + !----------------------------------------------------------------- + + ! local variables + !----------------------------------------------------------------- + + ! start procedure + !----------------------------------------------------------------- + + ! duplicate field and add new field to pool + if (info % fieldType .eq. MPAS_POOL_REAL) then + if (info % nDims .eq. 0) then + call copy_field_0r(inname, pool, prefix) + else if (info % nDims .eq. 1) then + call copy_field_1r(inname, pool, prefix) + else if (info % nDims .eq. 2) then + call copy_field_2r(inname, pool, prefix) + else if (info % nDims .eq. 3) then + call copy_field_3r(inname, pool, prefix) + else if (info % nDims .eq. 4) then + call copy_field_4r(inname, pool, prefix) + else + call copy_field_5r(inname, pool, prefix) + end if + else + if (info % nDims .eq. 0) then + call copy_field_0i(inname, pool, prefix) + else if (info % nDims .eq. 1) then + call copy_field_1i(inname, pool, prefix) + else if (info % nDims .eq. 2) then + call copy_field_2i(inname, pool, prefix) + else + call copy_field_3i(inname, pool, prefix) + end if + end if + + end subroutine add_new_field!}}} + + + +!*********************************************************************** +! routine timer_checking +! +!> \brief Timer functions to determine when to run +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> This routine conducts timer checking to determine if it +!> needs to run at this particular time. +!----------------------------------------------------------------------- + subroutine timer_checking(domain, err)!{{{ + ! input variables + !----------------------------------------------------------------- + + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain + + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err + + ! local variables + !----------------------------------------------------------------- + integer :: b + + ! start procedure + !----------------------------------------------------------------- + err = 0 + + do b = 1, size(buffers) + ! see if the started alarm is ringing + if (mpas_is_alarm_ringing(domain % clock, & + buffers(b) % start_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(domain % clock, & + buffers(b) % start_alarm_ID, ierr=err) + buffers(b) % started_flag = .true. + buffers(b) % accumulate_flag = .true. + + ! TODO only reset if not restart + buffers(b) % reset_flag = .true. + end if + + ! if we aren't started, continue to next buffer + if (.not. buffers(b) % started_flag) then + continue + end if + + ! check various other alarms + ! see if we need to reset + if(mpas_is_alarm_ringing(domain % clock, & + buffers(b) % reset_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(domain % clock, & + buffers(b) % reset_alarm_ID, ierr=err) + buffers(b) % reset_flag = .true. + buffers(b) % delay_reset_flag = .true. + end if + + ! turn off accumulation + ! + ! duration needs to be >= 2 * compute_interval + ! (a series can only be 2 or more) + if (mpas_is_alarm_ringing(domain % clock, & + buffers(b) % duration_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(domain % clock, & + buffers(b) % duration_alarm_ID, ierr=err) + buffers(b) % duration_over_flag = .true. + end if + + ! turn on accumulation + ! (this is second, in case the duration and repeat + ! overlaps on the same timer) + if (mpas_is_alarm_ringing(domain % clock, & + buffers(b) % repeat_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(domain % clock, & + buffers(b) % repeat_alarm_ID, ierr=err) + buffers(b) % accumulate_flag = .true. + buffers(b) % duration_over_flag = .false. + end if + + end do + + end subroutine timer_checking!}}} + + + +!*********************************************************************** +! routine typed_operate +! +!> \brief Do the operation, but switch on run-time type +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> Since we don't know the type of the array, we need to do some +!> run-time type switching based on the type of the array. +!----------------------------------------------------------------------- + subroutine typed_operate(block, tvar, operation)!{{{ + ! input variables + !----------------------------------------------------------------- + type (block_type), pointer, intent(in) :: block + integer, intent(in) :: operation + + ! input/output variables + !----------------------------------------------------------------- + type (time_variable_type), intent(inout) :: tvar + + ! output variables + !----------------------------------------------------------------- + + ! local variables + !----------------------------------------------------------------- + + ! switch based on the type, dimensionality, and operation + if (tvar % info % fieldType == MPAS_POOL_REAL) then + if (tvar % info % nDims == 0) then + if (operation .eq. AVG_OP) then + call operate0r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate0r_min(block, tvar) + else + call operate0r_max(block, tvar) + end if + else if (tvar % info % nDims == 1) then + if (operation .eq. AVG_OP) then + call operate1r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate1r_min(block, tvar) + else + call operate1r_max(block, tvar) + end if + else if (tvar % info % nDims == 2) then + if (operation .eq. AVG_OP) then + call operate2r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate2r_min(block, tvar) + else + call operate2r_max(block, tvar) + end if + else if (tvar % info % nDims == 3) then + if (operation .eq. AVG_OP) then + call operate3r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate3r_min(block, tvar) + else + call operate3r_max(block, tvar) + end if + else if (tvar % info % nDims == 4) then + if (operation .eq. AVG_OP) then + call operate4r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate4r_min(block, tvar) + else + call operate4r_max(block, tvar) + end if + else + if (operation .eq. AVG_OP) then + call operate5r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate5r_min(block, tvar) + else + call operate5r_max(block, tvar) + end if + end if + else + if (tvar % info % nDims == 0) then + if (operation .eq. AVG_OP) then + call operate0i_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate0i_min(block, tvar) + else + call operate0i_max(block, tvar) + end if + else if (tvar % info % nDims == 1) then + if (operation .eq. AVG_OP) then + call operate1i_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate1i_min(block, tvar) + else + call operate1i_max(block, tvar) + end if + else if (tvar % info % nDims == 2) then + if (operation .eq. AVG_OP) then + call operate2i_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate2i_min(block, tvar) + else + call operate2i_max(block, tvar) + end if + else + if (operation .eq. AVG_OP) then + call operate3i_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate3i_min(block, tvar) + else + call operate3i_max(block, tvar) + end if + end if + end if + + end subroutine typed_operate!}}} + + + +!*********************************************************************** +! routine copy_field_X +! +!> \brief Functions to create a new field from an existing field +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> This routine conducts initializations required for +!> duplicating a field and adding it to the allFields pool based on type. +!----------------------------------------------------------------------- + +subroutine copy_field_0r(inname, pool, prefix)!{{{ + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool + + type (field0DReal), pointer :: src, dst + integer :: i + + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) + + dst % fieldName = trim(prefix) // dst % fieldName + + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if + + call mpas_pool_add_field(pool, dst % fieldName, dst) +end subroutine copy_field_0r!}}} + +subroutine copy_field_1r(inname, pool, prefix)!{{{ + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool + + type (field1DReal), pointer :: src, dst + integer :: i + + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) + + dst % fieldName = trim(prefix) // dst % fieldName + + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if + + call mpas_pool_add_field(pool, dst % fieldName, dst) +end subroutine copy_field_1r!}}} + +subroutine copy_field_2r(inname, pool, prefix)!{{{ + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool + + type (field2DReal), pointer :: src, dst + integer :: i + + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) + + dst % fieldName = trim(prefix) // dst % fieldName + + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if + + call mpas_pool_add_field(pool, dst % fieldName, dst) +end subroutine copy_field_2r!}}} + +subroutine copy_field_3r(inname, pool, prefix)!{{{ + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool + + type (field3DReal), pointer :: src, dst + integer :: i + + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) + + dst % fieldName = trim(prefix) // dst % fieldName + + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if + + call mpas_pool_add_field(pool, dst % fieldName, dst) +end subroutine copy_field_3r!}}} + +subroutine copy_field_4r(inname, pool, prefix)!{{{ + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool + + type (field4DReal), pointer :: src, dst + integer :: i + + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) + + dst % fieldName = trim(prefix) // dst % fieldName + + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if + + call mpas_pool_add_field(pool, dst % fieldName, dst) +end subroutine copy_field_4r!}}} + +subroutine copy_field_5r(inname, pool, prefix)!{{{ + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool + + type (field5DReal), pointer :: src, dst + integer :: i + + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) + + dst % fieldName = trim(prefix) // dst % fieldName + + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if + + call mpas_pool_add_field(pool, dst % fieldName, dst) +end subroutine copy_field_5r!}}} + +subroutine copy_field_0i(inname, pool, prefix)!{{{ + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool + + type (field0DInteger), pointer :: src, dst + integer :: i + + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) + + dst % fieldName = trim(prefix) // dst % fieldName + + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if + + call mpas_pool_add_field(pool, dst % fieldName, dst) +end subroutine copy_field_0i!}}} + +subroutine copy_field_1i(inname, pool, prefix)!{{{ + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool + + type (field1DInteger), pointer :: src, dst + integer :: i + + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) + + dst % fieldName = trim(prefix) // dst % fieldName + + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if + + call mpas_pool_add_field(pool, dst % fieldName, dst) +end subroutine copy_field_1i!}}} + +subroutine copy_field_2i(inname, pool, prefix)!{{{ + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool + + type (field2DInteger), pointer :: src, dst + integer :: i + + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) + + dst % fieldName = trim(prefix) // dst % fieldName + + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if + + call mpas_pool_add_field(pool, dst % fieldName, dst) +end subroutine copy_field_2i!}}} + +subroutine copy_field_3i(inname, pool, prefix)!{{{ + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool + + type (field3DInteger), pointer :: src, dst + integer :: i + + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) + + dst % fieldName = trim(prefix) // dst % fieldName + + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if + + call mpas_pool_add_field(pool, dst % fieldName, dst) +end subroutine copy_field_3i!}}} + + +!*********************************************************************** +! routine operateX_Y +! +!> \brief Series of subroutines to support operations on run-time types +!> \author Jon Woodring +!> \date March 2, 2015 +!> \details +!> These subroutines encapsulate the different opertions that can occur +!> based on the run-time types. (This would likely be +!> instantiated generics/templates in other languages.) +!> +!> Averaging is done by multiplying out and dividing such that +!> the average state is always in a normalized form -- while +!> this could (will) cause more error in the long run, it does +!> mean that other AMs will be able to use this data and it will +!> always be prenormalized (it also means that we don't have to +!> have a special case of normalizing the data before writing it +!> to disk). +!----------------------------------------------------------------------- + +subroutine operate0r_avg (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate0r_avg + +subroutine operate1r_avg (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate1r_avg + +subroutine operate2r_avg (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate2r_avg + +subroutine operate3r_avg (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate3r_avg + +subroutine operate4r_avg (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate4r_avg + +subroutine operate5r_avg (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate5r_avg + +subroutine operate0i_avg (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate0i_avg + +subroutine operate1i_avg (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate1i_avg + +subroutine operate2i_avg (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate2i_avg + +subroutine operate3i_avg (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate3i_avg + +subroutine operate0r_min (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate0r_min + +subroutine operate1r_min (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate1r_min + +subroutine operate2r_min (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate2r_min + +subroutine operate3r_min (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate3r_min + +subroutine operate4r_min (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate4r_min + +subroutine operate5r_min (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate5r_min + +subroutine operate0i_min (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate0i_min + +subroutine operate1i_min (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate1i_min + +subroutine operate2i_min (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate2i_min + +subroutine operate3i_min (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate3i_min + +subroutine operate0r_max (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate0r_max + +subroutine operate1r_max (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate1r_max + +subroutine operate2r_max (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate2r_max + +subroutine operate3r_max (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate3r_max + +subroutine operate4r_max (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate4r_max + +subroutine operate5r_max (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate5r_max + +subroutine operate0i_max (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate0i_max + +subroutine operate1i_max (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate1i_max + +subroutine operate2i_max (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do +end subroutine operate2i_max + +subroutine operate3i_max (start_block, tvar) + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + block => block % next + end do +end subroutine operate3i_max end module ocn_time_series_stats ! vim: foldmethod=marker From c6828aee9b86de0bfb722d5b8e59e2bb5e978fde Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Mon, 17 Aug 2015 11:50:09 -0600 Subject: [PATCH 0138/1724] replace spaces with tabs --- src/core_landice/build_options.mk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_landice/build_options.mk b/src/core_landice/build_options.mk index dc37623b6a..d65eaf485c 100644 --- a/src/core_landice/build_options.mk +++ b/src/core_landice/build_options.mk @@ -7,4 +7,4 @@ FCINCLUDES += -I$(ROOT_DIR)/core_landice/mode_forward -I$(ROOT_DIR)/core_landice override CPPFLAGS += -DCORE_LANDICE report_builds: - @echo "CORE=landice" + @echo "CORE=landice" From e736549d4764b935405e1027230f22b8abe68018 Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Mon, 17 Aug 2015 12:09:20 -0600 Subject: [PATCH 0139/1724] incorporation some changes / clean-up suggested by Doug J. --- src/core_landice/Makefile | 9 ------ src/core_landice/build_options.mk | 40 ++++++++++++++++++++++++++ src/core_landice/mode_forward/Makefile | 40 -------------------------- 3 files changed, 40 insertions(+), 49 deletions(-) diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index d4f596b2ee..6671f31a35 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -42,12 +42,3 @@ clean: $(RM) -r default_inputs (cd shared; $(MAKE) clean) (cd mode_forward; $(MAKE) clean) - -.F.o: - $(RM) $@ $*.mod - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 - -.cpp.o: - $(CXX) $(CXXFLAGS) -c $*.cpp $(CXINCLUDES) $(CPPINCLUDES) -lmpi_cxx -lstdc++ $(CPPFLAGS) - diff --git a/src/core_landice/build_options.mk b/src/core_landice/build_options.mk index d65eaf485c..41403d05d2 100644 --- a/src/core_landice/build_options.mk +++ b/src/core_landice/build_options.mk @@ -6,5 +6,45 @@ NAMELIST_SUFFIX=landice FCINCLUDES += -I$(ROOT_DIR)/core_landice/mode_forward -I$(ROOT_DIR)/core_landice/shared override CPPFLAGS += -DCORE_LANDICE +# =================================== +# Check if building with LifeV, Albany, and/or PHG external libraries + +BUILD_INTERFACE=false # This will become true if any of the external libraries are being used. + +# LifeV can solve L1L2 or FO +ifeq "$(LIFEV)" "true" + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_L1L2 + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER + BUILD_INTERFACE = true +endif # LIFEV IF + +# Albany can only solve FO at present +ifeq "$(ALBANY)" "true" + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER + BUILD_INTERFACE = true +endif # ALBANY IF + +# Currently LifeV AND Albany is not allowed +ifeq "$(LIFEV)" "true" +ifeq "$(ALBANY)" "true" + $(error Compiling with both LifeV and Albany is not allowed at this time.) +endif +endif + +# PHG currently requires LifeV +ifeq "$(PHG)" "true" +ifneq "$(LIFEV)" "true" + $(error Compiling with PHG requires LifeV at this time.) +endif +endif +# PHG can only Stokes at present +ifeq "$(PHG)" "true" + EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_STOKES + BUILD_INTERFACE = true +endif # PHG IF + +override CPPFLAGS += $(EXTERNAL_DYCORE_FLAG) +# =================================== + report_builds: @echo "CORE=landice" diff --git a/src/core_landice/mode_forward/Makefile b/src/core_landice/mode_forward/Makefile index 2d458ada56..3c732f28d6 100644 --- a/src/core_landice/mode_forward/Makefile +++ b/src/core_landice/mode_forward/Makefile @@ -1,44 +1,4 @@ -# =================================== -# Check if building with LifeV, Albany, and/or PHG external libraries - -BUILD_INTERFACE=false # This will become true if any of the external libraries are being used. - -# LifeV can solve L1L2 or FO -ifeq "$(LIFEV)" "true" - EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_L1L2 - EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER - BUILD_INTERFACE = true -endif # LIFEV IF - -# Albany can only solve FO at present -ifeq "$(ALBANY)" "true" - EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER - BUILD_INTERFACE = true -endif # ALBANY IF - -# Currently LifeV AND Albany is not allowed -ifeq "$(LIFEV)" "true" -ifeq "$(ALBANY)" "true" - $(error Compiling with both LifeV and Albany is not allowed at this time.) -endif -endif - -# PHG currently requires LifeV -ifeq "$(PHG)" "true" -ifneq "$(LIFEV)" "true" - $(error Compiling with PHG requires LifeV at this time.) -endif -endif -# PHG can only Stokes at present -ifeq "$(PHG)" "true" - EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_STOKES - BUILD_INTERFACE = true -endif # PHG IF - -override CPPFLAGS += $(EXTERNAL_DYCORE_FLAG) -# =================================== - .SUFFIXES: .F .o .cpp OBJS = mpas_li_core.o \ From c63ad6367f66eee3cfbea0c712df28e4d10083b6 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Mon, 17 Aug 2015 12:47:20 -0600 Subject: [PATCH 0140/1724] Remove defunct analysis member variables and calls These changes remove some varliabes and calls that became defunct with commit bb3e26d (PR #466), mostly because package management was moved from the analysis member module to the driver. --- .../analysis_members/mpas_ocn_global_stats.F | 6 +-- .../mpas_ocn_layer_volume_weighted_averages.F | 3 -- .../mpas_ocn_surface_area_weighted_averages.F | 1 - .../mpas_ocn_water_mass_census.F | 3 -- .../analysis_members/mpas_ocn_zonal_mean.F | 53 ------------------- 5 files changed, 1 insertion(+), 65 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_global_stats.F b/src/core_ocean/analysis_members/mpas_ocn_global_stats.F index c989190b72..7dab22fcc8 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_global_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_global_stats.F @@ -247,16 +247,12 @@ subroutine ocn_compute_global_stats(domain, timeLevel, err)!{{{ real (kind=RKIND), dimension(:,:), allocatable :: enstrophy, normalizedAbsoluteVorticity, workArray - logical, pointer :: thicknessFilterActive, globalStatsAMPKGActive + logical, pointer :: thicknessFilterActive logical, pointer :: config_AM_globalStats_text_file character (len=StrKIND), pointer :: config_AM_globalStats_directory err = 0 - call mpas_pool_get_package(ocnPackages, 'globalStatsAMPKGActive', globalStatsAMPKGActive) - - if ( .not. globalStatsAMPKGActive ) return - dminfo = domain % dminfo call mpas_pool_get_package(ocnPackages, 'thicknessFilterActive', thicknessFilterActive) diff --git a/src/core_ocean/analysis_members/mpas_ocn_layer_volume_weighted_averages.F b/src/core_ocean/analysis_members/mpas_ocn_layer_volume_weighted_averages.F index 0d77586c53..ad31f86438 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_layer_volume_weighted_averages.F +++ b/src/core_ocean/analysis_members/mpas_ocn_layer_volume_weighted_averages.F @@ -196,9 +196,6 @@ subroutine ocn_compute_layer_volume_weighted_averages(domain, timeLevel, err)!{{ integer :: iDataField, nDefinedDataFields integer :: iCell, iLevel, iRegion, iTracer, err_tmp - ! package flag - logical, pointer :: layerVolumeWeightedAverageAMPKGActive - ! buffers data for message passaging integer :: kBuffer, kBufferLength real (kind=RKIND), dimension(:), allocatable :: workBufferSum, workBufferSumReduced diff --git a/src/core_ocean/analysis_members/mpas_ocn_surface_area_weighted_averages.F b/src/core_ocean/analysis_members/mpas_ocn_surface_area_weighted_averages.F index 086d762159..b65a2e3be3 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_surface_area_weighted_averages.F +++ b/src/core_ocean/analysis_members/mpas_ocn_surface_area_weighted_averages.F @@ -212,7 +212,6 @@ subroutine ocn_compute_surface_area_weighted_averages(domain, timeLevel, err)!{{ integer :: iCell, iRegion, iTracer, err_tmp ! package flag - logical, pointer :: surfaceAreaWeightedAveragesAMPKGActive logical, pointer :: bulkForcingPkgActive logical, pointer :: frazilIcePkgActive diff --git a/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F b/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F index 287a0e4dfc..b5288f8be5 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F +++ b/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F @@ -187,9 +187,6 @@ subroutine ocn_compute_water_mass_census(domain, timeLevel, err)!{{{ real (kind=RKIND), pointer :: minSalinity, maxSalinity real (kind=RKIND) :: deltaTemperature, deltaSalinity, temperature, salinity, density, zPosition, volume - ! package flag - logical, pointer :: waterMassCensusAMPKGActive - ! buffers data for message passaging integer :: kBuffer, kBufferLength real (kind=RKIND), dimension(:), allocatable :: workBufferSum, workBufferSumReduced diff --git a/src/core_ocean/analysis_members/mpas_ocn_zonal_mean.F b/src/core_ocean/analysis_members/mpas_ocn_zonal_mean.F index 47e101ee2f..04a1796de0 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_zonal_mean.F +++ b/src/core_ocean/analysis_members/mpas_ocn_zonal_mean.F @@ -60,59 +60,6 @@ module ocn_zonal_mean contains -!*********************************************************************** -! -! routine ocn_setup_packages_zonal_mean -! -!> \brief Set up packages for MPAS-Ocean analysis member -!> \author Mark Petersen -!> \date November 2013 -!> \details -!> This routine is intended to configure the packages for this MPAS -!> ocean analysis member -! -!----------------------------------------------------------------------- - - subroutine ocn_setup_packages_zonal_mean(configPool, packagePool, err)!{{{ - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - type (mpas_pool_type), intent(in) :: configPool - type (mpas_pool_type), intent(in) :: packagePool - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - integer, intent(out) :: err !< Output: error flag - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - logical, pointer :: zonalMeanAMActive - - err = 0 - - call mpas_pool_get_package(packagePool, 'zonalMeanAMActive', zonalMeanAMActive) - - ! turn on package for this analysis member - zonalMeanAMActive = .true. - - end subroutine ocn_setup_packages_zonal_mean!}}} - !*********************************************************************** ! ! routine ocn_init_zonal_mean From 8dcbb08eb07658adf038e559dafe8322fdb4b667 Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Mon, 17 Aug 2015 13:14:03 -0600 Subject: [PATCH 0141/1724] additional minor cleanup to main land ice core make file --- src/core_landice/Makefile | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index 6671f31a35..71fbb2e040 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -2,7 +2,7 @@ .SUFFIXES: .F .o .cpp .PHONY: mode_forward shared -all: shared mode_forward lib_landice core_landice +all: core_landice shared: (cd shared; $(MAKE)) @@ -10,10 +10,8 @@ shared: mode_forward: shared (cd mode_forward; $(MAKE)) -lib_landice: shared mode_forward - -core_landice: lib_landice - ar -ru libdycore.a mode_forward/*.o +core_landice: mode_forward shared + ar -ru libdycore.a `find . -type f -name "*.o"` core_input_gen: if [ ! -e default_inputs ]; then mkdir default_inputs; fi From 65c0375c490d4b194919ce08af50fde247ddb681 Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Mon, 17 Aug 2015 13:45:11 -0600 Subject: [PATCH 0142/1724] Retabbed. --- .../mpas_ocn_time_series_stats.F | 3911 ++++++++--------- 1 file changed, 1954 insertions(+), 1957 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index af4612b947..0f00c6cd76 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -7,7 +7,7 @@ ! !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! ocn_time_series_stats +! ocn_time_series_stats ! !> \brief MPAS ocean analysis core member: time_series_stats !> \author Jon Woodring @@ -16,85 +16,85 @@ !> Flexible time series averaging, mins, and maxes of fields. !----------------------------------------------------------------------- module ocn_time_series_stats - use mpas_derived_types - use mpas_pool_routines - use mpas_dmpar - use mpas_timekeeping - use mpas_stream_manager - - use ocn_constants - use ocn_diagnostics_routines - - implicit none - private - save - - ! Public parameters - !-------------------------------------------------------------------- - - ! Public member functions - !-------------------------------------------------------------------- - public :: ocn_init_time_series_stats, & - ocn_compute_time_series_stats, & - ocn_restart_time_series_stats, & - ocn_finalize_time_series_stats - - ! Private module variables - !-------------------------------------------------------------------- - - ! startup, interval, and restart is done in the outer analysis driver - - ! time buffer type - ! this keeps track of timers and if and when they need to accumulate - type time_buffer_type - ! internal state - logical :: started_flag, accumulate_flag, reset_flag - logical :: delay_reset_flag, duration_over_flag - integer :: total_accum - - type (MPAS_Time_type) :: start_time - type (MPAS_TimeInterval_type) :: duration_interval - type (MPAS_TimeInterval_type) :: repeat_interval - type (MPAS_TimeInterval_type) :: reset_interval - - ! alarm IDs - character (len=StrKIND) :: start_alarm_ID - character (len=StrKIND) :: repeat_alarm_ID - character (len=StrKIND) :: duration_alarm_ID - character (len=StrKIND) :: reset_alarm_ID - end type time_buffer_type - - ! time variable type - ! this keeps track of arrays, array types, and names - type time_variable_type - type (mpas_pool_field_info_type) :: info - character (len=StrKIND) :: input_name - ! either you have to put a number of buffers per variable - ! or put the output variables in the buffers (I decided to put it here) - character (len=StrKIND), dimension(:), allocatable :: output_names - end type time_variable_type - - ! operation - integer :: operation - - ! stream name - character (len=StrKIND), pointer :: stream_name - - ! information per variable - type (time_variable_type), dimension(:), allocatable :: variables - - ! information per buffer - type (time_buffer_type), dimension(:), allocatable :: buffers - - ! enum of ops and types - integer, parameter :: AVG_OP = 1 - integer, parameter :: MIN_OP = 2 - integer, parameter :: MAX_OP = 3 - - integer, parameter :: START_TIMES = 5 - integer, parameter :: DURATION_INTERVALS = 6 - integer, parameter :: REPEAT_INTERVALS = 7 - integer, parameter :: RESET_INTERVALS = 8 + use mpas_derived_types + use mpas_pool_routines + use mpas_dmpar + use mpas_timekeeping + use mpas_stream_manager + + use ocn_constants + use ocn_diagnostics_routines + + implicit none + private + save + + ! Public parameters + !-------------------------------------------------------------------- + + ! Public member functions + !-------------------------------------------------------------------- + public :: ocn_init_time_series_stats, & + ocn_compute_time_series_stats, & + ocn_restart_time_series_stats, & + ocn_finalize_time_series_stats + + ! Private module variables + !-------------------------------------------------------------------- + + ! startup, interval, and restart is done in the outer analysis driver + + ! time buffer type + ! this keeps track of timers and if and when they need to accumulate + type time_buffer_type + ! internal state + logical :: started_flag, accumulate_flag, reset_flag + logical :: delay_reset_flag, duration_over_flag + integer :: total_accum + + type (MPAS_Time_type) :: start_time + type (MPAS_TimeInterval_type) :: duration_interval + type (MPAS_TimeInterval_type) :: repeat_interval + type (MPAS_TimeInterval_type) :: reset_interval + + ! alarm IDs + character (len=StrKIND) :: start_alarm_ID + character (len=StrKIND) :: repeat_alarm_ID + character (len=StrKIND) :: duration_alarm_ID + character (len=StrKIND) :: reset_alarm_ID + end type time_buffer_type + + ! time variable type + ! this keeps track of arrays, array types, and names + type time_variable_type + type (mpas_pool_field_info_type) :: info + character (len=StrKIND) :: input_name + ! either you have to put a number of buffers per variable + ! or put the output variables in the buffers (I decided to put it here) + character (len=StrKIND), dimension(:), allocatable :: output_names + end type time_variable_type + + ! operation + integer :: operation + + ! stream name + character (len=StrKIND), pointer :: stream_name + + ! information per variable + type (time_variable_type), dimension(:), allocatable :: variables + + ! information per buffer + type (time_buffer_type), dimension(:), allocatable :: buffers + + ! enum of ops and types + integer, parameter :: AVG_OP = 1 + integer, parameter :: MIN_OP = 2 + integer, parameter :: MAX_OP = 3 + + integer, parameter :: START_TIMES = 5 + integer, parameter :: DURATION_INTERVALS = 6 + integer, parameter :: REPEAT_INTERVALS = 7 + integer, parameter :: RESET_INTERVALS = 8 !*********************************************************************** contains @@ -102,862 +102,859 @@ module ocn_time_series_stats !*********************************************************************** -! routine ocn_init_time_series_stats +! routine ocn_init_time_series_stats ! -!> \brief Initialize MPAS-Ocean analysis member +!> \brief Initialize MPAS-Ocean analysis member !> \author Jon Woodring !> \date March 2, 2015 !> \details !> This routine conducts all initializations required for the !> MPAS-Ocean analysis member. !----------------------------------------------------------------------- - subroutine ocn_init_time_series_stats(domain, err)!{{{ - - ! input variables - !----------------------------------------------------------------- - - ! input/output variables - !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain - - ! output variables - !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag - - ! local variables - !----------------------------------------------------------------- - integer :: v, b - character (len=StrKIND), pointer :: config_results - logical, pointer :: copy_mesh - integer :: number_of_variables, number_of_buffers - character (len=StrKIND) :: stream_str, prefix_str, & - config_str, buffer_str, op_str, var_str, field - logical :: ok - - ! start procedure - !----------------------------------------------------------------- - err = 0 - - ! TODO do restart - - ! string representation - ! TODO placeholder for some unique ID if this code is replicated - ! per multiple AMs for multiple streams - stream_str = '' - prefix_str = 'config_AM_timeSeriesStats' // trim(stream_str) - - ! get our operation - config_str = trim(prefix_str) // '_operation' - call mpas_pool_get_config(domain % configs, config_str, config_results) - if (config_results .eq. 'avg') then - operation = AVG_OP - op_str = 'avg' - else if (config_results .eq. 'min') then - operation = MIN_OP - op_str = 'min' - else if (config_results .eq. 'max') then - operation = MAX_OP - op_str = 'max' - else - ! error if unknown operation - call mpas_dmpar_global_abort('Error: unknown operation in time ' // & - 'averaging analysis member configuration.') - end if - - ! count string tokens - config_str = trim(prefix_str) // '_initial_times' - call mpas_pool_get_config(domain % configs, config_str, config_results) - field = config_results - number_of_buffers = 1 - b = scan(field, ';') - do while (b .gt. 0) - number_of_buffers = number_of_buffers + 1 - field = field(b+1:) - b = scan(field, ';') - end do - - ! get the stream name - config_str = trim(prefix_str) // '_stream_name' - call mpas_pool_get_config(domain % configs, config_str, stream_name) - - if (stream_name .eq. 'none') then - call mpas_dmpar_global_abort('Error: stream cannot be "none" ' // & - 'for time series stats.') - end if - - ! set up all of the timing - ! - - ! allocate the state for the buffers - allocate(buffers(number_of_buffers)) - - ! configure start times - config_str = trim(prefix_str) // '_initial_times' - call mpas_pool_get_config(domain % configs, config_str, config_results) - call set_times(buffers, number_of_buffers, domain % clock, & - START_TIMES, config_results, ok, err) - - ! order matters, don't reorder these following ones! - ! it matters because times/intervals can be configured to be equal - ! to other ones - - ! configure reset intervals - config_str = trim(prefix_str) // '_reset_intervals' - call mpas_pool_get_config(domain % configs, config_str, config_results) - call set_times(buffers, number_of_buffers, domain % clock, & - RESET_INTERVALS, config_results, ok, err) - if (.not. ok) then - call mpas_dmpar_global_abort('Error: number of times in ' // & - 'reset_intervals is not consistent with number of times ' // & - 'in initial_times in time series stats analysis member ' // & - 'configuration.') - end if - - ! configure repeat intervals - config_str = trim(prefix_str) // '_repeat_intervals' - call mpas_pool_get_config(domain % configs, config_str, config_results) - call set_times(buffers, number_of_buffers, domain % clock, & - REPEAT_INTERVALS, config_results, ok, err) - if (.not. ok) then - call mpas_dmpar_global_abort('Error: number of times in ' // & - 'repeat_intervals is not consistent with number of times ' // & - 'in initial_times in time series stats analysis member ' // & - 'configuration.') - end if - - ! configure duration intervals - config_str = trim(prefix_str) // '_duration_intervals' - call mpas_pool_get_config(domain % configs, config_str, config_results) - call set_times(buffers, number_of_buffers, domain % clock, & - DURATION_INTERVALS, config_results, ok, err) - if (.not. ok) then - call mpas_dmpar_global_abort('Error: number of times in ' // & - 'duration_intervals is not consistent with number of times ' // & - 'in initial_times in time series stats analysis member ' // & - 'configuration.') - end if - - ! check if the configuration is sensible - do b = 1, number_of_buffers - if (buffers(b) % repeat_interval .gt. & - buffers(b) % reset_interval) then - write(stderrUnit,*) 'Warning: repeat_interval > ' // & - 'reset_interval in time averaging analysis member ' // & - 'configuration. Truncating repeat_interval.' - buffers(b) % repeat_interval = buffers(b) % reset_interval - end if - - if (buffers(b) % duration_interval .gt. & - buffers(b) % repeat_interval) then - write(stderrUnit,*) 'Warning: duration_interval > ' // & - 'repeat_interval in time averaging analysis member ' // & - 'configuration. Truncating duration_interval.' - buffers(b) % repeat_interval = buffers(b) % reset_interval - end if - end do - - ! - ! OK, if we got this far, then we should be able to allocate memory - ! and set up the timers and variables that we will analyze - ! - - ! count the number of variables - call mpas_stream_mgr_begin_iteration(domain % streamManager, & - stream_name, err) - number_of_variables = 0 - do while (mpas_stream_mgr_get_next_field(domain % streamManager, & - stream_name, field)) - number_of_variables = number_of_variables + 1 - end do - - ! allocate the variable information - allocate(variables(number_of_variables)) - - ! get the old field names - call mpas_stream_mgr_begin_iteration(domain % streamManager, & - stream_name, err) - v = 1 - do while (mpas_stream_mgr_get_next_field(domain % streamManager, & - stream_name, field)) - variables(v) % input_name = field - v = v + 1 - end do - - ! remove the old ones from the stream - do v = 1, number_of_variables - call mpas_stream_mgr_remove_field(domain % streamManager, & - stream_name, variables(v) % input_name) - end do - - ! add xtime to the stream +subroutine ocn_init_time_series_stats(domain, err)!{{{ + + ! input variables + !----------------------------------------------------------------- + + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain + + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + ! local variables + !----------------------------------------------------------------- + integer :: v, b + character (len=StrKIND), pointer :: config_results + logical, pointer :: copy_mesh + integer :: number_of_variables, number_of_buffers + character (len=StrKIND) :: stream_str, prefix_str, & + config_str, buffer_str, op_str, var_str, field + logical :: ok + + ! start procedure + !----------------------------------------------------------------- + err = 0 + + ! TODO do restart + + ! string representation + ! TODO placeholder for some unique ID if this code is replicated + ! per multiple AMs for multiple streams + stream_str = '' + prefix_str = 'config_AM_timeSeriesStats' // trim(stream_str) + + ! get our operation + config_str = trim(prefix_str) // '_operation' + call mpas_pool_get_config(domain % configs, config_str, config_results) + if (config_results .eq. 'avg') then + operation = AVG_OP + op_str = 'avg' + else if (config_results .eq. 'min') then + operation = MIN_OP + op_str = 'min' + else if (config_results .eq. 'max') then + operation = MAX_OP + op_str = 'max' + else + ! error if unknown operation + call mpas_dmpar_global_abort('Error: unknown operation in time ' // & + 'averaging analysis member configuration.') + end if + + ! count string tokens + config_str = trim(prefix_str) // '_initial_times' + call mpas_pool_get_config(domain % configs, config_str, config_results) + field = config_results + number_of_buffers = 1 + b = scan(field, ';') + do while (b .gt. 0) + number_of_buffers = number_of_buffers + 1 + field = field(b+1:) + b = scan(field, ';') + end do + + ! get the stream name + config_str = trim(prefix_str) // '_stream_name' + call mpas_pool_get_config(domain % configs, config_str, stream_name) + + if (stream_name .eq. 'none') then + call mpas_dmpar_global_abort('Error: stream cannot be "none" ' // & + 'for time series stats.') + end if + + ! set up all of the timing + ! + + ! allocate the state for the buffers + allocate(buffers(number_of_buffers)) + + ! configure start times + config_str = trim(prefix_str) // '_initial_times' + call mpas_pool_get_config(domain % configs, config_str, config_results) + call set_times(buffers, number_of_buffers, domain % clock, & + START_TIMES, config_results, ok, err) + + ! order matters, don't reorder these following ones! + ! it matters because times/intervals can be configured to be equal + ! to other ones + + ! configure reset intervals + config_str = trim(prefix_str) // '_reset_intervals' + call mpas_pool_get_config(domain % configs, config_str, config_results) + call set_times(buffers, number_of_buffers, domain % clock, & + RESET_INTERVALS, config_results, ok, err) + if (.not. ok) then + call mpas_dmpar_global_abort('Error: number of times in ' // & + 'reset_intervals is not consistent with number of times ' // & + 'in initial_times in time series stats analysis member ' // & + 'configuration.') + end if + + ! configure repeat intervals + config_str = trim(prefix_str) // '_repeat_intervals' + call mpas_pool_get_config(domain % configs, config_str, config_results) + call set_times(buffers, number_of_buffers, domain % clock, & + REPEAT_INTERVALS, config_results, ok, err) + if (.not. ok) then + call mpas_dmpar_global_abort('Error: number of times in ' // & + 'repeat_intervals is not consistent with number of times ' // & + 'in initial_times in time series stats analysis member ' // & + 'configuration.') + end if + + ! configure duration intervals + config_str = trim(prefix_str) // '_duration_intervals' + call mpas_pool_get_config(domain % configs, config_str, config_results) + call set_times(buffers, number_of_buffers, domain % clock, & + DURATION_INTERVALS, config_results, ok, err) + if (.not. ok) then + call mpas_dmpar_global_abort('Error: number of times in ' // & + 'duration_intervals is not consistent with number of times ' // & + 'in initial_times in time series stats analysis member ' // & + 'configuration.') + end if + + ! check if the configuration is sensible + do b = 1, number_of_buffers + if (buffers(b) % repeat_interval .gt. & + buffers(b) % reset_interval) then + write(stderrUnit,*) 'Warning: repeat_interval > ' // & + 'reset_interval in time averaging analysis member ' // & + 'configuration. Truncating repeat_interval.' + buffers(b) % repeat_interval = buffers(b) % reset_interval + end if + + if (buffers(b) % duration_interval .gt. & + buffers(b) % repeat_interval) then + write(stderrUnit,*) 'Warning: duration_interval > ' // & + 'repeat_interval in time averaging analysis member ' // & + 'configuration. Truncating duration_interval.' + buffers(b) % repeat_interval = buffers(b) % reset_interval + end if + end do + + ! + ! OK, if we got this far, then we should be able to allocate memory + ! and set up the timers and variables that we will analyze + ! + + ! count the number of variables + call mpas_stream_mgr_begin_iteration(domain % streamManager, & + stream_name, err) + number_of_variables = 0 + do while (mpas_stream_mgr_get_next_field(domain % streamManager, & + stream_name, field)) + number_of_variables = number_of_variables + 1 + end do + + ! allocate the variable information + allocate(variables(number_of_variables)) + + ! get the old field names + call mpas_stream_mgr_begin_iteration(domain % streamManager, & + stream_name, err) + v = 1 + do while (mpas_stream_mgr_get_next_field(domain % streamManager, & + stream_name, field)) + variables(v) % input_name = field + v = v + 1 + end do + + ! remove the old ones from the stream + do v = 1, number_of_variables + call mpas_stream_mgr_remove_field(domain % streamManager, & + stream_name, variables(v) % input_name) + end do + + ! add xtime to the stream + call mpas_stream_mgr_add_field(domain % streamManager, & + stream_name, 'xtime', ierr=err) + + ! optionally add mesh to stream + config_str = trim(prefix_str) // '_add_mesh' + call mpas_pool_get_config(domain % configs, config_str, copy_mesh) + if (copy_mesh) then + call mpas_stream_mgr_begin_iteration(domain % streamManager, & + 'mesh', err) + do while (mpas_stream_mgr_get_next_field(domain % streamManager, & + 'mesh', field)) call mpas_stream_mgr_add_field(domain % streamManager, & - stream_name, 'xtime', ierr=err) - - ! optionally add mesh to stream - config_str = trim(prefix_str) // '_add_mesh' - call mpas_pool_get_config(domain % configs, config_str, copy_mesh) - if (copy_mesh) then - call mpas_stream_mgr_begin_iteration(domain % streamManager, & - 'mesh', err) - do while (mpas_stream_mgr_get_next_field(domain % streamManager, & - 'mesh', field)) - call mpas_stream_mgr_add_field(domain % streamManager, & - stream_name, field, ierr=err) - end do - end if - - ! set up the variables - call mpas_stream_mgr_begin_iteration(domain % streamManager, & - stream_name, err) - do v = 1, number_of_variables - ! allocate space for the names of the outputs - allocate(variables(v) % output_names(number_of_buffers)) - write(var_str, '(I0)') v - - ! get the info of the field - call mpas_pool_get_field_info(domain % blocklist % allFields, & - variables(v) % input_name, variables(v) % info) - - ! check if we can handle it - if(.not. & - ((variables(v) % info % fieldType .eq. MPAS_POOL_REAL) & - .or. & - (variables(v) % info % fieldType .eq. MPAS_POOL_INTEGER))) & - then - call mpas_dmpar_global_abort('Error: field "' // & - trim(variables(v) % input_name) // '" listed in the ' // & - 'output stream, for time series stats analysis member ' // & - 'stream, is not real or integer.') - end if - - ! allocate a number of fields and add field - do b = 1, number_of_buffers - ! create the name of the new field - write(buffer_str, '(I0)') b - field = 'time' // trim(stream_str) // '_' // & - trim(op_str) // '_' // trim(buffer_str) // '_' - variables(v) % output_names(b) = trim(field) // & - variables(v) % input_name - - ! create the field and add to pool - call add_new_field(variables(v) % info, & - variables(v) % input_name, field, & - domain % blocklist % allFields) - - ! add the field to the stream - call mpas_stream_mgr_add_field(domain % streamManager, & - stream_name, variables(v) % output_names(b), ierr=err) - end do - - end do ! number_of_variables - - ! configure alarms - do b = 1, number_of_buffers - write(buffer_str, '(I0)') b - buffers(b) % start_alarm_ID = & - 'tavg_start' // trim(stream_str) // '_' // buffer_str - call mpas_add_clock_alarm(domain % clock, & - buffers(b) % start_alarm_ID, & - buffers(b) % start_time, ierr=err) - - buffers(b) % repeat_alarm_ID = & - 'tavg_repeat' // trim(stream_str) // '_' // buffer_str - call mpas_add_clock_alarm(domain % clock, & - buffers(b) % repeat_alarm_ID, & - buffers(b) % start_time + & - buffers(b) % repeat_interval, & - buffers(b) % repeat_interval, ierr=err) - - buffers(b) % duration_alarm_ID = & - 'tavg_duration' // trim(stream_str) // '_' // buffer_str - call mpas_add_clock_alarm(domain % clock, & - buffers(b) % duration_alarm_ID, & - buffers(b) % start_time + & - buffers(b) % duration_interval, & - buffers(b) % repeat_interval, ierr=err) - - buffers(b) % reset_alarm_ID = & - 'tavg_reset' // trim(stream_str) // '_' // buffer_str - call mpas_add_clock_alarm(domain % clock, & - buffers(b) % reset_alarm_ID, & - buffers(b) % start_time + & - buffers(b) % reset_interval, & - buffers(b) % reset_interval, ierr=err) - end do - - ! set initial flags - do b = 1, number_of_buffers - buffers(b) % started_flag = .false. - buffers(b) % reset_flag = .false. - buffers(b) % accumulate_flag = .false. - buffers(b) % delay_reset_flag = .false. - buffers(b) % duration_over_flag = .false. - end do - - end subroutine ocn_init_time_series_stats!}}} + stream_name, field, ierr=err) + end do + end if + + ! set up the variables + call mpas_stream_mgr_begin_iteration(domain % streamManager, & + stream_name, err) + do v = 1, number_of_variables + ! allocate space for the names of the outputs + allocate(variables(v) % output_names(number_of_buffers)) + write(var_str, '(I0)') v + + ! get the info of the field + call mpas_pool_get_field_info(domain % blocklist % allFields, & + variables(v) % input_name, variables(v) % info) + + ! check if we can handle it + if(.not. & + ((variables(v) % info % fieldType .eq. MPAS_POOL_REAL) & + .or. & + (variables(v) % info % fieldType .eq. MPAS_POOL_INTEGER))) & + then + call mpas_dmpar_global_abort('Error: field "' // & + trim(variables(v) % input_name) // '" listed in the ' // & + 'output stream, for time series stats analysis member ' // & + 'stream, is not real or integer.') + end if + + ! allocate a number of fields and add field + do b = 1, number_of_buffers + ! create the name of the new field + write(buffer_str, '(I0)') b + field = 'time' // trim(stream_str) // '_' // & + trim(op_str) // '_' // trim(buffer_str) // '_' + variables(v) % output_names(b) = trim(field) // & + variables(v) % input_name + + ! create the field and add to pool + call add_new_field(variables(v) % info, & + variables(v) % input_name, field, & + domain % blocklist % allFields) + + ! add the field to the stream + call mpas_stream_mgr_add_field(domain % streamManager, & + stream_name, variables(v) % output_names(b), ierr=err) + end do + + end do ! number_of_variables + + ! configure alarms + do b = 1, number_of_buffers + write(buffer_str, '(I0)') b + buffers(b) % start_alarm_ID = & + 'tavg_start' // trim(stream_str) // '_' // buffer_str + call mpas_add_clock_alarm(domain % clock, & + buffers(b) % start_alarm_ID, & + buffers(b) % start_time, ierr=err) + + buffers(b) % repeat_alarm_ID = & + 'tavg_repeat' // trim(stream_str) // '_' // buffer_str + call mpas_add_clock_alarm(domain % clock, & + buffers(b) % repeat_alarm_ID, & + buffers(b) % start_time + & + buffers(b) % repeat_interval, & + buffers(b) % repeat_interval, ierr=err) + + buffers(b) % duration_alarm_ID = & + 'tavg_duration' // trim(stream_str) // '_' // buffer_str + call mpas_add_clock_alarm(domain % clock, & + buffers(b) % duration_alarm_ID, & + buffers(b) % start_time + & + buffers(b) % duration_interval, & + buffers(b) % repeat_interval, ierr=err) + + buffers(b) % reset_alarm_ID = & + 'tavg_reset' // trim(stream_str) // '_' // buffer_str + call mpas_add_clock_alarm(domain % clock, & + buffers(b) % reset_alarm_ID, & + buffers(b) % start_time + & + buffers(b) % reset_interval, & + buffers(b) % reset_interval, ierr=err) + end do + + ! set initial flags + do b = 1, number_of_buffers + buffers(b) % started_flag = .false. + buffers(b) % reset_flag = .false. + buffers(b) % accumulate_flag = .false. + buffers(b) % delay_reset_flag = .false. + buffers(b) % duration_over_flag = .false. + end do + +end subroutine ocn_init_time_series_stats!}}} !*********************************************************************** -! routine ocn_compute_time_series_stats +! routine ocn_compute_time_series_stats ! -!> \brief Compute MPAS-Ocean analysis member +!> \brief Compute MPAS-Ocean analysis member !> \author Jon Woodring !> \date March 2, 2015 !> \details !> This routine conducts all computation required for this !> MPAS-Ocean analysis member. !----------------------------------------------------------------------- - subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ - ! input variables - !----------------------------------------------------------------- - integer, intent(in) :: timeLevel - - ! input/output variables - !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain - - ! output variables - !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag - - ! local variables - !----------------------------------------------------------------- - integer :: i, v, b - - ! start procedure - !----------------------------------------------------------------- - err = 0 - - ! do all of the time checking and flag setting - call timer_checking(domain, err) - - ! update number of accumulations, once only - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - buffers(b) % total_accum = 1 - else if (buffers(b) % accumulate_flag) then - buffers(b) % total_accum = buffers(b) % total_accum + 1 - end if - end do - - ! do all of the operations - do v = 1, size(variables) - call typed_operate(domain % blocklist, variables(v), operation) - end do - - ! clear resets and accumulation - do b = 1, size(buffers) - if (buffers(b) % delay_reset_flag) then - buffers(b) % delay_reset_flag = .false. - else - buffers(b) % reset_flag = .false. - end if - - if (buffers(b) % duration_over_flag) then - buffers(b) % duration_over_flag = .false. - buffers(b) % accumulate_flag = .false. - end if - end do - - end subroutine ocn_compute_time_series_stats!}}} +subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ + ! input variables + !----------------------------------------------------------------- + integer, intent(in) :: timeLevel + + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain + + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + ! local variables + !----------------------------------------------------------------- + integer :: i, v, b + + ! start procedure + !----------------------------------------------------------------- + err = 0 + + ! do all of the time checking and flag setting + call timer_checking(domain, err) + + ! update number of accumulations, once only + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + buffers(b) % total_accum = 1 + else if (buffers(b) % accumulate_flag) then + buffers(b) % total_accum = buffers(b) % total_accum + 1 + end if + end do + + ! do all of the operations + do v = 1, size(variables) + call typed_operate(domain % blocklist, variables(v), operation) + end do + + ! clear resets and accumulation + do b = 1, size(buffers) + if (buffers(b) % delay_reset_flag) then + buffers(b) % delay_reset_flag = .false. + else + buffers(b) % reset_flag = .false. + end if + + if (buffers(b) % duration_over_flag) then + buffers(b) % duration_over_flag = .false. + buffers(b) % accumulate_flag = .false. + end if + end do + +end subroutine ocn_compute_time_series_stats!}}} !*********************************************************************** -! routine ocn_restart_time_series_stats +! routine ocn_restart_time_series_stats ! -!> \brief Save restart for MPAS-Ocean analysis member +!> \brief Save restart for MPAS-Ocean analysis member !> \author Jon Woodring !> \date March 2, 2015 !> \details !> This routine conducts computation required to save a restart state !> for the MPAS-Ocean analysis member. !----------------------------------------------------------------------- - subroutine ocn_restart_time_series_stats(domain, err)!{{{ +subroutine ocn_restart_time_series_stats(domain, err)!{{{ + + ! input variables + !----------------------------------------------------------------- - ! input variables - !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain - ! input/output variables - !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag - ! output variables - !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag + ! local variables + !----------------------------------------------------------------- - ! local variables - !----------------------------------------------------------------- + ! start procedure + !----------------------------------------------------------------- + err = 0 - ! start procedure - !----------------------------------------------------------------- - err = 0 + ! TODO save data to restart and accumulate - ! TODO save data to restart and accumulate - - end subroutine ocn_restart_time_series_stats!}}} +end subroutine ocn_restart_time_series_stats!}}} !*********************************************************************** -! routine ocn_finalize_time_series_stats +! routine ocn_finalize_time_series_stats ! -!> \brief Finalize MPAS-Ocean analysis member +!> \brief Finalize MPAS-Ocean analysis member !> \author Jon Woodring !> \date March 2, 2015 !> \details !> This routine conducts all finalizations required for this !> MPAS-Ocean analysis member. !----------------------------------------------------------------------- - subroutine ocn_finalize_time_series_stats(domain, err)!{{{ - - ! input variables - !----------------------------------------------------------------- - - ! input/output variables - !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain - - ! output variables - !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag - - ! local variables - !----------------------------------------------------------------- - integer :: i, v - - ! start procedure - !----------------------------------------------------------------- - err = 0 - - ! clean up memory - if (allocated(buffers)) then - deallocate(buffers) - end if - if (allocated(variables)) then - do v = 1, size(variables) - if (allocated(variables(v) % output_names)) & - then - deallocate(variables(v) % output_names) - end if - end do - deallocate(variables) +subroutine ocn_finalize_time_series_stats(domain, err)!{{{ + + ! input variables + !----------------------------------------------------------------- + + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain + + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + ! local variables + !----------------------------------------------------------------- + integer :: i, v + + ! start procedure + !----------------------------------------------------------------- + err = 0 + + ! clean up memory + if (allocated(buffers)) then + deallocate(buffers) + end if + if (allocated(variables)) then + do v = 1, size(variables) + if (allocated(variables(v) % output_names)) & + then + deallocate(variables(v) % output_names) end if + end do + deallocate(variables) + end if - end subroutine ocn_finalize_time_series_stats!}}} +end subroutine ocn_finalize_time_series_stats!}}} ! ! local subroutines ! !*********************************************************************** -! routine walk_string +! routine walk_string ! -!> \brief Walk a semicolon delimited string to find substrings +!> \brief Walk a semicolon delimited string to find substrings !> \author Jon Woodring !> \date March 2, 2015 !> \details !> Walk a string delimited by semicolons and return the first substring !> from start index, and modify start to point at the next candidate. !----------------------------------------------------------------------- - subroutine walk_string(next, substr, ok)!{{{ - ! input variables - !----------------------------------------------------------------- - - ! input/output variables - !----------------------------------------------------------------- - character (len=StrKIND), intent(inout) :: next - - ! output variables - !----------------------------------------------------------------- - character (len=StrKIND), intent(out) :: substr - logical, intent(out) :: ok - - ! local variables - !----------------------------------------------------------------- - integer :: i - character (len=StrKIND) :: copy - - ! make a copy - copy = trim(next) - - ! if there's anything in it other than whitespace, pass through - i = verify(copy, ' ') - ok = i .gt. 0 - if (.not. ok) then - return - end if - copy = trim(next(i:)) - - ! find the first semicolon and split - i = scan(copy, ';') - - ! return that substring and the remainder - if (i .gt. 0) then - substr = trim(copy(1:i-1)) - next = trim(copy(i+1:)) - else - substr = trim(copy) - next = '' - end if - - - end subroutine walk_string!}}} +subroutine walk_string(next, substr, ok)!{{{ + ! input variables + !----------------------------------------------------------------- + + ! input/output variables + !----------------------------------------------------------------- + character (len=StrKIND), intent(inout) :: next + + ! output variables + !----------------------------------------------------------------- + character (len=StrKIND), intent(out) :: substr + logical, intent(out) :: ok + + ! local variables + !----------------------------------------------------------------- + integer :: i + character (len=StrKIND) :: copy + + ! make a copy + copy = trim(next) + + ! if there's anything in it other than whitespace, pass through + i = verify(copy, ' ') + ok = i .gt. 0 + if (.not. ok) then + return + end if + copy = trim(next(i:)) + + ! find the first semicolon and split + i = scan(copy, ';') + + ! return that substring and the remainder + if (i .gt. 0) then + substr = trim(copy(1:i-1)) + next = trim(copy(i+1:)) + else + substr = trim(copy) + next = '' + end if + +end subroutine walk_string!}}} !*********************************************************************** -! routine set_times +! routine set_times ! -!> \brief Set a list of times +!> \brief Set a list of times !> \author Jon Woodring !> \date March 2, 2015 !> \details !> Walk a list of times delimited by spaces and set the time info !> for the buffer structure so that alarms can be set. !----------------------------------------------------------------------- - subroutine set_times(buffers, number_of_buffers, clock, & - which, config_str, ok, err) - ! input variables - !----------------------------------------------------------------- - integer, intent(in) :: number_of_buffers, which - character (len=StrKIND), pointer, intent(in) :: config_str - - ! input/output variables - !----------------------------------------------------------------- - type (time_buffer_type), dimension(:), intent(inout) :: buffers - type (MPAS_Clock_type), intent(inout) :: clock - - ! output variables - !----------------------------------------------------------------- - logical, intent(out) :: ok - integer, intent(out) :: err - - ! local variables - !----------------------------------------------------------------- - character (len=StrKIND) :: next_str, time_str - integer :: b - - ! find the first time in the list - next_str = config_str - b = 0 - call walk_string(next_str, time_str, ok) - - ! while the time string is ok - do while (ok) - ! exit if we went over - b = b + 1 - if (b .gt. number_of_buffers) then - exit - end if - - ! set the time - if (which .eq. START_TIMES) then - if (time_str .eq. 'initial_time') then - buffers(b) % start_time = mpas_get_clock_time(clock, & - MPAS_NOW, err) - else - call mpas_set_time(buffers(b) % start_time, & - dateTimeString=time_str, ierr=err) - end if - else if (which .eq. DURATION_INTERVALS) then - if (time_str .eq. 'repeat_interval') then - buffers(b) % duration_interval = buffers(b) % repeat_interval - else - call mpas_set_timeInterval(buffers(b) % duration_interval, & - timeString=time_str, ierr=err) - end if - else if (which .eq. REPEAT_INTERVALS) then - if (time_str .eq. 'reset_interval') then - buffers(b) % repeat_interval = buffers(b) % reset_interval - else - call mpas_set_timeInterval(buffers(b) % repeat_interval, & - timeString=time_str, ierr=err) - end if - else - call mpas_set_timeInterval(buffers(b) % reset_interval, & - timeString=time_str, ierr=err) - end if - - ! get the next time string - call walk_string(next_str, time_str, ok) - end do - - ! only ok if we parsed out as many as there are number of buffers - ok = number_of_buffers .eq. b - end subroutine set_times +subroutine set_times(buffers, number_of_buffers, clock, & + which, config_str, ok, err) + ! input variables + !----------------------------------------------------------------- + integer, intent(in) :: number_of_buffers, which + character (len=StrKIND), pointer, intent(in) :: config_str + + ! input/output variables + !----------------------------------------------------------------- + type (time_buffer_type), dimension(:), intent(inout) :: buffers + type (MPAS_Clock_type), intent(inout) :: clock + + ! output variables + !----------------------------------------------------------------- + logical, intent(out) :: ok + integer, intent(out) :: err + + ! local variables + !----------------------------------------------------------------- + character (len=StrKIND) :: next_str, time_str + integer :: b + + ! find the first time in the list + next_str = config_str + b = 0 + call walk_string(next_str, time_str, ok) + + ! while the time string is ok + do while (ok) + ! exit if we went over + b = b + 1 + if (b .gt. number_of_buffers) then + exit + end if + + ! set the time + if (which .eq. START_TIMES) then + if (time_str .eq. 'initial_time') then + buffers(b) % start_time = mpas_get_clock_time(clock, & + MPAS_NOW, err) + else + call mpas_set_time(buffers(b) % start_time, & + dateTimeString=time_str, ierr=err) + end if + else if (which .eq. DURATION_INTERVALS) then + if (time_str .eq. 'repeat_interval') then + buffers(b) % duration_interval = buffers(b) % repeat_interval + else + call mpas_set_timeInterval(buffers(b) % duration_interval, & + timeString=time_str, ierr=err) + end if + else if (which .eq. REPEAT_INTERVALS) then + if (time_str .eq. 'reset_interval') then + buffers(b) % repeat_interval = buffers(b) % reset_interval + else + call mpas_set_timeInterval(buffers(b) % repeat_interval, & + timeString=time_str, ierr=err) + end if + else + call mpas_set_timeInterval(buffers(b) % reset_interval, & + timeString=time_str, ierr=err) + end if + + ! get the next time string + call walk_string(next_str, time_str, ok) + end do + + ! only ok if we parsed out as many as there are number of buffers + ok = number_of_buffers .eq. b + end subroutine set_times !*********************************************************************** -! routine add_new_field +! routine add_new_field ! -!> \brief Function to create a new field from an existing field +!> \brief Function to create a new field from an existing field !> \author Jon Woodring !> \date March 2, 2015 !> \details !> This routine conducts all initializations required for !> duplicating a field and adding it to the allFields pool. !----------------------------------------------------------------------- - subroutine add_new_field(info, inname, prefix, pool)!{{{ - ! input variables - !----------------------------------------------------------------- - type (mpas_pool_field_info_type), intent(in) :: info - character (len=StrKIND), intent(in) :: inname, prefix - - ! input/output variables - !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: pool - - ! output variables - !----------------------------------------------------------------- - - ! local variables - !----------------------------------------------------------------- - - ! start procedure - !----------------------------------------------------------------- - - ! duplicate field and add new field to pool - if (info % fieldType .eq. MPAS_POOL_REAL) then - if (info % nDims .eq. 0) then - call copy_field_0r(inname, pool, prefix) - else if (info % nDims .eq. 1) then - call copy_field_1r(inname, pool, prefix) - else if (info % nDims .eq. 2) then - call copy_field_2r(inname, pool, prefix) - else if (info % nDims .eq. 3) then - call copy_field_3r(inname, pool, prefix) - else if (info % nDims .eq. 4) then - call copy_field_4r(inname, pool, prefix) - else - call copy_field_5r(inname, pool, prefix) - end if - else - if (info % nDims .eq. 0) then - call copy_field_0i(inname, pool, prefix) - else if (info % nDims .eq. 1) then - call copy_field_1i(inname, pool, prefix) - else if (info % nDims .eq. 2) then - call copy_field_2i(inname, pool, prefix) - else - call copy_field_3i(inname, pool, prefix) - end if - end if - - end subroutine add_new_field!}}} +subroutine add_new_field(info, inname, prefix, pool)!{{{ + ! input variables + !----------------------------------------------------------------- + type (mpas_pool_field_info_type), intent(in) :: info + character (len=StrKIND), intent(in) :: inname, prefix + + ! input/output variables + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: pool + + ! output variables + !----------------------------------------------------------------- + + ! local variables + !----------------------------------------------------------------- + + ! start procedure + !----------------------------------------------------------------- + + ! duplicate field and add new field to pool + if (info % fieldType .eq. MPAS_POOL_REAL) then + if (info % nDims .eq. 0) then + call copy_field_0r(inname, pool, prefix) + else if (info % nDims .eq. 1) then + call copy_field_1r(inname, pool, prefix) + else if (info % nDims .eq. 2) then + call copy_field_2r(inname, pool, prefix) + else if (info % nDims .eq. 3) then + call copy_field_3r(inname, pool, prefix) + else if (info % nDims .eq. 4) then + call copy_field_4r(inname, pool, prefix) + else + call copy_field_5r(inname, pool, prefix) + end if + else + if (info % nDims .eq. 0) then + call copy_field_0i(inname, pool, prefix) + else if (info % nDims .eq. 1) then + call copy_field_1i(inname, pool, prefix) + else if (info % nDims .eq. 2) then + call copy_field_2i(inname, pool, prefix) + else + call copy_field_3i(inname, pool, prefix) + end if + end if + +end subroutine add_new_field!}}} !*********************************************************************** -! routine timer_checking +! routine timer_checking ! -!> \brief Timer functions to determine when to run +!> \brief Timer functions to determine when to run !> \author Jon Woodring !> \date March 2, 2015 !> \details !> This routine conducts timer checking to determine if it !> needs to run at this particular time. !----------------------------------------------------------------------- - subroutine timer_checking(domain, err)!{{{ - ! input variables - !----------------------------------------------------------------- - - ! input/output variables - !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain - - ! output variables - !----------------------------------------------------------------- - integer, intent(out) :: err - - ! local variables - !----------------------------------------------------------------- - integer :: b - - ! start procedure - !----------------------------------------------------------------- - err = 0 - - do b = 1, size(buffers) - ! see if the started alarm is ringing - if (mpas_is_alarm_ringing(domain % clock, & - buffers(b) % start_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(domain % clock, & - buffers(b) % start_alarm_ID, ierr=err) - buffers(b) % started_flag = .true. - buffers(b) % accumulate_flag = .true. - - ! TODO only reset if not restart - buffers(b) % reset_flag = .true. - end if - - ! if we aren't started, continue to next buffer - if (.not. buffers(b) % started_flag) then - continue - end if - - ! check various other alarms - ! see if we need to reset - if(mpas_is_alarm_ringing(domain % clock, & - buffers(b) % reset_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(domain % clock, & - buffers(b) % reset_alarm_ID, ierr=err) - buffers(b) % reset_flag = .true. - buffers(b) % delay_reset_flag = .true. - end if - - ! turn off accumulation - ! - ! duration needs to be >= 2 * compute_interval - ! (a series can only be 2 or more) - if (mpas_is_alarm_ringing(domain % clock, & - buffers(b) % duration_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(domain % clock, & - buffers(b) % duration_alarm_ID, ierr=err) - buffers(b) % duration_over_flag = .true. - end if - - ! turn on accumulation - ! (this is second, in case the duration and repeat - ! overlaps on the same timer) - if (mpas_is_alarm_ringing(domain % clock, & - buffers(b) % repeat_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(domain % clock, & - buffers(b) % repeat_alarm_ID, ierr=err) - buffers(b) % accumulate_flag = .true. - buffers(b) % duration_over_flag = .false. - end if - - end do - - end subroutine timer_checking!}}} +subroutine timer_checking(domain, err)!{{{ + ! input variables + !----------------------------------------------------------------- + + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain + + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err + + ! local variables + !----------------------------------------------------------------- + integer :: b + + ! start procedure + !----------------------------------------------------------------- + err = 0 + + do b = 1, size(buffers) + ! see if the started alarm is ringing + if (mpas_is_alarm_ringing(domain % clock, & + buffers(b) % start_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(domain % clock, & + buffers(b) % start_alarm_ID, ierr=err) + buffers(b) % started_flag = .true. + buffers(b) % accumulate_flag = .true. + + ! TODO only reset if not restart + buffers(b) % reset_flag = .true. + end if + + ! if we aren't started, continue to next buffer + if (.not. buffers(b) % started_flag) then + continue + end if + + ! check various other alarms + ! see if we need to reset + if(mpas_is_alarm_ringing(domain % clock, & + buffers(b) % reset_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(domain % clock, & + buffers(b) % reset_alarm_ID, ierr=err) + buffers(b) % reset_flag = .true. + buffers(b) % delay_reset_flag = .true. + end if + + ! turn off accumulation + ! + ! duration needs to be >= 2 * compute_interval + ! (a series can only be 2 or more) + if (mpas_is_alarm_ringing(domain % clock, & + buffers(b) % duration_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(domain % clock, & + buffers(b) % duration_alarm_ID, ierr=err) + buffers(b) % duration_over_flag = .true. + end if + + ! turn on accumulation + ! (this is second, in case the duration and repeat + ! overlaps on the same timer) + if (mpas_is_alarm_ringing(domain % clock, & + buffers(b) % repeat_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(domain % clock, & + buffers(b) % repeat_alarm_ID, ierr=err) + buffers(b) % accumulate_flag = .true. + buffers(b) % duration_over_flag = .false. + end if + + end do +end subroutine timer_checking!}}} !*********************************************************************** -! routine typed_operate +! routine typed_operate ! -!> \brief Do the operation, but switch on run-time type +!> \brief Do the operation, but switch on run-time type !> \author Jon Woodring !> \date March 2, 2015 !> \details !> Since we don't know the type of the array, we need to do some !> run-time type switching based on the type of the array. !----------------------------------------------------------------------- - subroutine typed_operate(block, tvar, operation)!{{{ - ! input variables - !----------------------------------------------------------------- - type (block_type), pointer, intent(in) :: block - integer, intent(in) :: operation - - ! input/output variables - !----------------------------------------------------------------- - type (time_variable_type), intent(inout) :: tvar - - ! output variables - !----------------------------------------------------------------- - - ! local variables - !----------------------------------------------------------------- - - ! switch based on the type, dimensionality, and operation - if (tvar % info % fieldType == MPAS_POOL_REAL) then - if (tvar % info % nDims == 0) then - if (operation .eq. AVG_OP) then - call operate0r_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate0r_min(block, tvar) - else - call operate0r_max(block, tvar) - end if - else if (tvar % info % nDims == 1) then - if (operation .eq. AVG_OP) then - call operate1r_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate1r_min(block, tvar) - else - call operate1r_max(block, tvar) - end if - else if (tvar % info % nDims == 2) then - if (operation .eq. AVG_OP) then - call operate2r_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate2r_min(block, tvar) - else - call operate2r_max(block, tvar) - end if - else if (tvar % info % nDims == 3) then - if (operation .eq. AVG_OP) then - call operate3r_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate3r_min(block, tvar) - else - call operate3r_max(block, tvar) - end if - else if (tvar % info % nDims == 4) then - if (operation .eq. AVG_OP) then - call operate4r_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate4r_min(block, tvar) - else - call operate4r_max(block, tvar) - end if - else - if (operation .eq. AVG_OP) then - call operate5r_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate5r_min(block, tvar) - else - call operate5r_max(block, tvar) - end if - end if - else - if (tvar % info % nDims == 0) then - if (operation .eq. AVG_OP) then - call operate0i_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate0i_min(block, tvar) - else - call operate0i_max(block, tvar) - end if - else if (tvar % info % nDims == 1) then - if (operation .eq. AVG_OP) then - call operate1i_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate1i_min(block, tvar) - else - call operate1i_max(block, tvar) - end if - else if (tvar % info % nDims == 2) then - if (operation .eq. AVG_OP) then - call operate2i_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate2i_min(block, tvar) - else - call operate2i_max(block, tvar) - end if - else - if (operation .eq. AVG_OP) then - call operate3i_avg(block, tvar) - else if (operation .eq. MIN_OP) then - call operate3i_min(block, tvar) - else - call operate3i_max(block, tvar) - end if - end if - end if - - end subroutine typed_operate!}}} +subroutine typed_operate(block, tvar, operation)!{{{ + ! input variables + !----------------------------------------------------------------- + type (block_type), pointer, intent(in) :: block + integer, intent(in) :: operation + + ! input/output variables + !----------------------------------------------------------------- + type (time_variable_type), intent(inout) :: tvar + + ! output variables + !----------------------------------------------------------------- + + ! local variables + !----------------------------------------------------------------- + + ! switch based on the type, dimensionality, and operation + if (tvar % info % fieldType == MPAS_POOL_REAL) then + if (tvar % info % nDims == 0) then + if (operation .eq. AVG_OP) then + call operate0r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate0r_min(block, tvar) + else + call operate0r_max(block, tvar) + end if + else if (tvar % info % nDims == 1) then + if (operation .eq. AVG_OP) then + call operate1r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate1r_min(block, tvar) + else + call operate1r_max(block, tvar) + end if + else if (tvar % info % nDims == 2) then + if (operation .eq. AVG_OP) then + call operate2r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate2r_min(block, tvar) + else + call operate2r_max(block, tvar) + end if + else if (tvar % info % nDims == 3) then + if (operation .eq. AVG_OP) then + call operate3r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate3r_min(block, tvar) + else + call operate3r_max(block, tvar) + end if + else if (tvar % info % nDims == 4) then + if (operation .eq. AVG_OP) then + call operate4r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate4r_min(block, tvar) + else + call operate4r_max(block, tvar) + end if + else + if (operation .eq. AVG_OP) then + call operate5r_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate5r_min(block, tvar) + else + call operate5r_max(block, tvar) + end if + end if + else + if (tvar % info % nDims == 0) then + if (operation .eq. AVG_OP) then + call operate0i_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate0i_min(block, tvar) + else + call operate0i_max(block, tvar) + end if + else if (tvar % info % nDims == 1) then + if (operation .eq. AVG_OP) then + call operate1i_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate1i_min(block, tvar) + else + call operate1i_max(block, tvar) + end if + else if (tvar % info % nDims == 2) then + if (operation .eq. AVG_OP) then + call operate2i_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate2i_min(block, tvar) + else + call operate2i_max(block, tvar) + end if + else + if (operation .eq. AVG_OP) then + call operate3i_avg(block, tvar) + else if (operation .eq. MIN_OP) then + call operate3i_min(block, tvar) + else + call operate3i_max(block, tvar) + end if + end if + end if +end subroutine typed_operate!}}} !*********************************************************************** -! routine copy_field_X +! routine copy_field_X ! -!> \brief Functions to create a new field from an existing field +!> \brief Functions to create a new field from an existing field !> \author Jon Woodring !> \date March 2, 2015 !> \details @@ -966,230 +963,230 @@ end subroutine typed_operate!}}} !----------------------------------------------------------------------- subroutine copy_field_0r(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix - type (mpas_pool_type), intent(inout) :: pool + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool - type (field0DReal), pointer :: src, dst - integer :: i + type (field0DReal), pointer :: src, dst + integer :: i - call mpas_pool_get_field(pool, inname, src, 1) - call mpas_duplicate_field(src, dst) + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = trim(prefix) // dst % fieldName - if (dst % isVarArray) then - do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) - end do - end if + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if - call mpas_pool_add_field(pool, dst % fieldName, dst) + call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_0r!}}} subroutine copy_field_1r(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix - type (mpas_pool_type), intent(inout) :: pool + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool - type (field1DReal), pointer :: src, dst - integer :: i + type (field1DReal), pointer :: src, dst + integer :: i - call mpas_pool_get_field(pool, inname, src, 1) - call mpas_duplicate_field(src, dst) + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = trim(prefix) // dst % fieldName - if (dst % isVarArray) then - do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) - end do - end if + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if - call mpas_pool_add_field(pool, dst % fieldName, dst) + call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_1r!}}} subroutine copy_field_2r(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix - type (mpas_pool_type), intent(inout) :: pool + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool - type (field2DReal), pointer :: src, dst - integer :: i + type (field2DReal), pointer :: src, dst + integer :: i - call mpas_pool_get_field(pool, inname, src, 1) - call mpas_duplicate_field(src, dst) + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = trim(prefix) // dst % fieldName - if (dst % isVarArray) then - do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) - end do - end if + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if - call mpas_pool_add_field(pool, dst % fieldName, dst) + call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_2r!}}} subroutine copy_field_3r(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix - type (mpas_pool_type), intent(inout) :: pool + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool - type (field3DReal), pointer :: src, dst - integer :: i + type (field3DReal), pointer :: src, dst + integer :: i - call mpas_pool_get_field(pool, inname, src, 1) - call mpas_duplicate_field(src, dst) + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = trim(prefix) // dst % fieldName - if (dst % isVarArray) then - do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) - end do - end if + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if - call mpas_pool_add_field(pool, dst % fieldName, dst) + call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_3r!}}} subroutine copy_field_4r(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix - type (mpas_pool_type), intent(inout) :: pool + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool - type (field4DReal), pointer :: src, dst - integer :: i + type (field4DReal), pointer :: src, dst + integer :: i - call mpas_pool_get_field(pool, inname, src, 1) - call mpas_duplicate_field(src, dst) + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = trim(prefix) // dst % fieldName - if (dst % isVarArray) then - do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) - end do - end if + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if - call mpas_pool_add_field(pool, dst % fieldName, dst) + call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_4r!}}} subroutine copy_field_5r(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix - type (mpas_pool_type), intent(inout) :: pool + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool - type (field5DReal), pointer :: src, dst - integer :: i + type (field5DReal), pointer :: src, dst + integer :: i - call mpas_pool_get_field(pool, inname, src, 1) - call mpas_duplicate_field(src, dst) + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = trim(prefix) // dst % fieldName - if (dst % isVarArray) then - do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) - end do - end if + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if - call mpas_pool_add_field(pool, dst % fieldName, dst) + call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_5r!}}} subroutine copy_field_0i(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix - type (mpas_pool_type), intent(inout) :: pool + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool - type (field0DInteger), pointer :: src, dst - integer :: i + type (field0DInteger), pointer :: src, dst + integer :: i - call mpas_pool_get_field(pool, inname, src, 1) - call mpas_duplicate_field(src, dst) + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = trim(prefix) // dst % fieldName - if (dst % isVarArray) then - do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) - end do - end if + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if - call mpas_pool_add_field(pool, dst % fieldName, dst) + call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_0i!}}} subroutine copy_field_1i(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix - type (mpas_pool_type), intent(inout) :: pool + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool - type (field1DInteger), pointer :: src, dst - integer :: i + type (field1DInteger), pointer :: src, dst + integer :: i - call mpas_pool_get_field(pool, inname, src, 1) - call mpas_duplicate_field(src, dst) + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = trim(prefix) // dst % fieldName - if (dst % isVarArray) then - do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) - end do - end if + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if - call mpas_pool_add_field(pool, dst % fieldName, dst) + call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_1i!}}} subroutine copy_field_2i(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix - type (mpas_pool_type), intent(inout) :: pool + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool - type (field2DInteger), pointer :: src, dst - integer :: i + type (field2DInteger), pointer :: src, dst + integer :: i - call mpas_pool_get_field(pool, inname, src, 1) - call mpas_duplicate_field(src, dst) + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = trim(prefix) // dst % fieldName - if (dst % isVarArray) then - do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) - end do - end if + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if - call mpas_pool_add_field(pool, dst % fieldName, dst) + call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_2i!}}} subroutine copy_field_3i(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix - type (mpas_pool_type), intent(inout) :: pool + character (len=StrKIND), intent(in) :: inname, prefix + type (mpas_pool_type), intent(inout) :: pool - type (field3DInteger), pointer :: src, dst - integer :: i + type (field3DInteger), pointer :: src, dst + integer :: i - call mpas_pool_get_field(pool, inname, src, 1) - call mpas_duplicate_field(src, dst) + call mpas_pool_get_field(pool, inname, src, 1) + call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = trim(prefix) // dst % fieldName - if (dst % isVarArray) then - do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) - end do - end if + if (dst % isVarArray) then + do i = 1, size(dst % constituentNames) + dst % constituentNames(i) = trim(prefix) // & + dst % constituentNames(i) + end do + end if - call mpas_pool_add_field(pool, dst % fieldName, dst) + call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_3i!}}} !*********************************************************************** -! routine operateX_Y +! routine operateX_Y ! -!> \brief Series of subroutines to support operations on run-time types +!> \brief Series of subroutines to support operations on run-time types !> \author Jon Woodring !> \date March 2, 2015 !> \details @@ -1207,1083 +1204,1083 @@ end subroutine copy_field_3i!}}} !----------------------------------------------------------------------- subroutine operate0r_avg (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ - / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate0r_avg subroutine operate1r_avg (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ - / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate1r_avg subroutine operate2r_avg (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ - / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate2r_avg subroutine operate3r_avg (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ - / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate3r_avg subroutine operate4r_avg (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ - / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate4r_avg subroutine operate5r_avg (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ - / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate5r_avg subroutine operate0i_avg (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - integer, pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ - / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate0i_avg subroutine operate1i_avg (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - integer, dimension(:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ - / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate1i_avg subroutine operate2i_avg (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - integer, dimension(:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ - / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate2i_avg subroutine operate3i_avg (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - integer, dimension(:,:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ - / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + + out_array = (out_array * \ + (buffers(b) % total_accum - 1) + in_array) \ + / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate3i_avg subroutine operate0r_min (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; - out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate0r_min subroutine operate1r_min (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; - out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate1r_min subroutine operate2r_min (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; - out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate2r_min subroutine operate3r_min (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; - out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate3r_min subroutine operate4r_min (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; - out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate4r_min subroutine operate5r_min (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; - out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate5r_min subroutine operate0i_min (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - integer, pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; - out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate0i_min subroutine operate1i_min (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - integer, dimension(:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; - out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate1i_min subroutine operate2i_min (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - integer, dimension(:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; - out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate2i_min subroutine operate3i_min (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - integer, dimension(:,:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; - out_array = min(out_array, in_array) ; -! out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; + out_array = min(out_array, in_array) ; +! out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate3i_min subroutine operate0r_max (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; - out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate0r_max subroutine operate1r_max (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; - out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate1r_max subroutine operate2r_max (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; - out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate2r_max subroutine operate3r_max (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; - out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate3r_max subroutine operate4r_max (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; - out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate4r_max subroutine operate5r_max (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; - out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate5r_max subroutine operate0i_max (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - integer, pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; - out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate0i_max subroutine operate1i_max (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - integer, dimension(:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; - out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate1i_max subroutine operate2i_max (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - integer, dimension(:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; - out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate2i_max subroutine operate3i_max (start_block, tvar) - type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar - - integer, dimension(:,:,:), pointer :: in_array, out_array - integer :: b - type (block_type), pointer :: block - - block => start_block - do while (associated(block)) - call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) - - do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ -! / buffers(b) % total_accum ; -! out_array = min(out_array, in_array) ; - out_array = max(out_array, in_array) ; - - end if - end do - - block => block % next - end do + type (block_type), pointer, intent(in) :: start_block + type (time_variable_type), intent(inout) :: tvar + + integer, dimension(:,:,:), pointer :: in_array, out_array + integer :: b + type (block_type), pointer :: block + + block => start_block + do while (associated(block)) + call mpas_pool_get_array(block % allFields, & + tvar % input_name, in_array, 1) + + do b = 1, size(buffers) + if (buffers(b) % reset_flag .and. & + (.not. buffers(b) % delay_reset_flag)) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + out_array = in_array + else if (buffers(b) % accumulate_flag) then + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + +! out_array = (out_array * \ +! (buffers(b) % total_accum - 1) + in_array) \ +! / buffers(b) % total_accum ; +! out_array = min(out_array, in_array) ; + out_array = max(out_array, in_array) ; + + end if + end do + + block => block % next + end do end subroutine operate3i_max end module ocn_time_series_stats From 40ebb217e070adb4e1533d29a9ff207a42614375 Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Mon, 17 Aug 2015 14:52:19 -0600 Subject: [PATCH 0143/1724] Fixed defaults to the correct ones. --- .../analysis_members/Registry_time_series_stats.xml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_time_series_stats.xml b/src/core_ocean/analysis_members/Registry_time_series_stats.xml index 839f3cd64a..5036749cfd 100644 --- a/src/core_ocean/analysis_members/Registry_time_series_stats.xml +++ b/src/core_ocean/analysis_members/Registry_time_series_stats.xml @@ -52,21 +52,21 @@ Date: Tue, 18 Aug 2015 13:13:12 -0600 Subject: [PATCH 0144/1724] Fixing external dycore build system issues This commit fixes the build system issues related to external dycores within the landice core. --- src/core_landice/build_options.mk | 9 ++++----- src/core_landice/mode_forward/Makefile | 2 +- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/src/core_landice/build_options.mk b/src/core_landice/build_options.mk index 41403d05d2..707ba2cee9 100644 --- a/src/core_landice/build_options.mk +++ b/src/core_landice/build_options.mk @@ -9,19 +9,18 @@ override CPPFLAGS += -DCORE_LANDICE # =================================== # Check if building with LifeV, Albany, and/or PHG external libraries -BUILD_INTERFACE=false # This will become true if any of the external libraries are being used. - # LifeV can solve L1L2 or FO ifeq "$(LIFEV)" "true" + EXTERNAL_DYCORE_FLAG += -DLIFEV EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_L1L2 EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER - BUILD_INTERFACE = true + EXTERNAL_DYCORE_FLAG += -DMPAS_LI_BUILD_INTERFACE endif # LIFEV IF # Albany can only solve FO at present ifeq "$(ALBANY)" "true" EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_FIRSTORDER - BUILD_INTERFACE = true + EXTERNAL_DYCORE_FLAG += -DMPAS_LI_BUILD_INTERFACE endif # ALBANY IF # Currently LifeV AND Albany is not allowed @@ -40,7 +39,7 @@ endif # PHG can only Stokes at present ifeq "$(PHG)" "true" EXTERNAL_DYCORE_FLAG += -DUSE_EXTERNAL_STOKES - BUILD_INTERFACE = true + EXTERNAL_DYCORE_FLAG += -DMPAS_LI_BUILD_INTERFACE endif # PHG IF override CPPFLAGS += $(EXTERNAL_DYCORE_FLAG) diff --git a/src/core_landice/mode_forward/Makefile b/src/core_landice/mode_forward/Makefile index 3c732f28d6..0ed905af2c 100644 --- a/src/core_landice/mode_forward/Makefile +++ b/src/core_landice/mode_forward/Makefile @@ -14,7 +14,7 @@ OBJS = mpas_li_core.o \ mpas_li_mask.o \ mpas_li_velocity_external.o -ifeq "$(BUILD_INTERFACE)" "true" +ifneq (, $(findstring MPAS_LI_BUILD_INTERFACE,$(CPPFLAGS))) OBJS += Interface_velocity_solver.o endif From 5c11c33c5a91263aa2daa51255e6fca3d61122ce Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Wed, 12 Aug 2015 14:49:40 -0600 Subject: [PATCH 0145/1724] Pull advection into ocean core This commit pulls advection from operators into the ocean core. It is done as a preliminary step to allow OpenMP to be added in a way that matches the rest of the ocean core. Some small performance improvements have been performed as well during this conversion. --- src/core_ocean/Registry.xml | 28 + src/core_ocean/shared/Makefile | 8 +- src/core_ocean/shared/mpas_ocn_tendency.F | 3 +- .../shared/mpas_ocn_tracer_advection.F | 23 +- .../shared/mpas_ocn_tracer_advection_mono.F | 479 ++++++++++++++++++ .../shared/mpas_ocn_tracer_advection_std.F | 259 ++++++++++ 6 files changed, 787 insertions(+), 13 deletions(-) create mode 100644 src/core_ocean/shared/mpas_ocn_tracer_advection_mono.F create mode 100644 src/core_ocean/shared/mpas_ocn_tracer_advection_std.F diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index bd7ccb3390..9f0d315e25 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -2560,6 +2560,34 @@ + + + + + + + + + + diff --git a/src/core_ocean/shared/Makefile b/src/core_ocean/shared/Makefile index bfcb3e7fe5..3de97da1d0 100644 --- a/src/core_ocean/shared/Makefile +++ b/src/core_ocean/shared/Makefile @@ -31,6 +31,8 @@ OBJS = mpas_ocn_init_routines.o \ mpas_ocn_tracer_hmix_del2.o \ mpas_ocn_tracer_hmix_del4.o \ mpas_ocn_tracer_advection.o \ + mpas_ocn_tracer_advection_mono.o \ + mpas_ocn_tracer_advection_std.o \ mpas_ocn_tracer_nonlocalflux.o \ mpas_ocn_tracer_short_wave_absorption.o \ mpas_ocn_tracer_short_wave_absorption_jerlov.o \ @@ -95,7 +97,11 @@ mpas_ocn_tracer_hmix_del2.o: mpas_ocn_constants.o mpas_ocn_tracer_hmix_del4.o: mpas_ocn_constants.o -mpas_ocn_tracer_advection.o: mpas_ocn_constants.o +mpas_ocn_tracer_advection.o: mpas_ocn_constants.o mpas_ocn_tracer_advection_mono.o mpas_ocn_tracer_advection_std.o + +mpas_ocn_tracer_advection_mono.o: mpas_ocn_constants.o + +mpas_ocn_tracer_advection_std.o: mpas_ocn_constants.o mpas_ocn_high_freq_thickness_hmix_del2.o: mpas_ocn_constants.o diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index a3c11af680..87f39089dc 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -400,7 +400,8 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! Monotonoic Advection, or standard advection call mpas_timer_start("adv", .false., tracerHadvTimer) - call ocn_tracer_advection_tend(tracers, normalThicknessFlux, vertAleTransportTop, layerThickness, layerThickness, dt, meshPool, tend_layerThickness, tend_tr) + call ocn_tracer_advection_tend(tracers, normalThicknessFlux, vertAleTransportTop, layerThickness, layerThickness, dt, & + meshPool, scratchPool, tend_layerThickness, tend_tr) call mpas_timer_stop("adv", tracerHadvTimer) ! diff --git a/src/core_ocean/shared/mpas_ocn_tracer_advection.F b/src/core_ocean/shared/mpas_ocn_tracer_advection.F index 92c78709f2..fb697e0b9f 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_advection.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_advection.F @@ -27,8 +27,8 @@ module ocn_tracer_advection use mpas_sort use mpas_hash - use mpas_tracer_advection_std - use mpas_tracer_advection_mono + use ocn_tracer_advection_std + use ocn_tracer_advection_mono use ocn_constants @@ -56,7 +56,7 @@ module ocn_tracer_advection !> advection of tracers. ! !----------------------------------------------------------------------- - subroutine ocn_tracer_advection_tend(tracers, normalThicknessFlux, w, layerThickness, verticalCellSize, dt, meshPool, tend_layerThickness, tend)!{{{ + subroutine ocn_tracer_advection_tend(tracers, normalThicknessFlux, w, layerThickness, verticalCellSize, dt, meshPool, scratchPool, tend_layerThickness, tend)!{{{ real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/Output: tracer tendency real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input/Output: tracer values @@ -66,6 +66,7 @@ subroutine ocn_tracer_advection_tend(tracers, normalThicknessFlux, w, layerThick real (kind=RKIND), dimension(:,:), intent(in) :: verticalCellSize !< Input: Distance between vertical interfaces of a cell real (kind=RKIND), intent(in) :: dt !< Input: Time step type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: scratchPool !< Input: scratch fields real (kind=RKIND), dimension(:,:), intent(in) :: tend_layerThickness !< Input: Thickness tendency information real (kind=RKIND), dimension(:,:), pointer :: advCoefs, advCoefs3rd @@ -85,15 +86,15 @@ subroutine ocn_tracer_advection_tend(tracers, normalThicknessFlux, w, layerThick call mpas_pool_get_array(meshPool, 'advCellsForEdge', advCellsForEdge) if(monotonicOn) then - call mpas_tracer_advection_mono_tend(tracers, advCoefs, advCoefs3rd, & + call ocn_tracer_advection_mono_tend(tracers, advCoefs, advCoefs3rd, & nAdvCellsForEdge, advCellsForEdge, normalThicknessFlux, w, layerThickness, & - verticalCellSize, dt, meshPool, tend_layerThickness, tend, maxLevelCell, maxLevelEdgeTop, & - highOrderAdvectionMask, edgeSignOnCell_in = edgeSignOnCell) + verticalCellSize, dt, meshPool, scratchPool, tend_layerThickness, tend, maxLevelCell, maxLevelEdgeTop, & + highOrderAdvectionMask, edgeSignOnCell) else - call mpas_tracer_advection_std_tend(tracers, advCoefs, advCoefs3rd, & + call ocn_tracer_advection_std_tend(tracers, advCoefs, advCoefs3rd, & nAdvCellsForEdge, advCellsForEdge, normalThicknessFlux, w, layerThickness, & - verticalCellSize, dt, meshPool, tend_layerThickness, tend, maxLevelCell, maxLevelEdgeTop, & - highOrderAdvectionMask, edgeSignOnCell_in = edgeSignOnCell) + verticalCellSize, dt, meshPool, scratchPool, tend_layerThickness, tend, maxLevelCell, maxLevelEdgeTop, & + highOrderAdvectionMask, edgeSignOnCell) endif end subroutine ocn_tracer_advection_tend!}}} @@ -134,8 +135,8 @@ subroutine ocn_tracer_advection_init(err)!{{{ if(config_disable_tr_adv) tracerAdvOn = .false. - call mpas_tracer_advection_std_init(config_horiz_tracer_adv_order, config_vert_tracer_adv_order, config_coef_3rd_order, config_dzdk_positive, config_check_tracer_monotonicity, err_tmp) - call mpas_tracer_advection_mono_init(config_num_halos, config_horiz_tracer_adv_order, config_vert_tracer_adv_order, config_coef_3rd_order, config_dzdk_positive, config_check_tracer_monotonicity, err_tmp) + call ocn_tracer_advection_std_init(config_horiz_tracer_adv_order, config_vert_tracer_adv_order, config_coef_3rd_order, config_dzdk_positive, config_check_tracer_monotonicity, err_tmp) + call ocn_tracer_advection_mono_init(config_num_halos, config_horiz_tracer_adv_order, config_vert_tracer_adv_order, config_coef_3rd_order, config_dzdk_positive, config_check_tracer_monotonicity, err_tmp) err = ior(err, err_tmp) diff --git a/src/core_ocean/shared/mpas_ocn_tracer_advection_mono.F b/src/core_ocean/shared/mpas_ocn_tracer_advection_mono.F new file mode 100644 index 0000000000..a64a588679 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tracer_advection_mono.F @@ -0,0 +1,479 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tracer_advection_mono +! +!> \brief MPAS monotonic tracer advection with FCT +!> \author Doug Jacobsen +!> \date 03/09/12 +!> \details +!> This module contains routines for monotonic advection of tracers using a FCT +! +!----------------------------------------------------------------------- +module ocn_tracer_advection_mono + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use mpas_io_units + + use mpas_tracer_advection_helpers + + implicit none + private + save + + real (kind=RKIND) :: coef_3rd_order + integer :: horizOrder + logical :: vert2ndOrder, vert3rdOrder, vert4thOrder + logical :: positiveDzDk, monotonicityCheck + + public :: ocn_tracer_advection_mono_tend, & + ocn_tracer_advection_mono_init + + contains + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine ocn_tracer_advection_mono_tend +! +!> \brief MPAS monotonic tracer advection tendency with FCT +!> \author Doug Jacobsen +!> \date 03/09/12 +!> \details +!> This routine computes the monotonic tracer advection tendencity using a FCT. +!> Both horizontal and vertical. +! +!----------------------------------------------------------------------- + subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAdvCellsForEdge, advCellsForEdge, &!{{{ + normalThicknessFlux, w, layerThickness, verticalCellSize, dt, meshPool, & + scratchPool, tend_layerThickness, tend, maxLevelCell, maxLevelEdgeTop, & + highOrderAdvectionMask, edgeSignOnCell) + + real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input: current tracer values + real (kind=RKIND), dimension(:,:), intent(in) :: adv_coefs !< Input: Advection coefficients for 2nd order advection + real (kind=RKIND), dimension(:,:), intent(in) :: adv_coefs_3rd !< Input: Advection coefficients for blending in 3rd or 4th order advection + integer, dimension(:), intent(in) :: nAdvCellsForEdge !< Input: Number of advection cells for each edge + integer, dimension(:,:), intent(in) :: advCellsForEdge !< Input: List of advection cells for each edge + real (kind=RKIND), dimension(:,:), intent(in) :: normalThicknessFlux !< Input: Thichness weighted velocitiy - (nVertLevels, nEdge) + real (kind=RKIND), dimension(:,:), intent(in) :: w !< Input: Vertical velocitiy - (nVertLevels+1, nEdges) + real (kind=RKIND), dimension(:,:), intent(in) :: layerThickness !< Input: Thickness - (nVertLevels, nCells) + real (kind=RKIND), dimension(:,:), intent(in) :: verticalCellSize !< Input: Distance between vertical interfaces of a cell - (nVertLevels, nCells) + real (kind=RKIND), dimension(:,:), intent(in) :: tend_layerThickness !< Input: Tendency for thickness field - (nVertLevels, nCells) + real (kind=RKIND), intent(in) :: dt !< Input: Timestep + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), intent(in) :: scratchPool !< Input: Scratch fields + real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/Output: Tracer tendency + integer, dimension(:), pointer :: maxLevelCell !< Input: Index to max level at cell center + integer, dimension(:), pointer :: maxLevelEdgeTop !< Input: Index to max level at edge with non-land cells on both sides + integer, dimension(:,:), pointer :: highOrderAdvectionMask !< Input: Mask for high order advection + integer, dimension(:, :), pointer :: edgeSignOnCell !< Input: Sign for flux from edge on each cell. Used for bit-reproducibility + + integer :: i, iCell, iEdge, k, iTracer, cell1, cell2, nVertLevels, num_tracers + integer, pointer :: nCells, nEdges, nCellsSolve, maxEdges + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnCell, edgesOnCell + + real (kind=RKIND) :: flux_upwind, tracer_min_new, tracer_max_new, tracer_upwind_new, scale_factor + real (kind=RKIND) :: flux, tracer_weight, invAreaCell1, invAreaCell2 + real (kind=RKIND) :: verticalWeightK, verticalWeightKm1 + real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell, verticalDivergenceFactor + real (kind=RKIND), dimension(:,:), pointer :: tracer_cur, tracer_new, upwind_tendency, inv_h_new, tracer_max, tracer_min + real (kind=RKIND), dimension(:,:), pointer :: flux_incoming, flux_outgoing, high_order_horiz_flux, high_order_vert_flux + + type (field2DReal), pointer :: highOrderHorizFluxField, tracerNewField, & + tracerCurField, upwindTendencyField, inverseLayerThicknessField, tracerMinField, tracerMaxField, & + fluxIncomingField, fluxOutgoingField, highOrderVertFluxField + + + real (kind=RKIND), parameter :: eps = 1.e-10_RKIND + + ! Get dimensions + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'maxEdges', maxEdges) + nVertLevels = size(tracers,dim=2) + num_tracers = size(tracers,dim=1) + + ! Initialize pointers + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + + allocate(verticalDivergenceFactor(nVertLevels)) + verticalDivergenceFactor = 1.0_RKIND + + call mpas_pool_get_field(scratchPool, 'highOrderHorizFlux', highOrderHorizFluxField) + call mpas_pool_get_field(scratchPool, 'tracerValue', tracerNewField, 2) + call mpas_pool_get_field(scratchPool, 'tracerValue', tracerCurField, 1) + call mpas_pool_get_field(scratchPool, 'upwindTendency', upwindTendencyField) + call mpas_pool_get_field(scratchPool, 'inverseLayerThickness', inverseLayerThicknessField) + call mpas_pool_get_field(scratchPool, 'tracerMin', tracerMinField) + call mpas_pool_get_field(scratchPool, 'tracerMax', tracerMaxField) + call mpas_pool_get_field(scratchPool, 'fluxIncoming', fluxIncomingField) + call mpas_pool_get_field(scratchPool, 'fluxOutgoing', fluxOutgoingField) + call mpas_pool_get_field(scratchPool, 'highOrderVertFlux', highOrderVertFluxField) + + call mpas_allocate_scratch_field(highOrderHorizFluxField, .true.) + call mpas_allocate_scratch_field(tracerNewField, .true.) + call mpas_allocate_scratch_field(tracerCurField, .true.) + call mpas_allocate_scratch_field(upwindTendencyField, .true.) + call mpas_allocate_scratch_field(inverseLayerThicknessField, .true.) + call mpas_allocate_scratch_field(tracerMinField, .true.) + call mpas_allocate_scratch_field(tracerMaxField, .true.) + call mpas_allocate_scratch_field(fluxIncomingField, .true.) + call mpas_allocate_scratch_field(fluxOutgoingField, .true.) + call mpas_allocate_scratch_field(highOrderVertFluxField, .true.) + + + ! Setup high order horizontal flux field + high_order_horiz_flux => highOrderHorizFluxField % array + + ! allocate nCells arrays + tracer_new => tracerNewField % array + tracer_cur => tracerCurField % array + upwind_tendency => upwindTendencyField % array + inv_h_new => inverseLayerThicknessField % array + tracer_max => tracerMaxField % array + tracer_min => tracerMinField % array + flux_incoming => fluxIncomingField % array + flux_outgoing => fluxOutgoingField % array + + ! allocate nVertLevels+1 and nCells arrays + high_order_vert_flux => highOrderVertFluxField % array + + do iCell = 1, nCells + do k=1, maxLevelCell(iCell) + inv_h_new(k, iCell) = 1.0 / (layerThickness(k, iCell) + dt * tend_layerThickness(k, iCell)) + end do + end do + + ! Loop over tracers. One tracer is advected at a time. It is copied into a temporary array in order to improve locality + do iTracer = 1, num_tracers + ! Initialize variables for use in this iTracer iteration + do iCell = 1, nCells + do k=1, maxLevelCell(iCell) + tracer_cur(k,iCell) = tracers(iTracer,k,iCell) + upwind_tendency(k, iCell) = 0.0_RKIND + + !tracer_new is supposed to be the "new" tracer state. This allows bounds checks. + if (monotonicityCheck) then + tracer_new(k,iCell) = 0.0_RKIND + end if + end do ! k loop + end do ! iCell loop + + high_order_vert_flux = 0.0_RKIND + high_order_horiz_flux = 0.0_RKIND + + ! Compute the high order vertical flux. Also determine bounds on tracer_cur. + do iCell = 1, nCells + k = 1 + tracer_max(k,iCell) = max(tracer_cur(k,iCell),tracer_cur(k+1,iCell)) + tracer_min(k,iCell) = min(tracer_cur(k,iCell),tracer_cur(k+1,iCell)) + + k = max(1, min(maxLevelCell(iCell), 2)) + verticalWeightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) + verticalWeightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) + high_order_vert_flux(k,iCell) = w(k,iCell)*(verticalWeightK*tracer_cur(k,iCell)+verticalWeightKm1*tracer_cur(k-1,iCell)) + tracer_max(k,iCell) = max(tracer_cur(k-1,iCell),tracer_cur(k,iCell),tracer_cur(k+1,iCell)) + tracer_min(k,iCell) = min(tracer_cur(k-1,iCell),tracer_cur(k,iCell),tracer_cur(k+1,iCell)) + + do k=3,maxLevelCell(iCell)-1 + if(vert4thOrder) then + high_order_vert_flux(k, iCell) = mpas_tracer_advection_vflux4( tracer_cur(k-2,iCell),tracer_cur(k-1,iCell), & + tracer_cur(k ,iCell),tracer_cur(k+1,iCell), w(k,iCell)) + else if(vert3rdOrder) then + high_order_vert_flux(k, iCell) = mpas_tracer_advection_vflux3( tracer_cur(k-2,iCell),tracer_cur(k-1,iCell), & + tracer_cur(k ,iCell),tracer_cur(k+1,iCell), w(k,iCell), coef_3rd_order ) + else if (vert2ndOrder) then + verticalWeightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) + verticalWeightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) + high_order_vert_flux(k,iCell) = w(k,iCell)*(verticalWeightK*tracer_cur(k,iCell)+verticalWeightKm1*tracer_cur(k-1,iCell)) + end if + tracer_max(k,iCell) = max(tracer_cur(k-1,iCell),tracer_cur(k,iCell),tracer_cur(k+1,iCell)) + tracer_min(k,iCell) = min(tracer_cur(k-1,iCell),tracer_cur(k,iCell),tracer_cur(k+1,iCell)) + end do + + k = max(1, maxLevelCell(iCell)) + verticalWeightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) + verticalWeightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) + high_order_vert_flux(k,iCell) = w(k,iCell)*(verticalWeightK*tracer_cur(k,iCell)+verticalWeightKm1*tracer_cur(k-1,iCell)) + tracer_max(k,iCell) = max(tracer_cur(k,iCell),tracer_cur(k-1,iCell)) + tracer_min(k,iCell) = min(tracer_cur(k,iCell),tracer_cur(k-1,iCell)) + + ! pull tracer_min and tracer_max from the (horizontal) surrounding cells + do i = 1, nEdgesOnCell(iCell) + do k=1, min(maxLevelCell(iCell), maxLevelCell(cellsOnCell(i, iCell))) + tracer_max(k,iCell) = max(tracer_max(k,iCell),tracer_cur(k, cellsOnCell(i,iCell))) + tracer_min(k,iCell) = min(tracer_min(k,iCell),tracer_cur(k, cellsOnCell(i,iCell))) + end do ! k loop + end do ! i loop over nEdgesOnCell + end do ! iCell Loop + + ! Compute the high order horizontal flux + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1, iEdge) + cell2 = cellsOnEdge(2, iEdge) + + ! Compute 2nd order fluxes where needed. + do k = 1, maxLevelEdgeTop(iEdge) + tracer_weight = iand(highOrderAdvectionMask(k, iEdge)+1, 1) * (dvEdge(iEdge) * 0.5_RKIND) * normalThicknessFlux(k, iEdge) + + high_order_horiz_flux(k, iEdge) = high_order_horiz_flux(k, iedge) + tracer_weight * (tracer_cur(k, cell1) + tracer_cur(k, cell2)) + end do ! k loop + + ! Compute 3rd or 4th fluxes where requested. + do i = 1, nAdvCellsForEdge(iEdge) + iCell = advCellsForEdge(i,iEdge) + do k = 1, maxLevelCell(iCell) + tracer_weight = highOrderAdvectionMask(k, iEdge) * (adv_coefs(i,iEdge) + coef_3rd_order*sign(1.0_RKIND,normalThicknessFlux(k,iEdge))*adv_coefs_3rd(i,iEdge)) + + tracer_weight = normalThicknessFlux(k,iEdge)*tracer_weight + high_order_horiz_flux(k,iEdge) = high_order_horiz_flux(k,iEdge) + tracer_weight * tracer_cur(k,iCell) + end do ! k loop + end do ! i loop over nAdvCellsForEdge + end do ! iEdge loop + + ! low order upwind vertical flux (monotonic and diffused) + ! Remove low order flux from the high order flux. + ! Store left over high order flux in high_order_vert_flux array. + ! Upwind fluxes are accumulated in upwind_tendency + do iCell = 1, nCells + do k = 2, maxLevelCell(iCell) + ! dwj 02/03/12 and Atmosphere are different in vertical + if(positiveDzDk) then + flux_upwind = max(0.0_RKIND,w(k,iCell))*tracer_cur(k-1,iCell) + min(0.0_RKIND,w(k,iCell))*tracer_cur(k,iCell) + else + flux_upwind = min(0.0_RKIND,w(k,iCell))*tracer_cur(k-1,iCell) + max(0.0_RKIND,w(k,iCell))*tracer_cur(k,iCell) + end if + upwind_tendency(k-1,iCell) = upwind_tendency(k-1,iCell) + flux_upwind + upwind_tendency(k ,iCell) = upwind_tendency(k ,iCell) - flux_upwind + high_order_vert_flux(k,iCell) = high_order_vert_flux(k,iCell) - flux_upwind + end do ! k loop + + ! flux_incoming contains the total remaining high order flux into iCell + ! it is positive. + ! flux_outgoing contains the total remaining high order flux out of iCell + ! it is negative + do k = 1, maxLevelCell(iCell) + ! dwj 02/03/12 and Atmosphere are different in vertical + if(positiveDzDk) then + flux_incoming (k,iCell) = -(min(0.0_RKIND,high_order_vert_flux(k+1,iCell))-max(0.0_RKIND,high_order_vert_flux(k,iCell))) + flux_outgoing(k,iCell) = -(max(0.0_RKIND,high_order_vert_flux(k+1,iCell))-min(0.0_RKIND,high_order_vert_flux(k,iCell))) + else + flux_incoming (k, iCell) = max(0.0_RKIND, high_order_vert_flux(k+1, iCell)) - min(0.0_RKIND, high_order_vert_flux(k, iCell)) + flux_outgoing(k, iCell) = min(0.0_RKIND, high_order_vert_flux(k+1, iCell)) - max(0.0_RKIND, high_order_vert_flux(k, iCell)) + end if + end do ! k Loop + end do ! iCell Loop + + ! low order upwind horizontal flux (monotinc and diffused) + ! Remove low order flux from the high order flux + ! Store left over high order flux in high_order_horiz_flux array + ! Upwind fluxes are accumulated in upwind_tendency + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + invAreaCell1 = 1.0_RKIND / areaCell(cell1) + invAreaCell2 = 1.0_RKIND / areaCell(cell2) + + do k = 1, maxLevelEdgeTop(iEdge) + flux_upwind = dvEdge(iEdge) * (max(0.0_RKIND,normalThicknessFlux(k,iEdge))*tracer_cur(k,cell1) + min(0.0_RKIND,normalThicknessFlux(k,iEdge))*tracer_cur(k,cell2)) + high_order_horiz_flux(k,iEdge) = high_order_horiz_flux(k,iEdge) - flux_upwind + end do ! k loop + end do ! iEdge loop + + do iCell = 1, nCells + invAreaCell1 = 1.0_RKIND / areaCell(iCell) + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + do k = 1, maxLevelEdgeTop(iEdge) + flux_upwind = dvEdge(iEdge) * (max(0.0_RKIND,normalThicknessFlux(k,iEdge))*tracer_cur(k,cell1) + min(0.0_RKIND,normalThicknessFlux(k,iEdge))*tracer_cur(k,cell2)) + + upwind_tendency(k,iCell) = upwind_tendency(k,iCell) + edgeSignOncell(i, iCell) * flux_upwind * invAreaCell1 + + ! Accumulate remaining high order fluxes + flux_outgoing(k,iCell) = flux_outgoing(k,iCell) + min(0.0_RKIND, edgeSignOnCell(i, iCell) * high_order_horiz_flux(k, iEdge)) * invAreaCell1 + flux_incoming(k,iCell) = flux_incoming(k,iCell) + max(0.0_RKIND, edgeSignOnCell(i, iCell) * high_order_horiz_flux(k, iEdge)) * invAreaCell1 + end do + end do + end do + + ! Build the factors for the FCT + ! Computed using the bounds that were computed previously, and the bounds on the newly updated value + ! Factors are placed in the flux_incoming and flux_outgoing arrays + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracer_min_new = (tracer_cur(k,iCell)*layerThickness(k,iCell) + dt*(upwind_tendency(k,iCell)+flux_outgoing(k,iCell))) * inv_h_new(k,iCell) + tracer_max_new = (tracer_cur(k,iCell)*layerThickness(k,iCell) + dt*(upwind_tendency(k,iCell)+flux_incoming(k,iCell))) * inv_h_new(k,iCell) + tracer_upwind_new = (tracer_cur(k,iCell)*layerThickness(k,iCell) + dt*upwind_tendency(k,iCell)) * inv_h_new(k,iCell) + + scale_factor = (tracer_max(k,iCell)-tracer_upwind_new)/(tracer_max_new-tracer_upwind_new+eps) + flux_incoming(k,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + + scale_factor = (tracer_upwind_new-tracer_min(k,iCell))/(tracer_upwind_new-tracer_min_new+eps) + flux_outgoing(k,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + end do ! k loop + end do ! iCell loop + + ! rescale the high order horizontal fluxes + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + do k = 1, maxLevelEdgeTop(iEdge) + flux = high_order_horiz_flux(k,iEdge) + flux = max(0.0_RKIND,flux) * min(flux_outgoing(k,cell1), flux_incoming(k,cell2)) & + + min(0.0_RKIND,flux) * min(flux_incoming(k,cell1), flux_outgoing(k,cell2)) + high_order_horiz_flux(k,iEdge) = flux + end do ! k loop + end do ! iEdge loop + + ! rescale the high order vertical flux + do iCell = 1, nCellsSolve + do k = 2, maxLevelCell(iCell) + flux = high_order_vert_flux(k,iCell) + ! dwj 02/03/12 and Atmosphere are different in vertical. + if(positiveDzDk) then + flux = max(0.0_RKIND,flux) * min(flux_outgoing(k-1,iCell), flux_incoming(k ,iCell)) & + + min(0.0_RKIND,flux) * min(flux_outgoing(k ,iCell), flux_incoming(k-1,iCell)) + else + flux = max(0.0_RKIND,flux) * min(flux_outgoing(k ,iCell), flux_incoming(k-1,iCell)) & + + min(0.0_RKIND,flux) * min(flux_outgoing(k-1,iCell), flux_incoming(k ,iCell)) + end if + high_order_vert_flux(k,iCell) = flux + end do ! k loop + end do ! iCell loop + + ! Accumulate the scaled high order horizontal tendencies + do iCell = 1, nCells + invAreaCell1 = 1.0 / areaCell(iCell) + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + do k = 1, maxLevelEdgeTop(iEdge) + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + edgeSignOnCell(i, iCell) * high_order_horiz_flux(k, iEdge) * invAreaCell1 + + if(monotonicityCheck) then + tracer_new(k, iCell) = tracer_new(k, iCell) + edgeSignOnCell(i, iCell) * high_order_horiz_flux(k, iEdge) * invAreaCell1 + end if + end do + end do + end do + + ! Accumulate the scaled high order vertical tendencies, and the upwind tendencies + do iCell = 1, nCellsSolve + do k = 1,maxLevelCell(iCell) + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + verticalDivergenceFactor(k) * (high_order_vert_flux(k+1, iCell) - high_order_vert_flux(k, iCell)) + upwind_tendency(k,iCell) + + if (monotonicityCheck) then + !tracer_new holds a tendency for now. Only for a check on monotonicity + tracer_new(k, iCell) = tracer_new(k, iCell) + verticalDivergenceFactor(k) * (high_order_vert_flux(k+1, iCell) - high_order_vert_flux(k, iCell)) + upwind_tendency(k,iCell) + + !tracer_new is now the new state of the tracer. Only for a check on monotonicity + tracer_new(k, iCell) = (tracer_cur(k, iCell)*layerThickness(k, iCell) + dt * tracer_new(k, iCell)) * inv_h_new(k, iCell) + end if + end do ! k loop + end do ! iCell loop + + if (monotonicityCheck) then + !build min and max bounds on old and new tracer for check on monotonicity. + do iCell = 1, nCellsSolve + do k = 1, maxLevelCell(iCell) + if(tracer_new(k,iCell) < tracer_min(k, iCell)-eps) then + write(stderrUnit,*) 'Minimum out of bounds on tracer ', iTracer, tracer_min(k, iCell), tracer_new(k,iCell) + end if + + if(tracer_new(k,iCell) > tracer_max(k,iCell)+eps) then + write(stderrUnit,*) 'Maximum out of bounds on tracer ', iTracer, tracer_max(k, iCell), tracer_new(k,iCell) + end if + end do + end do + end if + end do ! iTracer loop + + call mpas_deallocate_scratch_field(highOrderHorizFluxField, .true.) + call mpas_deallocate_scratch_field(tracerNewField, .true.) + call mpas_deallocate_scratch_field(tracerCurField, .true.) + call mpas_deallocate_scratch_field(upwindTendencyField, .true.) + call mpas_deallocate_scratch_field(inverseLayerThicknessField, .true.) + call mpas_deallocate_scratch_field(tracerMinField, .true.) + call mpas_deallocate_scratch_field(tracerMaxField, .true.) + call mpas_deallocate_scratch_field(fluxIncomingField, .true.) + call mpas_deallocate_scratch_field(fluxOutgoingField, .true.) + call mpas_deallocate_scratch_field(highOrderVertFluxField, .true.) + + deallocate(verticalDivergenceFactor) + + end subroutine ocn_tracer_advection_mono_tend!}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine ocn_tracer_advection_mono_init +! +!> \brief MPAS initialize monotonic tracer advection tendency with FCT +!> \author Doug Jacobsen +!> \date 03/09/12 +!> \details +!> This routine initializes the monotonic tracer advection tendencity using a FCT. +! +!----------------------------------------------------------------------- + subroutine ocn_tracer_advection_mono_init(nHalos, horiz_adv_order, vert_adv_order, coef_3rd_order_in, dzdk_positive, check_monotonicity, err)!{{{ + + use mpas_dmpar + integer, intent(in) :: nHalos !< Input: number of halos in current simulation + integer, intent(in) :: horiz_adv_order !< Input: Order for horizontal advection + integer, intent(in) :: vert_adv_order !< Input: Order for vertical advection + real (kind=RKIND), intent(in) :: coef_3rd_order_in !< Input: coefficient for blending advection orders. + logical, intent(in) :: dzdk_positive !< Input: Logical flag determining if dzdk is positive or negative. + logical, intent(in) :: check_monotonicity !< Input: Logical flag determining check on monotonicity of tracers + integer, intent(inout) :: err !< Input/Output: Error Flag + + err = 0 + + vert2ndOrder = .false. + vert3rdOrder = .false. + vert4thOrder = .false. + + if ( horiz_adv_order == 3) then + coef_3rd_order = coef_3rd_order_in + else if(horiz_adv_order == 2 .or. horiz_adv_order == 4) then + coef_3rd_order = 0.0_RKIND + end if + + horizOrder = horiz_adv_order + + if (vert_adv_order == 3) then + vert3rdOrder = .true. + else if (vert_adv_order == 4) then + vert4thOrder = .true. + else + vert2ndOrder = .true. + if(vert_adv_order /= 2) then + write(stderrUnit,*) 'Invalid value for vert_adv_order, defaulting to 2nd order' + end if + end if + + if (nHalos < 3) then + call mpas_dmpar_global_abort('ERROR: Monotonic advection cannot be used with less than 3 halos.') + end if + + positiveDzDk = dzdk_positive + monotonicityCheck = check_monotonicity + + end subroutine ocn_tracer_advection_mono_init!}}} + +end module ocn_tracer_advection_mono + diff --git a/src/core_ocean/shared/mpas_ocn_tracer_advection_std.F b/src/core_ocean/shared/mpas_ocn_tracer_advection_std.F new file mode 100644 index 0000000000..0688962776 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tracer_advection_std.F @@ -0,0 +1,259 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tracer_advection_std +! +!> \brief MPAS standard tracer advection +!> \author Doug Jacobsen +!> \date 03/09/12 +!> \details +!> This module contains routines for standard advection of tracers +! +!----------------------------------------------------------------------- +module ocn_tracer_advection_std + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use mpas_io_units + + use mpas_tracer_advection_helpers + + implicit none + private + save + + real (kind=RKIND) :: coef_3rd_order + integer :: horizOrder + logical :: vert2ndOrder, vert3rdOrder, vert4thOrder + logical :: positiveDzDk, monotonicityCheck + + public :: ocn_tracer_advection_std_tend, & + ocn_tracer_advection_std_init + + contains + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine ocn_tracer_advection_std_tend +! +!> \brief MPAS standard tracer advection tendency +!> \author Doug Jacobsen +!> \date 03/09/12 +!> \details +!> This routine computes the standard tracer advection tendencity. +!> Both horizontal and vertical. +! +!----------------------------------------------------------------------- + subroutine ocn_tracer_advection_std_tend(tracers, adv_coefs, adv_coefs_3rd, nAdvCellsForEdge, advCellsForEdge, &!{{{ + normalThicknessFlux, w, layerThickness, verticalCellSize, dt, meshPool, & + scratchPool, tend_layerThickness, tend, maxLevelCell, maxLevelEdgeTop, & + highOrderAdvectionMask, edgeSignOnCell) + + real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input: current tracer values + real (kind=RKIND), dimension(:,:), intent(in) :: adv_coefs !< Input: Advection coefficients for 2nd order advection + real (kind=RKIND), dimension(:,:), intent(in) :: adv_coefs_3rd !< Input: Advection coefficients for blending in 3rd or 4th order advection + integer, dimension(:), intent(in) :: nAdvCellsForEdge !< Input: Number of advection cells for each edge + integer, dimension(:,:), intent(in) :: advCellsForEdge !< Input: List of advection cells for each edge + real (kind=RKIND), dimension(:,:), intent(in) :: normalThicknessFlux !< Input: Thichness weighted velocitiy - (nVertLevels, nEdge) + real (kind=RKIND), dimension(:,:), intent(in) :: w !< Input: Vertical velocitiy - (nVertLevels+1, nEdges) + real (kind=RKIND), dimension(:,:), intent(in) :: layerThickness !< Input: Thickness - (nVertLevels, nCells) + real (kind=RKIND), dimension(:,:), intent(in) :: verticalCellSize !< Input: Distance between vertical interfaces of a cell - (nVertLevels, nCells) + real (kind=RKIND), dimension(:,:), intent(in) :: tend_layerThickness !< Input: Tendency for thickness field - (nVertLevels, nCells) + real (kind=RKIND), intent(in) :: dt !< Input: Timestep + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), intent(in) :: scratchPool !< Input: Scratch fields + real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/Output: Tracer tendency + integer, dimension(:), pointer :: maxLevelCell !< Input: Index to max level at cell center + integer, dimension(:), pointer :: maxLevelEdgeTop !< Input: Index to max level at edge with non-land cells on both sides + integer, dimension(:,:), pointer :: highOrderAdvectionMask !< Input: Mask for high order advection + integer, dimension(:, :), pointer :: edgeSignOnCell !< Input: Sign for flux from edge on each cell. Used for bit-reproducibility + + integer :: i, iCell, iEdge, k, iTracer, cell1, cell2 + integer :: nVertLevels, num_tracers + integer, pointer :: nCells, nEdges, nCellsSolve, maxEdges + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnCell, edgesOnCell + + real (kind=RKIND) :: tracer_weight, invAreaCell1 + real (kind=RKIND) :: verticalWeightK, verticalWeightKm1 + real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell, verticalDivergenceFactor + real (kind=RKIND), dimension(:,:), pointer :: tracer_cur, high_order_horiz_flux, high_order_vert_flux + + type (field2DReal), pointer :: highOrderHorizFluxField, tracerCurField, highOrderVertFluxField + + real (kind=RKIND), parameter :: eps = 1.e-10_RKIND + + ! Get dimensions + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'maxEdges', maxEdges) + nVertLevels = size(tracers,dim=2) + num_tracers = size(tracers,dim=1) + + ! Initialize pointers + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + + allocate(verticalDivergenceFactor(nVertLevels)) + verticalDivergenceFactor = 1.0_RKIND + + call mpas_pool_get_field(scratchPool, 'highOrderHorizFlux', highOrderHorizFluxField) + call mpas_pool_get_field(scratchPool, 'tracerValue', tracerCurField, 1) + call mpas_pool_get_field(scratchPool, 'highOrderVertFlux', highOrderVertFluxField) + + call mpas_allocate_scratch_field(highOrderHorizFluxField, .true.) + call mpas_allocate_scratch_field(tracerCurField, .true.) + call mpas_allocate_scratch_field(highOrderVertFluxField, .true.) + + high_order_horiz_flux => highOrderHorizFluxField % array + tracer_cur => tracerCurField % array + high_order_vert_flux => highOrderVertFluxField % array + + ! Loop over tracers. One tracer is advected at a time. It is copied into a temporary array in order to improve locality + do iTracer = 1, num_tracers + ! Initialize variables for use in this iTracer iteration + tracer_cur(:, :) = tracers(iTracer, :, :) + + high_order_vert_flux = 0.0_RKIND + high_order_horiz_flux = 0.0_RKIND + + ! Compute the high order vertical flux. Also determine bounds on tracer_cur. + do iCell = 1, nCells + k = max(1, min(maxLevelCell(iCell), 2)) + verticalWeightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) + verticalWeightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) + high_order_vert_flux(k,iCell) = w(k,iCell)*(verticalWeightK*tracer_cur(k,iCell)+verticalWeightKm1*tracer_cur(k-1,iCell)) + + do k=3,maxLevelCell(iCell)-1 + if(vert4thOrder) then + high_order_vert_flux(k, iCell) = mpas_tracer_advection_vflux4( tracer_cur(k-2,iCell),tracer_cur(k-1,iCell), & + tracer_cur(k ,iCell),tracer_cur(k+1,iCell), w(k,iCell)) + else if(vert3rdOrder) then + high_order_vert_flux(k, iCell) = mpas_tracer_advection_vflux3( tracer_cur(k-2,iCell),tracer_cur(k-1,iCell), & + tracer_cur(k ,iCell),tracer_cur(k+1,iCell), w(k,iCell), coef_3rd_order ) + else if (vert2ndOrder) then + verticalWeightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) + verticalWeightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) + high_order_vert_flux(k,iCell) = w(k,iCell)*(verticalWeightK*tracer_cur(k,iCell)+verticalWeightKm1*tracer_cur(k-1,iCell)) + end if + end do + + k = max(1, maxLevelCell(iCell)) + verticalWeightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) + verticalWeightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) + high_order_vert_flux(k,iCell) = w(k,iCell)*(verticalWeightK*tracer_cur(k,iCell)+verticalWeightKm1*tracer_cur(k-1,iCell)) + end do ! iCell Loop + + ! Compute the high order horizontal flux + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1, iEdge) + cell2 = cellsOnEdge(2, iEdge) + + ! Compute 2nd order fluxes where needed. + do k = 1, maxLevelEdgeTop(iEdge) + tracer_weight = iand(highOrderAdvectionMask(k, iEdge)+1, 1) * (dvEdge(iEdge) * 0.5_RKIND) * normalThicknessFlux(k, iEdge) + + high_order_horiz_flux(k, iEdge) = high_order_horiz_flux(k, iedge) + tracer_weight * (tracer_cur(k, cell1) + tracer_cur(k, cell2)) + end do ! k loop + + ! Compute 3rd or 4th fluxes where requested. + do i = 1, nAdvCellsForEdge(iEdge) + iCell = advCellsForEdge(i,iEdge) + do k = 1, maxLevelCell(iCell) + tracer_weight = highOrderAdvectionMask(k, iEdge) * (adv_coefs(i,iEdge) + coef_3rd_order*sign(1.0_RKIND,normalThicknessFlux(k,iEdge))*adv_coefs_3rd(i,iEdge)) + + tracer_weight = normalThicknessFlux(k,iEdge)*tracer_weight + high_order_horiz_flux(k,iEdge) = high_order_horiz_flux(k,iEdge) + tracer_weight * tracer_cur(k,iCell) + end do ! k loop + end do ! i loop over nAdvCellsForEdge + end do ! iEdge loop + + ! Accumulate the scaled high order horizontal tendencies + do iCell = 1, nCells + invAreaCell1 = 1.0 / areaCell(iCell) + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + do k = 1, maxLevelEdgeTop(iEdge) + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + edgeSignOnCell(i, iCell) * high_order_horiz_flux(k, iEdge) * invAreaCell1 + end do + end do + end do + + ! Accumulate the scaled high order vertical tendencies. + do iCell = 1, nCellsSolve + do k = 1,maxLevelCell(iCell) + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + verticalDivergenceFactor(k) * (high_order_vert_flux(k+1, iCell) - high_order_vert_flux(k, iCell)) + end do ! k loop + end do ! iCell loop + end do ! iTracer loop + + call mpas_deallocate_scratch_field(highOrderHorizFluxField, .true.) + call mpas_deallocate_scratch_field(tracerCurField, .true.) + call mpas_deallocate_scratch_field(highOrderVertFluxField, .true.) + deallocate(verticalDivergenceFactor) + + end subroutine ocn_tracer_advection_std_tend!}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine ocn_tracer_advection_std_init +! +!> \brief MPAS initialize standard tracer advection tendency. +!> \author Doug Jacobsen +!> \date 03/09/12 +!> \details +!> This routine initializes the standard tracer advection tendencity. +! +!----------------------------------------------------------------------- + subroutine ocn_tracer_advection_std_init(horiz_adv_order, vert_adv_order, coef_3rd_order_in, dzdk_positive, check_monotonicity, err)!{{{ + integer, intent(in) :: horiz_adv_order !< Input: Order for horizontal advection + integer, intent(in) :: vert_adv_order !< Input: Order for vertical advection + real (kind=RKIND), intent(in) :: coef_3rd_order_in !< Input: coefficient for blending advection orders. + logical, intent(in) :: dzdk_positive !< Input: Logical flag determining if dzdk is positive or negative. + logical, intent(in) :: check_monotonicity !< Input: Logical flag determining check on monotonicity of tracers + integer, intent(inout) :: err !< Input/Output: Error Flag + + err = 0 + + vert2ndOrder = .false. + vert3rdOrder = .false. + vert4thOrder = .false. + + if ( horiz_adv_order == 3) then + coef_3rd_order = coef_3rd_order_in + else if(horiz_adv_order == 2 .or. horiz_adv_order == 4) then + coef_3rd_order = 0.0_RKIND + end if + + horizOrder = horiz_adv_order + + if (vert_adv_order == 3) then + vert3rdOrder = .true. + else if (vert_adv_order == 4) then + vert4thOrder = .true. + else + vert2ndOrder = .true. + if(vert_adv_order /= 2) then + write(stderrUnit,*) 'Invalid value for vert_adv_order, defaulting to 2nd order' + end if + end if + + positiveDzDk = dzdk_positive + monotonicityCheck = check_monotonicity + + end subroutine ocn_tracer_advection_std_init!}}} + +end module ocn_tracer_advection_std + From 833a299ae2445ed579c05693c93e42b4428af1ed Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Wed, 19 Aug 2015 07:31:12 -0600 Subject: [PATCH 0146/1724] Separating out the redi portion of hmix for gm This commit separates out the redi portion of hmix that is used when GM is turned on. Previously this was incorporated within the del2 module, and the logic to control if redi was used or not was confusing. In addition, this commit updates the redi hmix module to be bit reproducible, which it was not previously. --- src/core_ocean/Registry.xml | 2 +- src/core_ocean/shared/Makefile | 5 +- src/core_ocean/shared/mpas_ocn_tendency.F | 2 +- src/core_ocean/shared/mpas_ocn_tracer_hmix.F | 13 +- .../shared/mpas_ocn_tracer_hmix_del2.F | 243 +---------- .../shared/mpas_ocn_tracer_hmix_redi.F | 401 ++++++++++++++++++ 6 files changed, 425 insertions(+), 241 deletions(-) create mode 100644 src/core_ocean/shared/mpas_ocn_tracer_hmix_redi.F diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index bd7ccb3390..9cb4956f48 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -312,7 +312,7 @@ gradTracerEdgeField % array - gradTracerTopOfEdge => gradTracerTopOfEdgeField % array - gradHTracerSlopedTopOfCell => gradHTracerSlopedTopOfCellField % array - dTracerdZTopOfCell => dTracerdZTopOfCellField % array - dTracerdZTopOfEdge => dTracerdZTopOfEdgeField % array - areaCellSum => areaCellSumField % array - - gradTracerEdge = 0.0 - gradTracerTopOfEdge = 0.0 - gradHTracerSlopedTopOfCell = 0.0 - dTracerdZTopOfCell = 0.0 - dTracerdZTopOfEdge = 0.0 - - ! this is the "standard" del2 term, but forced to use config_redi_kappa - if(.not.config_disable_redi_horizontal_term1) then - do iCell = 1, nCells - invAreaCell = 1.0 / areaCell(iCell) - do i = 1, nEdgesOnCell(iCell) - iEdge = edgesOnCell(i, iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - r_tmp = config_redi_kappa * dvEdge(iEdge) / dcEdge(iEdge) - - do k = 1, maxLevelEdgeTop(iEdge) - - ! this is the tapering of config_redi_kappa where abs(slope) > config_max_relative_slope - s_tmp = relativeSlopeTapering(k,iEdge) - - do iTracer = 1, num_tracers - ! \kappa_2 \nabla \phi on edge - tracer_turb_flux = tracers(iTracer, k, cell2) - tracers(iTracer, k, cell1) - - ! div(h \kappa_2 \nabla \phi) at cell center - flux = layerThicknessEdge(k, iEdge) * tracer_turb_flux * r_tmp * s_tmp - - tend(iTracer, k, iCell) = tend(iTracer, k, iCell) - edgeSignOnCell(i, iCell) * flux * invAreaCell - end do - end do - - end do - end do - endif - - ! Compute vertical derivative of tracers at cell center and top of layer - do iTracer = 1, num_tracers - - do iCell = 1, nCells - do k = 2, maxLevelCell(iCell) - dTracerdZTopOfCell(k,iCell) = (tracers(iTracer,k-1,iCell) - tracers(iTracer,k,iCell)) / (zMid(k-1,iCell) - zMid(k,iCell)) - end do - - ! Approximation of dTracerdZTopOfCell on the top and bottom interfaces through the idea of having - ! ghost cells above the top and below the bottom layers of the same depths and tracer density. - ! Essentially, this enforces the boundary condition (d tracer)/dz = 0 at the top and bottom. - dTracerdZTopOfCell(1,iCell) = 0.0 - dTracerdZTopOfCell(maxLevelCell(iCell)+1,iCell) = 0.0 - end do - - ! Compute tracer gradient (gradTracerEdge) along the constant coordinate surface. - ! The computed variables lives at edge and mid-layer depth - do iEdge = 1, nEdges - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - do k=1,maxLevelEdgeTop(iEdge) - gradTracerEdge(k,iEdge) = (tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge) - end do - end do - - ! Interpolate dTracerdZTopOfCell to edge and top of layer - do iEdge = 1, nEdges - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - do k = 1, maxLevelEdgeTop(iEdge) - dTracerdZTopOfEdge(k,iEdge) = 0.5 * (dTracerdZTopOfCell(k,cell1) + dTracerdZTopOfCell(k,cell2)) - end do - dTracerdZTopOfEdge(maxLevelEdgeTop(iEdge)+1,iEdge) = 0.0 - end do - - ! Interpolate gradTracerEdge to edge and top of layer - do iEdge = 1, nEdges - do k = 2, maxLevelEdgeTop(iEdge) - h1 = layerThicknessEdge(k-1,iEdge) - h2 = layerThicknessEdge(k,iEdge) - - ! Using second-order interpolation below - gradTracerTopOfEdge(k,iEdge) = (h2 * gradTracerEdge(k-1,iEdge) + h1 * gradTracerEdge(k,iEdge)) / (h1 + h2) - end do - - ! Approximation of values on the top and bottom interfaces through the idea of having ghost cells above - ! the top and below the bottom layers of the same depths and tracer concentration. - gradTracerTopOfEdge(1,iEdge) = gradTracerEdge(1,iEdge) - gradTracerTopOfEdge(maxLevelEdgeTop(iEdge)+1,iEdge) = gradTracerEdge(max(maxLevelEdgeTop(iEdge),1),iEdge) - end do - - ! Compute \nabla\cdot(relativeSlope d\phi/dz) - if(.not.config_disable_redi_horizontal_term2) then - do iEdge = 1, nEdges - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - invAreaCell1 = 1./areaCell(cell1) - invAreaCell2 = 1./areaCell(cell2) - - do k = 1, maxLevelEdgeTop(iEdge) - s_tmpU = relativeSlopeTapering(k , iEdge) * relativeSlopeTopOfEdge(k,iEdge)*dTracerdZTopOfEdge(k,iEdge) - s_tmpD = relativeSlopeTapering(k+1, iEdge) * relativeSlopeTopOfEdge(k+1,iEdge)*dTracerdZTopOfEdge(k+1,iEdge) - flux = 0.5*dvEdge(iEdge)*(s_tmpU + s_tmpD) - flux = flux * layerThicknessEdge(k, iEdge) - tend(iTracer,k,cell1) = tend(iTracer,k,cell1) + config_Redi_kappa * flux * invAreaCell1 - tend(iTracer,k,cell2) = tend(iTracer,k,cell2) - config_Redi_kappa * flux * invAreaCell2 - end do - - end do - endif - - ! Compute dz * d(relativeSlope\cdot\nabla\phi)/dz (so the dz cancel out) - gradHTracerSlopedTopOfCell = 0.0 - - ! Compute relativeSlope\cdot\nabla\phi (variable gradHTracerSlopedTopOfCell) at non-boundary edges - areaCellSum = 1.0e-34 - do iEdge = 1, nEdges - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - ! contribution of cell area from this edge: - areaEdge = 0.25 * dcEdge(iEdge) * dvEdge(iEdge) - - do k = 1, maxLevelEdgeTop(iEdge) - r_tmp = 2.0 * areaEdge * relativeSlopeTopOfEdge(k,iEdge) * gradTracerTopOfEdge(k,iEdge) - gradHTracerSlopedTopOfCell(k,cell1) = gradHTracerSlopedTopOfCell(k,cell1) + r_tmp - gradHTracerSlopedTopOfCell(k,cell2) = gradHTracerSlopedTopOfCell(k,cell2) + r_tmp - - areaCellSum(k,cell1) = areaCellSum(k,cell1) + areaEdge - areaCellSum(k,cell2) = areaCellSum(k,cell2) + areaEdge - - end do - end do - do iCell=1,nCells - do k = 1, maxLevelCell(iCell) - gradHTracerSlopedTopOfCell(k,iCell) = gradHTracerSlopedTopOfCell(k,iCell)/areaCellSum(k,iCell) - end do - end do - - if(.not.config_disable_redi_horizontal_term3) then - do iCell = 1, nCells - ! impose no-flux boundary conditions at top and bottom of column - gradHTracerSlopedTopOfCell(1,iCell) = 0.0 - gradHTracerSlopedTopOfCell(maxLevelCell(iCell)+1,iCell) = 0.0 - do k = 1, maxLevelCell(iCell) - s_tmp = relativeSlopeTaperingCell(k,iCell) - tend(iTracer,k,iCell) = tend(iTracer,k,iCell) + s_tmp * config_Redi_kappa * (gradHTracerSlopedTopOfCell(k,iCell) - gradHTracerSlopedTopOfCell(k+1,iCell)) - end do - end do - endif - - end do ! iTracer - - call mpas_deallocate_scratch_field(gradTracerEdgeField, .true.) - call mpas_deallocate_scratch_field(gradTracerTopOfEdgeField, .true.) - call mpas_deallocate_scratch_field(gradHTracerSlopedTopOfCellField, .true.) - call mpas_deallocate_scratch_field(dTracerdZTopOfCellField, .true.) - call mpas_deallocate_scratch_field(dTracerdZTopOfEdgeField, .true.) - - end if ! config_use_standardGM - !-------------------------------------------------------------------- end subroutine ocn_tracer_hmix_del2_tend!}}} @@ -416,28 +205,16 @@ subroutine ocn_tracer_hmix_del2_init(err)!{{{ call mpas_pool_get_config(ocnConfigs, 'config_use_tracer_del2', config_use_tracer_del2) call mpas_pool_get_config(ocnConfigs, 'config_tracer_del2', config_tracer_del2) - call mpas_pool_get_config(ocnConfigs, 'config_use_standardGM',config_use_standardGM) - call mpas_pool_get_config(ocnConfigs, 'config_Redi_kappa',config_Redi_kappa) - call mpas_pool_get_config(ocnConfigs, 'config_disable_redi_horizontal_term1',config_disable_redi_horizontal_term1) - call mpas_pool_get_config(ocnConfigs, 'config_disable_redi_horizontal_term2',config_disable_redi_horizontal_term2) - call mpas_pool_get_config(ocnConfigs, 'config_disable_redi_horizontal_term3',config_disable_redi_horizontal_term3) del2on = .false. if ( config_use_tracer_del2 ) then - if ( config_tracer_del2 > 0.0 ) then - del2On = .true. - eddyDiff2 = config_tracer_del2 - endif + if ( config_tracer_del2 > 0.0 ) then + del2On = .true. + eddyDiff2 = config_tracer_del2 + endif endif - if ( config_use_standardGM ) then - if ( config_Redi_kappa > 0.0 ) then - del2On = .true. - endif - endif - - !-------------------------------------------------------------------- end subroutine ocn_tracer_hmix_del2_init!}}} diff --git a/src/core_ocean/shared/mpas_ocn_tracer_hmix_redi.F b/src/core_ocean/shared/mpas_ocn_tracer_hmix_redi.F new file mode 100644 index 0000000000..59aa3b7a73 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tracer_hmix_redi.F @@ -0,0 +1,401 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tracer_hmix_redi +! +!> \brief MPAS ocean horizontal tracer mixing driver +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This module contains the main driver routine for computing +!> horizontal mixing tendencies. +!> +!> It provides an init and a tend function. Each are described below. +! +!----------------------------------------------------------------------- + +module ocn_tracer_hmix_redi + + use mpas_derived_types + use mpas_pool_routines + + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_tracer_hmix_redi_tend, & + ocn_tracer_hmix_redi_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + logical :: rediOn + logical, pointer :: config_disable_redi_horizontal_term1 + logical, pointer :: config_disable_redi_horizontal_term2 + logical, pointer :: config_disable_redi_horizontal_term3 + real (kind=RKIND), pointer :: config_Redi_kappa + + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_tracer_hmix_redi_tend +! +!> \brief Computes Laplacian tendency term for horizontal tracer mixing +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine computes the horizontal mixing tendency for tracers +!> based on current state using a Laplacian parameterization. +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_hmix_redi_tend(meshPool, scratchPool, layerThicknessEdge, zMid, tracers, & + relativeSlopeTopOfEdge, relativeSlopeTapering, relativeSlopeTaperingCell, tend, err)!{{{ + + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), intent(in) :: scratchPool !< Input: Scratch information + + real (kind=RKIND), dimension(:,:), intent(in) :: & + layerThicknessEdge, &!< Input: thickness at edge + zMid, &!< Input: Z coordinate at the center of a cell + relativeSlopeTopOfEdge, &!< Input: slope of coordinate relative to neutral surface at edges + relativeSlopeTapering, &!< Input: tapering of slope of coordinate relative to neutral surface at edges + relativeSlopeTaperingCell !< Input: tapering of slope of coordinate relative to neutral surface at cells + + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + tracers !< Input: tracer quantities + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:,:), intent(inout) :: & + tend !< Input/Output: velocity tendency + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell, iEdge, cell1, cell2 + integer :: i, k, iTracer, num_tracers + integer, pointer :: nCells, nVertLevels, nEdges + + integer, dimension(:,:), allocatable :: boundaryMask + + integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnCell, maxLevelCell + integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, edgeSignOnCell + + real (kind=RKIND) :: invAreaCell1, invAreaCell2, invAreaCell, areaEdge + real (kind=RKIND) :: tracer_turb_flux, flux, s_tmp, r_tmp, h1, h2, s_tmpU, s_tmpD + + real (kind=RKIND), dimension(:), pointer :: areaCell, dvEdge, dcEdge + + real (kind=RKIND), dimension(:,:), pointer :: gradTracerEdge, gradTracerTopOfEdge, gradHTracerSlopedTopOfCell, & + dTracerdZTopOfCell, dTracerdZTopOfEdge, areaCellSum + + type (field2DReal), pointer :: gradTracerEdgeField, gradTracerTopOfEdgeField, gradHTracerSlopedTopOfCellField, dTracerdZTopOfCellField, dTracerdZTopOfEdgeField, & + areaCellSumField + + err = 0 + + if (.not.rediOn) return + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + num_tracers = size(tracers, dim=1) + + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + + call mpas_pool_get_config(ocnConfigs, 'config_Redi_kappa',config_Redi_kappa) + call mpas_pool_get_config(ocnConfigs, 'config_disable_redi_horizontal_term1',config_disable_redi_horizontal_term1) + call mpas_pool_get_config(ocnConfigs, 'config_disable_redi_horizontal_term2',config_disable_redi_horizontal_term2) + call mpas_pool_get_config(ocnConfigs, 'config_disable_redi_horizontal_term3',config_disable_redi_horizontal_term3) + + ! + ! COMPUTE the extra terms arising due to mismatch between the constant coordinate surfaces and the + ! isopycnal surfaces. + ! + ! mrp note: Redi diffusion should be put in a separate subroutine + + call mpas_pool_get_field(scratchPool, 'gradTracerEdge', gradTracerEdgeField) + call mpas_pool_get_field(scratchPool, 'gradTracerTopOfEdge', gradTracerTopOfEdgeField) + call mpas_pool_get_field(scratchPool, 'gradHTracerSlopedTopOfCell', gradHTracerSlopedTopOfCellField) + call mpas_pool_get_field(scratchPool, 'dTracerdZTopOfCell', dTracerdZTopOfCellField) + call mpas_pool_get_field(scratchPool, 'dTracerdZTopOfEdge', dTracerdZTopOfEdgeField) + call mpas_pool_get_field(scratchPool, 'areaCellSum', areaCellSumField) + + call mpas_allocate_scratch_field(gradTracerEdgeField, .true.) + call mpas_allocate_scratch_field(gradTracerTopOfEdgeField, .true.) + call mpas_allocate_scratch_field(gradHTracerSlopedTopOfCellField, .true.) + call mpas_allocate_scratch_field(dTracerdZTopOfCellField, .true.) + call mpas_allocate_scratch_field(dTracerdZTopOfEdgeField, .true.) + call mpas_allocate_scratch_field(areaCellSumField, .True.) + + gradTracerEdge => gradTracerEdgeField % array + gradTracerTopOfEdge => gradTracerTopOfEdgeField % array + gradHTracerSlopedTopOfCell => gradHTracerSlopedTopOfCellField % array + dTracerdZTopOfCell => dTracerdZTopOfCellField % array + dTracerdZTopOfEdge => dTracerdZTopOfEdgeField % array + areaCellSum => areaCellSumField % array + + gradTracerEdge = 0.0 + gradTracerTopOfEdge = 0.0 + gradHTracerSlopedTopOfCell = 0.0 + dTracerdZTopOfCell = 0.0 + dTracerdZTopOfEdge = 0.0 + + ! this is the "standard" del2 term, but forced to use config_redi_kappa + if(.not.config_disable_redi_horizontal_term1) then + + do iCell = 1, nCells + invAreaCell = 1.0 / areaCell(iCell) + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + r_tmp = config_redi_kappa * dvEdge(iEdge) / dcEdge(iEdge) + + do k = 1, maxLevelEdgeTop(iEdge) + + ! this is the tapering of config_redi_kappa where abs(slope) > config_max_relative_slope + s_tmp = relativeSlopeTapering(k,iEdge) + + do iTracer = 1, num_tracers + ! \kappa_2 \nabla \phi on edge + tracer_turb_flux = tracers(iTracer, k, cell2) - tracers(iTracer, k, cell1) + + ! div(h \kappa_2 \nabla \phi) at cell center + flux = layerThicknessEdge(k, iEdge) * tracer_turb_flux * r_tmp * s_tmp + + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) - edgeSignOnCell(i, iCell) * flux * invAreaCell + end do + end do + + end do + end do + + endif + + ! Compute vertical derivative of tracers at cell center and top of layer + do iTracer = 1, num_tracers + + do iCell = 1, nCells + do k = 2, maxLevelCell(iCell) + dTracerdZTopOfCell(k,iCell) = (tracers(iTracer,k-1,iCell) - tracers(iTracer,k,iCell)) / (zMid(k-1,iCell) - zMid(k,iCell)) + end do + + ! Approximation of dTracerdZTopOfCell on the top and bottom interfaces through the idea of having + ! ghost cells above the top and below the bottom layers of the same depths and tracer density. + ! Essentially, this enforces the boundary condition (d tracer)/dz = 0 at the top and bottom. + dTracerdZTopOfCell(1,iCell) = 0.0 + dTracerdZTopOfCell(maxLevelCell(iCell)+1,iCell) = 0.0 + end do + + ! Compute tracer gradient (gradTracerEdge) along the constant coordinate surface. + ! The computed variables lives at edge and mid-layer depth + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,maxLevelEdgeTop(iEdge) + gradTracerEdge(k,iEdge) = (tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge) + end do + end do + + ! Interpolate dTracerdZTopOfCell to edge and top of layer + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + do k = 1, maxLevelEdgeTop(iEdge) + dTracerdZTopOfEdge(k,iEdge) = 0.5 * (dTracerdZTopOfCell(k,cell1) + dTracerdZTopOfCell(k,cell2)) + end do + dTracerdZTopOfEdge(maxLevelEdgeTop(iEdge)+1,iEdge) = 0.0 + end do + + ! Interpolate gradTracerEdge to edge and top of layer + do iEdge = 1, nEdges + do k = 2, maxLevelEdgeTop(iEdge) + h1 = layerThicknessEdge(k-1,iEdge) + h2 = layerThicknessEdge(k,iEdge) + + ! Using second-order interpolation below + gradTracerTopOfEdge(k,iEdge) = (h2 * gradTracerEdge(k-1,iEdge) + h1 * gradTracerEdge(k,iEdge)) / (h1 + h2) + end do + + ! Approximation of values on the top and bottom interfaces through the idea of having ghost cells above + ! the top and below the bottom layers of the same depths and tracer concentration. + gradTracerTopOfEdge(1,iEdge) = gradTracerEdge(1,iEdge) + gradTracerTopOfEdge(maxLevelEdgeTop(iEdge)+1,iEdge) = gradTracerEdge(max(maxLevelEdgeTop(iEdge),1),iEdge) + end do + + ! Compute \nabla\cdot(relativeSlope d\phi/dz) + if(.not.config_disable_redi_horizontal_term2) then + do iCell = 1, nCells + invAreaCell = 1.0_RKIND / areaCell(iCell) + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + do k = 1, maxLevelEdgeTop(iEdge) + s_tmpU = relativeSlopeTapering(k, iEdge) * relativeSlopeTopOfEdge(k, iEdge) * dTracerdZTopOfEdge(k, iEdge) + s_tmpD = relativeSlopeTapering(k+1, iEdge) * relativeSlopeTopOfEdge(k+1, iEdge) * dTracerdZTopOfEdge(k+1, iEdge) + + flux = 0.5 * dvEdge(iEdge) * ( s_tmpU + s_tmpD ) + flux = flux * layerThicknessEdge(k, iEdge) + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + edgeSignOnCell(i, iCell) * config_Redi_kappa * flux * invAreaCell + end do + end do + end do + endif + + ! Compute dz * d(relativeSlope\cdot\nabla\phi)/dz (so the dz cancel out) + gradHTracerSlopedTopOfCell = 0.0 + + ! Compute relativeSlope\cdot\nabla\phi (variable gradHTracerSlopedTopOfCell) at non-boundary edges + areaCellSum = 1.0e-34 + + do iCell = 1, nCells + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + areaEdge = 0.5 * dcEdge(iEdge) * dvEdge(iEdge) + do k = 1, maxLevelEdgeTop(iEdge) + r_tmp = areaEdge * relativeSlopeTopOfEdge(k,iEdge) * gradTracerTopOfEdge(k,iEdge) + gradHTracerSlopedTopOfCell(k, iCell) = gradHTracerSlopedTopOfCell(k, iCell) + r_tmp + areaCellSum(k, iCell) = areaCellSum(k, iCell) + areaEdge + end do + end do + end do + + do iCell=1,nCells + do k = 1, maxLevelCell(iCell) + gradHTracerSlopedTopOfCell(k,iCell) = gradHTracerSlopedTopOfCell(k,iCell)/areaCellSum(k,iCell) + end do + end do + + if(.not.config_disable_redi_horizontal_term3) then + do iCell = 1, nCells + ! impose no-flux boundary conditions at top and bottom of column + gradHTracerSlopedTopOfCell(1,iCell) = 0.0 + gradHTracerSlopedTopOfCell(maxLevelCell(iCell)+1,iCell) = 0.0 + do k = 1, maxLevelCell(iCell) + s_tmp = relativeSlopeTaperingCell(k,iCell) + tend(iTracer,k,iCell) = tend(iTracer,k,iCell) + s_tmp * config_Redi_kappa * & + (gradHTracerSlopedTopOfCell(k,iCell) - gradHTracerSlopedTopOfCell(k+1,iCell)) + end do + end do + endif + end do ! iTracer + + call mpas_deallocate_scratch_field(gradTracerEdgeField, .true.) + call mpas_deallocate_scratch_field(gradTracerTopOfEdgeField, .true.) + call mpas_deallocate_scratch_field(gradHTracerSlopedTopOfCellField, .true.) + call mpas_deallocate_scratch_field(dTracerdZTopOfCellField, .true.) + call mpas_deallocate_scratch_field(dTracerdZTopOfEdgeField, .true.) + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_hmix_redi_tend!}}} + +!*********************************************************************** +! +! routine ocn_tracer_hmix_redi_init +! +!> \brief Initializes ocean tracer horizontal mixing quantities +!> \author Doug Jacobsen, Mark Petersen, Todd Ringler +!> \date September 2011 +!> \details +!> This routine initializes a variety of quantities related to +!> Laplacian horizontal velocity mixing in the ocean. +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_hmix_redi_init(err)!{{{ + + !-------------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! call individual init routines for each parameterization + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + logical, pointer :: config_use_standardGM + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_use_standardGM', config_use_standardGM) + + rediOn = .false. + + if ( config_use_standardGM ) then + rediOn = .true. + endif + + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_hmix_redi_init!}}} + +!*********************************************************************** + +end module ocn_tracer_hmix_redi + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker From 6a2fddded794ec3ffa6591ccc4e6a7daff03db47 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Wed, 19 Aug 2015 07:43:48 -0600 Subject: [PATCH 0147/1724] Changing the default git method to ssh for cvmix This commit changes the default method of acquiring cvmix via git to be ssh instead of http. Some clusters have issues with http access to github due to firewall issues, and using ssh is slightly more reliable in these cases. --- src/core_ocean/get_cvmix.sh | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core_ocean/get_cvmix.sh b/src/core_ocean/get_cvmix.sh index 736a43623c..f2807c738c 100755 --- a/src/core_ocean/get_cvmix.sh +++ b/src/core_ocean/get_cvmix.sh @@ -41,16 +41,16 @@ if [ ! -d cvmix ]; then if [ "${GIT}" != "" ]; then echo " ** Using git to acquire cvmix source. ** " - PROTOCOL="git https" - git clone ${CVMIX_GIT_HTTP_ADDRESS} .cvmix_all &> /dev/null + PROTOCOL="git ssh" + git clone ${CVMIX_GIT_SSH_ADDRESS} .cvmix_all &> /dev/null if [ -d .cvmix_all ]; then cd .cvmix_all git checkout ${CVMIX_TAG} &> /dev/null cd ../ ln -sf .cvmix_all/${CVMIX_SUBDIR} cvmix else - git clone ${CVMIX_GIT_SSH_ADDRESS} .cvmix_all &> /dev/null - PROTOCOL="git ssh" + git clone ${CVMIX_GIT_HTTP_ADDRESS} .cvmix_all &> /dev/null + PROTOCOL="git http" if [ -d .cvmix_all ]; then cd .cvmix_all git checkout ${CVMIX_TAG} &> /dev/null From 7c53078ba487c831c6b39320807b03bb0c10d0a4 Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Wed, 19 Aug 2015 13:37:32 -0600 Subject: [PATCH 0148/1724] Fixed timer "bug" (my misunderstanding of when timers trigger). --- .../mpas_ocn_time_series_stats.F | 131 ++++++------------ 1 file changed, 43 insertions(+), 88 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index 0f00c6cd76..b98b4d3321 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -49,7 +49,6 @@ module ocn_time_series_stats type time_buffer_type ! internal state logical :: started_flag, accumulate_flag, reset_flag - logical :: delay_reset_flag, duration_over_flag integer :: total_accum type (MPAS_Time_type) :: start_time @@ -352,6 +351,7 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ end do ! number_of_variables ! configure alarms + ! TODO modify the alarms based on do_restart do b = 1, number_of_buffers write(buffer_str, '(I0)') b buffers(b) % start_alarm_ID = & @@ -376,13 +376,14 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ buffers(b) % duration_interval, & buffers(b) % repeat_interval, ierr=err) + ! reset at start buffers(b) % reset_alarm_ID = & 'tavg_reset' // trim(stream_str) // '_' // buffer_str call mpas_add_clock_alarm(domain % clock, & buffers(b) % reset_alarm_ID, & - buffers(b) % start_time + & - buffers(b) % reset_interval, & + buffers(b) % start_time, & buffers(b) % reset_interval, ierr=err) + end do ! set initial flags @@ -390,10 +391,10 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ buffers(b) % started_flag = .false. buffers(b) % reset_flag = .false. buffers(b) % accumulate_flag = .false. - buffers(b) % delay_reset_flag = .false. - buffers(b) % duration_over_flag = .false. end do + ! set flags based on initial times + call timer_checking(domain, err) end subroutine ocn_init_time_series_stats!}}} @@ -429,13 +430,9 @@ subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ !----------------------------------------------------------------- err = 0 - ! do all of the time checking and flag setting - call timer_checking(domain, err) - - ! update number of accumulations, once only + ! update the counter do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then buffers(b) % total_accum = 1 else if (buffers(b) % accumulate_flag) then buffers(b) % total_accum = buffers(b) % total_accum + 1 @@ -447,20 +444,13 @@ subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ call typed_operate(domain % blocklist, variables(v), operation) end do - ! clear resets and accumulation + ! clear any resets do b = 1, size(buffers) - if (buffers(b) % delay_reset_flag) then - buffers(b) % delay_reset_flag = .false. - else - buffers(b) % reset_flag = .false. - end if - - if (buffers(b) % duration_over_flag) then - buffers(b) % duration_over_flag = .false. - buffers(b) % accumulate_flag = .false. - end if + buffers(b) % reset_flag = .false. end do + ! do all of the time checking and flag setting + call timer_checking(domain, err) end subroutine ocn_compute_time_series_stats!}}} @@ -788,9 +778,6 @@ subroutine timer_checking(domain, err)!{{{ buffers(b) % start_alarm_ID, ierr=err) buffers(b) % started_flag = .true. buffers(b) % accumulate_flag = .true. - - ! TODO only reset if not restart - buffers(b) % reset_flag = .true. end if ! if we aren't started, continue to next buffer @@ -805,7 +792,6 @@ subroutine timer_checking(domain, err)!{{{ call mpas_reset_clock_alarm(domain % clock, & buffers(b) % reset_alarm_ID, ierr=err) buffers(b) % reset_flag = .true. - buffers(b) % delay_reset_flag = .true. end if ! turn off accumulation @@ -816,7 +802,7 @@ subroutine timer_checking(domain, err)!{{{ buffers(b) % duration_alarm_ID, ierr=err)) then call mpas_reset_clock_alarm(domain % clock, & buffers(b) % duration_alarm_ID, ierr=err) - buffers(b) % duration_over_flag = .true. + buffers(b) % accumulate_flag = .false. end if ! turn on accumulation @@ -827,7 +813,6 @@ subroutine timer_checking(domain, err)!{{{ call mpas_reset_clock_alarm(domain % clock, & buffers(b) % repeat_alarm_ID, ierr=err) buffers(b) % accumulate_flag = .true. - buffers(b) % duration_over_flag = .false. end if end do @@ -1217,8 +1202,7 @@ subroutine operate0r_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1253,8 +1237,7 @@ subroutine operate1r_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1289,8 +1272,7 @@ subroutine operate2r_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1325,8 +1307,7 @@ subroutine operate3r_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1361,8 +1342,7 @@ subroutine operate4r_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1397,8 +1377,7 @@ subroutine operate5r_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1433,8 +1412,7 @@ subroutine operate0i_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1469,8 +1447,7 @@ subroutine operate1i_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1505,8 +1482,7 @@ subroutine operate2i_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1541,8 +1517,7 @@ subroutine operate3i_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1577,8 +1552,7 @@ subroutine operate0r_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1613,8 +1587,7 @@ subroutine operate1r_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1649,8 +1622,7 @@ subroutine operate2r_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1685,8 +1657,7 @@ subroutine operate3r_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1721,8 +1692,7 @@ subroutine operate4r_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1757,8 +1727,7 @@ subroutine operate5r_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1793,8 +1762,7 @@ subroutine operate0i_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1829,8 +1797,7 @@ subroutine operate1i_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1865,8 +1832,7 @@ subroutine operate2i_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1901,8 +1867,7 @@ subroutine operate3i_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1937,8 +1902,7 @@ subroutine operate0r_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -1973,8 +1937,7 @@ subroutine operate1r_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -2009,8 +1972,7 @@ subroutine operate2r_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -2045,8 +2007,7 @@ subroutine operate3r_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -2081,8 +2042,7 @@ subroutine operate4r_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -2117,8 +2077,7 @@ subroutine operate5r_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -2153,8 +2112,7 @@ subroutine operate0i_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -2189,8 +2147,7 @@ subroutine operate1i_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -2225,8 +2182,7 @@ subroutine operate2i_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array @@ -2261,8 +2217,7 @@ subroutine operate3i_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) - if (buffers(b) % reset_flag .and. & - (.not. buffers(b) % delay_reset_flag)) then + if (buffers(b) % reset_flag) then call mpas_pool_get_array(block % allFields, & tvar % output_names(b), out_array, 1) out_array = in_array From b7b5d4fb4653e641b0365dd4925c2e5d0acd2444 Mon Sep 17 00:00:00 2001 From: Luke Van Roekel Date: Wed, 19 Aug 2015 14:57:57 -0600 Subject: [PATCH 0149/1724] added v0 of mixed layer depth analysis member --- src/core_ocean/Registry.xml | 1 - src/core_ocean/analysis_members/Makefile | 3 +- .../Registry_analysis_members.xml | 1 + .../Registry_mixed_layer_depths.xml | 103 +++ .../mpas_ocn_analysis_driver.F | 10 + .../mpas_ocn_mixed_layer_depths.F | 595 ++++++++++++++++++ 6 files changed, 711 insertions(+), 2 deletions(-) create mode 100644 src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml create mode 100644 src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index bd7ccb3390..e00d147550 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -984,7 +984,6 @@ - diff --git a/src/core_ocean/analysis_members/Makefile b/src/core_ocean/analysis_members/Makefile index 6ad1a1281a..2392ee20dc 100644 --- a/src/core_ocean/analysis_members/Makefile +++ b/src/core_ocean/analysis_members/Makefile @@ -11,7 +11,8 @@ MEMBERS = mpas_ocn_global_stats.o \ mpas_ocn_test_compute_interval.o \ mpas_ocn_high_frequency_output.o \ mpas_ocn_zonal_mean.o \ - mpas_ocn_time_filters.o + mpas_ocn_time_filters.o \ + mpas_ocn_mixed_layer_depths.o all: $(OBJS) diff --git a/src/core_ocean/analysis_members/Registry_analysis_members.xml b/src/core_ocean/analysis_members/Registry_analysis_members.xml index 8bf29c81cf..fd8072c91c 100644 --- a/src/core_ocean/analysis_members/Registry_analysis_members.xml +++ b/src/core_ocean/analysis_members/Registry_analysis_members.xml @@ -8,3 +8,4 @@ #include "Registry_test_compute_interval.xml" #include "Registry_high_frequency_output.xml" #include "Registry_time_filters.xml" +#include "Registry_mixed_layer_depths.xml" diff --git a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml new file mode 100644 index 0000000000..a6f467a447 --- /dev/null +++ b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml @@ -0,0 +1,103 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F index 2b44615984..47904386e4 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -36,6 +36,7 @@ module ocn_analysis_driver use ocn_test_compute_interval use ocn_high_frequency_output use ocn_time_filters + use ocn_mixed_layer_depths ! use ocn_TEM_PLATE implicit none @@ -147,6 +148,7 @@ subroutine ocn_analysis_setup_packages(configPool, packagePool, err)!{{{ call mpas_pool_add_config(analysisMemberList, 'zonalMean', 1) call mpas_pool_add_config(analysisMemberList, 'highFrequencyOutput', 1) call mpas_pool_add_config(analysisMemberList, 'timeFilters', 1) + call mpas_pool_add_config(analysisMemberList, 'mixedLayerDepths', 1) ! call mpas_pool_add_config(analysisMemberList, 'temPlate', 1) ! DON'T EDIT BELOW HERE @@ -744,6 +746,8 @@ subroutine ocn_init_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_init_high_frequency_output(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'timeFilters' ) then call ocn_init_time_filters(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'mixedLayerDepths' ) then + call ocn_init_mixed_layer_depths(domain, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_init_TEM_PLATE(domain, err_tmp) end if @@ -795,6 +799,8 @@ subroutine ocn_compute_analysis_members(domain, timeLevel, analysisMemberName, i call ocn_compute_high_frequency_output(domain, timeLevel, err_tmp) else if ( analysisMemberName(1:nameLength) == 'timeFilters' ) then call ocn_compute_time_filters(domain, timeLevel, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'mixedLayerDepths' ) then + call ocn_compute_mixed_layer_depths(domain, timeLevel, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_compute_TEM_PLATE(domain, timeLevel, err_tmp) end if @@ -845,6 +851,8 @@ subroutine ocn_restart_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_restart_high_frequency_output(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'timeFilters' ) then call ocn_restart_time_filters(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'mixedLayerDepths' ) then + call ocn_restart_mixed_layer_depths(domain, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_restart_TEM_PLATE(domain, err_tmp) end if @@ -895,6 +903,8 @@ subroutine ocn_finalize_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_finalize_high_frequency_output(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'timeFilters' ) then call ocn_finalize_time_filters(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'mixedLayerDepths' ) then + call ocn_finalize_mixed_layer_depths(domain, err_tmp) ! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then ! call ocn_finalize_TEM_PLATE(domain, err_tmp) end if diff --git a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F new file mode 100644 index 0000000000..ec71ad6dc2 --- /dev/null +++ b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F @@ -0,0 +1,595 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_mixed_layer_depths +! +!> \brief MPAS ocean analysis mode member: mixed_layer_depths +!> \author Luke Van Roekel +!> \date August 2015 +!> \details +!> MPAS ocean analysis mode member: mixed_layer_depths +!> +! Computes mixed layer depths via a gradient method and threshold method +! may add more methods from Holte and Talley (2009) at a future time +!----------------------------------------------------------------------- + +module ocn_mixed_layer_depths + + use mpas_derived_types + use mpas_pool_routines + use mpas_dmpar + use mpas_timekeeping + use mpas_stream_manager + + use ocn_constants + use ocn_diagnostics_routines + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_mixed_layer_depths, & + ocn_compute_mixed_layer_depths, & + ocn_restart_mixed_layer_depths, & + ocn_finalize_mixed_layer_depths + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_mixed_layer_depths +! +!> \brief Initialize MPAS-Ocean analysis member +!> \author Luke Van Roekel +!> \date August 2015 +!> \details +!> This routine conducts all initializations required for the +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_mixed_layer_depths(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_init_mixed_layer_depths!}}} + +!*********************************************************************** +! +! routine ocn_compute_mixed_layer_depths +! +!> \brief Compute MPAS-Ocean analysis member +!> \author Luke Van Roekel +!> \date August 2015 +!> \details +!> This routine conducts all computation required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + integer, intent(in) :: timeLevel + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: mixedLayerDepthsAMPool + type (dm_info) :: dminfo + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: scratchPool + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: mixedLayerDepthsAM + + ! Here are some example variables which may be needed for your analysis member + integer, pointer :: nVertLevels, nCellsSolve, num_tracers + integer, pointer :: nThresholdBins, nGradientBins + integer :: k, iCell, i, refIndex, refLevel(1) + integer, pointer :: index_temperature + integer, dimension(:), pointer :: maxLevelCell + + + logical :: found_temp_mld, found_den_mld + logical,pointer :: thresholdFlag, gradientFlag +! real (kind=RKIND), dimension(:), pointer :: areaCell + real (kind=RKIND), dimension(:,:,:), pointer :: thresholdMLD, gradientMLD + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:), pointer :: zTop, zMid, pressure + real (kind=RKIND), dimension(:,:), pointer :: potentialDensity + real (kind=RKIND), pointer :: tempThreshMin, tempThreshMax + real (kind=RKIND), pointer :: tempGradMin, tempGradMax + real (kind=RKIND), pointer :: denThreshMin, denThreshMax + real (kind=RKIND), pointer :: denGradMin, denGradMax + character (len=StrKIND), pointer :: interp_type + real (kind=RKIND), pointer :: refPress + real (kind=RKIND), allocatable, dimension(:,:) :: gradientBins, thresholdBins + real (kind=RKIND), allocatable, dimension(:,:) :: densityGradient, temperatureGradient + real (kind=RKIND) :: dTempThres, dDenThres, dTempGrad, dDenGrad + real (kind=RKIND) :: dz,temp_ref_lev, den_ref_lev, dV, dVm1, dVp1 + err = 0 + + dminfo = domain % dminfo + + call mpas_pool_get_subpool(domain % blocklist % structs, 'mixedLayerDepthsAM', mixedLayerDepthsAMPool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + + call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nThresholdBins', nThresholdBins) + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nGradientBins', nGradientBins) + + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_threshold_method', thresholdFlag) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_gradient_method', gradientFlag) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_crit_temp_minthreshold', tempThreshMin) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_crit_temp_maxthreshold', tempThreshMax) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_crit_dens_minthreshold', denThreshMin) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_crit_dens_maxthreshold', denThreshMax) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_temp_gradient_minthreshold', tempGradMin) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_temp_gradient_maxthreshold', tempGradMax) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_den_gradient_minthreshold', denGradMin) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_den_gradient_maxthreshold', denGradMax) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_interp_method', interp_type) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_reference_pressure', refPress) + + block => domain % blocklist + do while (associated(block)) + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'mixedLayerDepthsAM', mixedLayerDepthsAMPool) + + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(statePool, 'tracers', tracers) + call mpas_pool_get_array(diagnosticsPool, 'potentialDensity', & + potentialDensity) + call mpas_pool_get_array(diagnosticsPool, 'pressure', pressure) + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + call mpas_pool_get_array(diagnosticsPool, 'zTop', zTop) + + if(thresholdFlag) then + call mpas_pool_get_array(mixedLayerDepthsAMPool, 'thresholdMLD',thresholdMLD) + + dTempThres = (tempThreshMax - tempThreshMin) / float(nThresholdBins) + dDenThres = (denThreshMax - denThreshMin) / float(nThresholdBins) + + allocate(thresholdBins(2,nThresholdBins)) + + do i=1,nThresholdBins + thresholdBins(1,i) = tempThreshMin + dTempThres*(i-1) + thresholdBins(2,i) = denThreshMin + dDenThres*(i-1) + enddo + + do iCell = 1,nCellsSolve + do k=1, maxLevelCell(iCell) + if(pressure(k+1,iCell) > refPress) then + call interp_bw_levels(tracers(index_temperature,k,iCell),tracers(index_temperature,k+1,iCell), & + pressure(k,iCell),pressure(k+1,iCell),refPress,trim(interp_type), & + pressure(k-1,iCell),tracers(index_temperature,k-1,iCell),temp_ref_lev) + + call interp_bw_levels(potentialDensity(k,iCell),potentialDensity(k+1,iCell), & + pressure(k,iCell),pressure(k+1,iCell),refPress,trim(interp_type), & + pressure(k-1,iCell),potentialDensity(k-1,iCell),den_ref_lev) + + refIndex = k+1 + exit + endif + enddo + + + do i=1,nThresholdBins + do k=refIndex,maxLevelCell(iCell) + if( abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) .ge. thresholdBins(1,i)) then + dVp1 = abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) + dV = abs(tracers(index_temperature,k ,iCell) - temp_ref_lev) + dVm1 = abs(tracers(index_temperature,k-1,iCell) - temp_ref_lev) + call interp_bw_levels(zMid(k,iCell),zMid(k+1,iCell), dV, dVp1, thresholdBins(1,i), & + trim(interp_type), dVm1, zMid(k-1,iCell), thresholdMLD(1,i,iCell)) + found_temp_mld = .true. + endif + + if( abs(potentialDensity(k+1,iCell) - den_ref_lev) .ge. thresholdBins(2,i)) then + dVp1 = abs(potentialDensity(k+1,iCell) - den_ref_lev) + dV = abs(potentialDensity(k ,iCell) - den_ref_lev) + dVm1 = abs(potentialDensity(k-1,iCell) - den_ref_lev) + call interp_bw_levels(zMid(k,iCell),zMid(k+1,iCell), dV, dVp1, thresholdBins(2,i), & + trim(interp_type), dVm1, zMid(k-1,iCell), thresholdMLD(2,i,iCell)) + found_den_mld = .true. + endif + + if(found_den_mld .and. found_temp_mld) exit + enddo + +! if no MLD found, set to bottom value of zMid + if(.not. found_den_mld) thresholdMLD(2,i,iCell) = zMid(maxLevelCell(iCell),iCell) + if(.not. found_temp_mld) thresholdMLD(1,i,iCell) = zMid(maxLevelCell(iCell),iCell) + enddo !i=1,nThresholdBins + enddo !iCell + endif !if thresholdflag + +! Compute the mixed layer depth based on a gradient threshold in temperature and density + + if(gradientFlag) then + found_temp_mld=.false. + found_den_mld=.false. + call mpas_pool_get_array(mixedLayerDepthsAMPool, 'gradientMLD', gradientMLD) + dTempGrad = (tempGradMax - tempGradMin) / float(nGradientBins) + dDenGrad = (denGradMax - denGradMin) / float(nGradientBins) + allocate(gradientBins(2,nGradientBins)) + allocate(densityGradient(2,nVertLevels),temperatureGradient(2,nVertLevels)) + + do i=1,nGradientBins + gradientBins(1,i) = tempGradMin + dTempGrad*(i-1) + gradientBins(2,i) = denGradMin + dDenGrad*(i-1) + enddo + + densityGradient(2,:)=0.0_RKIND + temperatureGradient(2,:) = 0.0_RKIND + + densityGradient(2,1) = 1 + temperatureGradient(2,1) = 1 + + do iCell = 1,nCellsSolve + do k=2,maxLevelCell(iCell) + dz=abs(zMid(k-1,iCell)-zMid(k,iCell)) + densityGradient(k,1) = (potentialDensity(k-1,iCell)-potentialDensity(k,iCell)) / dz + temperatureGradient(k,1) = (tracers(index_temperature,k-1,iCell) - tracers(index_temperature,k,iCell)) / dz + densityGradient(k,2) = k + temperatureGradient(k,2) = k + enddo + +! smooth the gradients to eliminate reduce single point maxima + + do k=2,maxLevelCell(iCell)-1 + densityGradient(k,1) = (densityGradient(k-1,1) + densityGradient(k,1) + densityGradient(k+1,1)) / float(3) + temperatureGradient(k,1) = (temperatureGradient(k-1,1) + temperatureGradient(k,1) + temperatureGradient(k+1,1)) / float(3) + enddo + + do i=1, nGradientBins + + do k=2, maxLevelCell(iCell) + if(densityGradient(1,k+1) .ge. gradientBins(2,i)) then + call interp_bw_levels(zTop(k,iCell),zTop(k+1,iCell),densityGradient(k,1),densityGradient(k+1,1), & + gradientBins(2,i), trim(interp_type),densityGradient(k-1,1),zTop(k-1,iCell), gradientMLD(2,i,iCell)) + found_den_mld=.true. + endif + if(temperatureGradient(k+1,1) .ge. gradientBins(2,i)) then + call interp_bw_levels(zTop(k,iCell),zTop(k+1,iCell),temperatureGradient(k,1),temperatureGradient(k+1,1), & + gradientBins(1,i), trim(interp_type),temperatureGradient(k-1,1),zTop(k-1,iCell), gradientMLD(1,i,iCell)) + found_temp_mld=.true. + endif + + if(found_temp_mld .and. found_den_mld) exit + enddo !maxLevelCell + + if(.not. found_temp_mld) then + refLevel=maxloc(temperatureGradient(:,1)) + gradientMLD(1,i,iCell) = zTop(refLevel(1),iCell) + endif + + if(.not. found_den_mld) then + refLevel=maxloc(densityGradient(:,2)) + gradientMLD(2,i,iCell) = zTop(refLevel(1),iCell) + endif + enddo ! nGradientBins + + enddo !icell + + endif !if(gradientflag) + + + block => block % next + end do + + + ! Even though some variables do not include an index that is decomposed amongst + ! domain partitions, we assign them within a block loop so that all blocks have the + ! correct values for writing output. +! block => domain % blocklist +! do while (associated(block)) +! call mpas_pool_get_subpool(block % structs, 'temPlateAM', temPlateAMPool) +! +! ! assignment of final temPlateAM variables could occur here. +! +! block => block % next +! end do + + end subroutine ocn_compute_mixed_layer_depths!}}} + +!*********************************************************************** +! +! routine interp_bw_levels +! +!> \brief Interpolates between model layers +!> \author Luke Van Roekel +!> \date September 2015 +!> \details +!> This routine conducts computations to compute various field values +!> between model levels (in pressure or depth) or could interpolate +!> between temperature/salinity/density values. Interpolations are +!> of the form +!> y = coeffs(1)*x^3 + coeffs(2)*x^2 + coeffs(3)*x + coeffs(4) +! +!----------------------------------------------------------------------- + + subroutine interp_bw_levels(y0,y1,x0,x1,xT,interp_type,xm1,ym1,yT)!{{{ + + character(len=StrKIND),intent(in) :: interp_type ! linear, quadratic, or spline + real(kind=RKIND),intent(in) :: y0,y1,x0,x1,xT + real(kind=RKIND),intent(inout) :: yT + real(kind=RKIND),optional,intent(in) :: xm1,ym1 + ! these values are to match the slope at a given point + +!------------------------------------------------------------------------ +! +! Local variables for the interpolations +! +!------------------------------------------------------------------------ + + real(kind=RKIND) :: coeffs(4) ! stores the coefficients for the interp + real(kind=RKIND) :: Minv(4,4) ! holds values for computing quad and spline + real(kind=RKIND) :: det + real(kind=RKIND) :: rhs(4) + integer :: k,k2 + + coeffs(:) = 0.0_RKIND + Minv(:,:) = 0.0_RKIND + rhs(:) = 0.0_RKIND + + select case (trim(interp_type)) + + case ("linear") + + coeffs(2) = (y1-y0)/(x1-x0) + coeffs(1) = y0 - coeffs(2)*x0 + + case ("quadratic") + + det = -(x1-x0)**2 + rhs(1) = y0 + rhs(2) = y1 + + if(present(xm1) .and. present(ym1)) then + rhs(3) = (y0-ym1)/(x0-xm1) + else + rhs(3) = 0.0_RKIND + endif + + Minv(1,1) = -1.0_RKIND/det + Minv(1,2) = 1.0_RKIND/det + Minv(1,3) = -1.0_RKIND/(x1-x0) + Minv(2,1) = 2.0_RKIND*x0/det + Minv(2,2) = -2.0_RKIND*x0/det + Minv(2,3) = (x1+x0)/(x1-x0) + Minv(3,1) = -(x0**2)/det + Minv(3,2) = x1*(2.0_RKIND*x0-x1)/det + Minv(3,3) = -x1*x0/(x1-x0) + + do k=1,3 + do k2=1,3 + coeffs(k2) = coeffs(k2) + Minv(4-k2,k)*rhs(k) + enddo + enddo + + case ("spline") + det = -(x1-x0)**3 + rhs(1) = y1 + rhs(2) = y0 + if(present(xm1) .and. present(ym1)) then + rhs(3) = (y0-ym1)/(x0-xm1) + else + rhs(3) = 0.0_RKIND + endif + + rhs(4) = (y1-y0)/(x1-x0) + + Minv(1,1) = 2.0_RKIND/det + Minv(1,2) = -2.0_RKIND/det + Minv(1,3) = (x0-x1)/det + Minv(1,4) = (x0-x1)/det + Minv(2,1) = -3.0_RKIND * (x1+x0)/det + Minv(2,2) = 3.0_RKIND*(x1+x0)/det + Minv(2,3) = (x1-x0)*(2.0_RKIND*x1+x0)/det + Minv(2,4) = (x1-x0)*(2.0_RKIND*x0+x1)/det + Minv(3,1) = 6.0_RKIND*x1*x0/det + Minv(3,2) = -6.0_RKIND*x1*x0/det + Minv(3,3) = -x1*(x1-x0)*(2.0_RKIND*x0+x1)/det + Minv(3,4) = -x0*(x1-x0)*(2.0_RKIND*x1+x0)/det + Minv(4,1) = -(x0**2)*(3.0_RKIND*x1-x0)/det + Minv(4,2) = -(x1**2)*(-3.0_RKIND*x0+x1)/det + Minv(4,3) = x0*(x1**2)*(x1-x0)/det + Minv(4,4) = x1*(x0**2)*(x1-x0)/det + + do k=1,4 + do k2=1,4 + coeffs(k2) = coeffs(k2) + Minv(5-k2,k)*rhs(k) + enddo + enddo + + end select + + yT = coeffs(1)*xT**3 + coeffs(2)*xT**2 + coeffs(3)*xT + coeffs(4) + end subroutine interp_bw_levels!}}} + +!*********************************************************************** +! +! routine ocn_restart_mixed_layer_depths +! +!> \brief Save restart for MPAS-Ocean analysis member +!> \author Luke Van Roekel +!> \date September 2015 +!> \details +!> This routine conducts computation required to save a restart state +!> for the MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_restart_mixed_layer_depths(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_restart_mixed_layer_depths!}}} + +!*********************************************************************** +! +! routine ocn_finalize_mixed_layer_depths +! +!> \brief Finalize MPAS-Ocean analysis member +!> \author Luke Van Roekel +!> \date August 2015 +!> \details +!> This routine conducts all finalizations required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_finalize_mixed_layer_depths(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine ocn_finalize_mixed_layer_depths!}}} + +end module ocn_mixed_layer_depths + +! vim: foldmethod=marker From 07f6cc18346acf8aaad95acf0f8a9964af40afb2 Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Wed, 19 Aug 2015 16:20:57 -0600 Subject: [PATCH 0150/1724] Refactored the code into subroutines in prep to removing module vars. --- .../mpas_ocn_time_series_stats.F | 779 ++++++++++-------- 1 file changed, 431 insertions(+), 348 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index b98b4d3321..ca58e96b24 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -11,7 +11,7 @@ ! !> \brief MPAS ocean analysis core member: time_series_stats !> \author Jon Woodring -!> \date March 2, 2015 +!> \date September 1, 2015 !> \details !> Flexible time series averaging, mins, and maxes of fields. !----------------------------------------------------------------------- @@ -105,36 +105,28 @@ module ocn_time_series_stats ! !> \brief Initialize MPAS-Ocean analysis member !> \author Jon Woodring -!> \date March 2, 2015 +!> \date September 1, 2015 !> \details !> This routine conducts all initializations required for the !> MPAS-Ocean analysis member. !----------------------------------------------------------------------- subroutine ocn_init_time_series_stats(domain, err)!{{{ - ! input variables - !----------------------------------------------------------------- ! input/output variables - !----------------------------------------------------------------- type (domain_type), intent(inout) :: domain ! output variables - !----------------------------------------------------------------- integer, intent(out) :: err !< Output: error flag ! local variables - !----------------------------------------------------------------- - integer :: v, b - character (len=StrKIND), pointer :: config_results - logical, pointer :: copy_mesh + integer :: b integer :: number_of_variables, number_of_buffers - character (len=StrKIND) :: stream_str, prefix_str, & - config_str, buffer_str, op_str, var_str, field - logical :: ok - + character (len=StrKIND) :: instance ! TODO intent(in) + character (len=StrKIND) :: prefix, op + character (len=StrKIND), pointer :: stream_name + ! start procedure - !----------------------------------------------------------------- err = 0 ! TODO do restart @@ -142,57 +134,277 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ ! string representation ! TODO placeholder for some unique ID if this code is replicated ! per multiple AMs for multiple streams - stream_str = '' - prefix_str = 'config_AM_timeSeriesStats' // trim(stream_str) + instance = '' + prefix = 'config_AM_timeSeriesStats' // trim(instance) + + ! get the basic configuration of this stream + call start_init(domain, prefix, number_of_variables, number_of_buffers, & + stream_name, op, err) + + ! modify the stream to remove existing vars and add accumulated versions + call modify_stream(domain, stream_name, number_of_variables, & + number_of_buffers, instance, prefix, op, err) + + ! get all of the timing and configuration + call get_alarms(domain, prefix, number_of_buffers, err) + + ! set all of the alarms based on timers + call set_alarms(domain, instance, number_of_buffers, err) + + ! set initial flags + do b = 1, number_of_buffers + buffers(b) % started_flag = .false. + buffers(b) % reset_flag = .false. + buffers(b) % accumulate_flag = .false. + end do + + ! set flags based on initial timers and times + ! TODO maybe needs to be modified based on restart + call timer_checking(domain, err) +end subroutine ocn_init_time_series_stats!}}} + + + +!*********************************************************************** +! routine ocn_compute_time_series_stats +! +!> \brief Compute MPAS-Ocean analysis member +!> \author Jon Woodring +!> \date September 1, 2015 +!> \details +!> This routine conducts all computation required for this +!> MPAS-Ocean analysis member. +!----------------------------------------------------------------------- +subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ + ! input variables + integer, intent(in) :: timeLevel + + ! input/output variables + type (domain_type), intent(inout) :: domain + + ! output variables + integer, intent(out) :: err !< Output: error flag + + ! local variables + integer :: i, v, b + + ! start procedure + err = 0 + + ! update the counter + do b = 1, size(buffers) + if (buffers(b) % reset_flag) then + buffers(b) % total_accum = 1 + else if (buffers(b) % accumulate_flag) then + buffers(b) % total_accum = buffers(b) % total_accum + 1 + end if + end do + + ! do all of the operations + do v = 1, size(variables) + call typed_operate(domain % blocklist, variables(v), operation) + end do + + ! clear any resets + do b = 1, size(buffers) + buffers(b) % reset_flag = .false. + end do + + ! do all of the time checking and flag setting + call timer_checking(domain, err) +end subroutine ocn_compute_time_series_stats!}}} + + + +!*********************************************************************** +! routine ocn_restart_time_series_stats +! +!> \brief Save restart for MPAS-Ocean analysis member +!> \author Jon Woodring +!> \date September 1, 2015 +!> \details +!> This routine conducts computation required to save a restart state +!> for the MPAS-Ocean analysis member. +!----------------------------------------------------------------------- +subroutine ocn_restart_time_series_stats(domain, err)!{{{ + ! input variables + + ! input/output variables + type (domain_type), intent(inout) :: domain + + ! output variables + integer, intent(out) :: err !< Output: error flag + + ! local variables + + ! start procedure + err = 0 + + ! TODO is there anything needed here? +end subroutine ocn_restart_time_series_stats!}}} + + + +!*********************************************************************** +! routine ocn_finalize_time_series_stats +! +!> \brief Finalize MPAS-Ocean analysis member +!> \author Jon Woodring +!> \date September 1, 2015 +!> \details +!> This routine conducts all finalizations required for this +!> MPAS-Ocean analysis member. +!----------------------------------------------------------------------- +subroutine ocn_finalize_time_series_stats(domain, err)!{{{ + ! input variables + + ! input/output variables + type (domain_type), intent(inout) :: domain + + ! output variables + integer, intent(out) :: err !< Output: error flag + + ! local variables + integer :: i, v + + ! start procedure + err = 0 + + ! clean up memory + if (allocated(buffers)) then + deallocate(buffers) + end if + if (allocated(variables)) then + do v = 1, size(variables) + if (allocated(variables(v) % output_names)) & + then + deallocate(variables(v) % output_names) + end if + end do + deallocate(variables) + end if + +end subroutine ocn_finalize_time_series_stats!}}} + +! +! local subroutines +! + +!*********************************************************************** +! routine start_init +! +!> \brief Begin the initialization of this analysis member +!> \author Jon Woodring +!> \date September 1, 2015 +!> \details +!> This will count the number of variables, number of buffers, and +!> also get the stream name and operation strings. +!----------------------------------------------------------------------- +subroutine start_init(domain, prefix, number_of_variables, & + number_of_buffers, stream_name, op, err) + ! input variables + character (len=StrKIND), intent(in) :: prefix + + ! input/output variables + type (domain_type), intent(inout) :: domain + + ! output variables + character (len=StrKIND), pointer, intent(out) :: stream_name + character (len=StrKIND), intent(out) :: op + integer, intent(out) :: number_of_variables, number_of_buffers + integer, intent(out) :: err !< Output: error flag + + ! local variables + character (len=StrKIND), pointer :: config_results + character (len=StrKIND) :: copy, config + integer :: b + + ! start procedure + err = 0 + + ! get the stream name + config = trim(prefix) // '_stream_name' + call mpas_pool_get_config(domain % configs, config, stream_name) + + if (stream_name == 'none') then + call mpas_dmpar_global_abort('Error: stream cannot be "none" ' // & + 'for time series stats.') + end if + + ! count the number of variables + call mpas_stream_mgr_begin_iteration(domain % streamManager, & + stream_name, err) + number_of_variables = 0 + do while (mpas_stream_mgr_get_next_field(domain % streamManager, & + stream_name, copy)) + number_of_variables = number_of_variables + 1 + end do + + ! count the number of buffers + config = trim(prefix) // '_initial_times' + call mpas_pool_get_config(domain % configs, config, config_results) + copy = config_results + number_of_buffers = 1 + b = scan(copy, ';') + do while (b > 0) + number_of_buffers = number_of_buffers + 1 + copy = copy(b+1:) + b = scan(copy, ';') + end do ! get our operation - config_str = trim(prefix_str) // '_operation' - call mpas_pool_get_config(domain % configs, config_str, config_results) - if (config_results .eq. 'avg') then + config = trim(prefix) // '_operation' + call mpas_pool_get_config(domain % configs, config, config_results) + if (config_results == 'avg') then operation = AVG_OP - op_str = 'avg' - else if (config_results .eq. 'min') then + op = 'avg' + else if (config_results == 'min') then operation = MIN_OP - op_str = 'min' - else if (config_results .eq. 'max') then + op = 'min' + else if (config_results == 'max') then operation = MAX_OP - op_str = 'max' + op = 'max' else ! error if unknown operation call mpas_dmpar_global_abort('Error: unknown operation in time ' // & 'averaging analysis member configuration.') end if - ! count string tokens - config_str = trim(prefix_str) // '_initial_times' - call mpas_pool_get_config(domain % configs, config_str, config_results) - field = config_results - number_of_buffers = 1 - b = scan(field, ';') - do while (b .gt. 0) - number_of_buffers = number_of_buffers + 1 - field = field(b+1:) - b = scan(field, ';') - end do +end subroutine start_init - ! get the stream name - config_str = trim(prefix_str) // '_stream_name' - call mpas_pool_get_config(domain % configs, config_str, stream_name) - if (stream_name .eq. 'none') then - call mpas_dmpar_global_abort('Error: stream cannot be "none" ' // & - 'for time series stats.') - end if - ! set up all of the timing - ! +!*********************************************************************** +! routine get_alarms +! +!> \brief Read the namelist for timings +!> \author Jon Woodring +!> \date September 1, 2015 +!> \details +!> This will read the namelist and get the strings and set the clocks +!> for the different timers to be used. The actual alarms are not set. +!----------------------------------------------------------------------- +subroutine get_alarms(domain, prefix, number_of_buffers, err) + ! input variables + integer, intent(in) :: number_of_buffers + character (len=StrKIND) :: prefix - ! allocate the state for the buffers - allocate(buffers(number_of_buffers)) + ! input/output variables + type (domain_type), intent(inout) :: domain + + ! output variables + integer, intent(out) :: err !< Output: error flag + + ! local variables + integer :: b + character (len=StrKIND), pointer :: config_results + character (len=StrKIND) :: config + logical :: ok - ! configure start times - config_str = trim(prefix_str) // '_initial_times' - call mpas_pool_get_config(domain % configs, config_str, config_results) + ! configure start times - we don't have to check ok + ! because the timer count is based on initial_times tokens + config = trim(prefix) // '_initial_times' + call mpas_pool_get_config(domain % configs, config, config_results) call set_times(buffers, number_of_buffers, domain % clock, & START_TIMES, config_results, ok, err) @@ -201,8 +413,8 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ ! to other ones ! configure reset intervals - config_str = trim(prefix_str) // '_reset_intervals' - call mpas_pool_get_config(domain % configs, config_str, config_results) + config = trim(prefix) // '_reset_intervals' + call mpas_pool_get_config(domain % configs, config, config_results) call set_times(buffers, number_of_buffers, domain % clock, & RESET_INTERVALS, config_results, ok, err) if (.not. ok) then @@ -213,8 +425,8 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ end if ! configure repeat intervals - config_str = trim(prefix_str) // '_repeat_intervals' - call mpas_pool_get_config(domain % configs, config_str, config_results) + config = trim(prefix) // '_repeat_intervals' + call mpas_pool_get_config(domain % configs, config, config_results) call set_times(buffers, number_of_buffers, domain % clock, & REPEAT_INTERVALS, config_results, ok, err) if (.not. ok) then @@ -225,8 +437,8 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ end if ! configure duration intervals - config_str = trim(prefix_str) // '_duration_intervals' - call mpas_pool_get_config(domain % configs, config_str, config_results) + config = trim(prefix) // '_duration_intervals' + call mpas_pool_get_config(domain % configs, config, config_results) call set_times(buffers, number_of_buffers, domain % clock, & DURATION_INTERVALS, config_results, ok, err) if (.not. ok) then @@ -236,9 +448,9 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ 'configuration.') end if - ! check if the configuration is sensible + ! check if some of the time configuration is sensible do b = 1, number_of_buffers - if (buffers(b) % repeat_interval .gt. & + if (buffers(b) % repeat_interval > & buffers(b) % reset_interval) then write(stderrUnit,*) 'Warning: repeat_interval > ' // & 'reset_interval in time averaging analysis member ' // & @@ -246,7 +458,7 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ buffers(b) % repeat_interval = buffers(b) % reset_interval end if - if (buffers(b) % duration_interval .gt. & + if (buffers(b) % duration_interval > & buffers(b) % repeat_interval) then write(stderrUnit,*) 'Warning: duration_interval > ' // & 'repeat_interval in time averaging analysis member ' // & @@ -254,24 +466,108 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ buffers(b) % repeat_interval = buffers(b) % reset_interval end if end do +end subroutine get_alarms - ! - ! OK, if we got this far, then we should be able to allocate memory - ! and set up the timers and variables that we will analyze - ! - ! count the number of variables - call mpas_stream_mgr_begin_iteration(domain % streamManager, & - stream_name, err) - number_of_variables = 0 - do while (mpas_stream_mgr_get_next_field(domain % streamManager, & - stream_name, field)) - number_of_variables = number_of_variables + 1 + +!*********************************************************************** +! routine get_alarms +! +!> \brief Set the alarms based on the clocks +!> \author Jon Woodring +!> \date September 1, 2015 +!> \details +!> Alarms for the different timers are set, such that temporal +!> window alarms are configured. +!----------------------------------------------------------------------- +subroutine set_alarms(domain, instance, number_of_buffers, err) + ! input variables + integer, intent(in) :: number_of_buffers + character (len=StrKIND) :: instance + + ! input/output variables + type (domain_type), intent(inout) :: domain + + ! output variables + integer, intent(out) :: err !< Output: error flag + + ! local variables + integer :: b + character (len=StrKIND) :: buffer + + ! configure alarms + ! TODO modify the alarms based on do_restart + do b = 1, number_of_buffers + write(buffer, '(I0)') b + buffers(b) % start_alarm_ID = & + 'tavg_start' // trim(instance) // '_' // buffer + call mpas_add_clock_alarm(domain % clock, & + buffers(b) % start_alarm_ID, & + buffers(b) % start_time, ierr=err) + + buffers(b) % repeat_alarm_ID = & + 'tavg_repeat' // trim(instance) // '_' // buffer + call mpas_add_clock_alarm(domain % clock, & + buffers(b) % repeat_alarm_ID, & + buffers(b) % start_time + & + buffers(b) % repeat_interval, & + buffers(b) % repeat_interval, ierr=err) + + buffers(b) % duration_alarm_ID = & + 'tavg_duration' // trim(instance) // '_' // buffer + call mpas_add_clock_alarm(domain % clock, & + buffers(b) % duration_alarm_ID, & + buffers(b) % start_time + & + buffers(b) % duration_interval, & + buffers(b) % repeat_interval, ierr=err) + + ! reset at start + buffers(b) % reset_alarm_ID = & + 'tavg_reset' // trim(instance) // '_' // buffer + call mpas_add_clock_alarm(domain % clock, & + buffers(b) % reset_alarm_ID, & + buffers(b) % start_time, & + buffers(b) % reset_interval, ierr=err) + end do +end subroutine set_alarms + + + +!*********************************************************************** +! routine modify_stream +! +!> \brief Remove existing variables and replace them with new ones +!> \author Jon Woodring +!> \date September 1, 2015 +!> \details +!> Given a stream name, this will remove the existing variables +!> in a stream and replace them with similiarly named ones for +!> their accumulation. It will also add xtime and optionally the mesh. +!----------------------------------------------------------------------- +subroutine modify_stream(domain, stream_name, number_of_variables, & + number_of_buffers, instance, prefix, op, err)!{{{ + ! input variables + integer, intent(in) :: number_of_variables, number_of_buffers + character (len=StrKIND) :: stream_name, instance, prefix, op + + ! input/output variables + type (domain_type), intent(inout) :: domain + + ! output variables + integer, intent(out) :: err !< Output: error flag + + ! local variables + integer :: v, b + character (len=StrKIND) :: field, buffer, config, var + logical, pointer :: copy_mesh ! allocate the variable information allocate(variables(number_of_variables)) + ! allocate the state for the buffers + allocate(buffers(number_of_buffers)) + ! get the old field names call mpas_stream_mgr_begin_iteration(domain % streamManager, & stream_name, err) @@ -293,8 +589,8 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ stream_name, 'xtime', ierr=err) ! optionally add mesh to stream - config_str = trim(prefix_str) // '_add_mesh' - call mpas_pool_get_config(domain % configs, config_str, copy_mesh) + config = trim(prefix) // '_add_mesh' + call mpas_pool_get_config(domain % configs, config, copy_mesh) if (copy_mesh) then call mpas_stream_mgr_begin_iteration(domain % streamManager, & 'mesh', err) @@ -311,7 +607,7 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ do v = 1, number_of_variables ! allocate space for the names of the outputs allocate(variables(v) % output_names(number_of_buffers)) - write(var_str, '(I0)') v + write(var, '(I0)') v ! get the info of the field call mpas_pool_get_field_info(domain % blocklist % allFields, & @@ -319,9 +615,9 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ ! check if we can handle it if(.not. & - ((variables(v) % info % fieldType .eq. MPAS_POOL_REAL) & + ((variables(v) % info % fieldType == MPAS_POOL_REAL) & .or. & - (variables(v) % info % fieldType .eq. MPAS_POOL_INTEGER))) & + (variables(v) % info % fieldType == MPAS_POOL_INTEGER))) & then call mpas_dmpar_global_abort('Error: field "' // & trim(variables(v) % input_name) // '" listed in the ' // & @@ -332,9 +628,9 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ ! allocate a number of fields and add field do b = 1, number_of_buffers ! create the name of the new field - write(buffer_str, '(I0)') b - field = 'time' // trim(stream_str) // '_' // & - trim(op_str) // '_' // trim(buffer_str) // '_' + write(buffer, '(I0)') b + field = 'time' // trim(instance) // '_' // & + trim(op) // '_' // trim(buffer) // '_' variables(v) % output_names(b) = trim(field) // & variables(v) % input_name @@ -349,224 +645,31 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ end do end do ! number_of_variables +end subroutine modify_stream!}}} - ! configure alarms - ! TODO modify the alarms based on do_restart - do b = 1, number_of_buffers - write(buffer_str, '(I0)') b - buffers(b) % start_alarm_ID = & - 'tavg_start' // trim(stream_str) // '_' // buffer_str - call mpas_add_clock_alarm(domain % clock, & - buffers(b) % start_alarm_ID, & - buffers(b) % start_time, ierr=err) - - buffers(b) % repeat_alarm_ID = & - 'tavg_repeat' // trim(stream_str) // '_' // buffer_str - call mpas_add_clock_alarm(domain % clock, & - buffers(b) % repeat_alarm_ID, & - buffers(b) % start_time + & - buffers(b) % repeat_interval, & - buffers(b) % repeat_interval, ierr=err) - - buffers(b) % duration_alarm_ID = & - 'tavg_duration' // trim(stream_str) // '_' // buffer_str - call mpas_add_clock_alarm(domain % clock, & - buffers(b) % duration_alarm_ID, & - buffers(b) % start_time + & - buffers(b) % duration_interval, & - buffers(b) % repeat_interval, ierr=err) - - ! reset at start - buffers(b) % reset_alarm_ID = & - 'tavg_reset' // trim(stream_str) // '_' // buffer_str - call mpas_add_clock_alarm(domain % clock, & - buffers(b) % reset_alarm_ID, & - buffers(b) % start_time, & - buffers(b) % reset_interval, ierr=err) - - end do - - ! set initial flags - do b = 1, number_of_buffers - buffers(b) % started_flag = .false. - buffers(b) % reset_flag = .false. - buffers(b) % accumulate_flag = .false. - end do - - ! set flags based on initial times - call timer_checking(domain, err) -end subroutine ocn_init_time_series_stats!}}} - - - -!*********************************************************************** -! routine ocn_compute_time_series_stats -! -!> \brief Compute MPAS-Ocean analysis member -!> \author Jon Woodring -!> \date March 2, 2015 -!> \details -!> This routine conducts all computation required for this -!> MPAS-Ocean analysis member. -!----------------------------------------------------------------------- -subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ - ! input variables - !----------------------------------------------------------------- - integer, intent(in) :: timeLevel - - ! input/output variables - !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain - - ! output variables - !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag - - ! local variables - !----------------------------------------------------------------- - integer :: i, v, b - - ! start procedure - !----------------------------------------------------------------- - err = 0 - - ! update the counter - do b = 1, size(buffers) - if (buffers(b) % reset_flag) then - buffers(b) % total_accum = 1 - else if (buffers(b) % accumulate_flag) then - buffers(b) % total_accum = buffers(b) % total_accum + 1 - end if - end do - - ! do all of the operations - do v = 1, size(variables) - call typed_operate(domain % blocklist, variables(v), operation) - end do - - ! clear any resets - do b = 1, size(buffers) - buffers(b) % reset_flag = .false. - end do - - ! do all of the time checking and flag setting - call timer_checking(domain, err) -end subroutine ocn_compute_time_series_stats!}}} - - - -!*********************************************************************** -! routine ocn_restart_time_series_stats -! -!> \brief Save restart for MPAS-Ocean analysis member -!> \author Jon Woodring -!> \date March 2, 2015 -!> \details -!> This routine conducts computation required to save a restart state -!> for the MPAS-Ocean analysis member. -!----------------------------------------------------------------------- -subroutine ocn_restart_time_series_stats(domain, err)!{{{ - - ! input variables - !----------------------------------------------------------------- - - ! input/output variables - !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain - - ! output variables - !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag - - ! local variables - !----------------------------------------------------------------- - - ! start procedure - !----------------------------------------------------------------- - err = 0 - - ! TODO save data to restart and accumulate - -end subroutine ocn_restart_time_series_stats!}}} - - - -!*********************************************************************** -! routine ocn_finalize_time_series_stats -! -!> \brief Finalize MPAS-Ocean analysis member -!> \author Jon Woodring -!> \date March 2, 2015 -!> \details -!> This routine conducts all finalizations required for this -!> MPAS-Ocean analysis member. -!----------------------------------------------------------------------- -subroutine ocn_finalize_time_series_stats(domain, err)!{{{ - - ! input variables - !----------------------------------------------------------------- - - ! input/output variables - !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain - - ! output variables - !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag - - ! local variables - !----------------------------------------------------------------- - integer :: i, v - - ! start procedure - !----------------------------------------------------------------- - err = 0 - - ! clean up memory - if (allocated(buffers)) then - deallocate(buffers) - end if - if (allocated(variables)) then - do v = 1, size(variables) - if (allocated(variables(v) % output_names)) & - then - deallocate(variables(v) % output_names) - end if - end do - deallocate(variables) - end if - -end subroutine ocn_finalize_time_series_stats!}}} -! -! local subroutines -! !*********************************************************************** ! routine walk_string ! !> \brief Walk a semicolon delimited string to find substrings !> \author Jon Woodring -!> \date March 2, 2015 +!> \date September 1, 2015 !> \details !> Walk a string delimited by semicolons and return the first substring !> from start index, and modify start to point at the next candidate. !----------------------------------------------------------------------- subroutine walk_string(next, substr, ok)!{{{ ! input variables - !----------------------------------------------------------------- ! input/output variables - !----------------------------------------------------------------- character (len=StrKIND), intent(inout) :: next ! output variables - !----------------------------------------------------------------- character (len=StrKIND), intent(out) :: substr logical, intent(out) :: ok ! local variables - !----------------------------------------------------------------- integer :: i character (len=StrKIND) :: copy @@ -575,7 +678,7 @@ subroutine walk_string(next, substr, ok)!{{{ ! if there's anything in it other than whitespace, pass through i = verify(copy, ' ') - ok = i .gt. 0 + ok = i > 0 if (.not. ok) then return end if @@ -585,7 +688,7 @@ subroutine walk_string(next, substr, ok)!{{{ i = scan(copy, ';') ! return that substring and the remainder - if (i .gt. 0) then + if (i > 0) then substr = trim(copy(1:i-1)) next = trim(copy(i+1:)) else @@ -602,80 +705,76 @@ end subroutine walk_string!}}} ! !> \brief Set a list of times !> \author Jon Woodring -!> \date March 2, 2015 +!> \date September 1, 2015 !> \details !> Walk a list of times delimited by spaces and set the time info !> for the buffer structure so that alarms can be set. !----------------------------------------------------------------------- subroutine set_times(buffers, number_of_buffers, clock, & - which, config_str, ok, err) + which, config, ok, err) ! input variables - !----------------------------------------------------------------- integer, intent(in) :: number_of_buffers, which - character (len=StrKIND), pointer, intent(in) :: config_str + character (len=StrKIND), pointer, intent(in) :: config ! input/output variables - !----------------------------------------------------------------- type (time_buffer_type), dimension(:), intent(inout) :: buffers type (MPAS_Clock_type), intent(inout) :: clock ! output variables - !----------------------------------------------------------------- logical, intent(out) :: ok integer, intent(out) :: err ! local variables - !----------------------------------------------------------------- - character (len=StrKIND) :: next_str, time_str + character (len=StrKIND) :: next, time integer :: b ! find the first time in the list - next_str = config_str + next = config b = 0 - call walk_string(next_str, time_str, ok) + call walk_string(next, time, ok) ! while the time string is ok do while (ok) ! exit if we went over b = b + 1 - if (b .gt. number_of_buffers) then + if (b > number_of_buffers) then exit end if ! set the time - if (which .eq. START_TIMES) then - if (time_str .eq. 'initial_time') then + if (which == START_TIMES) then + if (time == 'initial_time') then buffers(b) % start_time = mpas_get_clock_time(clock, & MPAS_NOW, err) else call mpas_set_time(buffers(b) % start_time, & - dateTimeString=time_str, ierr=err) + dateTimeString=time, ierr=err) end if - else if (which .eq. DURATION_INTERVALS) then - if (time_str .eq. 'repeat_interval') then + else if (which == DURATION_INTERVALS) then + if (time == 'repeat_interval') then buffers(b) % duration_interval = buffers(b) % repeat_interval else call mpas_set_timeInterval(buffers(b) % duration_interval, & - timeString=time_str, ierr=err) + timeString=time, ierr=err) end if - else if (which .eq. REPEAT_INTERVALS) then - if (time_str .eq. 'reset_interval') then + else if (which == REPEAT_INTERVALS) then + if (time == 'reset_interval') then buffers(b) % repeat_interval = buffers(b) % reset_interval else call mpas_set_timeInterval(buffers(b) % repeat_interval, & - timeString=time_str, ierr=err) + timeString=time, ierr=err) end if else call mpas_set_timeInterval(buffers(b) % reset_interval, & - timeString=time_str, ierr=err) + timeString=time, ierr=err) end if ! get the next time string - call walk_string(next_str, time_str, ok) + call walk_string(next, time, ok) end do ! only ok if we parsed out as many as there are number of buffers - ok = number_of_buffers .eq. b + ok = number_of_buffers == b end subroutine set_times @@ -685,51 +784,44 @@ end subroutine set_times ! !> \brief Function to create a new field from an existing field !> \author Jon Woodring -!> \date March 2, 2015 +!> \date September 1, 2015 !> \details !> This routine conducts all initializations required for !> duplicating a field and adding it to the allFields pool. !----------------------------------------------------------------------- subroutine add_new_field(info, inname, prefix, pool)!{{{ ! input variables - !----------------------------------------------------------------- type (mpas_pool_field_info_type), intent(in) :: info character (len=StrKIND), intent(in) :: inname, prefix ! input/output variables - !----------------------------------------------------------------- type (mpas_pool_type), intent(inout) :: pool ! output variables - !----------------------------------------------------------------- ! local variables - !----------------------------------------------------------------- - - ! start procedure - !----------------------------------------------------------------- ! duplicate field and add new field to pool - if (info % fieldType .eq. MPAS_POOL_REAL) then - if (info % nDims .eq. 0) then + if (info % fieldType == MPAS_POOL_REAL) then + if (info % nDims == 0) then call copy_field_0r(inname, pool, prefix) - else if (info % nDims .eq. 1) then + else if (info % nDims == 1) then call copy_field_1r(inname, pool, prefix) - else if (info % nDims .eq. 2) then + else if (info % nDims == 2) then call copy_field_2r(inname, pool, prefix) - else if (info % nDims .eq. 3) then + else if (info % nDims == 3) then call copy_field_3r(inname, pool, prefix) - else if (info % nDims .eq. 4) then + else if (info % nDims == 4) then call copy_field_4r(inname, pool, prefix) else call copy_field_5r(inname, pool, prefix) end if else - if (info % nDims .eq. 0) then + if (info % nDims == 0) then call copy_field_0i(inname, pool, prefix) - else if (info % nDims .eq. 1) then + else if (info % nDims == 1) then call copy_field_1i(inname, pool, prefix) - else if (info % nDims .eq. 2) then + else if (info % nDims == 2) then call copy_field_2i(inname, pool, prefix) else call copy_field_3i(inname, pool, prefix) @@ -745,29 +837,24 @@ end subroutine add_new_field!}}} ! !> \brief Timer functions to determine when to run !> \author Jon Woodring -!> \date March 2, 2015 +!> \date September 1, 2015 !> \details !> This routine conducts timer checking to determine if it !> needs to run at this particular time. !----------------------------------------------------------------------- subroutine timer_checking(domain, err)!{{{ ! input variables - !----------------------------------------------------------------- ! input/output variables - !----------------------------------------------------------------- type (domain_type), intent(inout) :: domain ! output variables - !----------------------------------------------------------------- integer, intent(out) :: err ! local variables - !----------------------------------------------------------------- integer :: b ! start procedure - !----------------------------------------------------------------- err = 0 do b = 1, size(buffers) @@ -825,73 +912,69 @@ end subroutine timer_checking!}}} ! !> \brief Do the operation, but switch on run-time type !> \author Jon Woodring -!> \date March 2, 2015 +!> \date September 1, 2015 !> \details !> Since we don't know the type of the array, we need to do some !> run-time type switching based on the type of the array. !----------------------------------------------------------------------- subroutine typed_operate(block, tvar, operation)!{{{ ! input variables - !----------------------------------------------------------------- type (block_type), pointer, intent(in) :: block integer, intent(in) :: operation ! input/output variables - !----------------------------------------------------------------- type (time_variable_type), intent(inout) :: tvar ! output variables - !----------------------------------------------------------------- ! local variables - !----------------------------------------------------------------- ! switch based on the type, dimensionality, and operation if (tvar % info % fieldType == MPAS_POOL_REAL) then if (tvar % info % nDims == 0) then - if (operation .eq. AVG_OP) then + if (operation == AVG_OP) then call operate0r_avg(block, tvar) - else if (operation .eq. MIN_OP) then + else if (operation == MIN_OP) then call operate0r_min(block, tvar) else call operate0r_max(block, tvar) end if else if (tvar % info % nDims == 1) then - if (operation .eq. AVG_OP) then + if (operation == AVG_OP) then call operate1r_avg(block, tvar) - else if (operation .eq. MIN_OP) then + else if (operation == MIN_OP) then call operate1r_min(block, tvar) else call operate1r_max(block, tvar) end if else if (tvar % info % nDims == 2) then - if (operation .eq. AVG_OP) then + if (operation == AVG_OP) then call operate2r_avg(block, tvar) - else if (operation .eq. MIN_OP) then + else if (operation == MIN_OP) then call operate2r_min(block, tvar) else call operate2r_max(block, tvar) end if else if (tvar % info % nDims == 3) then - if (operation .eq. AVG_OP) then + if (operation == AVG_OP) then call operate3r_avg(block, tvar) - else if (operation .eq. MIN_OP) then + else if (operation == MIN_OP) then call operate3r_min(block, tvar) else call operate3r_max(block, tvar) end if else if (tvar % info % nDims == 4) then - if (operation .eq. AVG_OP) then + if (operation == AVG_OP) then call operate4r_avg(block, tvar) - else if (operation .eq. MIN_OP) then + else if (operation == MIN_OP) then call operate4r_min(block, tvar) else call operate4r_max(block, tvar) end if else - if (operation .eq. AVG_OP) then + if (operation == AVG_OP) then call operate5r_avg(block, tvar) - else if (operation .eq. MIN_OP) then + else if (operation == MIN_OP) then call operate5r_min(block, tvar) else call operate5r_max(block, tvar) @@ -899,33 +982,33 @@ subroutine typed_operate(block, tvar, operation)!{{{ end if else if (tvar % info % nDims == 0) then - if (operation .eq. AVG_OP) then + if (operation == AVG_OP) then call operate0i_avg(block, tvar) - else if (operation .eq. MIN_OP) then + else if (operation == MIN_OP) then call operate0i_min(block, tvar) else call operate0i_max(block, tvar) end if else if (tvar % info % nDims == 1) then - if (operation .eq. AVG_OP) then + if (operation == AVG_OP) then call operate1i_avg(block, tvar) - else if (operation .eq. MIN_OP) then + else if (operation == MIN_OP) then call operate1i_min(block, tvar) else call operate1i_max(block, tvar) end if else if (tvar % info % nDims == 2) then - if (operation .eq. AVG_OP) then + if (operation == AVG_OP) then call operate2i_avg(block, tvar) - else if (operation .eq. MIN_OP) then + else if (operation == MIN_OP) then call operate2i_min(block, tvar) else call operate2i_max(block, tvar) end if else - if (operation .eq. AVG_OP) then + if (operation == AVG_OP) then call operate3i_avg(block, tvar) - else if (operation .eq. MIN_OP) then + else if (operation == MIN_OP) then call operate3i_min(block, tvar) else call operate3i_max(block, tvar) @@ -941,7 +1024,7 @@ end subroutine typed_operate!}}} ! !> \brief Functions to create a new field from an existing field !> \author Jon Woodring -!> \date March 2, 2015 +!> \date September 1, 2015 !> \details !> This routine conducts initializations required for !> duplicating a field and adding it to the allFields pool based on type. @@ -1173,7 +1256,7 @@ end subroutine copy_field_3i!}}} ! !> \brief Series of subroutines to support operations on run-time types !> \author Jon Woodring -!> \date March 2, 2015 +!> \date September 1, 2015 !> \details !> These subroutines encapsulate the different opertions that can occur !> based on the run-time types. (This would likely be From 6b6b606690bbe0f82251da2fdc54c739a017b48c Mon Sep 17 00:00:00 2001 From: Luke Van Roekel Date: Thu, 20 Aug 2015 08:43:28 -0600 Subject: [PATCH 0151/1724] changed the interp type from a character string to integer string. this was due to having to pass character pointers to an interp subroutine --- .../Registry_mixed_layer_depths.xml | 4 +- .../mpas_ocn_mixed_layer_depths.F | 46 +++++++++++-------- 2 files changed, 30 insertions(+), 20 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml index a6f467a447..652adfea27 100644 --- a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml +++ b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml @@ -70,9 +70,9 @@ description="minimum potential density gradient crit value. If not exceeded max gradient used" possible_values="all positive reals" /> - diff --git a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F index ec71ad6dc2..760e9cc267 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F +++ b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F @@ -181,7 +181,8 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ real (kind=RKIND), pointer :: tempGradMin, tempGradMax real (kind=RKIND), pointer :: denThreshMin, denThreshMax real (kind=RKIND), pointer :: denGradMin, denGradMax - character (len=StrKIND), pointer :: interp_type + integer, pointer :: interp_type + integer :: interp_local real (kind=RKIND), pointer :: refPress real (kind=RKIND), allocatable, dimension(:,:) :: gradientBins, thresholdBins real (kind=RKIND), allocatable, dimension(:,:) :: densityGradient, temperatureGradient @@ -211,6 +212,10 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_interp_method', interp_type) call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_reference_pressure', refPress) + if (interp_type == 1) interp_local = 1 + if (interp_type == 2) interp_local = 2 + if (interp_type == 3) interp_local = 3 + block => domain % blocklist do while (associated(block)) @@ -246,14 +251,18 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ enddo do iCell = 1,nCellsSolve + + found_den_mld = .false. + found_temp_mld = .false. + do k=1, maxLevelCell(iCell) if(pressure(k+1,iCell) > refPress) then call interp_bw_levels(tracers(index_temperature,k,iCell),tracers(index_temperature,k+1,iCell), & - pressure(k,iCell),pressure(k+1,iCell),refPress,trim(interp_type), & + pressure(k,iCell),pressure(k+1,iCell),refPress,interp_local, & pressure(k-1,iCell),tracers(index_temperature,k-1,iCell),temp_ref_lev) call interp_bw_levels(potentialDensity(k,iCell),potentialDensity(k+1,iCell), & - pressure(k,iCell),pressure(k+1,iCell),refPress,trim(interp_type), & + pressure(k,iCell),pressure(k+1,iCell),refPress,interp_local, & pressure(k-1,iCell),potentialDensity(k-1,iCell),den_ref_lev) refIndex = k+1 @@ -261,7 +270,6 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ endif enddo - do i=1,nThresholdBins do k=refIndex,maxLevelCell(iCell) if( abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) .ge. thresholdBins(1,i)) then @@ -269,7 +277,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ dV = abs(tracers(index_temperature,k ,iCell) - temp_ref_lev) dVm1 = abs(tracers(index_temperature,k-1,iCell) - temp_ref_lev) call interp_bw_levels(zMid(k,iCell),zMid(k+1,iCell), dV, dVp1, thresholdBins(1,i), & - trim(interp_type), dVm1, zMid(k-1,iCell), thresholdMLD(1,i,iCell)) + interp_local, dVm1, zMid(k-1,iCell), thresholdMLD(1,i,iCell)) found_temp_mld = .true. endif @@ -278,7 +286,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ dV = abs(potentialDensity(k ,iCell) - den_ref_lev) dVm1 = abs(potentialDensity(k-1,iCell) - den_ref_lev) call interp_bw_levels(zMid(k,iCell),zMid(k+1,iCell), dV, dVp1, thresholdBins(2,i), & - trim(interp_type), dVm1, zMid(k-1,iCell), thresholdMLD(2,i,iCell)) + interp_local, dVm1, zMid(k-1,iCell), thresholdMLD(2,i,iCell)) found_den_mld = .true. endif @@ -295,8 +303,6 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ ! Compute the mixed layer depth based on a gradient threshold in temperature and density if(gradientFlag) then - found_temp_mld=.false. - found_den_mld=.false. call mpas_pool_get_array(mixedLayerDepthsAMPool, 'gradientMLD', gradientMLD) dTempGrad = (tempGradMax - tempGradMin) / float(nGradientBins) dDenGrad = (denGradMax - denGradMin) / float(nGradientBins) @@ -315,6 +321,10 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ temperatureGradient(2,1) = 1 do iCell = 1,nCellsSolve + + found_den_mld=.false. + found_temp_mld=.false. + do k=2,maxLevelCell(iCell) dz=abs(zMid(k-1,iCell)-zMid(k,iCell)) densityGradient(k,1) = (potentialDensity(k-1,iCell)-potentialDensity(k,iCell)) / dz @@ -335,12 +345,12 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ do k=2, maxLevelCell(iCell) if(densityGradient(1,k+1) .ge. gradientBins(2,i)) then call interp_bw_levels(zTop(k,iCell),zTop(k+1,iCell),densityGradient(k,1),densityGradient(k+1,1), & - gradientBins(2,i), trim(interp_type),densityGradient(k-1,1),zTop(k-1,iCell), gradientMLD(2,i,iCell)) + gradientBins(2,i), interp_local,densityGradient(k-1,1),zTop(k-1,iCell), gradientMLD(2,i,iCell)) found_den_mld=.true. endif if(temperatureGradient(k+1,1) .ge. gradientBins(2,i)) then call interp_bw_levels(zTop(k,iCell),zTop(k+1,iCell),temperatureGradient(k,1),temperatureGradient(k+1,1), & - gradientBins(1,i), trim(interp_type),temperatureGradient(k-1,1),zTop(k-1,iCell), gradientMLD(1,i,iCell)) + gradientBins(1,i), interp_local,temperatureGradient(k-1,1),zTop(k-1,iCell), gradientMLD(1,i,iCell)) found_temp_mld=.true. endif @@ -397,9 +407,9 @@ end subroutine ocn_compute_mixed_layer_depths!}}} ! !----------------------------------------------------------------------- - subroutine interp_bw_levels(y0,y1,x0,x1,xT,interp_type,xm1,ym1,yT)!{{{ + subroutine interp_bw_levels(y0,y1,x0,x1,xT,interp_f,xm1,ym1,yT)!{{{ - character(len=StrKIND),intent(in) :: interp_type ! linear, quadratic, or spline + integer,intent(in) :: interp_f ! linear, quadratic, or spline real(kind=RKIND),intent(in) :: y0,y1,x0,x1,xT real(kind=RKIND),intent(inout) :: yT real(kind=RKIND),optional,intent(in) :: xm1,ym1 @@ -421,14 +431,14 @@ subroutine interp_bw_levels(y0,y1,x0,x1,xT,interp_type,xm1,ym1,yT)!{{{ Minv(:,:) = 0.0_RKIND rhs(:) = 0.0_RKIND - select case (trim(interp_type)) - case ("linear") + select case (interp_f) + + case (1) coeffs(2) = (y1-y0)/(x1-x0) coeffs(1) = y0 - coeffs(2)*x0 - - case ("quadratic") + case (2) det = -(x1-x0)**2 rhs(1) = y0 @@ -456,7 +466,7 @@ subroutine interp_bw_levels(y0,y1,x0,x1,xT,interp_type,xm1,ym1,yT)!{{{ enddo enddo - case ("spline") + case (3) det = -(x1-x0)**3 rhs(1) = y1 rhs(2) = y0 @@ -493,7 +503,7 @@ subroutine interp_bw_levels(y0,y1,x0,x1,xT,interp_type,xm1,ym1,yT)!{{{ end select - yT = coeffs(1)*xT**3 + coeffs(2)*xT**2 + coeffs(3)*xT + coeffs(4) + yT = coeffs(4)*xT**3 + coeffs(3)*xT**2 + coeffs(2)*xT + coeffs(1) end subroutine interp_bw_levels!}}} !*********************************************************************** From 55522bc54d787afd341a9b4e15ca291f2226844b Mon Sep 17 00:00:00 2001 From: Luke Van Roekel Date: Thu, 20 Aug 2015 10:12:40 -0600 Subject: [PATCH 0152/1724] fixed the gradient method to do gradients in pressure space --- .../analysis_members/mpas_ocn_mixed_layer_depths.F | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F index 760e9cc267..7ff3964295 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F +++ b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F @@ -272,7 +272,8 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ do i=1,nThresholdBins do k=refIndex,maxLevelCell(iCell) - if( abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) .ge. thresholdBins(1,i)) then + + if( abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) .ge. thresholdBins(1,i)) then dVp1 = abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) dV = abs(tracers(index_temperature,k ,iCell) - temp_ref_lev) dVm1 = abs(tracers(index_temperature,k-1,iCell) - temp_ref_lev) @@ -326,9 +327,9 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ found_temp_mld=.false. do k=2,maxLevelCell(iCell) - dz=abs(zMid(k-1,iCell)-zMid(k,iCell)) - densityGradient(k,1) = (potentialDensity(k-1,iCell)-potentialDensity(k,iCell)) / dz - temperatureGradient(k,1) = (tracers(index_temperature,k-1,iCell) - tracers(index_temperature,k,iCell)) / dz + dz=abs(pressure(k-1,iCell)-pressure(k,iCell)) + densityGradient(k,1) = abs(potentialDensity(k-1,iCell)-potentialDensity(k,iCell)) / dz + temperatureGradient(k,1) = abs(tracers(index_temperature,k-1,iCell) - tracers(index_temperature,k,iCell)) / dz densityGradient(k,2) = k temperatureGradient(k,2) = k enddo @@ -339,7 +340,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ densityGradient(k,1) = (densityGradient(k-1,1) + densityGradient(k,1) + densityGradient(k+1,1)) / float(3) temperatureGradient(k,1) = (temperatureGradient(k-1,1) + temperatureGradient(k,1) + temperatureGradient(k+1,1)) / float(3) enddo - + do i=1, nGradientBins do k=2, maxLevelCell(iCell) From b80942ce38bad74a4f3d2456b06714c184bd903d Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Thu, 20 Aug 2015 11:22:24 -0600 Subject: [PATCH 0153/1724] Fixed the error of comparing different time intervals. --- .../mpas_ocn_time_series_stats.F | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index ca58e96b24..edd218724c 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -396,10 +396,11 @@ subroutine get_alarms(domain, prefix, number_of_buffers, err) integer, intent(out) :: err !< Output: error flag ! local variables - integer :: b + integer :: b, n character (len=StrKIND), pointer :: config_results character (len=StrKIND) :: config logical :: ok + type (mpas_timeinterval_type) :: rem, zero ! configure start times - we don't have to check ok ! because the timer count is based on initial_times tokens @@ -449,17 +450,23 @@ subroutine get_alarms(domain, prefix, number_of_buffers, err) end if ! check if some of the time configuration is sensible + call mpas_set_timeInterval(zero, s=0) + do b = 1, number_of_buffers - if (buffers(b) % repeat_interval > & - buffers(b) % reset_interval) then + call mpas_interval_division(buffers(b) % start_time, & + buffers(b) % repeat_interval, buffers(b) % reset_interval, n, rem) + + if (n > 1 .or. (n == 1 .and. rem /= zero)) then write(stderrUnit,*) 'Warning: repeat_interval > ' // & 'reset_interval in time averaging analysis member ' // & 'configuration. Truncating repeat_interval.' buffers(b) % repeat_interval = buffers(b) % reset_interval end if - if (buffers(b) % duration_interval > & - buffers(b) % repeat_interval) then + call mpas_interval_division(buffers(b) % start_time, & + buffers(b) % duration_interval, buffers(b) % repeat_interval, n, rem) + + if (n > 1 .or. (n == 1 .and. rem /= zero)) then write(stderrUnit,*) 'Warning: duration_interval > ' // & 'repeat_interval in time averaging analysis member ' // & 'configuration. Truncating duration_interval.' From 8e284aa37d8f39da0d68ef0518526c74dfb3abed Mon Sep 17 00:00:00 2001 From: Luke Van Roekel Date: Thu, 20 Aug 2015 12:32:54 -0600 Subject: [PATCH 0154/1724] fixed a gradient flag to check the temperature gradient and not density --- src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F index 7ff3964295..fcea768c3b 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F +++ b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F @@ -349,7 +349,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ gradientBins(2,i), interp_local,densityGradient(k-1,1),zTop(k-1,iCell), gradientMLD(2,i,iCell)) found_den_mld=.true. endif - if(temperatureGradient(k+1,1) .ge. gradientBins(2,i)) then + if(temperatureGradient(k+1,1) .ge. gradientBins(1,i)) then call interp_bw_levels(zTop(k,iCell),zTop(k+1,iCell),temperatureGradient(k,1),temperatureGradient(k+1,1), & gradientBins(1,i), interp_local,temperatureGradient(k-1,1),zTop(k-1,iCell), gradientMLD(1,i,iCell)) found_temp_mld=.true. From ce279440f767c21a0e51826b7a4cd4ea92472143 Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Sat, 22 Aug 2015 12:49:05 -0600 Subject: [PATCH 0155/1724] It now uses reference_times has does behavior similar to streams. --- .../Registry_time_series_stats.xml | 2 +- .../mpas_ocn_time_series_stats.F | 710 ++++++++++-------- 2 files changed, 417 insertions(+), 295 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_time_series_stats.xml b/src/core_ocean/analysis_members/Registry_time_series_stats.xml index 5036749cfd..ac280fe45a 100644 --- a/src/core_ocean/analysis_members/Registry_time_series_stats.xml +++ b/src/core_ocean/analysis_members/Registry_time_series_stats.xml @@ -50,7 +50,7 @@ possible_values="An operation, where it can be 'avg', 'min', or 'max'." /> - \brief Set the alarms based on the clocks !> \author Jon Woodring @@ -487,55 +472,123 @@ end subroutine get_alarms !> Alarms for the different timers are set, such that temporal !> window alarms are configured. !----------------------------------------------------------------------- -subroutine set_alarms(domain, instance, number_of_buffers, err) +subroutine set_alarms(clock, instance, number_of_buffers, err) ! input variables integer, intent(in) :: number_of_buffers character (len=StrKIND) :: instance ! input/output variables - type (domain_type), intent(inout) :: domain + type (mpas_clock_type), intent(inout) :: clock ! output variables integer, intent(out) :: err !< Output: error flag ! local variables - integer :: b + integer :: b, repeat_n, duration_n, reset_n character (len=StrKIND) :: buffer + type (mpas_time_type) :: current_time, when, & + duration_time, repeat_time, reset_time + type (mpas_timeinterval_type) :: elapsed, zero, & + repeat_rem, duration_rem, reset_rem + + ! get current time + current_time = mpas_get_clock_time(clock, MPAS_NOW, err) ! configure alarms - ! TODO modify the alarms based on do_restart do b = 1, number_of_buffers write(buffer, '(I0)') b - buffers(b) % start_alarm_ID = & - 'tavg_start' // trim(instance) // '_' // buffer - call mpas_add_clock_alarm(domain % clock, & - buffers(b) % start_alarm_ID, & - buffers(b) % start_time, ierr=err) - buffers(b) % repeat_alarm_ID = & - 'tavg_repeat' // trim(instance) // '_' // buffer - call mpas_add_clock_alarm(domain % clock, & - buffers(b) % repeat_alarm_ID, & - buffers(b) % start_time + & - buffers(b) % repeat_interval, & - buffers(b) % repeat_interval, ierr=err) + ! see if we start in the future or we have already started + if (current_time >= buffers(b) % start_time) then + buffers(b) % started_flag = .true. + ! TODO this needs to be false if do_restart + buffers(b) % reset_flag = .true. + ! no start alarm + buffers(b) % start_alarm_ID = '' + else + buffers(b) % started_flag = .false. + buffers(b) % reset_flag = .false. + + ! set the start alarm + buffers(b) % start_alarm_ID = & + 'tavg_start' // trim(instance) // '_' // buffer + call mpas_add_clock_alarm(clock, & + buffers(b) % start_alarm_ID, & + buffers(b) % start_time, ierr=err) + end if + + ! + ! determine next alarm times + ! + + ! set next duration time + when = buffers(b) % start_time + & + buffers(b) % duration_interval ! duration is offset + if (current_time > when) then + elapsed = current_time - when + call mpas_interval_division(when, elapsed, & + buffers(b) % repeat_interval, & ! repeat is correct + duration_n, duration_rem) + duration_rem = buffers(b) % repeat_interval - duration_rem + duration_time = current_time + duration_rem ! remainder of repeat + else + duration_time = buffers(b) % start_time + buffers(b) % duration_interval + duration_n = 0 + end if + + ! set next repeat time + when = buffers(b) % start_time + buffers(b) % repeat_interval + if (current_time > when) then + elapsed = current_time - when + call mpas_interval_division(when, elapsed, & + buffers(b) % repeat_interval, repeat_n, repeat_rem) + repeat_rem = buffers(b) % repeat_interval - repeat_rem + repeat_time = current_time + repeat_rem + else + repeat_time = buffers(b) % start_time + buffers(b) % repeat_interval + repeat_n = 0 + end if + + ! set next reset time + when = buffers(b) % start_time + buffers(b) % reset_interval + if (current_time > when) then + elapsed = current_time - when + call mpas_interval_division(when, elapsed, & + buffers(b) % reset_interval, reset_n, reset_rem) + reset_rem = buffers(b) % reset_interval - reset_rem + reset_time = current_time + reset_rem + else + reset_time = buffers(b) % start_time + buffers(b) % reset_interval + reset_n = 0 + end if + + ! we're accumulating if we are in a window between duration and repeat + buffers(b) % accumulate_flag = duration_n == repeat_n + + ! + ! set the reoccurring timers + ! buffers(b) % duration_alarm_ID = & 'tavg_duration' // trim(instance) // '_' // buffer - call mpas_add_clock_alarm(domain % clock, & + call mpas_add_clock_alarm(clock, & buffers(b) % duration_alarm_ID, & - buffers(b) % start_time + & - buffers(b) % duration_interval, & + duration_time, & ! duration sets the offset + buffers(b) % repeat_interval, ierr=err) ! but repeat sets the interval + + buffers(b) % repeat_alarm_ID = & + 'tavg_repeat' // trim(instance) // '_' // buffer + call mpas_add_clock_alarm(clock, & + buffers(b) % repeat_alarm_ID, & + repeat_time, & buffers(b) % repeat_interval, ierr=err) - ! reset at start buffers(b) % reset_alarm_ID = & 'tavg_reset' // trim(instance) // '_' // buffer - call mpas_add_clock_alarm(domain % clock, & + call mpas_add_clock_alarm(clock, & buffers(b) % reset_alarm_ID, & - buffers(b) % start_time, & + reset_time, & buffers(b) % reset_interval, ierr=err) - end do end subroutine set_alarms @@ -752,7 +805,7 @@ subroutine set_times(buffers, number_of_buffers, clock, & if (which == START_TIMES) then if (time == 'initial_time') then buffers(b) % start_time = mpas_get_clock_time(clock, & - MPAS_NOW, err) + MPAS_START_TIME, err) else call mpas_set_time(buffers(b) % start_time, & dateTimeString=time, ierr=err) @@ -849,11 +902,11 @@ end subroutine add_new_field!}}} !> This routine conducts timer checking to determine if it !> needs to run at this particular time. !----------------------------------------------------------------------- -subroutine timer_checking(domain, err)!{{{ +subroutine timer_checking(clock, err)!{{{ ! input variables ! input/output variables - type (domain_type), intent(inout) :: domain + type (mpas_clock_type), intent(inout) :: clock ! output variables integer, intent(out) :: err @@ -865,25 +918,35 @@ subroutine timer_checking(domain, err)!{{{ err = 0 do b = 1, size(buffers) + ! clear any resets + if (buffers(b) % reset_flag) then + if (buffers(b) % accumulate_flag) then + buffers(b) % reset_flag = .false. + end if + end if + ! see if the started alarm is ringing - if (mpas_is_alarm_ringing(domain % clock, & - buffers(b) % start_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(domain % clock, & - buffers(b) % start_alarm_ID, ierr=err) - buffers(b) % started_flag = .true. - buffers(b) % accumulate_flag = .true. + if (trim(buffers(b) % start_alarm_ID) /= '') then + if (mpas_is_alarm_ringing(clock, & + buffers(b) % start_alarm_ID, ierr=err)) then + call mpas_reset_clock_alarm(clock, & + buffers(b) % start_alarm_ID, ierr=err) + buffers(b) % started_flag = .true. + buffers(b) % reset_flag = .true. + buffers(b) % accumulate_flag = .true. + end if end if - ! if we aren't started, continue to next buffer + ! if we aren't started, cycle to next buffer if (.not. buffers(b) % started_flag) then - continue + cycle end if ! check various other alarms ! see if we need to reset - if(mpas_is_alarm_ringing(domain % clock, & + if(mpas_is_alarm_ringing(clock, & buffers(b) % reset_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(domain % clock, & + call mpas_reset_clock_alarm(clock, & buffers(b) % reset_alarm_ID, ierr=err) buffers(b) % reset_flag = .true. end if @@ -892,9 +955,9 @@ subroutine timer_checking(domain, err)!{{{ ! ! duration needs to be >= 2 * compute_interval ! (a series can only be 2 or more) - if (mpas_is_alarm_ringing(domain % clock, & + if (mpas_is_alarm_ringing(clock, & buffers(b) % duration_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(domain % clock, & + call mpas_reset_clock_alarm(clock, & buffers(b) % duration_alarm_ID, ierr=err) buffers(b) % accumulate_flag = .false. end if @@ -902,9 +965,9 @@ subroutine timer_checking(domain, err)!{{{ ! turn on accumulation ! (this is second, in case the duration and repeat ! overlaps on the same timer) - if (mpas_is_alarm_ringing(domain % clock, & + if (mpas_is_alarm_ringing(clock, & buffers(b) % repeat_alarm_ID, ierr=err)) then - call mpas_reset_clock_alarm(domain % clock, & + call mpas_reset_clock_alarm(clock, & buffers(b) % repeat_alarm_ID, ierr=err) buffers(b) % accumulate_flag = .true. end if @@ -924,101 +987,100 @@ end subroutine timer_checking!}}} !> Since we don't know the type of the array, we need to do some !> run-time type switching based on the type of the array. !----------------------------------------------------------------------- -subroutine typed_operate(block, tvar, operation)!{{{ +subroutine typed_operate(block, v, operation)!{{{ ! input variables type (block_type), pointer, intent(in) :: block - integer, intent(in) :: operation + integer, intent(in) :: v, operation ! input/output variables - type (time_variable_type), intent(inout) :: tvar ! output variables ! local variables ! switch based on the type, dimensionality, and operation - if (tvar % info % fieldType == MPAS_POOL_REAL) then - if (tvar % info % nDims == 0) then + if (variables(v) % info % fieldType == MPAS_POOL_REAL) then + if (variables(v) % info % nDims == 0) then if (operation == AVG_OP) then - call operate0r_avg(block, tvar) + call operate0r_avg(block, variables(v)) else if (operation == MIN_OP) then - call operate0r_min(block, tvar) + call operate0r_min(block, variables(v)) else - call operate0r_max(block, tvar) + call operate0r_max(block, variables(v)) end if - else if (tvar % info % nDims == 1) then + else if (variables(v) % info % nDims == 1) then if (operation == AVG_OP) then - call operate1r_avg(block, tvar) + call operate1r_avg(block, variables(v)) else if (operation == MIN_OP) then - call operate1r_min(block, tvar) + call operate1r_min(block, variables(v)) else - call operate1r_max(block, tvar) + call operate1r_max(block, variables(v)) end if - else if (tvar % info % nDims == 2) then + else if (variables(v) % info % nDims == 2) then if (operation == AVG_OP) then - call operate2r_avg(block, tvar) + call operate2r_avg(block, variables(v)) else if (operation == MIN_OP) then - call operate2r_min(block, tvar) + call operate2r_min(block, variables(v)) else - call operate2r_max(block, tvar) + call operate2r_max(block, variables(v)) end if - else if (tvar % info % nDims == 3) then + else if (variables(v) % info % nDims == 3) then if (operation == AVG_OP) then - call operate3r_avg(block, tvar) + call operate3r_avg(block, variables(v)) else if (operation == MIN_OP) then - call operate3r_min(block, tvar) + call operate3r_min(block, variables(v)) else - call operate3r_max(block, tvar) + call operate3r_max(block, variables(v)) end if - else if (tvar % info % nDims == 4) then + else if (variables(v) % info % nDims == 4) then if (operation == AVG_OP) then - call operate4r_avg(block, tvar) + call operate4r_avg(block, variables(v)) else if (operation == MIN_OP) then - call operate4r_min(block, tvar) + call operate4r_min(block, variables(v)) else - call operate4r_max(block, tvar) + call operate4r_max(block, variables(v)) end if else if (operation == AVG_OP) then - call operate5r_avg(block, tvar) + call operate5r_avg(block, variables(v)) else if (operation == MIN_OP) then - call operate5r_min(block, tvar) + call operate5r_min(block, variables(v)) else - call operate5r_max(block, tvar) + call operate5r_max(block, variables(v)) end if end if else - if (tvar % info % nDims == 0) then + if (variables(v) % info % nDims == 0) then if (operation == AVG_OP) then - call operate0i_avg(block, tvar) + call operate0i_avg(block, variables(v)) else if (operation == MIN_OP) then - call operate0i_min(block, tvar) + call operate0i_min(block, variables(v)) else - call operate0i_max(block, tvar) + call operate0i_max(block, variables(v)) end if - else if (tvar % info % nDims == 1) then + else if (variables(v) % info % nDims == 1) then if (operation == AVG_OP) then - call operate1i_avg(block, tvar) + call operate1i_avg(block, variables(v)) else if (operation == MIN_OP) then - call operate1i_min(block, tvar) + call operate1i_min(block, variables(v)) else - call operate1i_max(block, tvar) + call operate1i_max(block, variables(v)) end if - else if (tvar % info % nDims == 2) then + else if (variables(v) % info % nDims == 2) then if (operation == AVG_OP) then - call operate2i_avg(block, tvar) + call operate2i_avg(block, variables(v)) else if (operation == MIN_OP) then - call operate2i_min(block, tvar) + call operate2i_min(block, variables(v)) else - call operate2i_max(block, tvar) + call operate2i_max(block, variables(v)) end if else if (operation == AVG_OP) then - call operate3i_avg(block, tvar) + call operate3i_avg(block, variables(v)) else if (operation == MIN_OP) then - call operate3i_min(block, tvar) + call operate3i_min(block, variables(v)) else - call operate3i_max(block, tvar) + call operate3i_max(block, variables(v)) end if end if end if @@ -1292,14 +1354,16 @@ subroutine operate0r_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else out_array = (out_array * \ (buffers(b) % total_accum - 1) + in_array) \ / buffers(b) % total_accum ; @@ -1327,14 +1391,16 @@ subroutine operate1r_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else out_array = (out_array * \ (buffers(b) % total_accum - 1) + in_array) \ / buffers(b) % total_accum ; @@ -1362,14 +1428,16 @@ subroutine operate2r_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else out_array = (out_array * \ (buffers(b) % total_accum - 1) + in_array) \ / buffers(b) % total_accum ; @@ -1397,14 +1465,16 @@ subroutine operate3r_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else out_array = (out_array * \ (buffers(b) % total_accum - 1) + in_array) \ / buffers(b) % total_accum ; @@ -1432,14 +1502,16 @@ subroutine operate4r_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else out_array = (out_array * \ (buffers(b) % total_accum - 1) + in_array) \ / buffers(b) % total_accum ; @@ -1467,14 +1539,16 @@ subroutine operate5r_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else out_array = (out_array * \ (buffers(b) % total_accum - 1) + in_array) \ / buffers(b) % total_accum ; @@ -1502,14 +1576,16 @@ subroutine operate0i_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else out_array = (out_array * \ (buffers(b) % total_accum - 1) + in_array) \ / buffers(b) % total_accum ; @@ -1537,14 +1613,16 @@ subroutine operate1i_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else out_array = (out_array * \ (buffers(b) % total_accum - 1) + in_array) \ / buffers(b) % total_accum ; @@ -1572,14 +1650,16 @@ subroutine operate2i_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else out_array = (out_array * \ (buffers(b) % total_accum - 1) + in_array) \ / buffers(b) % total_accum ; @@ -1607,14 +1687,16 @@ subroutine operate3i_avg (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else out_array = (out_array * \ (buffers(b) % total_accum - 1) + in_array) \ / buffers(b) % total_accum ; @@ -1642,14 +1724,16 @@ subroutine operate0r_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -1677,14 +1761,16 @@ subroutine operate1r_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -1712,14 +1798,16 @@ subroutine operate2r_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -1747,14 +1835,16 @@ subroutine operate3r_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -1782,14 +1872,16 @@ subroutine operate4r_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -1817,14 +1909,16 @@ subroutine operate5r_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -1852,14 +1946,16 @@ subroutine operate0i_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -1887,14 +1983,16 @@ subroutine operate1i_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -1922,14 +2020,16 @@ subroutine operate2i_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -1957,14 +2057,16 @@ subroutine operate3i_min (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -1992,14 +2094,16 @@ subroutine operate0r_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -2027,14 +2131,16 @@ subroutine operate1r_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -2062,14 +2168,16 @@ subroutine operate2r_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -2097,14 +2205,16 @@ subroutine operate3r_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -2132,14 +2242,16 @@ subroutine operate4r_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -2167,14 +2279,16 @@ subroutine operate5r_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -2202,14 +2316,16 @@ subroutine operate0i_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -2237,14 +2353,16 @@ subroutine operate1i_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -2272,14 +2390,16 @@ subroutine operate2i_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; @@ -2307,14 +2427,16 @@ subroutine operate3i_max (start_block, tvar) tvar % input_name, in_array, 1) do b = 1, size(buffers) + if (.not. buffers(b) % accumulate_flag) then + cycle + end if + + call mpas_pool_get_array(block % allFields, & + tvar % output_names(b), out_array, 1) + if (buffers(b) % reset_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) out_array = in_array - else if (buffers(b) % accumulate_flag) then - call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) - + else ! out_array = (out_array * \ ! (buffers(b) % total_accum - 1) + in_array) \ ! / buffers(b) % total_accum ; From 012dea8fc8b9662cb4748a811fc17a3653c56b30 Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Sat, 22 Aug 2015 14:17:28 -0600 Subject: [PATCH 0156/1724] Added counters to the output stream. --- .../Registry_time_series_stats.xml | 15 +++++++- .../mpas_ocn_time_series_stats.F | 38 ++++++++++++++++--- 2 files changed, 46 insertions(+), 7 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_time_series_stats.xml b/src/core_ocean/analysis_members/Registry_time_series_stats.xml index ac280fe45a..82d86f71aa 100644 --- a/src/core_ocean/analysis_members/Registry_time_series_stats.xml +++ b/src/core_ocean/analysis_members/Registry_time_series_stats.xml @@ -73,7 +73,7 @@ /> + + + + have a special case of normalizing the data before writing it !> to disk). !----------------------------------------------------------------------- - subroutine operate0r_avg (start_block, tvar) type (block_type), pointer, intent(in) :: start_block type (time_variable_type), intent(inout) :: tvar From a28b2f2a783900147a3197fae79392111fd2d778 Mon Sep 17 00:00:00 2001 From: Luke Van Roekel Date: Mon, 24 Aug 2015 11:56:46 -0600 Subject: [PATCH 0157/1724] added a flag to Registry_mixed_layer_depths to compute on start up and not just write --- .../analysis_members/Registry_mixed_layer_depths.xml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml index 652adfea27..6b3abde94d 100644 --- a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml +++ b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml @@ -26,6 +26,10 @@ description="Logical flag determining if an analysis member write occurs on start-up." possible_values=".true. or .false." /> + Date: Tue, 25 Aug 2015 13:36:52 -0600 Subject: [PATCH 0158/1724] registry for MLD was modified to include latCell and lonCell in stream for easy plotting the analysis member had a few logical errors, such as recomputing the MLD even after it was found at the previous depth level. It was also modified to include constraints that the MLD fall between the two values of zMid of interest. This prevents extrapolation producing bad values. This was evident in very coarse simulations where the temperature changed quickly between the first and second levels --- .../Registry_mixed_layer_depths.xml | 4 +- .../mpas_ocn_mixed_layer_depths.F | 64 +++++++++++++------ 2 files changed, 46 insertions(+), 22 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml index 6b3abde94d..1f9c6b1019 100644 --- a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml +++ b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml @@ -101,7 +101,9 @@ clobber_mode="truncate" runtime_format="single_file"> - + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F index fcea768c3b..c7e28fb5c7 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F +++ b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F @@ -186,8 +186,9 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ real (kind=RKIND), pointer :: refPress real (kind=RKIND), allocatable, dimension(:,:) :: gradientBins, thresholdBins real (kind=RKIND), allocatable, dimension(:,:) :: densityGradient, temperatureGradient - real (kind=RKIND) :: dTempThres, dDenThres, dTempGrad, dDenGrad - real (kind=RKIND) :: dz,temp_ref_lev, den_ref_lev, dV, dVm1, dVp1 + real (kind=RKIND) :: mldTemp,dTempThres, dDenThres, dTempGrad, dDenGrad + real (kind=RKIND) :: dz,temp_ref_lev, den_ref_lev, dV, dVm1, dVp1, localVals(6) + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell err = 0 dminfo = domain % dminfo @@ -236,6 +237,8 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ call mpas_pool_get_array(diagnosticsPool, 'pressure', pressure) call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) call mpas_pool_get_array(diagnosticsPool, 'zTop', zTop) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) if(thresholdFlag) then call mpas_pool_get_array(mixedLayerDepthsAMPool, 'thresholdMLD',thresholdMLD) @@ -257,37 +260,50 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ do k=1, maxLevelCell(iCell) if(pressure(k+1,iCell) > refPress) then - call interp_bw_levels(tracers(index_temperature,k,iCell),tracers(index_temperature,k+1,iCell), & - pressure(k,iCell),pressure(k+1,iCell),refPress,interp_local, & - pressure(k-1,iCell),tracers(index_temperature,k-1,iCell),temp_ref_lev) - - call interp_bw_levels(potentialDensity(k,iCell),potentialDensity(k+1,iCell), & - pressure(k,iCell),pressure(k+1,iCell),refPress,interp_local, & - pressure(k-1,iCell),potentialDensity(k-1,iCell),den_ref_lev) + localvals(2:3)=tracers(index_temperature,k:k+1,iCell) + localvals(5:6)=pressure(k:k+1,iCell) + + call interp_bw_levels(localVals(2),localVals(3), & + localVals(5),localVals(6),refPress,interp_local, & + temp_ref_lev) + + localVals(2:3)=potentialDensity(k:k+1,iCell) + call interp_bw_levels(localVals(2),localVals(3), & + localVals(5),localVals(6),refPress,interp_local, & + den_ref_lev) - refIndex = k+1 + refIndex = k exit endif enddo + do i=1,nThresholdBins do k=refIndex,maxLevelCell(iCell) - if( abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) .ge. thresholdBins(1,i)) then + if(.not. found_temp_mld .and. abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) .ge. thresholdBins(1,i)) then dVp1 = abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) dV = abs(tracers(index_temperature,k ,iCell) - temp_ref_lev) dVm1 = abs(tracers(index_temperature,k-1,iCell) - temp_ref_lev) - call interp_bw_levels(zMid(k,iCell),zMid(k+1,iCell), dV, dVp1, thresholdBins(1,i), & - interp_local, dVm1, zMid(k-1,iCell), thresholdMLD(1,i,iCell)) + localVals(1:3)=zMid(k-1:k+1,iCell) + call interp_bw_levels(localVals(2),localVals(3), dV, dVp1, thresholdBins(1,i), & + interp_local, mldTemp)!,dVm1, localVals(1)) + mldTemp=max(mldTemp,zMid(k+1,iCell)) !make sure MLD isn't deeper than zMid(k+1) + thresholdMLD(1,i,iCell)=min(mldTemp,zMid(k,iCell)) !MLD should be deeper than zMid(k) found_temp_mld = .true. endif - if( abs(potentialDensity(k+1,iCell) - den_ref_lev) .ge. thresholdBins(2,i)) then + if( .not. found_den_mld .and. abs(potentialDensity(k,iCell) - den_ref_lev) .ge. thresholdBins(2,i)) then dVp1 = abs(potentialDensity(k+1,iCell) - den_ref_lev) dV = abs(potentialDensity(k ,iCell) - den_ref_lev) dVm1 = abs(potentialDensity(k-1,iCell) - den_ref_lev) - call interp_bw_levels(zMid(k,iCell),zMid(k+1,iCell), dV, dVp1, thresholdBins(2,i), & - interp_local, dVm1, zMid(k-1,iCell), thresholdMLD(2,i,iCell)) + localVals(1:3)=zMid(k-1:k+1,iCell) + call interp_bw_levels(localVals(2),localVals(3), dV, dVp1, thresholdBins(2,i), & + interp_local, mldTemp)!,dVm1,localVals(1)) + + mldTemp=max(mldTemp,zMid(k+1,iCell)) !make sure MLD isn't deeper than zMid(k+1) + thresholdMLD(2,i,iCell)=min(mldTemp,zMid(k,iCell)) !MLD should be deeper than zMid(k) + found_den_mld = .true. endif @@ -299,6 +315,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ if(.not. found_temp_mld) thresholdMLD(1,i,iCell) = zMid(maxLevelCell(iCell),iCell) enddo !i=1,nThresholdBins enddo !iCell + endif !if thresholdflag ! Compute the mixed layer depth based on a gradient threshold in temperature and density @@ -344,14 +361,19 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ do i=1, nGradientBins do k=2, maxLevelCell(iCell) - if(densityGradient(1,k+1) .ge. gradientBins(2,i)) then + if(.not. found_den_mld .and. densityGradient(1,k+1) .ge. gradientBins(2,i)) then call interp_bw_levels(zTop(k,iCell),zTop(k+1,iCell),densityGradient(k,1),densityGradient(k+1,1), & - gradientBins(2,i), interp_local,densityGradient(k-1,1),zTop(k-1,iCell), gradientMLD(2,i,iCell)) + gradientBins(2,i), interp_local,mldTemp,densityGradient(k-1,1),zTop(k-1,iCell)) + mldTemp=max(mldTemp,zTop(k+1,iCell)) !make sure MLD isn't deeper than zMid(k+1) + gradientMLD(2,i,iCell)=min(mldTemp,zTop(k,iCell)) !MLD should be deeper than zMid(k) found_den_mld=.true. endif - if(temperatureGradient(k+1,1) .ge. gradientBins(1,i)) then + if(.not. found_temp_mld .and. temperatureGradient(k+1,1) .ge. gradientBins(1,i)) then call interp_bw_levels(zTop(k,iCell),zTop(k+1,iCell),temperatureGradient(k,1),temperatureGradient(k+1,1), & - gradientBins(1,i), interp_local,temperatureGradient(k-1,1),zTop(k-1,iCell), gradientMLD(1,i,iCell)) + gradientBins(1,i), interp_local,mldTemp,temperatureGradient(k-1,1),zTop(k-1,iCell)) + mldTemp=max(mldTemp,zTop(k+1,iCell)) !make sure MLD isn't deeper than zMid(k+1) + gradientMLD(1,i,iCell)=min(mldTemp,zTop(k,iCell)) !MLD should be deeper than zMid(k) + found_temp_mld=.true. endif @@ -408,7 +430,7 @@ end subroutine ocn_compute_mixed_layer_depths!}}} ! !----------------------------------------------------------------------- - subroutine interp_bw_levels(y0,y1,x0,x1,xT,interp_f,xm1,ym1,yT)!{{{ + subroutine interp_bw_levels(y0,y1,x0,x1,xT,interp_f,yT,xm1,ym1)!{{{ integer,intent(in) :: interp_f ! linear, quadratic, or spline real(kind=RKIND),intent(in) :: y0,y1,x0,x1,xT From a774bf778bdd91388f50d4145c72ba0aa8ed3457 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Wed, 26 Aug 2015 08:51:49 -0600 Subject: [PATCH 0159/1724] Adding the analysis member infrastructure to the build system This commit adds the analysis member infrastructure to the landice core's build system. It also cleans up some include statements in the different landice make files, and adds a .gitignore to ignore .f90 files when GEN_F90=true. Currently there are no calls to the analysis driver so, it doesn't actually do anything other than build yet. --- src/core_landice/.gitignore | 1 + src/core_landice/Makefile | 16 +- src/core_landice/Registry.xml | 1 + src/core_landice/analysis_members/Makefile | 24 + .../analysis_members/Registry_TEMPLATE.xml | 57 ++ .../Registry_analysis_members.xml | 1 + .../analysis_members/mpas_li_TEMPLATE.F | 361 ++++++++ .../mpas_li_analysis_driver.F | 808 ++++++++++++++++++ src/core_landice/mode_forward/Makefile | 6 +- src/core_landice/shared/Makefile | 6 +- 10 files changed, 1274 insertions(+), 7 deletions(-) create mode 100644 src/core_landice/.gitignore create mode 100644 src/core_landice/analysis_members/Makefile create mode 100644 src/core_landice/analysis_members/Registry_TEMPLATE.xml create mode 100644 src/core_landice/analysis_members/Registry_analysis_members.xml create mode 100644 src/core_landice/analysis_members/mpas_li_TEMPLATE.F create mode 100644 src/core_landice/analysis_members/mpas_li_analysis_driver.F diff --git a/src/core_landice/.gitignore b/src/core_landice/.gitignore new file mode 100644 index 0000000000..b2c8b2f700 --- /dev/null +++ b/src/core_landice/.gitignore @@ -0,0 +1 @@ +*.f90 diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index 71fbb2e040..8f814d70a9 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -1,16 +1,22 @@ .SUFFIXES: .F .o .cpp -.PHONY: mode_forward shared +.PHONY: mode_forward shared analysis_members + +SHARED_INCLUDES = -I$(PWD)/../framework -I$(PWD)/../external/esmf_time_f90 -I$(PWD)/../operators +SHARED_INCLUDES += -I$(PWD)/shared -I$(PWD)/analysis_members -I$(PWD)/mode_forward all: core_landice shared: - (cd shared; $(MAKE)) + (cd shared; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(SHARED_INCLUDES)") + +analysis_members: shared + (cd analysis_members; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(SHARED_INCLUDES)") -mode_forward: shared - (cd mode_forward; $(MAKE)) +mode_forward: shared analysis_members + (cd mode_forward; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(SHARED_INCLUDES)") -core_landice: mode_forward shared +core_landice: mode_forward shared analysis_members ar -ru libdycore.a `find . -type f -name "*.o"` core_input_gen: diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 68f43bcb61..ee9621e335 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -790,5 +790,6 @@ is the value of that variable from the *previous* time level! +#include "analysis_members/Registry_analysis_members.xml" diff --git a/src/core_landice/analysis_members/Makefile b/src/core_landice/analysis_members/Makefile new file mode 100644 index 0000000000..4f76b4638f --- /dev/null +++ b/src/core_landice/analysis_members/Makefile @@ -0,0 +1,24 @@ +.SUFFIXES: .F .c .o + +OBJS = mpas_li_analysis_driver.o + +MEMBERS = + +all: $(OBJS) + +mpas_li_analysis_driver.o: $(MEMBERS) + +clean: + $(RM) *.o *.i *.mod *.f90 + +.F.o: + $(RM) $@ $*.mod +ifeq "$(GEN_F90)" "true" + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) +else + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) +endif + +.c.o: + $(CC) $(CPPFLAGS) $(CFLAGS) $(CINCLUDES) -c $< diff --git a/src/core_landice/analysis_members/Registry_TEMPLATE.xml b/src/core_landice/analysis_members/Registry_TEMPLATE.xml new file mode 100644 index 0000000000..7781514365 --- /dev/null +++ b/src/core_landice/analysis_members/Registry_TEMPLATE.xml @@ -0,0 +1,57 @@ + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_landice/analysis_members/Registry_analysis_members.xml b/src/core_landice/analysis_members/Registry_analysis_members.xml new file mode 100644 index 0000000000..ff45f26355 --- /dev/null +++ b/src/core_landice/analysis_members/Registry_analysis_members.xml @@ -0,0 +1 @@ +//#include "Registry_TEMPLATE.xml" diff --git a/src/core_landice/analysis_members/mpas_li_TEMPLATE.F b/src/core_landice/analysis_members/mpas_li_TEMPLATE.F new file mode 100644 index 0000000000..0ded880b3f --- /dev/null +++ b/src/core_landice/analysis_members/mpas_li_TEMPLATE.F @@ -0,0 +1,361 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! li_TEM_PLATE +! +!> \brief MPAS land ice analysis mode member: TEM_PLATE +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE +!> \details +!> MPAS land ice analysis mode member: TEM_PLATE +!> In order to add a new analysis member, do the following: +!> 1. Copy these to your new analysis member name: +!> cp mpas_li_TEMPLATE.F mpas_li_your_new_name.F +!> cp Registry_TEMPLATE.xml Registry_your_new_name.xml +!> +!> 2. In those two new files, replace the following text: +!> tempLate, TEM_PLATE, FILL_IN_AUTHOR, FILL_IN_DATE +!> Typically tempLate uses camel case (variable names), like yourNewName, +!> while TEM_PLATE uses underscores (subroutine names), like your_new_name. +!> note: do not replace 'filename_template' in Registry_li_yourNewName.xml +!> +!> 3. Add a #include line for your registry to +!> Registry_analysis_members.xml +!> +!> 4. In mpas_li_analysis_driver.F, add a use statement for your new analysis member. +!> In addition, add lines for your analysis member, and replace TEM_PLATE +!> and temPlate as described in step 2. There should be 5 places that need additions: +!> - Adding the analysis member name to the analysis member list +!> - Adding an init if test can subroutine call +!> - Adding a compute if test can subroutine call +!> - Adding a restart if test can subroutine call +!> - Adding a finalize if test can subroutine call +!> +!> 5. In src/core_landice/analysis_members/Makefile, add your +!> new analysis member to the list of members. See another analysis member +!> in that file for an example. +!> NOTE: If your analysis member depends on other files, add a dependency +!> line for the member and list them there. See okubo weiss for an example. +!> +!----------------------------------------------------------------------- + +module li_TEM_PLATE + + use mpas_derived_types + use mpas_pool_routines + use mpas_dmpar + use mpas_timekeeping + use mpas_stream_manager + + use li_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: li_init_TEM_PLATE, & + li_compute_TEM_PLATE, & + li_restart_TEM_PLATE, & + li_finalize_TEM_PLATE + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine li_init_TEM_PLATE +! +!> \brief Initialize MPAS-Land Ice analysis member +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE +!> \details +!> This routine conducts all initializations required for the +!> MPAS-Land Ice analysis member. +! +!----------------------------------------------------------------------- + + subroutine li_init_TEM_PLATE(domain, memberName, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + character (len=*), intent(in) :: memberName + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine li_init_TEM_PLATE!}}} + +!*********************************************************************** +! +! routine li_compute_TEM_PLATE +! +!> \brief Compute MPAS-Land Ice analysis member +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE +!> \details +!> This routine conducts all computation required for this +!> MPAS-Land Ice analysis member. +! +!----------------------------------------------------------------------- + + subroutine li_compute_TEM_PLATE(domain, memberName, timeLevel, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + integer, intent(in) :: timeLevel + character (len=*), intent(in) :: memberName + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: temPlateAMPool + type (dm_info) :: dminfo + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: scratchPool + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: temPlateAM + + ! Here are some example variables which may be needed for your analysis member + integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, num_tracers + integer :: iTracer, k, iCell + integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop, maxLevelVertexBot + + real (kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge + + err = 0 + + dminfo = domain % dminfo + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'temPlateAM', temPlateAMPool) + + ! Here are some example variables which may be needed for your analysis member + call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(block % dimensions, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(block % dimensions, 'nVerticesSolve', nVerticesSolve) + + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + call mpas_pool_get_array(meshPool, 'maxLevelVertexBot', maxLevelVertexBot) + + ! Computations which are functions of nCells, nEdges, or nVertices + ! must be placed within this block loop + ! Here are some example loops + do iCell = 1,nCellsSolve + do k = 1, maxLevelCell(iCell) + do iTracer = 1, num_tracers + ! computations on tracers(iTracer,k, iCell) + end do + end do + end do + + block => block % next + end do + + ! mpi gather/scatter calls may be placed here. + ! Here are some examples. See mpas_oac_global_stats.F for further details. +! call mpas_dmpar_sum_real_array(dminfo, nVariables, sumSquares(1:nVariables), reductions(1:nVariables)) +! call mpas_dmpar_min_real_array(dminfo, nMins, mins(1:nMins), reductions(1:nMins)) +! call mpas_dmpar_max_real_array(dminfo, nMaxes, maxes(1:nMaxes), reductions(1:nMaxes)) + + ! Even though some variables do not include an index that is decomposed amongst + ! domain partitions, we assign them within a block loop so that all blocks have the + ! correct values for writing output. + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'temPlateAM', temPlateAMPool) + + ! assignment of final temPlateAM variables could occur here. + + block => block % next + end do + + end subroutine li_compute_TEM_PLATE!}}} + +!*********************************************************************** +! +! routine li_restart_TEM_PLATE +! +!> \brief Save restart for MPAS-Land Ice analysis member +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE +!> \details +!> This routine conducts computation required to save a restart state +!> for the MPAS-Land Ice analysis member. +! +!----------------------------------------------------------------------- + + subroutine li_restart_TEM_PLATE(domain, memberName, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + character (len=*), intent(in) :: memberName + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine li_restart_TEM_PLATE!}}} + +!*********************************************************************** +! +! routine li_finalize_TEM_PLATE +! +!> \brief Finalize MPAS-Land Ice analysis member +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE +!> \details +!> This routine conducts all finalizations required for this +!> MPAS-Land Ice analysis member. +! +!----------------------------------------------------------------------- + + subroutine li_finalize_TEM_PLATE(domain, memberName, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + character (len=*), intent(in) :: memberName + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine li_finalize_TEM_PLATE!}}} + +end module li_TEM_PLATE + +! vim: foldmethod=marker diff --git a/src/core_landice/analysis_members/mpas_li_analysis_driver.F b/src/core_landice/analysis_members/mpas_li_analysis_driver.F new file mode 100644 index 0000000000..67ece45fc2 --- /dev/null +++ b/src/core_landice/analysis_members/mpas_li_analysis_driver.F @@ -0,0 +1,808 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! li_analysis_driver +! +!> \brief Driver for MPAS Land Ice analysis members +!> \author MPAS-LI Team +!> \date November 2013 +!> \details +!> This is the driver for the MPAS Land Ice members. +! +!----------------------------------------------------------------------- + +module li_analysis_driver + + use mpas_derived_types + use mpas_pool_routines + use mpas_timekeeping + use mpas_timer + use mpas_stream_manager + + use li_constants +! use li_TEM_PLATE + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: li_analysis_setup_packages, & + li_analysis_init, & + li_analysis_compute_startup, & + li_analysis_compute, & + li_analysis_write, & + li_analysis_restart, & + li_analysis_finalize + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + + character (len=*), parameter :: initTimerPrefix = 'init_' + character (len=*), parameter :: computeTimerPrefix = 'compute_' + character (len=*), parameter :: writeTimerPrefix = 'write_' + character (len=*), parameter :: alarmTimerPrefix = 'reset_alarm_' + character (len=*), parameter :: restartTimerPrefix = 'restart_' + character (len=*), parameter :: finalizeTimerPrefix = 'finalize_' + character (len=*), parameter :: computeAlarmSuffix = 'CMPALRM' + type (mpas_pool_type), pointer :: analysisMemberList + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine li_analysis_setup_packages +! +!> \brief Setup packages for MPAS-Land Ice analysis driver +!> \author MPAS-LI Team +!> \date November 2013 +!> \details +!> This routine is intended to configure the packages for all +!> Land Ice analysis members. +! +!----------------------------------------------------------------------- + + subroutine li_analysis_setup_packages(configPool, packagePool, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: configPool + type (mpas_pool_type), intent(in) :: packagePool + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: err_tmp + + character (len=StrKIND) :: configName, packageName + logical, pointer :: config_AM_enable + logical, pointer :: AMPackageActive + type (mpas_pool_iterator_type) :: poolItr + integer :: nameLength + + err = 0 + + call mpas_pool_create_pool(analysisMemberList) +! call mpas_pool_add_config(analysisMemberList, 'temPlate', 1) + + ! DON'T EDIT BELOW HERE + + ! Iterate over all analysis members to setup packages + call mpas_pool_begin_iteration(analysisMemberList) + do while ( mpas_pool_get_next_member(analysisMemberList, poolItr) ) + nameLength = len_trim(poolItr % memberName) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_enable' + call mpas_pool_get_config(configPool, configName, config_AM_enable) + + if ( config_AM_enable ) then + packageName = poolItr % memberName(1:nameLength) // 'AMPKGActive' + call mpas_pool_get_package(packagePool, packageName, AMPackageActive) + AMPackageActive = .true. + end if + end do + + end subroutine li_analysis_setup_packages!}}} + +!*********************************************************************** +! +! routine li_analysis_init +! +!> \brief Initialize MPAS-Land Ice analysis driver +!> \author MPAS-LI Team +!> \date November 2013 +!> \details +!> This routine calls all initializations required for the +!> MPAS-Land Ice analysis driver. +! +!----------------------------------------------------------------------- + + subroutine li_analysis_init(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: err_tmp + + character (len=StrKIND) :: configName, alarmName, streamName, timerName + logical, pointer :: config_AM_enable + character (len=StrKIND), pointer :: config_AM_compute_interval, config_AM_stream_name + integer :: nameLength + type (mpas_pool_iterator_type) :: poolItr + + logical :: streamFound + character (len=StrKIND) :: referenceTimeString, outputIntervalString + type (MPAS_Time_Type) :: referenceTime + type (MPAS_TimeInterval_type) :: alarmTimeStep + + err = 0 + + call mpas_timer_start('analysis_init', .false.) + + call mpas_pool_begin_iteration(analysisMemberList) + do while ( mpas_pool_get_next_member(analysisMemberList, poolItr) ) + nameLength = len_trim(poolItr % memberName) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_enable' + call mpas_pool_get_config(domain % configs, configName, config_AM_enable) + + if ( config_AM_enable ) then + timerName = trim(initTimerPrefix) // poolItr % memberName(1:nameLength) + call mpas_timer_start(timerName, .false.) + call li_init_analysis_members(domain, poolItr % memberName, err_tmp) + err = ior(err, err_tmp) + + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_compute_interval' + call mpas_pool_get_config(domain % configs, configName, config_AM_compute_interval) + + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_stream_name' + call mpas_pool_get_config(domain % configs, configName, config_AM_stream_name) + + if ( config_AM_compute_interval == 'dt' ) then + alarmTimeStep = mpas_get_clock_timestep(domain % clock, err_tmp) + call mpas_get_timeInterval(alarmTimeStep, timeString=config_AM_compute_interval, ierr=err_tmp) + end if + + ! Verify stream exists before trying to use output_interval + if ( config_AM_stream_name /= 'none' ) then + streamFound = .false. + + call mpas_stream_mgr_begin_iteration(domain % streamManager) + do while ( mpas_stream_mgr_get_next_stream(domain % streamManager, streamName) ) + if ( trim(streamName) == trim(config_AM_stream_name) ) then + streamFound = .true. + end if + end do + + if ( .not. streamFound ) then + call mpas_dmpar_global_abort('ERROR: Stream ' // trim(config_AM_stream_name) // ' does not exist. Exiting...') + end if + end if + + + if ( config_AM_compute_interval /= 'output_interval' .and. config_AM_stream_name /= 'none') then + alarmName = poolItr % memberName(1:nameLength) // computeAlarmSuffix + call mpas_set_timeInterval(alarmTimeStep, timeString=config_AM_compute_interval, ierr=err_tmp) + call MPAS_stream_mgr_get_property(domain % streamManager, config_AM_stream_name, MPAS_STREAM_PROPERTY_REF_TIME, referenceTimeString, err_tmp) + call mpas_set_time(referenceTime, dateTimeString=referenceTimeString, ierr=err_tmp) + call mpas_add_clock_alarm(domain % clock, alarmName, referenceTime, alarmTimeStep, ierr=err_tmp) + call mpas_reset_clock_alarm(domain % clock, alarmName, ierr=err_tmp) + end if + call mpas_timer_stop(timerName) + end if + end do + + call mpas_timer_stop('analysis_init') + + end subroutine li_analysis_init!}}} + +!*********************************************************************** +! +! routine li_analysis_compute_startup +! +!> \brief Driver for MPAS-Land Ice analysis computations +!> \author MPAS-LI Team +!> \date November 2013 +!> \details +!> This routine calls all computation subroutines required for the +!> MPAS-Land Ice analysis driver. +! +!----------------------------------------------------------------------- + + subroutine li_analysis_compute_startup(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: timeLevel, err_tmp + + character (len=StrKIND) :: configName, timerName + character (len=StrKIND), pointer :: config_AM_stream_name + logical, pointer :: config_AM_enable, config_AM_write_on_startup, config_AM_compute_on_startup + type (mpas_pool_iterator_type) :: poolItr + integer :: nameLength + + err = 0 + + call mpas_timer_start('analysis_compute', .false.) + + timeLevel=1 + + call mpas_pool_begin_iteration(analysisMemberList) + do while ( mpas_pool_get_next_member(analysisMemberList, poolItr) ) + nameLength = len_trim(poolItr % memberName) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_enable' + call mpas_pool_get_config(domain % configs, configName, config_AM_enable) + + if ( config_AM_enable ) then + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_compute_on_startup' + call mpas_pool_get_config(domain % configs, configName, config_AM_compute_on_startup) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_write_on_startup' + call mpas_pool_get_config(domain % configs, configName, config_AM_write_on_startup) + + if ( config_AM_compute_on_startup ) then + timerName = trim(computeTimerPrefix) // poolItr % memberName(1:nameLength) + call mpas_timer_start(timerName, .false.) + call li_compute_analysis_members(domain, timeLevel, poolItr % memberName, err_tmp) + call mpas_timer_stop(timerName) + err = ior(err, err_tmp) + + if ( config_AM_write_on_startup ) then + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_stream_name' + call mpas_pool_get_config(domain % configs, configName, config_AM_stream_name) + if ( config_AM_stream_name /= 'none' ) then + call mpas_stream_mgr_write(domain % streamManager, streamID=config_AM_stream_name, forceWriteNow=.true., ierr=err_tmp) + end if + end if + else + if ( config_AM_write_on_startup ) then + write(stderrUnit, *) ' *** WARNING: write_on_startup called without compute_on_startup for analysis member: ' & + // poolItr % memberName(1:nameLength) // '. Skipping output...' + end if + end if + end if + end do + + call mpas_timer_stop('analysis_compute') + + end subroutine li_analysis_compute_startup!}}} + +!*********************************************************************** +! +! routine li_analysis_compute +! +!> \brief Driver for MPAS-Land Ice analysis computations +!> \author MPAS-LI Team +!> \date November 2013 +!> \details +!> This routine calls all computation subroutines required for the +!> MPAS-Land Ice analysis driver. +! +!----------------------------------------------------------------------- + + subroutine li_analysis_compute(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: timeLevel, err_tmp + + character (len=StrKIND) :: configName, alarmName, timerName + character (len=StrKIND), pointer :: config_AM_stream_name, config_AM_compute_interval + logical, pointer :: config_AM_enable + type (mpas_pool_iterator_type) :: poolItr + integer :: nameLength + + err = 0 + + call mpas_timer_start('analysis_compute', .false.) + + timeLevel=1 + + call mpas_pool_begin_iteration(analysisMemberList) + do while ( mpas_pool_get_next_member(analysisMemberList, poolItr) ) + nameLength = len_trim(poolItr % memberName) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_enable' + call mpas_pool_get_config(domain % configs, configName, config_AM_enable) + + if ( config_AM_enable ) then + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_compute_interval' + call mpas_pool_get_config(domain % configs, configName, config_AM_compute_interval) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_stream_name' + call mpas_pool_get_config(domain % configs, configName, config_AM_stream_name) + + ! Build name of alarm for analysis member + alarmName = poolItr % memberName(1:nameLength) // computeAlarmSuffix + timerName = trim(computeTimerPrefix) // poolItr % memberName(1:nameLength) + + ! Compute analysis member just before output + if ( config_AM_compute_interval == 'output_interval' .and. config_AM_stream_name /= 'none') then + if ( mpas_stream_mgr_ringing_alarms(domain % streamManager, streamID=config_AM_stream_name, direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) ) then + call mpas_timer_start(timerName, .false.) + call li_compute_analysis_members(domain, timeLevel, poolItr % memberName, err_tmp) + call mpas_timer_stop(timerName) + end if + else if ( mpas_is_alarm_ringing(domain % clock, alarmName, ierr=err_tmp) ) then + call mpas_reset_clock_alarm(domain % clock, alarmName, ierr=err_tmp) + call mpas_timer_start(timerName, .false.) + call li_compute_analysis_members(domain, timeLevel, poolItr % memberName, err_tmp) + call mpas_timer_stop(timerName) + end if + end if + end do + + call mpas_timer_stop('analysis_compute') + + end subroutine li_analysis_compute!}}} + +!*********************************************************************** +! +! routine li_analysis_restart +! +!> \brief Save restart for MPAS-Land Ice analysis driver +!> \author MPAS-LI Team +!> \date November 2013 +!> \details +!> This routine calls all subroutines required to prepare to save +!> the restart state for the MPAS-Land Ice analysis driver. +! +!----------------------------------------------------------------------- + + subroutine li_analysis_restart(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: err_tmp + + character (len=StrKIND) :: configName, timerName + type (mpas_pool_iterator_type) :: poolItr + logical, pointer :: config_AM_enable + integer :: nameLength + + err = 0 + + call mpas_timer_start('analysis_restart', .false.) + + call mpas_pool_begin_iteration(analysisMemberList) + do while ( mpas_pool_get_next_member(analysisMemberList, poolItr) ) + nameLength = len_trim(poolItr % memberName) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_enable' + call mpas_pool_get_config(domain % configs, configName, config_AM_enable) + + if ( config_AM_enable ) then + timerName = trim(restartTimerPrefix) // poolItr % memberName(1:nameLength) + call mpas_timer_start(timerName, .false.) + call li_restart_analysis_members(domain, poolItr % memberName, err_tmp) + err = ior(err, err_tmp) + call mpas_timer_stop(timerName) + end if + end do + + call mpas_timer_stop('analysis_restart') + + end subroutine li_analysis_restart!}}} + +!*********************************************************************** +! +! routine li_analysis_write +! +!> \brief Driver for MPAS-Land Ice analysis output +!> \author MPAS-LI Team +!> \date November 2013 +!> \details +!> This routine calls all output writing subroutines required for the +!> MPAS-Land Ice analysis driver. +!> At this time this is just a stub, and all analysis output is written +!> to the output file specified by config_output_name. +! +!----------------------------------------------------------------------- + + subroutine li_analysis_write(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: err_tmp + + character (len=StrKIND) :: configName, timerName + character (len=StrKIND), pointer :: config_AM_stream_name + logical, pointer :: config_AM_enable + type (mpas_pool_iterator_type) :: poolItr + integer :: nameLength + + err = 0 + + call mpas_timer_start('analysis_write', .false.) + + call mpas_pool_begin_iteration(analysisMemberList) + do while ( mpas_pool_get_next_member(analysisMemberList, poolItr) ) + nameLength = len_trim(poolItr % memberName) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_enable' + call mpas_pool_get_config(domain % configs, configName, config_AM_enable) + + if ( config_AM_enable ) then + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_stream_name' + call mpas_pool_get_config(domain % configs, configName, config_AM_stream_name) + if ( config_AM_stream_name /= 'none' ) then + timerName = trim(writeTimerPrefix) // poolItr % memberName(1:nameLength) + call mpas_timer_start(timerName, .false.) + call mpas_stream_mgr_write(domain % streamManager, streamID=config_AM_stream_name, ierr=err_tmp) + call mpas_timer_stop(timerName) + timerName = trim(alarmTimerPrefix) // poolItr % memberName(1:nameLength) + call mpas_timer_start(timerName, .false.) + call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID=config_AM_stream_name, ierr=err_tmp) + call mpas_timer_stop(timerName) + end if + end if + end do + + call mpas_timer_stop('analysis_write') + + end subroutine li_analysis_write!}}} + +!*********************************************************************** +! +! routine li_analysis_finalize +! +!> \brief Finalize MPAS-Land Ice analysis driver +!> \author MPAS-LI Team +!> \date November 2013 +!> \details +!> This routine calls all finalize routines required for the +!> MPAS-Land Ice analysis driver. +! +!----------------------------------------------------------------------- + + subroutine li_analysis_finalize(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: err_tmp + + character (len=StrKIND) :: configName, timerName + logical, pointer :: config_AM_enable + type (mpas_pool_iterator_type) :: poolItr + integer :: nameLength + + err = 0 + + call mpas_timer_start('analysis_finalize', .false.) + + call mpas_pool_begin_iteration(analysisMemberList) + + do while ( mpas_pool_get_next_member(analysisMemberList, poolItr) ) + nameLength = len_trim(poolItr % memberName) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_enable' + call mpas_pool_get_config(domain % configs, configName, config_AM_enable) + + if ( config_AM_enable ) then + timerName = trim(finalizeTimerPrefix) // poolItr % memberName(1:nameLength) + call mpas_timer_start(timerName, .false.) + call li_finalize_analysis_members(domain, poolItr % memberName, err_tmp) + err = ior(err, err_tmp) + call mpas_timer_stop(timerName) + end if + end do + + call mpas_timer_stop('analysis_finalize') + + end subroutine li_analysis_finalize!}}} + +!*********************************************************************** +! +! routine li_init_analysis_members +! +!> \brief Analysis member initialization driver +!> \author Doug Jacobsen +!> \date 07/01/2015 +!> \details +!> This private routine calls the correct init routine for each analysis member. +! +!----------------------------------------------------------------------- + subroutine li_init_analysis_members(domain, analysisMemberName, iErr)!{{{ + type (domain_type), intent(inout) :: domain !< Input: Domain information + character (len=*), intent(in) :: analysisMemberName !< Input: Name of analysis member + integer, intent(out) :: iErr !< Output: Error code + + integer :: nameLength, err_tmp + + iErr = 0 + + nameLength = len_trim(analysisMemberName) + +! if ( analysisMemberName(1:nameLength) == 'temPlate' ) then +! call li_init_TEM_PLATE(domain, analysisMemberName, err_tmp) + end if + + iErr = ior(iErr, err_tmp) + + end subroutine li_init_analysis_members!}}} + +!*********************************************************************** +! +! routine li_compute_analysis_members +! +!> \brief Analysis member compute driver +!> \author Doug Jacobsen +!> \date 07/01/2015 +!> \details +!> This private routine calls the correct compute routine for each analysis member. +! +!----------------------------------------------------------------------- + subroutine li_compute_analysis_members(domain, timeLevel, analysisMemberName, iErr)!{{{ + type (domain_type), intent(inout) :: domain !< Input: Domain information + integer, intent(in) :: timeLevel !< Input: Time level to compute with in analysis member + character (len=*), intent(in) :: analysisMemberName !< Input: Name of analysis member + integer, intent(out) :: iErr !< Output: Error code + + integer :: nameLength, err_tmp + + iErr = 0 + + nameLength = len_trim(analysisMemberName) + +! if ( analysisMemberName(1:nameLength) == 'temPlate' ) then +! call li_compute_TEM_PLATE(domain, analysisMemberName, timeLevel, err_tmp) + end if + + iErr = ior(iErr, err_tmp) + + end subroutine li_compute_analysis_members!}}} + +!*********************************************************************** +! +! routine li_restart_analysis_members +! +!> \brief Analysis member restart driver +!> \author Doug Jacobsen +!> \date 07/01/2015 +!> \details +!> This private routine calls the correct restart routine for each analysis member. +! +!----------------------------------------------------------------------- + subroutine li_restart_analysis_members(domain, analysisMemberName, iErr)!{{{ + type (domain_type), intent(inout) :: domain !< Input: Domain information + character (len=*), intent(in) :: analysisMemberName !< Input: Name of analysis member + integer, intent(out) :: iErr !< Output: Error code + + integer :: nameLength, err_tmp + + iErr = 0 + + nameLength = len_trim(analysisMemberName) + +! if ( analysisMemberName(1:nameLength) == 'temPlate' ) then +! call li_restart_TEM_PLATE(domain, analysisMemberName, err_tmp) + end if + + iErr = ior(iErr, err_tmp) + + end subroutine li_restart_analysis_members!}}} + +!*********************************************************************** +! +! routine li_finalize_analysis_members +! +!> \brief Analysis member finalize driver +!> \author Doug Jacobsen +!> \date 07/01/2015 +!> \details +!> This private routine calls the correct finalize routine for each analysis member. +! +!----------------------------------------------------------------------- + subroutine li_finalize_analysis_members(domain, analysisMemberName, iErr)!{{{ + type (domain_type), intent(inout) :: domain !< Input: Domain information + character (len=*), intent(in) :: analysisMemberName !< Input: Name of analysis member + integer, intent(out) :: iErr !< Output: Error code + + integer :: nameLength, err_tmp + + iErr = 0 + + nameLength = len_trim(analysisMemberName) + +! if ( analysisMemberName(1:nameLength) == 'temPlate' ) then +! call li_finalize_TEM_PLATE(domain, analysisMemberName, err_tmp) + end if + + iErr = ior(iErr, err_tmp) + + end subroutine li_finalize_analysis_members!}}} + +end module li_analysis_driver + +! vim: foldmethod=marker diff --git a/src/core_landice/mode_forward/Makefile b/src/core_landice/mode_forward/Makefile index 0ed905af2c..22d81c90eb 100644 --- a/src/core_landice/mode_forward/Makefile +++ b/src/core_landice/mode_forward/Makefile @@ -71,8 +71,12 @@ clean: .F.o: $(RM) $@ $*.mod +ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../../external/esmf_time_f90 -I../shared + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) +else + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) +endif .cpp.o: $(CXX) $(CXXFLAGS) -c $*.cpp $(CXINCLUDES) $(CPPINCLUDES) -lmpi_cxx -lstdc++ $(CPPFLAGS) diff --git a/src/core_landice/shared/Makefile b/src/core_landice/shared/Makefile index 0ffbc73bad..231262b2ff 100644 --- a/src/core_landice/shared/Makefile +++ b/src/core_landice/shared/Makefile @@ -15,8 +15,12 @@ clean: .F.o: $(RM) $@ $*.mod +ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) +else + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) +endif .cpp.o: $(CXX) $(CXXFLAGS) -c $*.cpp $(CXINCLUDES) $(CPPINCLUDES) -lmpi_cxx -lstdc++ $(CPPFLAGS) From a9140267ab7956d1453980bffb57ba6f6db88180 Mon Sep 17 00:00:00 2001 From: toddringler Date: Mon, 1 Jun 2015 16:00:24 -0600 Subject: [PATCH 0160/1724] Addition of tracer_groups registry files This commit introduces the tracer groups directory and registry files into the ocean core. Later these will be used to define groups of tracers. --- .../tracer_groups/Registry_TEMPLATEGRP.xml | 68 ++++++++ .../tracer_groups/Registry_activeTracers.xml | 145 ++++++++++++++++++ .../tracer_groups/Registry_debugTracers.xml | 115 ++++++++++++++ .../tracer_groups/Registry_tracers.xml | 3 + 4 files changed, 331 insertions(+) create mode 100644 src/core_ocean/tracer_groups/Registry_TEMPLATEGRP.xml create mode 100644 src/core_ocean/tracer_groups/Registry_activeTracers.xml create mode 100644 src/core_ocean/tracer_groups/Registry_debugTracers.xml create mode 100644 src/core_ocean/tracer_groups/Registry_tracers.xml diff --git a/src/core_ocean/tracer_groups/Registry_TEMPLATEGRP.xml b/src/core_ocean/tracer_groups/Registry_TEMPLATEGRP.xml new file mode 100644 index 0000000000..e2e908f0e0 --- /dev/null +++ b/src/core_ocean/tracer_groups/Registry_TEMPLATEGRP.xml @@ -0,0 +1,68 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/tracer_groups/Registry_activeTracers.xml b/src/core_ocean/tracer_groups/Registry_activeTracers.xml new file mode 100644 index 0000000000..456555dbf8 --- /dev/null +++ b/src/core_ocean/tracer_groups/Registry_activeTracers.xml @@ -0,0 +1,145 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/tracer_groups/Registry_debugTracers.xml b/src/core_ocean/tracer_groups/Registry_debugTracers.xml new file mode 100644 index 0000000000..b396bdf13a --- /dev/null +++ b/src/core_ocean/tracer_groups/Registry_debugTracers.xml @@ -0,0 +1,115 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/tracer_groups/Registry_tracers.xml b/src/core_ocean/tracer_groups/Registry_tracers.xml new file mode 100644 index 0000000000..bc28af3c36 --- /dev/null +++ b/src/core_ocean/tracer_groups/Registry_tracers.xml @@ -0,0 +1,3 @@ +#include "Registry_activeTracers.xml" +#include "Registry_debugTracers.xml" +//#include "Registry_TEMPLATEGRP.xml" From 28161632c66669c45a1df69fc604b22b299308e8 Mon Sep 17 00:00:00 2001 From: toddringler Date: Mon, 1 Jun 2015 16:00:24 -0600 Subject: [PATCH 0161/1724] Update the ocean core to use the newer tracer groups This commit updates the ocean core to utilize the newer tracer groups, instead of the older tracer infrastructure. --- src/core_ocean/Registry.xml | 122 +++--- .../Registry_high_frequency_output.xml | 8 +- .../analysis_members/mpas_ocn_global_stats.F | 23 +- .../mpas_ocn_high_frequency_output.F | 14 +- .../mpas_ocn_meridional_heat_transport.F | 11 +- .../mpas_ocn_surface_area_weighted_averages.F | 90 ++-- .../analysis_members/mpas_ocn_zonal_mean.F | 29 +- .../driver/mpas_ocn_core_interface.F | 104 ++++- .../mode_analysis/mpas_ocn_analysis_mode.F | 4 +- .../mode_forward/mpas_ocn_forward_mode.F | 2 +- .../mpas_ocn_time_integration_rk4.F | 148 +++++-- .../mpas_ocn_time_integration_split.F | 156 +++++-- src/core_ocean/shared/Makefile | 33 +- src/core_ocean/shared/mpas_ocn_diagnostics.F | 50 ++- .../shared/mpas_ocn_equation_of_state.F | 16 +- src/core_ocean/shared/mpas_ocn_forcing.F | 60 +-- src/core_ocean/shared/mpas_ocn_forcing_bulk.F | 220 ---------- .../shared/mpas_ocn_forcing_restoring.F | 3 + .../shared/mpas_ocn_init_routines.F | 73 ++-- .../shared/mpas_ocn_surface_bulk_forcing.F | 405 ++++++++++++++++++ src/core_ocean/shared/mpas_ocn_tendency.F | 377 ++++++++++++---- src/core_ocean/shared/mpas_ocn_tracer_TTD.F | 156 +++++++ .../mpas_ocn_tracer_exponential_decay.F | 163 +++++++ .../shared/mpas_ocn_tracer_ideal_age.F | 166 +++++++ .../mpas_ocn_tracer_interior_restoring.F | 163 +++++++ ...=> mpas_ocn_tracer_surface_flux_to_tend.F} | 6 +- .../mpas_ocn_tracer_surface_restoring.F | 157 +++++++ src/core_ocean/shared/mpas_ocn_vmix.F | 26 +- .../shared/mpas_ocn_vmix_coefs_rich.F | 32 +- 29 files changed, 2161 insertions(+), 656 deletions(-) delete mode 100644 src/core_ocean/shared/mpas_ocn_forcing_bulk.F create mode 100644 src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F create mode 100644 src/core_ocean/shared/mpas_ocn_tracer_TTD.F create mode 100644 src/core_ocean/shared/mpas_ocn_tracer_exponential_decay.F create mode 100644 src/core_ocean/shared/mpas_ocn_tracer_ideal_age.F create mode 100644 src/core_ocean/shared/mpas_ocn_tracer_interior_restoring.F rename src/core_ocean/shared/{mpas_ocn_tracer_surface_flux.F => mpas_ocn_tracer_surface_flux_to_tend.F} (98%) create mode 100644 src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 77e445d081..24f73bf7e4 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -575,8 +575,17 @@ + + + - + + @@ -967,7 +977,7 @@ - + @@ -1046,7 +1056,7 @@ mode="forward;analysis"> - + @@ -1065,7 +1075,7 @@ mode="forward;analysis"> - + @@ -1092,7 +1102,7 @@ mode="forward"> - + @@ -1221,7 +1231,7 @@ - + @@ -1245,11 +1255,14 @@ + @@ -1307,18 +1320,8 @@ + - - - - - @@ -1607,17 +1610,6 @@ /> - - - - - - - - - - - - + + - - - - + - + #include "mode_init/Registry.xml" +#include "tracer_groups/Registry_tracers.xml" #include "analysis_members/Registry_analysis_members.xml" diff --git a/src/core_ocean/analysis_members/Registry_high_frequency_output.xml b/src/core_ocean/analysis_members/Registry_high_frequency_output.xml index fa992c2c54..40c678a410 100644 --- a/src/core_ocean/analysis_members/Registry_high_frequency_output.xml +++ b/src/core_ocean/analysis_members/Registry_high_frequency_output.xml @@ -30,11 +30,11 @@ - - + - @@ -53,7 +53,7 @@ - + diff --git a/src/core_ocean/analysis_members/mpas_ocn_global_stats.F b/src/core_ocean/analysis_members/mpas_ocn_global_stats.F index c989190b72..8c468da1b0 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_global_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_global_stats.F @@ -143,7 +143,7 @@ subroutine ocn_init_global_stats(domain, err)!{{{ write (fileID,'(/,a)') 'A chain of simple unix commands may be used to access a specific part of the data. For example,' write (fileID,'(a)') 'to view the last three values of column seven in the global average, use:' write (fileID,'(a)') "cat stats_avg.txt | awk '{print $7}' | tail -n3" - + close (fileID) endif @@ -218,6 +218,7 @@ subroutine ocn_compute_global_stats(domain, timeLevel, err)!{{{ type (dm_info) :: dminfo type (block_type), pointer :: block type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tracersPool type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: scratchPool type (mpas_pool_type), pointer :: diagnosticsPool @@ -227,7 +228,7 @@ subroutine ocn_compute_global_stats(domain, timeLevel, err)!{{{ integer :: elementIndex, variableIndex, nVariables, nSums, nMaxes, nMins integer :: k, i, fileID integer :: timeYYYY, timeMM, timeDD, timeH, timeM, timeS - integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, num_tracers + integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, num_activeTracers character*1 timeChar integer, parameter :: kMaxVariables = 1024 ! this must be a little more than double the number of variables to be reduced integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop, maxLevelVertexBot @@ -239,7 +240,8 @@ subroutine ocn_compute_global_stats(domain, timeLevel, err)!{{{ real (kind=RKIND), dimension(:,:), pointer :: layerThickness, normalVelocity, tangentialVelocity, layerThicknessEdge, relativeVorticity, kineticEnergyCell, & normalizedRelativeVorticityEdge, normalizedPlanetaryVorticityEdge, pressure, montgomeryPotential, vertAleTransportTop, vertVelocityTop, & lowFreqDivergence, highFreqThickness, density - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers real (kind=RKIND), dimension(:), pointer :: minGlobalStats,maxGlobalStats,sumGlobalStats, averages, rms, verticalSumMins, verticalSumMaxes real (kind=RKIND), dimension(kMaxVariables) :: sumSquares, reductions, sums, mins, maxes @@ -288,12 +290,13 @@ subroutine ocn_compute_global_stats(domain, timeLevel, err)!{{{ call mpas_pool_get_dimension(block % dimensions, 'nVerticesSolve', nVerticesSolve) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'globalStatsAM', globalStatsAMPool) - call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + call mpas_pool_get_dimension(tracersPool, 'num_activeTracers', num_activeTracers) call mpas_pool_get_array(meshPool, 'areaCell', areaCell) call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) @@ -305,7 +308,7 @@ subroutine ocn_compute_global_stats(domain, timeLevel, err)!{{{ call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, 1) - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) if(thicknessFilterActive) then call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergence, 1) call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThickness, 1) @@ -508,10 +511,10 @@ subroutine ocn_compute_global_stats(domain, timeLevel, err)!{{{ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex)) end if - ! Tracers - do iTracer=1,num_tracers + ! active Tracers + do iTracer=1,num_activeTracers variableIndex = variableIndex + 1 - workArray = Tracers(iTracer,:,1:nCellsSolve) + workArray = activeTracers(iTracer,:,1:nCellsSolve) call ocn_compute_field_volume_weighted_local_stats_max_level(dminfo, nVertLevels, nCellsSolve, maxLevelCell(1:nCellsSolve), areaCell(1:nCellsSolve), layerThickness(:,1:nCellsSolve), & workArray, sums_tmp(variableIndex), sumSquares_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), & verticalSumMaxes_tmp(variableIndex)) @@ -682,8 +685,8 @@ subroutine ocn_compute_global_stats(domain, timeLevel, err)!{{{ rms(variableIndex) = 0.0_RKIND end if - ! Tracers - do iTracer=1,num_tracers + ! active tracers + do iTracer=1,num_activeTracers variableIndex = variableIndex + 1 averages(variableIndex) = sums(variableIndex)/volumeCellGlobal rms(variableIndex) = sqrt(sumSquares(variableIndex)/volumeCellGlobal) diff --git a/src/core_ocean/analysis_members/mpas_ocn_high_frequency_output.F b/src/core_ocean/analysis_members/mpas_ocn_high_frequency_output.F index 38e3675394..1ab71450c7 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_high_frequency_output.F +++ b/src/core_ocean/analysis_members/mpas_ocn_high_frequency_output.F @@ -158,12 +158,13 @@ subroutine ocn_compute_high_frequency_output(domain, timeLevel, err)!{{{ type (mpas_pool_type), pointer :: diagnosticsPool type (mpas_pool_type), pointer :: forcingPool type (mpas_pool_type), pointer :: highFrequencyOutputAMPool + type (mpas_pool_type), pointer :: tracersPool integer :: iLevel, iLevelTarget integer, pointer :: nVertLevels real (kind=RKIND), dimension(:), pointer :: refBottomDepth, kineticEnergyAt100m, relativeVorticityAt100m - real (kind=RKIND), dimension(:,:), pointer :: kineticEnergyCell, relativeVorticityCell, tracersAtSurface - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:), pointer :: kineticEnergyCell, relativeVorticityCell, activeTracersAtSurface + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers err = 0 @@ -179,6 +180,7 @@ subroutine ocn_compute_high_frequency_output(domain, timeLevel, err)!{{{ call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(domain % blocklist % structs, 'highFrequencyOutputAM', highFrequencyOutputAMPool) ! get static data from mesh pool @@ -187,12 +189,12 @@ subroutine ocn_compute_high_frequency_output(domain, timeLevel, err)!{{{ ! get arrays that will be 'sliced' and put into high frequency output call mpas_pool_get_array(diagnosticsPool, 'kineticEnergyCell', kineticEnergyCell, timeLevel) call mpas_pool_get_array(diagnosticsPool, 'relativeVorticityCell', relativeVorticityCell, timeLevel) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) ! get arrays that can be written to output at high freqency call mpas_pool_get_array(highFrequencyOutputAMPool, 'kineticEnergyAt100m', kineticEnergyAt100m) call mpas_pool_get_array(highFrequencyOutputAMPool, 'relativeVorticityAt100m', relativeVorticityAt100m) - call mpas_pool_get_array(highFrequencyOutputAMPool, 'tracersAtSurface', tracersAtSurface) + call mpas_pool_get_array(highFrequencyOutputAMPool, 'activeTracersAtSurface', activeTracersAtSurface) ! ! note for future build out @@ -212,8 +214,8 @@ subroutine ocn_compute_high_frequency_output(domain, timeLevel, err)!{{{ ! tracer data will be converted to new tracer infrastrcture (and this line removed) before June 23 2015. kineticEnergyAt100m(:) = kineticEnergyCell(iLevelTarget,:) relativeVorticityAt100m(:) = relativeVorticityCell(iLevelTarget,:) - tracersAtSurface(1,:) = tracers(1,1,:) - tracersAtSurface(2,:) = tracers(2,1,:) + activeTracersAtSurface(1,:) = activeTracers(1,1,:) + activeTracersAtSurface(2,:) = activeTracers(2,1,:) block => block % next end do diff --git a/src/core_ocean/analysis_members/mpas_ocn_meridional_heat_transport.F b/src/core_ocean/analysis_members/mpas_ocn_meridional_heat_transport.F index 64bc16b483..4ccf52e8d3 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_meridional_heat_transport.F +++ b/src/core_ocean/analysis_members/mpas_ocn_meridional_heat_transport.F @@ -240,6 +240,7 @@ subroutine ocn_compute_meridional_heat_transport(domain, timeLevel, err)!{{{ type (block_type), pointer :: block type (mpas_pool_type), pointer :: meridionalHeatTransportAMPool type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tracersPool type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: scratchPool type (mpas_pool_type), pointer :: diagnosticsPool @@ -255,7 +256,7 @@ subroutine ocn_compute_meridional_heat_transport(domain, timeLevel, err)!{{{ real (kind=RKIND), dimension(:), pointer :: meridionalHeatTransportLat real (kind=RKIND), dimension(:,:), pointer :: layerThicknessEdge, normalTransportVelocity real (kind=RKIND), dimension(:,:), pointer :: meridionalHeatTransportLatZ - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers real (kind=RKIND), dimension(:,:), allocatable :: mht_meridional_integral real (kind=RKIND), dimension(:,:,:), allocatable :: sumMerHeatTrans, totalSumMerHeatTrans @@ -287,9 +288,11 @@ subroutine ocn_compute_meridional_heat_transport(domain, timeLevel, err)!{{{ call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) @@ -300,7 +303,7 @@ subroutine ocn_compute_meridional_heat_transport(domain, timeLevel, err)!{{{ call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) @@ -332,7 +335,7 @@ subroutine ocn_compute_meridional_heat_transport(domain, timeLevel, err)!{{{ do i = 1, nEdgesOnCell(iCell) iEdge = edgesOnCell(i, iCell) div_huT = div_huT - layerThicknessEdge(k, iEdge) * normalTransportVelocity(k, iEdge) & - * 0.5_RKIND * (tracers(indexTemperature,k,cellsOnEdge(1,iEdge)) + tracers(indexTemperature,k,cellsOnEdge(2,iEdge))) & + * 0.5_RKIND * (activeTracers(indexTemperature,k,cellsOnEdge(1,iEdge)) + activeTracers(indexTemperature,k,cellsOnEdge(2,iEdge))) & * edgeSignOnCell(i, iCell) * dvEdge(iEdge) end do sumMerHeatTrans(iField,k,iBin) = sumMerHeatTrans(iField,k,iBin) + div_huT diff --git a/src/core_ocean/analysis_members/mpas_ocn_surface_area_weighted_averages.F b/src/core_ocean/analysis_members/mpas_ocn_surface_area_weighted_averages.F index 086d762159..adea1e81ed 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_surface_area_weighted_averages.F +++ b/src/core_ocean/analysis_members/mpas_ocn_surface_area_weighted_averages.F @@ -156,10 +156,12 @@ subroutine ocn_compute_surface_area_weighted_averages(domain, timeLevel, err)!{{ type (block_type), pointer :: block type (mpas_pool_type), pointer :: surfaceAreaWeightedAveragesAMPool type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tracersPool type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: scratchPool type (mpas_pool_type), pointer :: diagnosticsPool type (mpas_pool_type), pointer :: forcingPool + type (mpas_pool_type), pointer :: tracersSurfaceFluxPool real (kind=RKIND), dimension(:,:), pointer :: minValueWithinOceanRegion real (kind=RKIND), dimension(:,:), pointer :: maxValueWithinOceanRegion @@ -184,7 +186,7 @@ subroutine ocn_compute_surface_area_weighted_averages(domain, timeLevel, err)!{{ real (kind=RKIND), dimension(:), pointer :: seaIceEnergy real (kind=RKIND), dimension(:), pointer :: surfaceThicknessFlux - real (kind=RKIND), dimension(:,:), pointer :: surfaceTracerFlux + real (kind=RKIND), dimension(:,:), pointer :: activeTracersSurfaceFlux real (kind=RKIND), dimension(:), pointer :: penetrativeTemperatureFlux real (kind=RKIND), dimension(:), pointer :: seaIceSalinityFlux @@ -194,7 +196,7 @@ subroutine ocn_compute_surface_area_weighted_averages(domain, timeLevel, err)!{{ real (kind=RKIND), dimension(:), pointer :: seaSurfacePressure real (kind=RKIND), dimension(:), pointer :: ssh real (kind=RKIND), dimension(:), pointer :: boundaryLayerDepth - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers ! pointers to data in mesh pool integer, pointer :: nCells, nCellsSolve, nSfcAreaWeightedAvgFields, nOceanRegions @@ -213,7 +215,7 @@ subroutine ocn_compute_surface_area_weighted_averages(domain, timeLevel, err)!{{ ! package flag logical, pointer :: surfaceAreaWeightedAveragesAMPKGActive - logical, pointer :: bulkForcingPkgActive + logical, pointer :: activeTracersBulkRestoringPKG logical, pointer :: frazilIcePkgActive ! buffers data for message passaging @@ -226,7 +228,7 @@ subroutine ocn_compute_surface_area_weighted_averages(domain, timeLevel, err)!{{ err = 0 ! get status of other packages - call mpas_pool_get_package(ocnPackages, 'bulkForcingActive', bulkForcingPkgActive) + call mpas_pool_get_package(ocnPackages, 'activeTracersBulkRestoringPKGActive', activeTracersBulkRestoringPKG) call mpas_pool_get_package(ocnPackages, 'frazilIceActive', frazilIcePkgActive) ! set highest level pointer @@ -287,17 +289,19 @@ subroutine ocn_compute_surface_area_weighted_averages(domain, timeLevel, err)!{{ do while (associated(block)) ! get pointers to pools call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceFlux', tracersSurfaceFluxPool) ! get pointers to mesh call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) call mpas_pool_get_dimension(block % dimensions, 'nSfcAreaWeightedAvgFields', nSfcAreaWeightedAvgFields) call mpas_pool_get_dimension(block % dimensions, 'nOceanRegions', nOceanRegions) - call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', indexSalinity) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) call mpas_pool_get_array(meshPool, 'areaCell', areaCell) call mpas_pool_get_array(meshPool, 'lonCell', lonCell) call mpas_pool_get_array(meshPool, 'latCell', latCell) @@ -312,28 +316,28 @@ subroutine ocn_compute_surface_area_weighted_averages(domain, timeLevel, err)!{{ ! get pointers to data that will be analyzed ! listed in the order in which the fields appear in {avg,min,max}SurfaceStatistics - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'latentHeatFlux', latentHeatFlux) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'longWaveHeatFluxUp', longWaveHeatFluxUp) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'longWaveHeatFluxDown', longWaveHeatFluxDown) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'seaIceHeatFlux', seaIceHeatFlux) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'evaporationFlux', evaporationFlux) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'seaIceFreshWaterFlux', seaIceFreshWaterFlux) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'riverRunoffFlux', riverRunoffFlux) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'iceRunoffFlux', iceRunoffFlux) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'snowFlux', snowFlux) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'latentHeatFlux', latentHeatFlux) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'longWaveHeatFluxUp', longWaveHeatFluxUp) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'longWaveHeatFluxDown', longWaveHeatFluxDown) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'seaIceHeatFlux', seaIceHeatFlux) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'evaporationFlux', evaporationFlux) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'seaIceFreshWaterFlux', seaIceFreshWaterFlux) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'riverRunoffFlux', riverRunoffFlux) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'iceRunoffFlux', iceRunoffFlux) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'snowFlux', snowFlux) if (frazilIcePkgActive) call mpas_pool_get_array(forcingPool, 'seaIceEnergy', seaIceEnergy) call mpas_pool_get_array(forcingPool, 'surfaceThicknessFlux', surfaceThicknessFlux) - call mpas_pool_get_array(forcingPool, 'surfaceTracerFlux', surfaceTracerFlux) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'seaIceSalinityFlux', seaIceSalinityFlux) + call mpas_pool_get_array(tracersSurfaceFluxPool, 'activeTracersSurfaceFlux', activeTracersSurfaceFlux) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'seaIceSalinityFlux', seaIceSalinityFlux) call mpas_pool_get_array(forcingPool, 'surfaceWindStressMagnitude', surfaceWindStressMagnitude) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'windStressZonal', windStressZonal) - if (bulkForcingPkgActive) call mpas_pool_get_array(forcingPool, 'windStressMeridional', windStressMeridional) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'windStressZonal', windStressZonal) + if (activeTracersBulkRestoringPKG) call mpas_pool_get_array(forcingPool, 'windStressMeridional', windStressMeridional) call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) call mpas_pool_get_array(statePool, 'ssh', ssh, 1) - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) call mpas_pool_get_array(diagnosticsPool, 'boundaryLayerDepth',boundaryLayerDepth) ! compute mask @@ -343,37 +347,37 @@ subroutine ocn_compute_surface_area_weighted_averages(domain, timeLevel, err)!{{ workArray( :,:) = 0.0 workArray( 1,:) = workMask(:) workArray( 2,:) = areaCell(:) - if (bulkForcingPkgActive) workArray( 3,:) = latentHeatFlux(:) - if (bulkForcingPkgActive) workArray( 4,:) = sensibleHeatFlux(:) - if (bulkForcingPkgActive) workArray( 5,:) = longWaveHeatFluxUp(:) - if (bulkForcingPkgActive) workArray( 6,:) = longWaveHeatFluxDown(:) - if (bulkForcingPkgActive) workArray( 7,:) = seaIceHeatFlux(:) - if (bulkForcingPkgActive) workArray( 8,:) = shortWaveHeatFlux(:) - if (bulkForcingPkgActive) workArray( 9,:) = evaporationFlux(:) - if (bulkForcingPkgActive) workArray(10,:) = seaIceFreshWaterFlux(:) - if (bulkForcingPkgActive) workArray(11,:) = riverRunoffFlux(:) - if (bulkForcingPkgActive) workArray(12,:) = iceRunoffFlux(:) - if (bulkForcingPkgActive) workArray(13,:) = rainFlux(:) - if (bulkForcingPkgActive) workArray(14,:) = snowFlux(:) + if (activeTracersBulkRestoringPKG) workArray( 3,:) = latentHeatFlux(:) + if (activeTracersBulkRestoringPKG) workArray( 4,:) = sensibleHeatFlux(:) + if (activeTracersBulkRestoringPKG) workArray( 5,:) = longWaveHeatFluxUp(:) + if (activeTracersBulkRestoringPKG) workArray( 6,:) = longWaveHeatFluxDown(:) + if (activeTracersBulkRestoringPKG) workArray( 7,:) = seaIceHeatFlux(:) + if (activeTracersBulkRestoringPKG) workArray( 8,:) = shortWaveHeatFlux(:) + if (activeTracersBulkRestoringPKG) workArray( 9,:) = evaporationFlux(:) + if (activeTracersBulkRestoringPKG) workArray(10,:) = seaIceFreshWaterFlux(:) + if (activeTracersBulkRestoringPKG) workArray(11,:) = riverRunoffFlux(:) + if (activeTracersBulkRestoringPKG) workArray(12,:) = iceRunoffFlux(:) + if (activeTracersBulkRestoringPKG) workArray(13,:) = rainFlux(:) + if (activeTracersBulkRestoringPKG) workArray(14,:) = snowFlux(:) if (frazilIcePkgActive) workArray(15,:) = seaIceEnergy(:) workArray(16,:) = surfaceThicknessFlux(:) - workArray(17,:) = surfaceTracerFlux(indexTemperature,:) - workArray(18,:) = surfaceTracerFlux(indexSalinity,:) - if (bulkForcingPkgActive) workArray(19,:) = seaIceSalinityFlux(:) + workArray(17,:) = activeTracersSurfaceFlux(indexTemperature,:) + workArray(18,:) = activeTracersSurfaceFlux(indexSalinity,:) + if (activeTracersBulkRestoringPKG) workArray(19,:) = seaIceSalinityFlux(:) workArray(20,:) = surfaceWindStressMagnitude(:) - if (bulkForcingPkgActive) workArray(21,:) = windStressZonal(:) - if (bulkForcingPkgActive) workArray(22,:) = windStressMeridional(:) + if (activeTracersBulkRestoringPKG) workArray(21,:) = windStressZonal(:) + if (activeTracersBulkRestoringPKG) workArray(22,:) = windStressMeridional(:) workArray(23,:) = seaSurfacePressure(:) workArray(24,:) = ssh(:) - workArray(25,:) = tracers(indexTemperature,1,:) - workArray(26,:) = tracers(indexSalinity,1,:) + workArray(25,:) = activeTracers(indexTemperature,1,:) + workArray(26,:) = activeTracers(indexSalinity,1,:) workArray(27,:) = boundaryLayerDepth(:) ! build net heat, salinity and fresh water budget ! net heat into ocean = latentHeatFlux+sensibleHeatFlux+longWaveHeatFluxUp+longWaveHeatFluxDown+shortWaveHeatFlux+seaIceHeatFlux+(?seaIceEnergy?) ! net salinity into ocean = seaIceSalinityFlux ! net freshwater into ocean = evaporationFlux+seaIceFreshWaterFlux+riverRunoffFlux+iceRunoffFlux+rainFlux+snowFlux+(?seaIceEnergy?) - if (bulkForcingPkgActive) then + if (activeTracersBulkRestoringPKG) then workArray(28,:) = latentHeatFlux(:) & + sensibleHeatFlux(:) & + longWaveHeatFluxUp(:) & diff --git a/src/core_ocean/analysis_members/mpas_ocn_zonal_mean.F b/src/core_ocean/analysis_members/mpas_ocn_zonal_mean.F index 47e101ee2f..2dbcb435d1 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_zonal_mean.F +++ b/src/core_ocean/analysis_members/mpas_ocn_zonal_mean.F @@ -294,16 +294,17 @@ subroutine ocn_compute_zonal_mean(domain, timeLevel, err)!{{{ type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: scratchPool type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: tracersPool integer :: iTracer, k, iCell, kMax integer :: iBin, iField, nZonalMeanVariables - integer, pointer :: num_tracers, nCellsSolve, nVertLevels, nZonalMeanBins + integer, pointer :: num_activeTracers, nCellsSolve, nVertLevels, nZonalMeanBins integer, dimension(:), pointer :: maxLevelCell real (kind=RKIND), dimension(:), pointer :: areaCell, binVariable, binBoundaryZonalMean real (kind=RKIND), dimension(:,:), pointer :: velocityZonal, velocityMeridional real (kind=RKIND), dimension(:,:), pointer :: velocityZonalZonalMean, velocityMeridionalZonalMean - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers real (kind=RKIND), dimension(:,:,:), allocatable :: sumZonalMean, totalSumZonalMean, normZonalMean real (kind=RKIND), dimension(:,:,:), pointer :: tracersZonalMean @@ -316,8 +317,10 @@ subroutine ocn_compute_zonal_mean(domain, timeLevel, err)!{{{ call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) - call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) - nZonalMeanVariables = num_tracers + 3 + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + + call mpas_pool_get_dimension(tracersPool, 'num_activeTracers', num_activeTracers) + nZonalMeanVariables = num_activeTracers + 3 call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nZonalMeanBins', nZonalMeanBins) call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nVertLevels', nVertLevels) @@ -336,6 +339,7 @@ subroutine ocn_compute_zonal_mean(domain, timeLevel, err)!{{{ call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) !state => block % state % time_levs(timeLevel) % state @@ -343,7 +347,7 @@ subroutine ocn_compute_zonal_mean(domain, timeLevel, err)!{{{ !scratch => block % scratch !diagnostics => block % diagnostics - call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + call mpas_pool_get_dimension(tracersPool, 'num_activeTracers', num_activeTracers) call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) @@ -351,7 +355,7 @@ subroutine ocn_compute_zonal_mean(domain, timeLevel, err)!{{{ call mpas_pool_get_array(meshPool, 'areaCell', areaCell) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) call mpas_pool_get_array(diagnosticsPool, 'velocityZonal', velocityZonal) call mpas_pool_get_array(diagnosticsPool, 'velocityMeridional', velocityMeridional) @@ -376,11 +380,11 @@ subroutine ocn_compute_zonal_mean(domain, timeLevel, err)!{{{ ! Field 1 is the total area in this bin, which can vary by level due to land. sumZonalMean(1,k,iBin) = sumZonalMean(1,k,iBin) + areaCell(iCell) - do iField = 1,num_tracers - sumZonalMean(iField+1,k,iBin) = sumZonalMean(iField+1,k,iBin) + tracers(iField,k,iCell)*areaCell(iCell) + do iField = 1,num_activeTracers + sumZonalMean(iField+1,k,iBin) = sumZonalMean(iField+1,k,iBin) + activeTracers(iField,k,iCell)*areaCell(iCell) enddo - iField = num_tracers+2 + iField = num_activeTracers+2 sumZonalMean(iField,k,iBin) = sumZonalMean(iField,k,iBin) + velocityZonal(k,iCell)*areaCell(iCell) iField = iField+1 sumZonalMean(iField,k,iBin) = sumZonalMean(iField,k,iBin) + velocityMeridional(k,iCell)*areaCell(iCell) @@ -424,8 +428,9 @@ subroutine ocn_compute_zonal_mean(domain, timeLevel, err)!{{{ call mpas_pool_get_subpool(block % structs, 'zonalMeanAM', zonalMeanAMPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) - call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + call mpas_pool_get_dimension(tracersPool, 'num_activeTracers', num_activeTracers) call mpas_pool_get_array(zonalMeanAMPool, 'tracersZonalMean', tracersZonalMean) call mpas_pool_get_array(zonalMeanAMPool, 'velocityZonalZonalMean', velocityZonalZonalMean) @@ -434,11 +439,11 @@ subroutine ocn_compute_zonal_mean(domain, timeLevel, err)!{{{ do iBin = 1, nZonalMeanBins do k = 1, nVertLevels - do iField = 1, num_tracers + do iField = 1, num_activeTracers tracersZonalMean(iField,k,iBin) = normZonalMean(iField+1,k,iBin) enddo - iField = num_tracers + 2 + iField = num_activeTracers + 2 velocityZonalZonalMean(k,iBin) = normZonalMean(iField,k,iBin) iField = iField+1 velocityMeridionalZonalMean(k,iBin) = normZonalMean(iField,k,iBin) diff --git a/src/core_ocean/driver/mpas_ocn_core_interface.F b/src/core_ocean/driver/mpas_ocn_core_interface.F index 5caff85304..78faccc36f 100644 --- a/src/core_ocean/driver/mpas_ocn_core_interface.F +++ b/src/core_ocean/driver/mpas_ocn_core_interface.F @@ -107,14 +107,33 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ logical, pointer :: thicknessFilterActive logical, pointer :: splitTimeIntegratorActive logical, pointer :: surfaceRestoringActive - logical, pointer :: bulkForcingActive + logical, pointer :: windStressBulkPKGActive + logical, pointer :: thicknessBulkPKGActive logical, pointer :: frazilIceActive logical, pointer :: inSituEOSActive + logical, pointer :: tracerGroupPKGActive + logical, pointer :: tracerGroupBulkRestoringPKGActive + logical, pointer :: tracerGroupSurfaceRestoringPKGActive + logical, pointer :: tracerGroupInteriorRestoringPKGActive + logical, pointer :: tracerGroupExponentialDecayPKGActive + logical, pointer :: tracerGroupIdealAgePKGActive + logical, pointer :: tracerGroupTTDPKGActive + + logical, pointer :: config_use_tracerGroup, config_use_tracerGroup_surface_bulk_forcing, config_use_tracerGroup_surface_restoring, & + config_use_tracerGroup_interior_restoring, config_use_tracerGroup_exponential_decay, config_use_tracerGroup_idealAge_forcing, & + config_use_tracerGroup_ttd_forcing + logical, pointer :: config_use_freq_filtered_thickness logical, pointer :: config_frazil_ice_formation character (len=StrKIND), pointer :: config_time_integrator, config_forcing_type character (len=StrKIND), pointer :: config_ocean_run_mode, config_pressure_gradient_type + logical, pointer :: config_use_bulk_wind_stress + logical, pointer :: config_use_bulk_thickness_flux + + type (mpas_pool_iterator_type) :: groupItr + character (len=StrKIND) :: tracerGroupName, configName, packageName + integer :: startIndex, strLen ! Get Packages call mpas_pool_get_package(packagePool, 'forwardModeActive', forwardModeActive) @@ -123,9 +142,10 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ call mpas_pool_get_package(packagePool, 'thicknessFilterActive', thicknessFilterActive) call mpas_pool_get_package(packagePool, 'splitTimeIntegratorActive', splitTimeIntegratorActive) call mpas_pool_get_package(packagePool, 'surfaceRestoringActive', surfaceRestoringActive) - call mpas_pool_get_package(packagePool, 'bulkForcingActive', bulkForcingActive) call mpas_pool_get_package(packagePool, 'frazilIceActive', frazilIceActive) call mpas_pool_get_package(packagePool, 'inSituEOSActive', inSituEOSActive) + call mpas_pool_get_package(packagePool, 'windStressBulkPKGActive', windStressBulkPKGActive) + call mpas_pool_get_package(packagePool, 'thicknessBulkPKGActive', thicknessBulkPKGActive) call mpas_pool_get_config(configPool, 'config_ocean_run_mode', config_ocean_run_mode) @@ -140,6 +160,9 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ call mpas_pool_get_config(configPool, 'config_frazil_ice_formation', config_frazil_ice_formation) call mpas_pool_get_config(configPool, 'config_pressure_gradient_type', config_pressure_gradient_type) + call mpas_pool_get_config(configPool, 'config_use_bulk_wind_stress', config_use_bulk_wind_stress) + call mpas_pool_get_config(configPool, 'config_use_bulk_thickness_flux', config_use_bulk_thickness_flux) + if (config_use_freq_filtered_thickness) then thicknessFilterActive = .true. end if @@ -152,8 +175,14 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ if (config_forcing_type == trim('restoring')) then surfaceRestoringActive = .true. - else if (config_forcing_type == trim('bulk')) then - bulkForcingActive = .true. + end if + + if ( config_use_bulk_wind_stress ) then + windStressBulkPKGActive = .true. + end if + + if ( config_use_bulk_thickness_flux ) then + thicknessBulkPKGActive = .true. end if if (config_frazil_ice_formation) then @@ -175,6 +204,73 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ call ocn_analysis_setup_packages(configPool, packagePool, ierr) call ocn_init_mode_validate_configuration(configPool, packagePool, ierr) + call mpas_pool_begin_iteration(packagePool) + do while ( mpas_pool_get_next_member(packagePool, groupItr) ) + startIndex = index(groupItr % memberName, 'TracersPKG') + if ( startIndex .ne. 0 ) then + strLen = len_trim(groupItr % memberName) + tracerGroupName = groupItr % memberName(1:strLen-9) + + configName = 'config_use_' // trim(tracerGroupName) + call mpas_pool_get_config(configPool, configName, config_use_tracerGroup) + if ( config_use_tracerGroup ) then + packageName = trim(tracerGroupName) // 'PKGActive' + call mpas_pool_get_package(packagePool, packageName, tracerGroupPKGActive) + tracerGroupPKGActive = .true. + + configName = 'config_use_' // trim(tracerGroupName) // '_surface_bulk_forcing' + call mpas_pool_get_config(configPool, configName, config_use_tracerGroup_surface_bulk_forcing) + + if ( config_use_tracerGroup_surface_bulk_forcing ) then + packageName = trim(tracerGroupName) // 'BulkRestoringPKGActive' + call mpas_pool_get_package(packagePool, packageName, tracerGroupBulkRestoringPKGActive) + tracerGroupBulkRestoringPKGActive = .true. + end if + + configName = 'config_use_' // trim(tracerGroupName) // '_surface_restoring' + call mpas_pool_get_config(configPool, configName, config_use_tracerGroup_surface_restoring) + + if ( config_use_tracerGroup_surface_restoring ) then + packageName = trim(tracerGroupName) // 'SurfaceRestoringPKGActive' + call mpas_pool_get_package(packagePool, packageName, tracerGroupSurfaceRestoringPKGActive) + tracerGroupSurfaceRestoringPKGActive = .true. + end if + + configName = 'config_use_' // trim(tracerGroupName) // '_interior_restoring' + call mpas_pool_get_config(configPool, configName, config_use_tracerGroup_interior_restoring) + if ( config_use_tracerGroup_interior_restoring ) then + packageName = trim(tracerGroupName) // 'InteriorRestoringPKGActive' + call mpas_pool_get_package(packagePool, packageName, tracerGroupInteriorRestoringPKGActive) + tracerGroupInteriorRestoringPKGActive = .true. + end if + + configName = 'config_use_' // trim(tracerGroupName) // '_exponential_decay' + call mpas_pool_get_config(configPool, configName, config_use_tracerGroup_exponential_decay) + if ( config_use_tracerGroup_exponential_decay ) then + packageName = trim(tracerGroupName) // 'ExponentialDecayPKGActive' + call mpas_pool_get_package(packagePool, packageName, tracerGroupExponentialDecayPKGActive) + tracerGroupExponentialDecayPKGActive = .true. + end if + + configName = 'config_use_' // trim(tracerGroupName) // '_idealAge_forcing' + call mpas_pool_get_config(configPool, configName, config_use_tracerGroup_idealAge_forcing) + if ( config_use_tracerGroup_idealAge_forcing ) then + packageName = trim(tracerGroupName) // 'IdealAgePKGActive' + call mpas_pool_get_package(packagePool, packageName, tracerGroupIdealAgePKGActive) + tracerGroupIdealAgePKGActive = .true. + end if + + configName = 'config_use_' // trim(tracerGroupName) // '_ttd_forcing' + call mpas_pool_get_config(configPool, configName, config_use_tracerGroup_ttd_forcing) + if ( config_use_tracerGroup_ttd_forcing ) then + packageName = trim(tracerGroupName) // 'TTDPKGActive' + call mpas_pool_get_package(packagePool, packageName, tracerGroupTTDPKGActive) + tracerGroupTTDPKGActive = .true. + end if + end if + end if + end do + end function ocn_setup_packages!}}} diff --git a/src/core_ocean/mode_analysis/mpas_ocn_analysis_mode.F b/src/core_ocean/mode_analysis/mpas_ocn_analysis_mode.F index 515a33f9f3..870c973a40 100644 --- a/src/core_ocean/mode_analysis/mpas_ocn_analysis_mode.F +++ b/src/core_ocean/mode_analysis/mpas_ocn_analysis_mode.F @@ -205,6 +205,7 @@ function ocn_analysis_mode_run(domain) result(ierr)!{{{ integer :: err, ierr type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tracersPool type (mpas_pool_type), pointer :: forcingPool type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: diagnosticsPool @@ -231,12 +232,13 @@ function ocn_analysis_mode_run(domain) result(ierr)!{{{ block_ptr => domain % blocklist do while(associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block_ptr % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) - call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 1) + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 1) block_ptr => block_ptr % next end do call mpas_timer_stop("diagnostic solve") diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index 250279eb69..ef759a4413 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -51,7 +51,7 @@ module ocn_forward_mode use ocn_vel_coriolis use ocn_tracer_hmix - use ocn_tracer_surface_flux + use ocn_tracer_surface_flux_to_tend use ocn_tracer_short_wave_absorption use ocn_tracer_nonlocalflux use ocn_tracer_advection diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F index d0148a0cbe..28d2daa9f0 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F @@ -90,9 +90,12 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ type (block_type), pointer :: block type (mpas_pool_type), pointer :: tendPool + type (mpas_pool_type), pointer :: tracersTendPool type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tracersPool type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: provisStatePool + type (mpas_pool_type), pointer :: provisTracersPool type (mpas_pool_type), pointer :: diagnosticsPool type (mpas_pool_type), pointer :: verticalMeshPool type (mpas_pool_type), pointer :: forcingPool @@ -136,11 +139,11 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ real (kind=RKIND), dimension(:,:), pointer :: normalVelocityProvis, layerThicknessProvis real (kind=RKIND), dimension(:,:), pointer :: highFreqThicknessProvis real (kind=RKIND), dimension(:,:), pointer :: lowFreqDivergenceProvis - real (kind=RKIND), dimension(:,:,:), pointer :: tracersProvis + real (kind=RKIND), dimension(:,:,:), pointer :: tracersGroupProvis ! Tend Array Pointers real (kind=RKIND), dimension(:,:), pointer :: highFreqThicknessTend, lowFreqDivergenceTend, normalVelocityTend, layerThicknessTend - real (kind=RKIND), dimension(:,:,:), pointer :: tracersTend + real (kind=RKIND), dimension(:,:,:), pointer :: tracersGroupTend ! Diagnostics Array Pointers real (kind=RKIND), dimension(:,:), pointer :: layerThicknessEdge @@ -160,7 +163,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ real (kind=RKIND), dimension(:,:), pointer :: lowFreqDivergenceCur, lowFreqDivergenceNew real (kind=RKIND), dimension(:), pointer :: sshCur, sshNew - real (kind=RKIND), dimension(:,:,:), pointer :: tracers, tracersCur, tracersNew + real (kind=RKIND), dimension(:,:,:), pointer :: tracerGroup, tracersCur, tracersNew ! Forcing Array pointers real (kind=RKIND), dimension(:), pointer :: seaIceEnergy @@ -172,7 +175,11 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ ! State/Tend Field Pointers type (field2DReal), pointer :: highFreqThicknessField, lowFreqDivergenceField type (field2DReal), pointer :: normalVelocityField, layerThicknessField - type (field3DReal), pointer :: tracersField + type (field3DReal), pointer :: tracersGroupField + + ! Tracer Group Iteartion + type (mpas_pool_iterator_type) :: groupItr + character (len=StrKIND) :: modifiedGroupName ! Get config options call mpas_pool_get_config(domain % configs, 'config_mom_del4', config_mom_del4) @@ -192,6 +199,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) allocate(provisStatePool) @@ -206,8 +214,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityNew, 2) call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) - call mpas_pool_get_array(statePool, 'tracers', tracersCur, 1) - call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) + call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessCur, 1) call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessNew, 2) call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergenceCur, 1) @@ -218,10 +225,20 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ normalVelocityNew(:,:) = normalVelocityCur(:,:) layerThicknessNew(:,:) = layerThicknessCur(:,:) - do iCell = 1, nCells ! couple tracers to thickness - do k = 1, maxLevelCell(iCell) - tracersNew(:,k,iCell) = tracersCur(:,k,iCell) * layerThicknessCur(k,iCell) - end do + call mpas_pool_begin_iteration(tracersPool) + do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) + + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + + call mpas_pool_get_array(tracersPool, trim(groupItr % memberName), tracersCur, 1) + call mpas_pool_get_array(tracersPool, trim(groupItr % memberName), tracersNew, 2) + + do iCell = 1, nCells ! couple tracers to thickness + do k = 1, maxLevelCell(iCell) + tracersNew(:,k,iCell) = tracersCur(:,k,iCell) * layerThicknessCur(k,iCell) + end do + end do + end if end do if (associated(highFreqThicknessCur)) then @@ -339,6 +356,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) call ocn_tend_freq_filtered_thickness(tendPool, provisStatePool, diagnosticsPool, meshPool, 1) @@ -362,6 +380,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) @@ -384,6 +403,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'verticalMesh', verticalMeshPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) @@ -446,11 +466,19 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_field(tendPool, 'normalVelocity', normalVelocityField) call mpas_pool_get_field(tendPool, 'layerThickness', layerThicknessField) - call mpas_pool_get_field(tendPool, 'tracers', tracersField) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_dmpar_exch_halo_field(normalVelocityField) call mpas_dmpar_exch_halo_field(layerThicknessField) - call mpas_dmpar_exch_halo_field(tracersField) + + call mpas_pool_begin_iteration(tracersTendPool) + do while ( mpas_pool_get_next_member(tracersTendPool, groupItr) ) + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + call mpas_pool_get_field(tracersTendPool, trim(groupItr % memberName), tracersGroupField) + call mpas_dmpar_exch_halo_field(tracersGroupField) + end if + end do + call mpas_timer_stop("RK4-prognostic halo update") ! Compute next substep state for velocity, thickness, and tracers. @@ -463,26 +491,28 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(provisStatePool, 'tracers', provisTracersPool) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) - call mpas_pool_get_array(statePool, 'tracers', tracersCur, 1) call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergenceCur, 1) call mpas_pool_get_array(provisStatePool, 'normalVelocity', normalVelocityProvis, 1) call mpas_pool_get_array(provisStatePool, 'layerThickness', layerThicknessProvis, 1) - call mpas_pool_get_array(provisStatePool, 'tracers', tracersProvis, 1) call mpas_pool_get_array(provisStatePool, 'lowFreqDivergence', lowFreqDivergenceProvis, 1) call mpas_pool_get_array(tendPool, 'normalVelocity', normalVelocityTend) call mpas_pool_get_array(tendPool, 'layerThickness', layerThicknessTend) - call mpas_pool_get_array(tendPool, 'tracers', tracersTend) + call mpas_pool_get_array(tendPool, 'lowFreqDivergence', lowFreqDivergenceTend) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) @@ -493,13 +523,24 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ normalVelocityProvis(:,:) = normalVelocityCur(:,:) + rk_substep_weights(rk_step) * normalVelocityTend(:,:) layerThicknessProvis(:,:) = layerThicknessCur(:,:) + rk_substep_weights(rk_step) * layerThicknessTend(:,:) - do iCell = 1, nCells - do k = 1, maxLevelCell(iCell) - tracersProvis(:,k,iCell) = ( layerThicknessCur(k,iCell) * tracersCur(:,k,iCell) & - + rk_substep_weights(rk_step) * tracersTend(:,k,iCell) & - ) / layerThicknessProvis(k,iCell) - end do + call mpas_pool_begin_iteration(tracersPool) + do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersCur, 1) + call mpas_pool_get_array(provisTracersPool, groupItr % memberName, tracersGroupProvis, 1) + + modifiedGroupName = trim(groupItr % memberName) // 'Tend' + call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersGroupProvis(:,k,iCell) = ( layerThicknessCur(k,iCell) * tracersCur(:,k,iCell) & + + rk_substep_weights(rk_step) * tracersGroupTend(:,k,iCell) & + ) / layerThicknessProvis(k,iCell) + end do + + end do + end if end do if (associated(lowFreqDivergenceCur)) then @@ -514,7 +555,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ layerThicknessProvis(:,:) = layerThicknessCur(:,:) end if - call ocn_diagnostic_solve(dt, provisStatePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 1) + call ocn_diagnostic_solve(dt, provisStatePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 1) ! ------------------------------------------------------------------ ! Accumulating various parametrizations of the transport velocity @@ -549,24 +590,24 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) - call mpas_pool_get_array(statePool, 'tracers', tracersCur, 1) call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessCur, 1) call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergenceCur, 1) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityNew, 2) call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) - call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessNew, 2) call mpas_pool_get_array(statePool, 'lowFreqDivergence', lowFreqDivergenceNew, 2) call mpas_pool_get_array(tendPool, 'normalVelocity', normalVelocityTend) call mpas_pool_get_array(tendPool, 'layerThickness', layerThicknessTend) - call mpas_pool_get_array(tendPool, 'tracers', tracersTend) + call mpas_pool_get_array(tendPool, 'highFreqThickness', highFreqThicknessTend) call mpas_pool_get_array(tendPool, 'lowFreqDivergence', lowFreqDivergenceTend) @@ -576,10 +617,19 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ layerThicknessNew(:,:) = layerThicknessNew(:,:) + rk_weights(rk_step) * layerThicknessTend(:,:) - do iCell = 1, nCells - do k = 1, maxLevelCell(iCell) - tracersNew(:,k,iCell) = tracersNew(:,k,iCell) + rk_weights(rk_step) * tracersTend(:,k,iCell) - end do + call mpas_pool_begin_iteration(tracersPool) + do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersNew, 2) + + modifiedGroupName = trim(groupItr % memberName) // 'Tend' + call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersNew(:,k,iCell) = tracersNew(:,k,iCell) + rk_weights(rk_step) * tracersGroupTend(:,k,iCell) + end do + end do + end if end do if (associated(highFreqThicknessNew)) then @@ -611,28 +661,34 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) - call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) - call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', indexSalinity) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) call mpas_pool_get_array(forcingPool, 'seaIceEnergy', seaIceEnergy) - do iCell = 1, nCells - do k = 1, maxLevelCell(iCell) - tracersNew(:, k, iCell) = tracersNew(:, k, iCell) / layerThicknessNew(k, iCell) - end do + call mpas_pool_begin_iteration(tracersPool) + do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersNew, 2) + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersNew(:, k, iCell) = tracersNew(:, k, iCell) / layerThicknessNew(k, iCell) + end do + end do + end if end do - call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) call ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, layerThicknessNew, tracersNew, seaIceEnergy, err) block => block % next end do @@ -641,6 +697,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ block => domain % blocklist do while(associated(block)) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) @@ -655,7 +712,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ ! be computed. For kpp, more variables may be needed. Either way, this ! could be made more efficient by only computing what is needed for the ! implicit vmix routine that follows. - call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) call ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, err, 2) @@ -686,12 +743,20 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ ! communicate the change due to implicit vertical mixing across the boundary. call mpas_timer_start("RK4-implicit vert mix halos") call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_field(statePool, 'normalVelocity', normalVelocityField, 2) - call mpas_pool_get_field(statePool, 'tracers', tracersField, 2) call mpas_dmpar_exch_halo_field(normalVelocityField) - call mpas_dmpar_exch_halo_field(tracersField) + + call mpas_pool_begin_iteration(tracersPool) + do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + call mpas_pool_get_field(tracersPool, groupItr % memberName, tracersGroupField, 2) + call mpas_dmpar_exch_halo_field(tracersGroupField) + end if + end do + call mpas_timer_stop("RK4-implicit vert mix halos") call mpas_timer_stop("RK4-implicit vert mix") @@ -699,6 +764,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) @@ -739,7 +805,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ layerThicknessNew(:,:) = layerThicknessCur(:,:) end if - call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) ! ------------------------------------------------------------------ ! Accumulating various parameterizations of the transport velocity diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F index dc1512f6e7..68ab20553f 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F @@ -94,10 +94,12 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ real (kind=RKIND), intent(in) :: dt type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tracersPool type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: verticalMeshPool type (mpas_pool_type), pointer :: diagnosticsPool type (mpas_pool_type), pointer :: tendPool + type (mpas_pool_type), pointer :: tracersTendPool type (mpas_pool_type), pointer :: forcingPool type (mpas_pool_type), pointer :: averagePool type (mpas_pool_type), pointer :: scratchPool @@ -113,7 +115,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ integer :: useVelocityCorrection, err real (kind=RKIND), dimension(:,:), pointer :: & vertViscTopOfEdge, vertDiffTopOfCell - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), pointer :: tracersGroup real (kind=RKIND), dimension(:), allocatable:: uTemp real (kind=RKIND), dimension(:,:), allocatable:: tracersTemp @@ -134,7 +136,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ real (kind=RKIND), pointer :: config_btr_gam3_velWt2 ! Dimensions - integer, pointer :: nCells, nEdges, nVertLevels, num_tracers, startIndex, endIndex + integer, pointer :: nCells, nEdges, nVertLevels, num_tracersGroup, startIndex, endIndex integer, pointer :: indexTemperature, indexSalinity integer, pointer :: indexSurfaceVelocityZonal, indexSurfaceVelocityMeridional integer, pointer :: indexSSHGradientZonal, indexSSHGradientMeridional @@ -158,14 +160,14 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ real (kind=RKIND), dimension(:,:), pointer :: layerThicknessCur, layerThicknessNew real (kind=RKIND), dimension(:,:), pointer :: highFreqThicknessCur, highFreqThicknessNew real (kind=RKIND), dimension(:,:), pointer :: lowFreqDivergenceCur, lowFreqDivergenceNew - real (kind=RKIND), dimension(:,:,:), pointer :: tracersCur, tracersNew + real (kind=RKIND), dimension(:,:,:), pointer :: tracersGroupCur, tracersGroupNew ! Tend Array Pointers real (kind=RKIND), dimension(:), pointer :: sshTend real (kind=RKIND), dimension(:,:), pointer :: highFreqThicknessTend real (kind=RKIND), dimension(:,:), pointer :: lowFreqDivergenceTend real (kind=RKIND), dimension(:,:), pointer :: normalVelocityTend, layerThicknessTend - real (kind=RKIND), dimension(:,:,:), pointer :: tracersTend + real (kind=RKIND), dimension(:,:,:), pointer :: tracersGroupTend, activeTracersTend ! Diagnostics Array Pointers real (kind=RKIND), dimension(:), pointer :: barotropicForcing, barotropicThicknessFlux @@ -190,7 +192,11 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ type (field2DReal), pointer :: highFreqThicknessField, lowFreqDivergenceField type (field2DReal), pointer :: normalBaroclinicVelocityField, layerThicknessField type (field2DReal), pointer :: normalVelocityField - type (field3DReal), pointer :: tracersField + type (field3DReal), pointer :: tracersGroupField + + ! tracer iterators + type (mpas_pool_iterator_type) :: groupItr + character (len=StrKIND) :: modifiedGroupName call mpas_timer_start("se timestep", .false., timer_main) @@ -236,6 +242,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocityCur, 1) @@ -252,9 +259,6 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) - call mpas_pool_get_array(statePool, 'tracers', tracersCur, 1) - call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) - call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessCur, 1) call mpas_pool_get_array(statePool, 'highFreqThickness', highFreqThicknessNew, 2) @@ -290,11 +294,25 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ do iCell = 1, nCells do k = 1, maxLevelCell(iCell) layerThicknessNew(k,iCell) = layerThicknessCur(k,iCell) - - tracersNew(:,k,iCell) = tracersCur(:,k,iCell) end do end do + + call mpas_pool_begin_iteration(tracersPool) + do while ( mpas_pool_get_next_member(tracersPool, groupItr)) + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroupCur, 1) + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroupNew, 2) + + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersGroupNew(:,k,iCell) = tracersGroupCur(:,k,iCell) + end do + end do + end if + end do + + if (associated(highFreqThicknessNew)) then highFreqThicknessNew(:,:) = highFreqThicknessCur(:,:) end if @@ -351,7 +369,9 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_subpool(block % structs, 'state', statepool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) @@ -362,6 +382,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_timer_start("se freq-filtered-thick halo update") call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_field(tendPool, 'highFreqThickness', highFreqThicknessField) call mpas_pool_get_field(tendPool, 'lowFreqDivergence', lowFreqDivergenceField) @@ -376,7 +397,9 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) @@ -403,9 +426,11 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'verticalMesh', verticalMeshPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) @@ -454,8 +479,10 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) @@ -557,6 +584,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) @@ -580,8 +608,6 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! normalTransportVelocity = normalBaroclinicVelocity + normalGMBolusVelocity ! This is u used in advective terms for layerThickness and tracers ! in tendency calls in stage 3. -!mrp note: in QC version, there is an if (config_use_standardGM) on adding normalGMBolusVelocity -! I think it is not needed because normalGMBolusVelocity=0 when GM not on. normalTransportVelocity(k,iEdge) = edgeMask(k,iEdge) & *( normalBaroclinicVelocityNew(k,iEdge) + normalGMBolusVelocity(k,iEdge) ) @@ -601,6 +627,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_array(diagnosticsPool, 'barotropicForcing', barotropicForcing) call mpas_pool_get_array(diagnosticsPool, 'barotropicThicknessFlux', barotropicThicknessFlux) @@ -652,6 +679,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) @@ -695,6 +723,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! boundary update on normalBarotropicVelocityNew call mpas_timer_start("se halo normalBarotropicVelocity", .false., timer_halo_normalBarotropicVelocity) call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_field(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleField, newBtrSubcycleTime) call mpas_dmpar_exch_halo_field(normalBarotropicVelocitySubcycleField) @@ -710,8 +739,10 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_array(tendPool, 'ssh', sshTend) @@ -831,6 +862,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) @@ -883,6 +915,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! boundary update on normalBarotropicVelocityNew call mpas_timer_start("se halo normalBarotropicVelocity", .false., timer_halo_normalBarotropicVelocity) call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_field(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleField, newBtrSubcycleTime) @@ -901,8 +934,10 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_array(tendPool, 'ssh', sshTend) @@ -1003,6 +1038,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! boundary update on SSHnew call mpas_timer_start("se halo ssh", .false., timer_halo_ssh) call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_field(statePool, 'sshSubcycle', sshSubcycleField) @@ -1019,6 +1055,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityNew, 2) call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleNew, newBtrSubcycleTime) @@ -1048,6 +1085,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityNew, 2) @@ -1086,6 +1124,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) @@ -1117,8 +1156,6 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ do iEdge = 1, nEdges ! velocity for normalVelocityCorrectionection is normalBarotropicVelocity + normalBaroclinicVelocity + uBolus -!mrp note: in QC version, there is an if (config_use_standardGM) on adding normalGMBolusVelocity -! I think it is not needed because normalGMBolusVelocity=0 when GM not on. uTemp(:) = normalBarotropicVelocityNew(iEdge) + normalBaroclinicVelocityNew(:,iEdge) + normalGMBolusVelocity(:,iEdge) ! thicknessSum is initialized outside the loop because on land boundaries @@ -1171,8 +1208,10 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'verticalMesh', verticalMeshPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) @@ -1204,6 +1243,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! update halo for thickness tendencies call mpas_timer_start("se halo thickness", .false., timer_halo_thickness) call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_field(tendPool, 'layerThickness', layerThicknessField) @@ -1213,7 +1253,9 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) @@ -1225,10 +1267,16 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! update halo for tracer tendencies call mpas_timer_start("se halo tracers", .false., timer_halo_tracers) call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) - call mpas_pool_get_field(tendPool, 'tracers', tracersField) + call mpas_pool_begin_iteration(tracersTendPool) + do while ( mpas_pool_get_next_member(tracersTendPool, groupItr) ) + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + call mpas_pool_get_field(tracersTendPool, groupItr % memberName, tracersGroupField) - call mpas_dmpar_exch_halo_field(tracersField) + call mpas_dmpar_exch_halo_field(tracersGroupField) + end if + end do call mpas_timer_stop("se halo tracers", timer_halo_tracers) block => domain % blocklist @@ -1239,19 +1287,19 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) - call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) - call mpas_pool_get_array(statePool, 'tracers', tracersCur, 1) - call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) + call mpas_pool_get_array(tracersPool, 'activeTracers', tracersGroupCur, 1) + call mpas_pool_get_array(tracersPool, 'activeTracers', tracersGroupNew, 2) call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessCur, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, 1) @@ -1265,12 +1313,13 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocityCur, 1) call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocityNew, 2) - call mpas_pool_get_array(tendPool, 'tracers', tracersTend) call mpas_pool_get_array(tendPool, 'layerThickness', layerThicknessTend) call mpas_pool_get_array(tendPool, 'normalVelocity', normalVelocityTend) call mpas_pool_get_array(tendPool, 'highFreqThickness', highFreqThicknessTend) call mpas_pool_get_array(tendPool, 'lowFreqDivergence', lowFreqDivergenceTend) + call mpas_pool_get_array(tracersTendPool, 'activeTracersTend', activeTracersTend) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! If iterating, reset variables for next iteration @@ -1279,8 +1328,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ if (split_explicit_step < config_n_ts_iter) then ! Get indices for dynamic tracers (Includes T&S). - call mpas_pool_get_dimension(statePool, 'dynamics_start', startIndex) - call mpas_pool_get_dimension(statePool, 'dynamics_end', endIndex) + call mpas_pool_get_dimension(tracersPool, 'activeGRP_start', startIndex) + call mpas_pool_get_dimension(tracersPool, 'activeGRP_end', endIndex) ! Only need T & S for earlier iterations, ! then all the tracers needed the last time through. @@ -1296,10 +1345,10 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ do i = startIndex, endIndex ! This is Phi at n+1 - temp = ( tracersCur(i,k,iCell) * layerThicknessCur(k,iCell) + dt * tracersTend(i,k,iCell)) / temp_h + temp = ( tracersGroupCur(i,k,iCell) * layerThicknessCur(k,iCell) + dt * activeTracersTend(i,k,iCell)) / temp_h ! This is Phi at n+1/2 - tracersNew(i,k,iCell) = 0.5 * ( tracersCur(i,k,iCell) + temp ) + tracersGroupNew(i,k,iCell) = 0.5 * ( tracersGroupCur(i,k,iCell) + temp ) end do end do end do ! iCell @@ -1338,7 +1387,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! Efficiency note: We really only need this to compute layerThicknessEdge, density, pressure, and SSH ! in this diagnostics solve. - call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! @@ -1349,17 +1398,27 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ do iCell = 1, nCells do k = 1, maxLevelCell(iCell) - ! this is h_{n+1} layerThicknessNew(k,iCell) = layerThicknessCur(k,iCell) + dt * layerThicknessTend(k,iCell) + end do + end do - ! This is Phi at n+1 - do i = 1, num_tracers - tracersNew(i,k,iCell) = (tracersCur(i,k,iCell) * layerThicknessCur(k,iCell) + dt * tracersTend(i,k,iCell) ) & - / layerThicknessNew(k,iCell) + call mpas_pool_begin_iteration(tracersPool) + do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroupCur, 1) + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroupNew, 2) - enddo - end do + modifiedGroupName = trim(groupItr % memberName) // 'Tend' + call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) + + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersGroupNew(:,k,iCell) = (tracersGroupCur(:,k,iCell) * layerThicknessCur(k,iCell) + dt * tracersGroupTend(:,k,iCell) ) & + / layerThicknessNew(k,iCell) + end do + end do + end if end do if (config_use_freq_filtered_thickness) then @@ -1405,22 +1464,23 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ block => domain % blocklist do while(associated(block)) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) - call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', indexSalinity) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) - call mpas_pool_get_array(statePool, 'tracers', tracersNew, 2) + call mpas_pool_get_array(tracersPool, 'activeTracers', tracersGroupNew, 2) call mpas_pool_get_array(forcingPool, 'seaIceEnergy', seaIceEnergy) - call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) call ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, layerThicknessNew, & - tracersNew, seaIceEnergy, err) + tracersGroupNew, seaIceEnergy, err) block => block % next end do @@ -1428,6 +1488,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ block => domain % blocklist do while(associated(block)) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) @@ -1439,7 +1500,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! be computed. For kpp, more variables may be needed. Either way, this ! could be made more efficient by only computing what is needed for the ! implicit vmix routine that follows. - call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) ! Compute normalGMBolusVelocity; it will be added to the baroclinic modes in Stage 2 above. if (config_use_standardGM) then @@ -1456,12 +1517,19 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! communicate the change due to implicit vertical mixing across the boundary. call mpas_timer_start("se implicit vert mix halos") call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_field(statePool, 'normalVelocity', normalVelocityField, 2) - call mpas_pool_get_field(statePool, 'tracers', tracersField, 2) call mpas_dmpar_exch_halo_field(normalVelocityField) - call mpas_dmpar_exch_halo_field(tracersField) + + call mpas_pool_begin_iteration(tracersPool) + do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + call mpas_pool_get_field(tracersPool, groupItr % memberName, tracersGroupField, 2) + call mpas_dmpar_exch_halo_field(tracersGroupField) + end if + end do call mpas_timer_stop("se implicit vert mix halos") call mpas_timer_stop("se implicit vert mix") @@ -1469,6 +1537,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) @@ -1510,7 +1579,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ layerThicknessNew(:,:) = layerThicknessCur(:,:) end if - call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, 2) + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) ! Compute normalGMBolusVelocity; it will be added to normalVelocity in Stage 2 of the next cycle. if (config_use_standardGM) then @@ -1569,7 +1638,7 @@ subroutine ocn_time_integration_split_init(domain)!{{{ integer :: i, iCell, iEdge, iVertex, k type (block_type), pointer :: block - type (mpas_pool_type), pointer :: statePool, meshPool + type (mpas_pool_type), pointer :: statePool, meshPool, tracersPool integer :: iTracer, cell, cell1, cell2 integer, dimension(:), pointer :: maxLevelEdgeTop @@ -1589,6 +1658,7 @@ subroutine ocn_time_integration_split_init(domain)!{{{ call mpas_pool_get_config(block % configs, 'config_time_integrator', config_time_integrator) call mpas_pool_get_config(block % configs, 'config_filter_btr_mode', config_filter_btr_mode) call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) diff --git a/src/core_ocean/shared/Makefile b/src/core_ocean/shared/Makefile index bfcb3e7fe5..572b56388c 100644 --- a/src/core_ocean/shared/Makefile +++ b/src/core_ocean/shared/Makefile @@ -1,12 +1,12 @@ .SUFFIXES: .F .o -OBJS = mpas_ocn_init_routines.o \ - mpas_ocn_gm.o \ - mpas_ocn_diagnostics.o \ - mpas_ocn_diagnostics_routines.o \ - mpas_ocn_thick_ale.o \ - mpas_ocn_equation_of_state.o \ - mpas_ocn_equation_of_state_jm.o \ - mpas_ocn_equation_of_state_linear.o \ +OBJS = mpas_ocn_init_routines.o \ + mpas_ocn_gm.o \ + mpas_ocn_diagnostics.o \ + mpas_ocn_diagnostics_routines.o \ + mpas_ocn_thick_ale.o \ + mpas_ocn_equation_of_state.o \ + mpas_ocn_equation_of_state_jm.o \ + mpas_ocn_equation_of_state_linear.o \ mpas_ocn_thick_hadv.o \ mpas_ocn_thick_vadv.o \ mpas_ocn_thick_surface_flux.o \ @@ -24,7 +24,7 @@ OBJS = mpas_ocn_init_routines.o \ mpas_ocn_vmix_coefs_const.o \ mpas_ocn_vmix_coefs_rich.o \ mpas_ocn_vmix_coefs_tanh.o \ - mpas_ocn_vmix_coefs_redi.o \ + mpas_ocn_vmix_coefs_redi.o \ mpas_ocn_vmix_cvmix.o \ mpas_ocn_tendency.o \ mpas_ocn_tracer_hmix.o \ @@ -34,12 +34,17 @@ OBJS = mpas_ocn_init_routines.o \ mpas_ocn_tracer_nonlocalflux.o \ mpas_ocn_tracer_short_wave_absorption.o \ mpas_ocn_tracer_short_wave_absorption_jerlov.o \ + mpas_ocn_tracer_surface_restoring.o \ + mpas_ocn_tracer_interior_restoring.o \ + mpas_ocn_tracer_exponential_decay.o \ + mpas_ocn_tracer_ideal_age.o \ + mpas_ocn_tracer_TTD.o \ mpas_ocn_high_freq_thickness_hmix_del2.o \ - mpas_ocn_tracer_surface_flux.o \ + mpas_ocn_tracer_surface_flux_to_tend.o \ mpas_ocn_test.o \ mpas_ocn_constants.o \ mpas_ocn_forcing.o \ - mpas_ocn_forcing_bulk.o \ + mpas_ocn_surface_bulk_forcing.o \ mpas_ocn_forcing_restoring.o \ mpas_ocn_time_average.o \ mpas_ocn_time_average_coupled.o \ @@ -49,7 +54,7 @@ all: $(OBJS) mpas_ocn_init_routines.o: mpas_ocn_constants.o mpas_ocn_time_average.o mpas_ocn_diagnostics.o mpas_ocn_gm.o -mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_flux.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_vmix.o mpas_ocn_constants.o +mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_restoring.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_surface_bulk_forcing.o mpas_ocn_tracer_surface_flux_to_tend.o mpas_ocn_tracer_interior_restoring.o mpas_ocn_tracer_exponential_decay.o mpas_ocn_tracer_ideal_age.o mpas_ocn_tracer_TTD.o mpas_ocn_vmix.o mpas_ocn_constants.o mpas_ocn_diagnostics_routines.o: mpas_ocn_constants.o @@ -129,9 +134,9 @@ mpas_ocn_test.o: mpas_ocn_constants.o mpas_ocn_constants.o: -mpas_ocn_forcing.o: mpas_ocn_constants.o mpas_ocn_forcing_bulk.o mpas_ocn_forcing_restoring.o +mpas_ocn_forcing.o: mpas_ocn_constants.o mpas_ocn_forcing_restoring.o -mpas_ocn_forcing_bulk.o: mpas_ocn_constants.o +mpas_ocn_surface_bulk_forcing.o: mpas_ocn_forcing_restoring.o: mpas_ocn_constants.o diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index 7542d5c004..a93290f046 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -84,7 +84,7 @@ module ocn_diagnostics ! !----------------------------------------------------------------------- - subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, timeLevelIn)!{{{ + subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, timeLevelIn)!{{{ real (kind=RKIND), intent(in) :: dt !< Input: Time step type (mpas_pool_type), intent(in) :: statePool !< Input: State information @@ -92,6 +92,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information type (mpas_pool_type), intent(inout) :: diagnosticsPool !< Input: diagnostic fields derived from State type (mpas_pool_type), intent(in) :: scratchPool !< Input: scratch variables + type (mpas_pool_type), intent(in) :: tracersPool !< Input: tracer fields integer, intent(in), optional :: timeLevelIn !< Input: Time level in state integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j @@ -124,7 +125,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic vorticityGradientNormalComponent, vorticityGradientTangentialComponent, gradSSH, RiTopOfCell, & inSituThermalExpansionCoeff, inSituSalineContractionCoeff - real (kind=RKIND), dimension(:,:,:), pointer :: tracers, derivTwo + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers, derivTwo character :: c1*6 real (kind=RKIND), dimension(:,:), pointer :: tracersSurfaceValue @@ -155,12 +156,12 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic call mpas_pool_get_config(ocnConfigs, 'config_cvmix_kpp_surface_layer_averaging', config_cvmix_kpp_surface_layer_averaging) call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_kpp', config_use_cvmix_kpp) - call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', indexSalinity) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) call mpas_pool_get_array(statePool, 'ssh', ssh, timeLevel) call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) @@ -253,8 +254,8 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ! normalVelocity(:,nEdges+1) = -1e34 layerThickness(:,nCells+1) = -1e34 - tracers(indexTemperature,:,nCells+1) = -1e34 - tracers(indexSalinity,:,nCells+1) = -1e34 + activeTracers(indexTemperature,:,nCells+1) = -1e34 + activeTracers(indexSalinity,:,nCells+1) = -1e34 divergence(:,:) = 0.0 vertVelocityTop(:,:)=0.0 @@ -595,7 +596,10 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ! this eventually be a modelled process ! at present, just copy k=1 tracer values onto surface values ! field will be updated below is better approximations are available - tracersSurfaceValue(:,:) = tracers(:,1,:) + +!TDR need to consider how to handel tracersSurfaceValues + + tracersSurfaceValue(:,:) = activeTracers(:,1,:) normalVelocitySurfaceLayer(:) = normalVelocity(1,:) ! @@ -617,10 +621,10 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic endif end do do k=1,int(rSurfaceLayer) - tracersSurfaceLayerValue(:,iCell) = tracersSurfaceLayerValue(:,iCell) + tracers(:,k,iCell)*layerThickness(k,iCell) + tracersSurfaceLayerValue(:,iCell) = tracersSurfaceLayerValue(:,iCell) + activeTracers(:,k,iCell)*layerThickness(k,iCell) enddo k=int(rSurfaceLayer)+1 - tracersSurfaceLayerValue(:,iCell) = tracersSurfaceLayerValue(:,iCell) + fraction(rSurfaceLayer)*tracers(:,k,iCell)*layerThickness(k,iCell) + tracersSurfaceLayerValue(:,iCell) = tracersSurfaceLayerValue(:,iCell) + fraction(rSurfaceLayer)*activeTracers(:,k,iCell)*layerThickness(k,iCell) tracersSurfaceLayerValue(:,iCell) = tracersSurfaceLayerValue(:,iCell) / surfaceLayerDepth enddo @@ -1091,6 +1095,9 @@ subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPo type (mpas_pool_type), intent(in) :: scratchPool !< Input: scratch variables integer, intent(in), optional :: timeLevelIn + ! pool pointers + type (mpas_pool_type), pointer :: tracersSurfaceFluxPool + ! scalars integer, pointer :: nCells, nVertLevels @@ -1105,8 +1112,8 @@ subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPo normalVelocitySurfaceLayer real (kind=RKIND), dimension(:), pointer :: surfaceWindStress, surfaceWindStressMagnitude real (kind=RKIND), dimension(:,:), pointer :: & - layerThickness, zMid, zTop, tracersSurfaceValues, densitySurfaceDisplaced, density, & - normalVelocity, surfaceTracerFlux, thermalExpansionCoeff, salineContractionCoeff + layerThickness, zMid, zTop, densitySurfaceDisplaced, density, & + normalVelocity, activeTracersSurfaceFlux, thermalExpansionCoeff, salineContractionCoeff real (kind=RKIND), dimension(:), pointer :: & indexSurfaceLayerDepth @@ -1130,6 +1137,7 @@ subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPo timeLevel = 1 end if + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceFlux', tracersSurfaceFluxPool) call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) ! set the parameter turbulentVelocitySquared @@ -1138,8 +1146,8 @@ subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPo ! set scalar values call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(forcingPool, 'index_surfaceTemperatureFlux', indexTempFlux) - call mpas_pool_get_dimension(forcingPool, 'index_surfaceSalinityFlux', indexSaltFlux) + call mpas_pool_get_dimension(tracersSurfaceFluxPool, 'index_temperatureSurfaceFlux', indexTempFlux) + call mpas_pool_get_dimension(tracersSurfaceFluxPool, 'index_salinitySurfaceFlux', indexSaltFlux) ! set pointers into state, mesh, diagnostics and scratch call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) @@ -1155,7 +1163,6 @@ subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPo call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) call mpas_pool_get_array(diagnosticsPool, 'zTop', zTop) call mpas_pool_get_array(diagnosticsPool, 'density', density) - call mpas_pool_get_array(diagnosticsPool, 'tracersSurfaceValue ', tracersSurfaceValues) call mpas_pool_get_array(diagnosticsPool, 'surfaceFrictionVelocity', surfaceFrictionVelocity) call mpas_pool_get_array(diagnosticsPool, 'penetrativeTemperatureFluxOBL', penetrativeTemperatureFluxOBL) call mpas_pool_get_array(diagnosticsPool, 'bulkRichardsonNumberBuoy', bulkRichardsonNumberBuoy) @@ -1165,11 +1172,12 @@ subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPo call mpas_pool_get_array(diagnosticsPool, 'normalVelocitySurfaceLayer', normalVelocitySurfaceLayer) call mpas_pool_get_array(forcingPool, 'surfaceThicknessFlux', surfaceThicknessFlux) - call mpas_pool_get_array(forcingPool, 'surfaceTracerFlux', surfaceTracerFlux) call mpas_pool_get_array(forcingPool, 'penetrativeTemperatureFlux', penetrativeTemperatureFlux) call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) call mpas_pool_get_array(forcingPool, 'surfaceWindStressMagnitude', surfaceWindStressMagnitude) + call mpas_pool_get_array(tracersSurfaceFluxPool, 'activeTracersSurfaceFlux', activeTracersSurfaceFlux) + ! allocate scratch space displaced density computation call mpas_pool_get_field(scratchPool, 'densitySurfaceDisplaced', densitySurfaceDisplacedField) call mpas_pool_get_field(scratchPool, 'thermalExpansionCoeff', thermalExpansionCoeffField) @@ -1198,18 +1206,18 @@ subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPo ! everything below should be consistent with the CVMix/KPP documentation: https://www.dropbox.com/s/6hqgc0rsoa828nf/cvmix_20aug2013.pdf ! ! surfaceThicknessFlux: surface mass flux, m/s, positive into ocean - ! surfaceTracerFlux(indexTempFlux): non-penetrative temperature flux, C m/s, positive into ocean + ! activeTracersSurfaceFlux(indexTempFlux): non-penetrative temperature flux, C m/s, positive into ocean ! penetrativeTemperatureFlux: penetrative surface temperature flux at ocean surface, positive into ocean - ! surfaceTracerFlux(indexSaltFlux): salinity flux, PSU m/s, positive into ocean + ! activeTracersSurfaceFlux(indexSaltFlux): salinity flux, PSU m/s, positive into ocean ! penetrativeTemperatureFluxOBL: penetrative temperature flux computed at z=OBL, positive down ! ! note: the following fields used the CVMix/KPP computation of buoyancy forcing are not included here ! 1. Tm: temperature associated with surfaceThicknessFlux, C (here we assume Tm == temperatureSurfaceValue) - ! 2. Sm: salinity associated with surfaceThicknessFlux, PSU (here we assume Sm == salinitySurfaceValue and account for salinity flux in surfaceTracerFlux array) + ! 2. Sm: salinity associated with surfaceThicknessFlux, PSU (here we assume Sm == salinitySurfaceValue and account for salinity flux in activeTracersSurfaceFlux array) ! surfaceBuoyancyForcing(iCell) = thermalExpansionCoeff (1,iCell) * & - (surfaceTracerFlux(indexTempFlux,iCell) + penetrativeTemperatureFlux(iCell) - penetrativeTemperatureFluxOBL(iCell)) & - - salineContractionCoeff(1,iCell) * surfaceTracerFlux(indexSaltFlux,iCell) + (activeTracersSurfaceFlux(indexTempFlux,iCell) + penetrativeTemperatureFlux(iCell) - penetrativeTemperatureFluxOBL(iCell)) & + - salineContractionCoeff(1,iCell) * activeTracersSurfaceFlux(indexSaltFlux,iCell) ! at this point, surfaceBuoyancyForcing has units of m/s ! change into units of m^2/s^3 (which can be thought of as the flux of buoyancy, units of buoyancy * velocity ) diff --git a/src/core_ocean/shared/mpas_ocn_equation_of_state.F b/src/core_ocean/shared/mpas_ocn_equation_of_state.F index f8df5baa78..5755fdccbd 100644 --- a/src/core_ocean/shared/mpas_ocn_equation_of_state.F +++ b/src/core_ocean/shared/mpas_ocn_equation_of_state.F @@ -79,7 +79,7 @@ subroutine ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, k ! from model temperature and salinity using an equation of state. ! ! Input: mesh - mesh metadata - ! s - state: tracers + ! s - state: activeTracers ! k_displaced ! ! If k_displaced==0, density is returned with no displacement @@ -97,6 +97,7 @@ subroutine ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, k type (mpas_pool_type), intent(inout) :: diagnosticsPool type (mpas_pool_type), intent(in) :: meshPool integer, intent(in), optional :: timeLevelIn + type (mpas_pool_type), pointer :: tracersPool integer :: k_displaced character(len=*), intent(in) :: displacement_type real (kind=RKIND), dimension(:,:), intent(out) :: density @@ -107,7 +108,7 @@ subroutine ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, k integer, dimension(:), pointer :: maxLevelCell real (kind=RKIND), dimension(:,:), pointer :: tracersSurfaceValue - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers integer :: iCell, k integer, pointer :: indexT, indexS type (dm_info) :: dminfo @@ -122,18 +123,19 @@ subroutine ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, k end if call mpas_pool_get_array(diagnosticsPool, 'tracersSurfaceValue', tracersSurfaceValue) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) - call mpas_pool_get_dimension(statePool, 'index_temperature', indexT) - call mpas_pool_get_dimension(statePool, 'index_salinity', indexS) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexT) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexS) if (linearEos) then - call ocn_equation_of_state_linear_density(meshPool, k_displaced, displacement_type, indexT, indexS, tracers, density, err, & + call ocn_equation_of_state_linear_density(meshPool, k_displaced, displacement_type, indexT, indexS, activeTracers, density, err, & tracersSurfaceValue, thermalExpansionCoeff, salineContractionCoeff) elseif (jmEos) then - call ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_type, indexT, indexS, tracers, density, err, & + call ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_type, indexT, indexS, activeTracers, density, err, & tracersSurfaceValue, thermalExpansionCoeff, salineContractionCoeff) endif diff --git a/src/core_ocean/shared/mpas_ocn_forcing.F b/src/core_ocean/shared/mpas_ocn_forcing.F index 80986b6273..25a7f6b6fc 100644 --- a/src/core_ocean/shared/mpas_ocn_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_forcing.F @@ -25,7 +25,6 @@ module ocn_forcing use mpas_timekeeping use mpas_io_units use mpas_dmpar - use ocn_forcing_bulk use ocn_forcing_restoring use ocn_constants @@ -33,6 +32,10 @@ module ocn_forcing private save + ! TRACER-CLEAN-UP + ! Need to figure out what to do with absorption coefficient computation. + ! Also need to remove restoring stuff + !-------------------------------------------------------------------- ! ! Public parameters @@ -58,7 +61,7 @@ module ocn_forcing real (kind=RKIND) :: attenuationCoefficient - logical :: restoringOn, bulkOn + logical :: restoringOn !*********************************************************************** @@ -112,13 +115,24 @@ subroutine ocn_forcing_build_arrays(meshPool, statePool, forcingPool, err, timeL ! !----------------------------------------------------------------- - integer :: timeLevel + ! pool pointers + type (mpas_pool_type), pointer :: tracersPool + type (mpas_pool_type), pointer :: tracersSurfaceFluxPool + + ! scalar pointers integer, pointer :: indexTemperature, indexSalinity - integer, pointer :: indexSurfaceTemperatureFlux, indexSurfaceSalinityFlux + integer, pointer :: indexTemperatureSurfaceFlux, indexSalinitySurfaceFlux + ! array pointers real (kind=RKIND), dimension(:), pointer :: temperatureRestore, salinityRestore - real (kind=RKIND), dimension(:,:), pointer :: surfaceTracerFlux - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:), pointer :: activeTracersSurfaceFlux + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers + + ! local integer/real/logical + integer :: timeLevel + + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceFlux', tracersSurfaceFluxPool) if (present(timeLevelIn)) then timeLevel = timeLevelIn @@ -126,28 +140,24 @@ subroutine ocn_forcing_build_arrays(meshPool, statePool, forcingPool, err, timeL timeLevel = 1 end if - if ( bulkOn ) then - call ocn_forcing_bulk_build_arrays(meshPool, forcingPool, err) - end if - if ( restoringOn ) then - call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', indexSalinity) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) - call mpas_pool_get_dimension(forcingPool, 'index_surfaceTemperatureFlux', indexSurfaceTemperatureFlux) - call mpas_pool_get_dimension(forcingPool, 'index_surfaceSalinityFlux', indexSurfaceSalinityFlux) + call mpas_pool_get_dimension(tracersSurfaceFluxPool, 'index_temperatureSurfaceFlux', indexTemperatureSurfaceFlux) + call mpas_pool_get_dimension(tracersSurfaceFluxPool, 'index_salinitySurfaceFlux', indexSalinitySurfaceFlux) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) call mpas_pool_get_array(meshPool, 'temperatureRestore', temperatureRestore) call mpas_pool_get_array(meshPool, 'salinityRestore', salinityRestore) - call mpas_pool_get_array(forcingPool, 'surfaceTracerFlux', surfaceTracerFlux) + call mpas_pool_get_array(tracersSurfaceFluxPool, 'activeTracersSurfaceFlux', activeTracersSurfaceFlux) call ocn_forcing_restoring_build_arrays(meshPool, indexTemperature, indexSalinity, & - indexSurfaceTemperatureFlux, indexSurfaceSalinityFlux, & - tracers, temperatureRestore, salinityRestore, & - surfaceTracerFlux, err) + indexTemperatureSurfaceFlux, indexSalinitySurfaceFlux, & + activeTracers, temperatureRestore, salinityRestore, & + activeTracersSurfaceFlux, err) end if !-------------------------------------------------------------------- @@ -183,21 +193,15 @@ subroutine ocn_forcing_init(err)!{{{ attenuationCoefficient = config_flux_attenuation_coefficient - if ( config_forcing_type == trim('bulk') ) then - call ocn_forcing_bulk_init(err1) - bulkOn = .true. - restoringOn = .false. - else if ( config_forcing_type == trim('restoring') ) then + if ( config_forcing_type == trim('restoring') ) then call ocn_forcing_restoring_init(err1) restoringOn = .true. - bulkOn = .false. else if ( config_forcing_type == trim('off') ) then restoringOn = .false. - bulkOn = .false. else - write(stderrUnit, *) "ERROR: config_forcing_type not one of 'bulk' 'restoring', or 'off'." + write(stderrUnit, *) "ERROR: config_forcing_type not one of 'restoring', or 'off'." err = 1 - call mpas_dmpar_global_abort("ERROR: config_forcing_type not one of 'bulk', 'restoring', or 'off'.") + call mpas_dmpar_global_abort("ERROR: config_forcing_type not one of 'restoring', or 'off'.") end if err = ior(err,err1) diff --git a/src/core_ocean/shared/mpas_ocn_forcing_bulk.F b/src/core_ocean/shared/mpas_ocn_forcing_bulk.F deleted file mode 100644 index bce3cb0794..0000000000 --- a/src/core_ocean/shared/mpas_ocn_forcing_bulk.F +++ /dev/null @@ -1,220 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_forcing_bulk -! -!> \brief MPAS ocean bulk forcing -!> \author Doug Jacobsen -!> \date 04/25/12 -!> \details -!> This module contains routines for building the forcing arrays, -!> if bulk forcing is used. -! -!----------------------------------------------------------------------- - -module ocn_forcing_bulk - - use mpas_kind_types - use mpas_derived_types - use mpas_pool_routines - use mpas_timekeeping - use ocn_constants - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_forcing_bulk_build_arrays, & - ocn_forcing_bulk_init - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - - real (kind=RKIND) :: refDensity - -!*********************************************************************** - -contains - -!*********************************************************************** -! -! routine ocn_forcing_bulk_build_arrays -! -!> \brief Determines the forcing array used for the bulk forcing. -!> \author Doug Jacobsen -!> \date 04/25/12 -!> \details -!> This routine computes the forcing arrays used later in MPAS. -! -!----------------------------------------------------------------------- - - subroutine ocn_forcing_bulk_build_arrays(meshPool, forcingPool, err)!{{{ - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - integer, intent(out) :: err !< Output: Error flag - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - - integer :: iEdge, cell1, cell2 - integer :: iCell, k - integer, pointer :: index_temperature_flux, index_salinity_flux - integer, pointer :: nCells, nEdges - - integer, dimension(:,:), pointer :: cellsOnEdge - - real (kind=RKIND) :: meridionalAverage, zonalAverage - real (kind=RKIND), dimension(:), pointer :: angleEdge - real (kind=RKIND), dimension(:), pointer :: windStressZonal, windStressMeridional - real (kind=RKIND), dimension(:), pointer :: latentHeatFlux, sensibleHeatFlux, longWaveHeatFluxUp, longWaveHeatFluxDown, evaporationFlux, seaIceHeatFlux, snowFlux - real (kind=RKIND), dimension(:), pointer :: seaIceFreshWaterFlux, seaIceSalinityFlux, riverRunoffFlux, iceRunoffFlux - real (kind=RKIND), dimension(:), pointer :: shortWaveHeatFlux, penetrativeTemperatureFlux - - real (kind=RKIND), dimension(:), pointer :: rainFlux - real (kind=RKIND), dimension(:), pointer :: seaSurfacePressure, iceFraction - - real (kind=RKIND), dimension(:), pointer :: surfaceThicknessFlux, surfaceWindStress, surfaceWindStressMagnitude - real (kind=RKIND), dimension(:,:), pointer :: surfaceTracerFlux - - err = 0 - - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - - call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) - call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - - call mpas_pool_get_dimension(forcingPool, 'index_surfaceTemperatureFlux', index_temperature_flux) - call mpas_pool_get_dimension(forcingPool, 'index_surfaceSalinityFlux', index_salinity_flux) - - call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) - call mpas_pool_get_array(forcingPool, 'surfaceWindStressMagnitude', surfaceWindStressMagnitude) - call mpas_pool_get_array(forcingPool, 'windStressZonal', windStressZonal) - call mpas_pool_get_array(forcingPool, 'windStressMeridional', windStressMeridional) - call mpas_pool_get_array(forcingPool, 'latentHeatFlux', latentHeatFlux) - call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) - call mpas_pool_get_array(forcingPool, 'longWaveHeatFluxUp', longWaveHeatFluxUp) - call mpas_pool_get_array(forcingPool, 'longWaveHeatFluxDown', longWaveHeatFluxDown) - call mpas_pool_get_array(forcingPool, 'evaporationFlux', evaporationFlux) - call mpas_pool_get_array(forcingPool, 'seaIceHeatFlux', seaIceHeatFlux) - call mpas_pool_get_array(forcingPool, 'snowFlux', snowFlux) - call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) - - call mpas_pool_get_array(forcingPool, 'seaIceFreshWaterFlux', seaIceFreshWaterFlux) - call mpas_pool_get_array(forcingPool, 'seaIceSalinityFlux', seaIceSalinityFlux) - call mpas_pool_get_array(forcingPool, 'riverRunoffFlux', riverRunoffFlux) - call mpas_pool_get_array(forcingPool, 'iceRunoffFlux', iceRunoffFlux) - - call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) - - call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) - call mpas_pool_get_array(forcingPool, 'iceFraction', iceFraction) - - call mpas_pool_get_array(forcingPool, 'surfaceThicknessFlux', surfaceThicknessFlux) - call mpas_pool_get_array(forcingPool, 'surfaceTracerFlux', surfaceTracerFlux) - call mpas_pool_get_array(forcingPool, 'penetrativeTemperatureFlux', penetrativeTemperatureFlux) - - ! Convert CESM wind stress to MPAS-O windstress - do iEdge = 1, nEdges - cell1 = cellsOnEdge(1, iEdge) - cell2 = cellsOnEdge(2, iEdge) - - zonalAverage = 0.5 * (windStressZonal(cell1) + windStressZonal(cell2)) - meridionalAverage = 0.5 * (windStressMeridional(cell1) + windStressMeridional(cell2)) - - surfaceWindStress(iEdge) = cos(angleEdge(iEdge)) * zonalAverage + sin(angleEdge(iEdge)) * meridionalAverage - end do - - - ! Build surface fluxes at cell centers - do iCell = 1, nCells - surfaceWindStressMagnitude(iCell) = sqrt(windStressZonal(iCell)**2 + windStressMeridional(iCell)**2) - surfaceTracerFlux(index_temperature_flux, iCell) = (latentHeatFlux(iCell) + sensibleHeatFlux(iCell) + longWaveHeatFluxUp(iCell) + longWaveHeatFluxDown(iCell) & - + seaIceHeatFlux(iCell) - (snowFlux(iCell) + iceRunoffFlux(iCell)) * latent_heat_fusion_mks) * hflux_factor - - surfaceTracerFlux(index_salinity_flux, iCell) = seaIceSalinityFlux(iCell) * sflux_factor - - surfaceThicknessFlux(iCell) = ( snowFlux(iCell) + rainFlux(iCell) + evaporationFlux(iCell) + seaIceFreshWaterFlux(iCell) + iceRunoffFlux(iCell) + riverRunoffFlux(iCell) ) / refDensity - end do - - penetrativeTemperatureFlux = shortWaveHeatFlux * hflux_factor - - end subroutine ocn_forcing_bulk_build_arrays!}}} - -!*********************************************************************** -! -! routine ocn_forcing_bulk_init -! -!> \brief Initializes bulk forcing module -!> \author Doug Jacobsen -!> \date 04/25/12 -!> \details -!> This routine initializes the bulk forcing module. -! -!----------------------------------------------------------------------- - - subroutine ocn_forcing_bulk_init(err)!{{{ - - integer, intent(out) :: err !< Output: error flag - - real (kind=RKIND), pointer :: config_density0 - - err = 0 - - - call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) - - refDensity = config_density0 - - end subroutine ocn_forcing_bulk_init!}}} - -!*********************************************************************** - -end module ocn_forcing_bulk - - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! vim: foldmethod=marker diff --git a/src/core_ocean/shared/mpas_ocn_forcing_restoring.F b/src/core_ocean/shared/mpas_ocn_forcing_restoring.F index b7377d105d..1b01a479d2 100644 --- a/src/core_ocean/shared/mpas_ocn_forcing_restoring.F +++ b/src/core_ocean/shared/mpas_ocn_forcing_restoring.F @@ -23,6 +23,9 @@ module ocn_forcing_restoring use mpas_pool_routines use ocn_constants + ! TRACER-CLEAN-UP + ! Need to remove this module at some point + implicit none private save diff --git a/src/core_ocean/shared/mpas_ocn_init_routines.F b/src/core_ocean/shared/mpas_ocn_init_routines.F index 29ae889050..d0078b447f 100644 --- a/src/core_ocean/shared/mpas_ocn_init_routines.F +++ b/src/core_ocean/shared/mpas_ocn_init_routines.F @@ -359,6 +359,7 @@ subroutine ocn_init_routines_vert_coord(domain)!{{{ type (mpas_pool_type), pointer :: statePool type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: tracersPool type (mpas_pool_type), pointer :: verticalMeshPool type (dm_info) :: dminfo @@ -374,8 +375,8 @@ subroutine ocn_init_routines_vert_coord(domain)!{{{ real (kind=RKIND), dimension(:), allocatable :: minBottomDepth, minBottomDepthMid, zMidZLevel real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness - real (kind=RKIND), dimension(:,:,:), pointer :: tracers - integer, pointer :: nVertLevels, nCells, num_tracers + real (kind=RKIND), dimension(:,:,:), pointer :: tracersGroup + integer, pointer :: nVertLevels, nCells logical :: consistentSSH real (kind=RKIND), pointer :: config_min_pbc_fraction @@ -383,6 +384,8 @@ subroutine ocn_init_routines_vert_coord(domain)!{{{ logical, pointer :: config_check_zlevel_consistency, config_set_restingThickness_to_IC character (len=StrKIND), pointer :: config_vert_coord_movement, config_pbc_alteration_type + type (mpas_pool_iterator_type) :: groupItr + call mpas_pool_get_config(domain % configs, 'config_vert_coord_movement', config_vert_coord_movement) call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) call mpas_pool_get_config(domain % configs, 'config_alter_ICs_for_pbcs', config_alter_ICs_for_pbcs) @@ -398,9 +401,9 @@ subroutine ocn_init_routines_vert_coord(domain)!{{{ call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) call mpas_pool_get_array(meshPool, 'refBottomDepthTopOfCell', refBottomDepthTopOfCell) @@ -415,8 +418,6 @@ subroutine ocn_init_routines_vert_coord(domain)!{{{ call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) - ! TopOfCell needed where zero depth for the very top may be referenced. refBottomDepthTopOfCell(1) = 0.0 do k = 1, nVertLevels @@ -469,7 +470,7 @@ subroutine ocn_init_routines_vert_coord(domain)!{{{ minBottomDepth(k) = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*(refBottomDepth(k) - refBottomDepth(k-1)) minBottomDepthMid(k) = 0.5*(minBottomDepth(k) + refBottomDepthTopOfCell(k)) zMidZLevel(k) = - 0.5*(refBottomDepth(k) + refBottomDepthTopOfCell(k)) - enddo + end do do iCell = 1, nCells @@ -479,27 +480,34 @@ subroutine ocn_init_routines_vert_coord(domain)!{{{ ! Round up to cell above maxLevelCell(iCell) = maxLevelCell(iCell) - 1 bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) - elseif (bottomDepth(iCell) .lt. minBottomDepth(k)) then + else if (bottomDepth(iCell) .lt. minBottomDepth(k)) then ! Round down cell to the min_pbc_fraction. bottomDepth(iCell) = minBottomDepth(k) - endif + end if ! reset k to new value of maxLevelCell k = maxLevelCell(iCell) ! Alter thickness of bottom level to account for PBC - layerThickness(k,iCell) = bottomDepth(iCell) - refBottomDepthTopOfCell(k) - - ! Linearly interpolate the initial T&S for new location of bottom cell for PBCs - zMidPBC = -0.5*(bottomDepth(iCell) + refBottomDepthTopOfCell(k)) - km1 = max(k-1,1) - do iTracer = 1, num_tracers - tracers(iTracer,k,iCell) = tracers(iTracer,k,iCell) & - + (tracers(iTracer,km1,iCell) - tracers(iTracer,k,iCell)) & - /(zMidZLevel(km1)-zMidZLevel(k)+1.0e-16) & - *(zMidPBC - zMidZLevel(k)) - enddo - - enddo + layerThickness(k,iCell) = bottomDepth(iCell) - refBottomDepthTopOfCell(k) + end do + + call mpas_pool_begin_iteration(tracersPool) + do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroup, 1) + + do iCell = 1, nCells + ! Linearly interpolate the initial T&S for new location of bottom cell for PBCs + zMidPBC = -0.5_RKIND * (bottomDepth(iCell) + refBottomDepthTopOfCell(k)) + km1 = max(k-1,1) + tracersGroup(:, k, iCell) = tracersGroup(:, k, iCell) & + + (tracersGroup(:, km1, iCell) - tracersGroup(:, k, iCell)) & + /(zMidZLevel(km1) - zMidZLevel(k) + 1.0e-16_RKIND) & + *(zMidPBC - zMidZLevel(k)) + + end do + end if + end do deallocate(minBottomDepth,zMidZLevel) @@ -587,7 +595,7 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ real (kind=RKIND), intent(in) :: dt integer, intent(out) :: err - type (mpas_pool_type), pointer :: meshPool, averagePool, statePool + type (mpas_pool_type), pointer :: meshPool, averagePool, statePool, tracersPool type (mpas_pool_type), pointer :: forcingPool, diagnosticsPool, scratchPool integer :: i, iEdge, iCell, k integer :: err1 @@ -603,7 +611,7 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ real (kind=RKIND), dimension(:,:), pointer :: velocityZonal, velocityMeridional real (kind=RKIND), dimension(:,:,:), pointer :: derivTwo - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), pointer :: tracersGroup integer, pointer :: nCells, nEdges, nVertices, nVertLevels integer, pointer :: config_horiz_tracer_adv_order @@ -611,6 +619,8 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ logical, pointer :: config_use_standardGM real (kind=RKIND), pointer :: config_maxMeshDensity + type (mpas_pool_iterator_type) :: groupItr + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) call mpas_pool_get_dimension(block % dimensions, 'nEdges', nEdges) call mpas_pool_get_dimension(block % dimensions, 'nVertices', nVertices) @@ -623,6 +633,8 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) call mpas_pool_get_subpool(block % structs, 'average', averagePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_array(meshPool, 'derivTwo', derivTwo) call mpas_pool_get_array(meshPool, 'advCoefs', advCoefs) call mpas_pool_get_array(meshPool, 'advCoefs3rd', advCoefs3rd) @@ -648,7 +660,6 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) call mpas_pool_get_config(block % configs, 'config_horiz_tracer_adv_order', config_horiz_tracer_adv_order) call mpas_pool_get_config(block % configs, 'config_hmix_scaleWithMesh', config_hmix_scaleWithMesh) @@ -674,10 +685,10 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ end if call mpas_timer_start("diagnostic solve", .false., initDiagSolveTimer) - call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool) + call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool) call mpas_timer_stop("diagnostic solve", initDiagSolveTimer) - ! initialize velocities and tracers on land to be zero. + ! initialize velocities and active tracers on land to be zero. areaCell(nCells+1) = -1.0e34 layerThickness(:, nCells+1) = 0.0 @@ -688,8 +699,14 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ normalVelocity(maxLevelEdgeBot(iEdge)+1:nVertLevels,iEdge) = -1.0e34 end do - do iCell=1,nCells - tracers(:, maxLevelCell(iCell)+1:nVertLevels,iCell) = -1.0e34 + call mpas_pool_begin_iteration(tracersPool) + do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroup, 1) + do iCell=1,nCells + tracersGroup(:, maxLevelCell(iCell)+1:nVertLevels,iCell) = -1.0e34 + end do + end if end do ! ------------------------------------------------------------------ diff --git a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F new file mode 100644 index 0000000000..6aa71c7c92 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F @@ -0,0 +1,405 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_surface_bulk_forcing +! +!> \brief MPAS ocean bulk forcing +!> \author Doug Jacobsen +!> \date 04/25/12 +!> \details +!> This module contains routines for building the forcing arrays, +!> if bulk forcing is used. +! +!----------------------------------------------------------------------- + +module ocn_surface_bulk_forcing + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use mpas_timekeeping + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_surface_bulk_forcing_tracers, & + ocn_surface_bulk_forcing_vel, & + ocn_surface_bulk_forcing_thick, & + ocn_surface_bulk_forcing_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + real (kind=RKIND) :: refDensity + logical :: bulkWindStressOn, bulkThicknessFluxOn + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_surface_bulk_forcing_tracers +! +!> \brief Determines the tracers forcing array used for the bulk forcing. +!> \author Doug Jacobsen +!> \date 04/25/12 +!> \details +!> This routine computes the tracers forcing arrays used later in MPAS. +! +!----------------------------------------------------------------------- + +! TRACER-CLEAN-UP +! Currently, penetrativeTemperatureFlux is built into bulk forcing.. what should we do about that? + subroutine ocn_surface_bulk_forcing_tracers(meshPool, groupName, forcingPool, tracersSurfaceFlux, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + character (len=*) :: groupName !< Input: Name of tracer group + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information + real (kind=RKIND), dimension(:,:), intent(inout) :: tracersSurfaceFlux !< Input/Output: Surface flux for tracer group + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + if ( trim(groupName) == 'activeTracers' ) then + call ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracersSurfaceFlux, err) + end if + + end subroutine ocn_surface_bulk_forcing_tracers!}}} + +!*********************************************************************** +! +! routine ocn_surface_bulk_forcing_vel +! +!> \brief Determines the velocity forcing array used for the bulk forcing. +!> \author Doug Jacobsen +!> \date 04/25/12 +!> \details +!> This routine computes the velocity forcing arrays used later in MPAS. +! +!----------------------------------------------------------------------- + + subroutine ocn_surface_bulk_forcing_vel(meshPool, forcingPool, surfaceWindStress, surfaceWindStressMagnitude, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:), intent(inout) :: surfaceWindStress, & !< Input/Output: Array for surface windStress + surfaceWindStressMagnitude !< Input/Output: Array for magnitude of wind stress + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iEdge, cell1, cell2, iCell + integer, pointer :: nCells, nEdges + + integer, dimension(:,:), pointer :: cellsOnEdge + + real (kind=RKIND) :: meridionalAverage, zonalAverage + real (kind=RKIND), dimension(:), pointer :: angleEdge + real (kind=RKIND), dimension(:), pointer :: windStressZonal, windStressMeridional + + err = 0 + + if ( .not. bulkWindStressOn ) return + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + + call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + + call mpas_pool_get_array(forcingPool, 'windStressZonal', windStressZonal) + call mpas_pool_get_array(forcingPool, 'windStressMeridional', windStressMeridional) + + ! Convert CESM wind stress to MPAS-O windstress + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1, iEdge) + cell2 = cellsOnEdge(2, iEdge) + + zonalAverage = 0.5 * (windStressZonal(cell1) + windStressZonal(cell2)) + meridionalAverage = 0.5 * (windStressMeridional(cell1) + windStressMeridional(cell2)) + + surfaceWindStress(iEdge) = cos(angleEdge(iEdge)) * zonalAverage + sin(angleEdge(iEdge)) * meridionalAverage + end do + + + ! Build surface fluxes at cell centers + do iCell = 1, nCells + surfaceWindStressMagnitude(iCell) = sqrt(windStressZonal(iCell)**2 + windStressMeridional(iCell)**2) + end do + + end subroutine ocn_surface_bulk_forcing_vel!}}} + +!*********************************************************************** +! +! routine ocn_surface_bulk_forcing_thick +! +!> \brief Determines the thickness forcing array used for the bulk forcing. +!> \author Doug Jacobsen +!> \date 04/25/12 +!> \details +!> This routine computes the thickness forcing arrays used later in MPAS. +! +!----------------------------------------------------------------------- + + subroutine ocn_surface_bulk_forcing_thick(meshPool, forcingPool, surfaceThicknessFlux, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information + real (kind=RKIND), dimension(:), intent(inout) :: surfaceThicknessFlux !< Input/Output: Array for surface thickness flux + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell + integer, pointer :: index_temperature_flux, index_salinity_flux + integer, pointer :: nCells, nEdges + + integer, dimension(:,:), pointer :: cellsOnEdge + + real (kind=RKIND), dimension(:), pointer :: evaporationFlux, snowFlux + real (kind=RKIND), dimension(:), pointer :: seaIceFreshWaterFlux, riverRunoffFlux, iceRunoffFlux + real (kind=RKIND), dimension(:), pointer :: rainFlux + + err = 0 + + if ( .not. bulkThicknessFluxOn ) return + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_array(forcingPool, 'evaporationFlux', evaporationFlux) + call mpas_pool_get_array(forcingPool, 'snowFlux', snowFlux) + call mpas_pool_get_array(forcingPool, 'seaIceFreshWaterFlux', seaIceFreshWaterFlux) + call mpas_pool_get_array(forcingPool, 'riverRunoffFlux', riverRunoffFlux) + call mpas_pool_get_array(forcingPool, 'iceRunoffFlux', iceRunoffFlux) + call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) + + + ! Build surface fluxes at cell centers + do iCell = 1, nCells + surfaceThicknessFlux(iCell) = ( snowFlux(iCell) + rainFlux(iCell) + evaporationFlux(iCell) + seaIceFreshWaterFlux(iCell) + iceRunoffFlux(iCell) + riverRunoffFlux(iCell) ) / refDensity + end do + + end subroutine ocn_surface_bulk_forcing_thick!}}} + +!*********************************************************************** +! +! routine ocn_surface_bulk_forcing_init +! +!> \brief Initializes bulk forcing module +!> \author Doug Jacobsen +!> \date 04/25/12 +!> \details +!> This routine initializes the bulk forcing module. +! +!----------------------------------------------------------------------- + + subroutine ocn_surface_bulk_forcing_init(err)!{{{ + + integer, intent(out) :: err !< Output: error flag + + real (kind=RKIND), pointer :: config_density0 + logical, pointer :: config_use_bulk_wind_stress, config_use_bulk_thickness_flux + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) + call mpas_pool_get_config(ocnConfigs, 'config_use_bulk_wind_stress', config_use_bulk_wind_stress) + call mpas_pool_get_config(ocnConfigs, 'config_use_bulk_thickness_flux', config_use_bulk_thickness_flux) + + refDensity = config_density0 + bulkWindStressOn = config_use_bulk_wind_stress + bulkThicknessFluxOn = config_use_bulk_thickness_flux + + end subroutine ocn_surface_bulk_forcing_init!}}} + +!*********************************************************************** +! +! Private module subroutines +! +!*********************************************************************** + + +!*********************************************************************** +! +! routine ocn_surface_bulk_forcing_active_tracers +! +!> \brief Determines the active tracers forcing array used for the bulk forcing. +!> \author Doug Jacobsen +!> \date 04/25/12 +!> \details +!> This routine computes the active tracers forcing arrays used later in MPAS. +! +!----------------------------------------------------------------------- + + subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracersSurfaceFlux, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information + real (kind=RKIND), dimension(:,:), intent(inout) :: tracersSurfaceFlux + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell + integer, pointer :: index_temperature_flux, index_salinity_flux + integer, pointer :: nCells + + real (kind=RKIND), dimension(:), pointer :: latentHeatFlux, sensibleHeatFlux, longWaveHeatFluxUp, longWaveHeatFluxDown, seaIceHeatFlux, snowFlux + real (kind=RKIND), dimension(:), pointer :: seaIceFreshWaterFlux, seaIceSalinityFlux, iceRunoffFlux + real (kind=RKIND), dimension(:), pointer :: shortWaveHeatFlux, penetrativeTemperatureFlux + + err = 0 + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_dimension(forcingPool, 'index_temperatureSurfaceFlux', index_temperature_flux) + call mpas_pool_get_dimension(forcingPool, 'index_salinitySurfaceFlux', index_salinity_flux) + + call mpas_pool_get_array(forcingPool, 'latentHeatFlux', latentHeatFlux) + call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) + call mpas_pool_get_array(forcingPool, 'longWaveHeatFluxUp', longWaveHeatFluxUp) + call mpas_pool_get_array(forcingPool, 'longWaveHeatFluxDown', longWaveHeatFluxDown) + call mpas_pool_get_array(forcingPool, 'seaIceHeatFlux', seaIceHeatFlux) + call mpas_pool_get_array(forcingPool, 'snowFlux', snowFlux) + call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) + + call mpas_pool_get_array(forcingPool, 'seaIceSalinityFlux', seaIceSalinityFlux) + call mpas_pool_get_array(forcingPool, 'iceRunoffFlux', iceRunoffFlux) + + call mpas_pool_get_array(forcingPool, 'penetrativeTemperatureFlux', penetrativeTemperatureFlux) + + ! Build surface fluxes at cell centers + do iCell = 1, nCells + tracersSurfaceFlux(index_temperature_flux, iCell) = tracersSurfaceFlux(index_temperature_flux, iCell) & + + (latentHeatFlux(iCell) + sensibleHeatFlux(iCell) + longWaveHeatFluxUp(iCell) + longWaveHeatFluxDown(iCell) & + + seaIceHeatFlux(iCell) - (snowFlux(iCell) + iceRunoffFlux(iCell)) * latent_heat_fusion_mks) * hflux_factor + + tracersSurfaceFlux(index_salinity_flux, iCell) = tracersSurfaceFlux(index_salinity_flux, iCell) & + + seaIceSalinityFlux(iCell) * sflux_factor + end do + + ! TRACER-CLEAN-UP + ! Do we want this here still? + penetrativeTemperatureFlux = shortWaveHeatFlux * hflux_factor + + end subroutine ocn_surface_bulk_forcing_active_tracers!}}} + +end module ocn_surface_bulk_forcing + + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index a3c11af680..b41a676dba 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -27,9 +27,19 @@ module ocn_tendency use ocn_constants + use ocn_surface_bulk_forcing + + use ocn_tracer_hmix + use ocn_high_freq_thickness_hmix_del2 use ocn_tracer_advection use ocn_tracer_short_wave_absorption use ocn_tracer_nonlocalflux + use ocn_tracer_surface_restoring + use ocn_tracer_interior_restoring + use ocn_tracer_exponential_decay + use ocn_tracer_ideal_age + use ocn_tracer_TTD + use ocn_tracer_surface_flux_to_tend use ocn_thick_hadv use ocn_thick_vadv @@ -42,10 +52,6 @@ module ocn_tendency use ocn_vel_forcing use ocn_vmix - use ocn_tracer_hmix - use ocn_high_freq_thickness_hmix_del2 - use ocn_tracer_surface_flux - implicit none private save @@ -100,7 +106,7 @@ subroutine ocn_tend_thick(tendPool, forcingPool, diagnosticsPool, meshPool)!{{{ implicit none type (mpas_pool_type), intent(inout) :: tendPool !< Input/Output: Tendency structure - type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostics information type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information @@ -132,6 +138,11 @@ subroutine ocn_tend_thick(tendPool, forcingPool, diagnosticsPool, meshPool)!{{{ if(config_disable_thick_all_tend) return + ! Build windstress array from bulk + call mpas_timer_start("bulk_thick", .false.) + call ocn_surface_bulk_forcing_thick(meshPool, forcingPool, surfaceThicknessFlux, err) + call mpas_timer_stop("bulk_thick") + ! ! height tendency: horizontal advection term -\nabla\cdot ( hu) ! @@ -155,7 +166,6 @@ subroutine ocn_tend_thick(tendPool, forcingPool, diagnosticsPool, meshPool)!{{{ ! surface flux tendency ! call mpas_timer_start("surface flux", .false.) - call ocn_thick_surface_flux_tend(meshPool, fractionAbsorbed, layerThickness, surfaceThicknessFlux, tend_layerThickness, err) call mpas_timer_stop("surface flux") @@ -186,14 +196,16 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP type (mpas_pool_type), intent(inout) :: scratchPool !< Input: Scratch structure integer, intent(in), optional :: timeLevelIn !< Input: Time level for state fields - real (kind=RKIND), dimension(:), pointer :: surfaceWindStress + type (mpas_pool_type), pointer :: tracersPool + + real (kind=RKIND), dimension(:), pointer :: surfaceWindStress, surfaceWindStressMagnitude real (kind=RKIND), dimension(:,:), pointer :: & layerThicknessEdge, normalVelocity, tangentialVelocity, density, potentialDensity, zMid, pressure, & tend_normalVelocity, circulation, relativeVorticity, viscosity, kineticEnergyCell, & normalizedRelativeVorticityEdge, normalizedPlanetaryVorticityEdge, & montgomeryPotential, vertAleTransportTop, divergence, vertViscTopOfEdge, & inSituThermalExpansionCoeff, inSituSalineContractionCoeff - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers integer :: timeLevel @@ -205,6 +217,8 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP call mpas_timer_start("ocn_tend_vel") + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + if (present(timeLevelIn)) then timeLevel = timeLevelIn else @@ -215,9 +229,9 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP call mpas_pool_get_config(ocnConfigs, 'config_pressure_gradient_type', config_pressure_gradient_type) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) - call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', indexSalinity) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) call mpas_pool_get_array(diagnosticsPool, 'kineticEnergyCell', kineticEnergyCell) call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) @@ -238,6 +252,7 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP call mpas_pool_get_array(tendPool, 'normalVelocity', tend_normalVelocity) call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) + call mpas_pool_get_array(forcingPool, 'surfaceWindStressMagnitude', surfaceWindStressMagnitude) ! ! velocity tendency: start accumulating tendency terms @@ -246,6 +261,11 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP if(config_disable_vel_all_tend) return + ! Build bulk forcing windstress + call mpas_timer_start("bulk_ws", .false.) + call ocn_surface_bulk_forcing_vel(meshPool, forcingPool, surfaceWindStress, surfaceWindStressMagnitude, err) + call mpas_timer_stop("bulk_ws") + ! ! velocity tendency: nonlinear Coriolis term and grad of kinetic energy ! @@ -271,11 +291,11 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP call mpas_pool_get_array(diagnosticsPool, 'inSituThermalExpansionCoeff',inSituThermalExpansionCoeff) call mpas_pool_get_array(diagnosticsPool, 'inSituSalineContractionCoeff', inSituSalineContractionCoeff) call ocn_vel_pressure_grad_tend(meshPool, pressure, montgomeryPotential, zMid, density, potentialDensity, & - indexTemperature, indexSalinity, tracers, tend_normalVelocity, err, & + indexTemperature, indexSalinity, activeTracers, tend_normalVelocity, err, & inSituThermalExpansionCoeff,inSituSalineContractionCoeff) else call ocn_vel_pressure_grad_tend(meshPool, pressure, montgomeryPotential, zMid, density, potentialDensity, & - indexTemperature, indexSalinity, tracers, tend_normalVelocity, err, & + indexTemperature, indexSalinity, activeTracers, tend_normalVelocity, err, & inSituThermalExpansionCoeff,inSituSalineContractionCoeff) endif call mpas_timer_stop("pressure grad", velPgradTimer) @@ -319,43 +339,117 @@ end subroutine ocn_tend_vel!}}} subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, meshPool, scratchPool, dt, timeLevelIn)!{{{ implicit none - type (mpas_pool_type), intent(inout) :: tendPool !< Input/Output: Tendency structure - type (mpas_pool_type), intent(in) :: statePool !< Input: State information - type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information - type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostic information - type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information - type (mpas_pool_type), intent(in) :: scratchPool !< Input: Scratch information - real (kind=RKIND), intent(in) :: dt !< Input: Time step - integer, intent(in), optional :: timeLevelIn + ! + ! intent in/out + ! + type (mpas_pool_type), intent(inout) :: tendPool !< Input/Output: Tendency structure + type (mpas_pool_type), intent(in) :: statePool !< Input: State information + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information + type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostic information + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), intent(in) :: scratchPool !< Input: Scratch information + real (kind=RKIND), intent(in) :: dt !< Input: Time step + integer, intent(in), optional :: timeLevelIn !< Input/Optional: Time Level Indes + ! + ! additional pools + ! + type (mpas_pool_type), pointer :: tracersPool, tracersTendPool ! tracers and their tendency + type (mpas_pool_type), pointer :: tracersSurfaceFluxPool ! surface fluxes + type (mpas_pool_type), pointer :: tracersSurfaceRestoringFieldsPool ! surface restoring + type (mpas_pool_type), pointer :: tracersInteriorRestoringFieldsPool ! interior restoring + type (mpas_pool_type), pointer :: tracersExponentialDecayFieldsPool ! exponential decay + type (mpas_pool_type), pointer :: tracersIdealAgeFieldsPool ! ideal age + type (mpas_pool_type), pointer :: tracersTTDFieldsPool ! transit time distribution + + ! scalar pointers + integer :: nTracerGroup + integer, pointer :: nVertLevels, nEdges, nCellsSolve, indexTemperature + logical, pointer :: config_disable_tr_all_tend, config_use_cvmix_kpp + logical, pointer :: config_use_tracerGroup, config_use_tracerGroup_surface_bulk_forcing, config_use_tracerGroup_surface_restoring, & + config_use_tracerGroup_interior_restoring, config_use_tracerGroup_exponential_decay, config_use_tracerGroup_idealAge_forcing, & + config_use_tracerGroup_ttd_forcing + + ! iterator for tracer categories + type (mpas_pool_iterator_type) :: groupItr + character (len=StrKIND) :: modifiedGroupName + character (len=StrKIND) :: modifiedConfigName + + ! + ! one dimensional pointers + ! real (kind=RKIND), dimension(:), pointer :: penetrativeTemperatureFlux + real (kind=RKIND), dimension(:), pointer :: tracerGroupExponentialDecayRate + integer, dimension(:), pointer :: maxLevelCell + + ! + ! two dimensional pointers + ! + real (kind=RKIND), dimension(:,:), pointer :: tracerGroupPistonVelocity, tracerGroupSurfaceRestoringValue, tracerGroupIdealAgeMask, tracerGroupTTDMask + real (kind=RKIND), dimension(:,:), pointer :: & normalTransportVelocity, layerThickness,vertAleTransportTop, layerThicknessEdge, vertDiffTopOfCell, & - tend_layerThickness, normalThicknessFlux, surfaceTracerFlux, fractionAbsorbed, zMid, relativeSlopeTopOfEdge, & + tend_layerThickness, normalThicknessFlux, tracerGroupSurfaceFlux, fractionAbsorbed, zMid, relativeSlopeTopOfEdge, & relativeSlopeTapering, relativeSlopeTaperingCell + + ! + ! three dimensional pointers + ! real (kind=RKIND), dimension(:,:,:), pointer :: & - tracers, tend_tr, vertNonLocalFlux + tracerGroup, tracerGroupTend, vertNonLocalFlux - integer :: err, iEdge, k - integer, pointer :: nVertLevels, nEdges, indexTemperature - integer :: timeLevel + real (kind=RKIND), dimension(:,:,:), pointer :: tracerGroupInteriorRestoringTimeScale, tracerGroupInteriorRestoringValue - logical, pointer :: config_disable_tr_all_tend, config_use_cvmix_kpp + ! + ! Field pointers + ! + type (field2DReal), pointer :: normalThicknessFluxField + ! + ! local integers/reals/logicals + ! + integer :: err, iEdge, k, timeLevel + + ! + ! start timers + ! call mpas_timer_start("ocn_tend_tracer") + ! + ! get tracers pools + ! + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceFlux', tracersSurfaceFluxPool) + + ! + ! set time level of optional argument is present + ! if (present(timeLevelIn)) then timeLevel = timeLevelIn else timeLevel = 1 end if + ! + ! get dimensions + ! + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) + + ! + ! get configure options + ! call mpas_pool_get_config(ocnConfigs, 'config_disable_tr_all_tend', config_disable_tr_all_tend) call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_kpp', config_use_cvmix_kpp) + ! + ! get arrays + ! call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) - call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) call mpas_pool_get_array(diagnosticsPool, 'vertDiffTopOfCell', vertDiffTopOfCell) @@ -365,29 +459,22 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTapering', relativeSlopeTapering) call mpas_pool_get_array(diagnosticsPool, 'relativeSlopeTaperingCell', relativeSlopeTaperingCell) call mpas_pool_get_array(diagnosticsPool, 'vertNonLocalFlux', vertNonLocalFlux) - call mpas_pool_get_array(forcingPool, 'penetrativeTemperatureFlux', penetrativeTemperatureFlux) - call mpas_pool_get_array(forcingPool, 'surfaceTracerFlux', surfaceTracerFlux) call mpas_pool_get_array(forcingPool, 'fractionAbsorbed', fractionAbsorbed) - - call mpas_pool_get_array(tendPool, 'tracers', tend_tr) call mpas_pool_get_array(tendPool, 'layerThickness', tend_layerThickness) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_field(scratchPool, 'normalThicknessFlux', normalThicknessFluxField) - call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) + call mpas_allocate_scratch_field(normalThicknessFluxField, .true.) + normalThicknessFlux => normalThicknessFluxField % array - ! - ! initialize tracer tendency (RHS of tracer equation) to zero. - ! - tend_tr(:,:,:) = 0.0 if(config_disable_tr_all_tend) return - allocate(normalThicknessFlux(nVertLevels, nEdges+1)) ! ! transport velocity for the tracer. + ! do iEdge = 1, nEdges do k = 1, nVertLevels normalThicknessFlux(k, iEdge) = normalTransportVelocity(k, iEdge) * layerThicknessEdge(k, iEdge) @@ -395,48 +482,194 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me end do ! - ! tracer tendency: horizontal advection term -div( layerThickness \phi u) - ! - - ! Monotonoic Advection, or standard advection - call mpas_timer_start("adv", .false., tracerHadvTimer) - call ocn_tracer_advection_tend(tracers, normalThicknessFlux, vertAleTransportTop, layerThickness, layerThickness, dt, meshPool, tend_layerThickness, tend_tr) - call mpas_timer_stop("adv", tracerHadvTimer) - + ! begin iterate over tracer categories + ! + call mpas_pool_begin_iteration(tracersPool) + do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + + ! load configure setting for this category + ! + modifiedConfigName = 'config_use_' // trim(groupItr % memberName) + call mpas_pool_get_config(ocnConfigs, modifiedConfigName, config_use_tracerGroup) + + if ( config_use_tracerGroup ) then + modifiedConfigName = 'config_use_' // trim(groupItr % memberName) // '_surface_bulk_forcing' + call mpas_pool_get_config(ocnConfigs, modifiedConfigName, config_use_tracerGroup_surface_bulk_forcing) + modifiedConfigName = 'config_use_' // trim(groupItr % memberName) // '_surface_restoring' + call mpas_pool_get_config(ocnConfigs, modifiedConfigName, config_use_tracerGroup_surface_restoring) + modifiedConfigName = 'config_use_' // trim(groupItr % memberName) // '_interior_restoring' + call mpas_pool_get_config(ocnConfigs, modifiedConfigName, config_use_tracerGroup_interior_restoring) + modifiedConfigName = 'config_use_' // trim(groupItr % memberName) // '_exponential_decay' + call mpas_pool_get_config(ocnConfigs, modifiedConfigName, config_use_tracerGroup_exponential_decay) + modifiedConfigName = 'config_use_' // trim(groupItr % memberName) // '_idealAge_forcing' + call mpas_pool_get_config(ocnConfigs, modifiedConfigName, config_use_tracerGroup_idealAge_forcing) + modifiedConfigName = 'config_use_' // trim(groupItr % memberName) // '_ttd_forcing' + call mpas_pool_get_config(ocnConfigs, modifiedConfigName, config_use_tracerGroup_ttd_forcing) + + + ! Get tracer group, and other groups (tendencies, etc.) + call mpas_pool_get_array(tracersPool, trim(groupItr % memberName), tracerGroup, timeLevel) + nTracerGroup = size(tracerGroup, dim=1) + + ! Get Tendency array + modifiedGroupName = trim(groupItr % memberName) // "Tend" + call mpas_pool_get_array(tracersTendPool, trim(modifiedGroupName), tracerGroupTend) + + ! Get surface flux array + modifiedGroupName = trim(groupItr % memberName) // "SurfaceFlux" + call mpas_pool_get_array(tracersSurfaceFluxPool, trim(modifiedGroupName), tracerGroupSurfaceFlux) + + ! + ! initialize tracer surface flux and tendency to zero. + ! + tracerGroupTend(:,:,:) = 0.0 + tracerGroupSurfaceFlux(:,:) = 0.0 + + ! + ! fill components of surface tracer flux + ! + if (config_use_tracerGroup_surface_bulk_forcing) then + call mpas_timer_start("bulk_" // trim(groupItr % memberName), .false.) + call ocn_surface_bulk_forcing_tracers(meshPool, groupItr % memberName, forcingPool, tracerGroupSurfaceFlux, err) + call mpas_timer_stop("bulk_" // trim(groupItr % memberName)) + end if + + ! + ! ocean surface restoring + ! + if (config_use_tracerGroup_surface_restoring) then + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) + modifiedGroupName = trim(groupItr % memberName) // "PistonVelocity" + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, trim(modifiedGroupName), tracerGroupPistonVelocity) + modifiedGroupName = trim(groupItr % memberName) // "SurfaceRestoringValue" + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, trim(modifiedGroupName), tracerGroupSurfaceRestoringValue) + call ocn_tracer_surface_restoring_compute(nTracerGroup, nCellsSolve, tracerGroup, tracerGroupPistonVelocity, tracerGroupSurfaceRestoringValue, tracerGroupSurfaceFlux, err) + endif + + ! land-ice / ocean interface flux + ! this is a flux at the top ocean surface -- so these fluxes should be added into tracerGroupSurfaceFlux + ! if (put correct logic here, only 'active' only when coupling is turned on) + ! call ocn_tracer_landIce_ocean_coupling(tracerGroup, tracerGroupSurfaceFlux) + ! endif + + ! + ! other additions to tracerGroupSurfaceFlux should be added here + ! + + ! + ! now begin to accumulate the RHS tracer tendencies. + ! + + ! + ! interior restoring forcing tendency + ! + if (config_use_tracerGroup_interior_restoring) then + call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) + modifiedGroupName = trim(groupItr % memberName) // "InteriorRestoringTimeScale" + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, trim(modifiedGroupName), tracerGroupInteriorRestoringTimeScale) + modifiedGroupName = trim(groupItr % memberName) // "InteriorRestoringValue" + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, trim(modifiedGroupName),tracerGroupInteriorRestoringValue) + call ocn_tracer_interior_restoring_compute(nTracerGroup, nCellsSolve, maxLevelCell, layerThickness, & + tracerGroup, tracerGroupInteriorRestoringTimeScale, tracerGroupInteriorRestoringValue, tracerGroupTend, err) + endif + + ! + ! exponential decay tendency + ! + if (config_use_tracerGroup_exponential_decay) then + call mpas_pool_get_subpool(forcingPool, 'tracersExponentialDecayFields', tracersExponentialDecayFieldsPool) + modifiedGroupName = trim(groupItr % memberName) // "ExponentialDecayRate" + call mpas_pool_get_array(tracersExponentialDecayFieldsPool, trim(modifiedGroupName), tracerGroupExponentialDecayRate) + call ocn_tracer_exponential_decay_compute(nTracerGroup, nCellsSolve, maxLevelCell, layerThickness, & + tracerGroup, tracerGroupExponentialDecayRate, tracerGroupTend, err) + endif + + ! + ! ideal age forcing tendency + ! note: ocn_tracer_ideal_age_compute resets tracers in top layer to zero + ! + if (config_use_tracerGroup_idealAge_forcing) then + call mpas_pool_get_subpool(forcingPool, 'tracersIdealAgeFields', tracersIdealAgeFieldsPool) + modifiedGroupName = trim(groupItr % memberName) // "IdealAgeMask" + call mpas_pool_get_array(tracersIdealAgeFieldsPool, trim(modifiedGroupName), tracerGroupIdealAgeMask) + call ocn_tracer_ideal_age_compute(nTracerGroup, nCellsSolve, maxLevelCell, layerThickness, & + tracerGroupIdealAgeMask, tracerGroup, tracerGroupTend, err) + endif + + ! + ! transit-time distribution (TTD) forcing tendency + ! note: no tendency is actually computed in ocn_tracer_TTD_compute + ! note: rather, tracerGroup is reset to tracerGroupTTDMask in top-most layer + ! + if (config_use_tracerGroup_ttd_forcing) then + call mpas_pool_get_subpool(forcingPool, 'tracersTTDFields', tracersTTDFieldsPool) + modifiedGroupName = trim(groupItr % memberName) // "TTDMask" + call mpas_pool_get_array(tracersTTDFieldsPool, trim(modifiedGroupName), tracerGroupTTDMask) + call ocn_tracer_TTD_compute(nTracerGroup, nCellsSolve, maxLevelCell, layerThickness, & + tracerGroupTTDMask, tracerGroup, err) + endif + + ! + ! tracer tendency: horizontal advection term -div( layerThickness \phi u) + ! + + ! Monotonoic Advection, or standard advection + call mpas_timer_start("adv", .false., tracerHadvTimer) + call ocn_tracer_advection_tend(tracerGroup, normalThicknessFlux, vertAleTransportTop, layerThickness, layerThickness, dt, meshPool, tend_layerThickness, tracerGroupTend) + call mpas_timer_stop("adv", tracerHadvTimer) + + ! + ! tracer tendency: del2 horizontal tracer diffusion, div(h \kappa_2 \nabla \phi) + ! + call mpas_timer_start("hmix", .false., tracerHmixTimer) + call ocn_tracer_hmix_tend(meshPool, scratchPool, layerThickness, layerThicknessEdge, zMid, tracerGroup, & + relativeSlopeTopOfEdge, relativeSlopeTapering, relativeSlopeTaperingCell, tracerGroupTend, err) + call mpas_timer_stop("hmix", tracerHmixTimer) + + ! + ! convert the surface tracer flux into a tracer tendency by distributing the flux across some number of surface layers + ! + ! TRACER-CLEAN-UP surfaceTracerFlux + call mpas_timer_start("surface_flux", .false.) + call ocn_tracer_surface_flux_tend(meshPool, fractionAbsorbed, layerThickness, tracerGroupSurfaceFlux, tracerGroupTend, err) + call mpas_timer_stop("surface_flux") + + ! + ! Performing shortwave absorption + ! + if ( trim(groupItr % memberName) == 'activeTracers' ) then + call mpas_timer_start("short wave", .false.) + call ocn_tracer_short_wave_absorption_tend(meshPool, indexTemperature, layerThickness, penetrativeTemperatureFlux, tracerGroupTend, err) + call mpas_timer_stop("short wave") + endif + + ! + ! Compute tracer tendency due to non-local flux computed in KPP + ! + if (config_use_cvmix_kpp) then + call mpas_timer_start("non-local flux from KPP", .false.) + call ocn_tracer_nonlocalflux_tend(meshPool, vertNonLocalFlux, tracerGroupSurfaceFlux, tracerGroupTend, err) + call mpas_timer_stop("non-local flux from KPP") + end if + end if + end if + end do ! - ! tracer tendency: del2 horizontal tracer diffusion, div(h \kappa_2 \nabla \phi) + ! end iterate over tracer categories ! - call mpas_timer_start("hmix", .false., tracerHmixTimer) - call ocn_tracer_hmix_tend(meshPool, scratchPool, layerThickness, layerThicknessEdge, zMid, tracers, & - relativeSlopeTopOfEdge, relativeSlopeTapering, relativeSlopeTaperingCell, tend_tr, err) - call mpas_timer_stop("hmix", tracerHmixTimer) - ! - ! Perform forcing from surface fluxes - ! - call mpas_timer_start("surface_flux", .false.) - call ocn_tracer_surface_flux_tend(meshPool, fractionAbsorbed, layerThickness, surfaceTracerFlux, tend_tr, err) - call mpas_timer_stop("surface_flux") ! - ! Performing shortwave absorption + ! deallocate workspace ! - call mpas_timer_start("short wave", .false.) - call ocn_tracer_short_wave_absorption_tend(meshPool, indexTemperature, layerThickness, penetrativeTemperatureFlux, tend_tr, err) - call mpas_timer_stop("short wave") + call mpas_deallocate_scratch_field(normalThicknessFluxField, .true.) ! - ! Compute tracer tendency due to non-local flux computed in KPP + ! stop timer ! - if (config_use_cvmix_kpp) then - call mpas_timer_start("non-local flux from KPP", .false.) - call ocn_tracer_nonlocalflux_tend(meshPool, vertNonLocalFlux, surfaceTracerFlux, tend_tr, err) - call mpas_timer_stop("non-local flux from KPP") - endif - call mpas_timer_stop("ocn_tend_tracer") - deallocate(normalThicknessFlux) end subroutine ocn_tend_tracer!}}} diff --git a/src/core_ocean/shared/mpas_ocn_tracer_TTD.F b/src/core_ocean/shared/mpas_ocn_tracer_TTD.F new file mode 100644 index 0000000000..473b801f83 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tracer_TTD.F @@ -0,0 +1,156 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tracer_TTD +! +!> \brief MPAS ocean restoring +!> \author Todd Ringler +!> \date 06/08/2015 +!> \details +!> This module contains routines for computing the tracer tendency due to +!> to transit time distribution +! +!----------------------------------------------------------------------- + +module ocn_tracer_TTD + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_tracer_TTD_compute, & + ocn_tracer_TTD_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_tracer_TTD_compute +! +!> \brief computes a tracer tendency to approximate transit time distribution +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine computes a tracer tendency to approximate transit time distribution +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_TTD_compute(nTracers, nCellsSolve, maxLevelCell, layerThickness, & + TTDMask, tracers, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + ! one dimensional arrays + integer, dimension(:), intent(in) :: & + maxLevelCell + + ! two dimensional arrays + real (kind=RKIND), dimension(:,:), intent(in) :: & + layerThickness, & + TTDMask + + integer, intent(in) :: nTracers, nCellsSolve + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + ! three dimensional arrays + real (kind=RKIND), dimension(:,:,:), intent(inout) :: & + tracers + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell, iLevel, iTracer + + !move to ocean constants + real (kind=RKIND), parameter :: c0 = 0.0 + real (kind=RKIND), parameter :: c1 = 1.0 + + err = 0 + + ! zero tracers at surface to TTDMask at top-most layer + ! TTDMask should be 1 within region of interest and zero elsewhere + tracers(:,1,:) = TTDMask(:,:) + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_TTD_compute!}}} + +!*********************************************************************** +! +! routine ocn_tracer_TTD_init +! +!> \brief Initializes ocean ideal age +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine initializes fields required for tracer ideal age +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_TTD_init(err)!{{{ + + integer, intent(out) :: err !< Output: error flag + + err = 0 + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_TTD_init!}}} + +!*********************************************************************** + +end module ocn_tracer_TTD + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/shared/mpas_ocn_tracer_exponential_decay.F b/src/core_ocean/shared/mpas_ocn_tracer_exponential_decay.F new file mode 100644 index 0000000000..b2ea46ea3b --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tracer_exponential_decay.F @@ -0,0 +1,163 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tracer_exponential_decay +! +!> \brief MPAS ocean exponential decay +!> \author Todd Ringler +!> \date 06/08/2015 +!> \details +!> This module contains routines for computing tracer forcing due to exponential decay +! +!----------------------------------------------------------------------- + +module ocn_tracer_exponential_decay + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_tracer_exponential_decay_compute, & + ocn_tracer_exponential_decay_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_tracer_exponential_decay_compute +! +!> \brief computes a tracer tendency due to exponential decay +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine computes a tracer tendency due to exponential decay +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_exponential_decay_compute(nTracers, nCellsSolve, maxLevelCell, layerThickness, tracers, tracersExponentialDecayRate, tracer_tend, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + ! one dimensional arrays + integer, dimension(:), intent(in) :: & + maxLevelCell + + real (kind=RKIND), dimension(:), intent(in) :: & + tracersExponentialDecayRate + + ! two dimensional arrays + real (kind=RKIND), dimension(:,:), intent(in) :: & + layerThickness + + ! three dimensional arrays + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + tracers + + ! scalars + integer, intent(in) :: nTracers, nCellsSolve + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:,:), intent(inout) :: & + tracer_tend + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell, iLevel, iTracer + + err = 0 + + do iCell=1,nCellsSolve + do iLevel=1,maxLevelCell(iCell) + do iTracer=1,nTracers + tracer_tend(iTracer,iLevel,iCell) = tracer_tend(iTracer,iLevel,iCell) & + - ( layerThickness(iLevel,iCell) & + * tracers(iTracer,iLevel,iCell) & + * exp(-tracersExponentialDecayRate(iTracer)) ) + enddo + enddo + enddo + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_exponential_decay_compute!}}} + +!*********************************************************************** +! +! routine ocn_tracer_exponential_decay_init +! +!> \brief Initializes ocean surface restoring +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine initializes fields required for tracer surface flux restoring +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_exponential_decay_init(err)!{{{ + + integer, intent(out) :: err !< Output: error flag + + err = 0 + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_exponential_decay_init!}}} + +!*********************************************************************** + +end module ocn_tracer_exponential_decay + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/shared/mpas_ocn_tracer_ideal_age.F b/src/core_ocean/shared/mpas_ocn_tracer_ideal_age.F new file mode 100644 index 0000000000..362b01a55e --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tracer_ideal_age.F @@ -0,0 +1,166 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tracer_ideal_age +! +!> \brief MPAS ocean restoring +!> \author Todd Ringler +!> \date 06/08/2015 +!> \details +!> This module contains routines for computing the tracer tendency due to restoring +! +!----------------------------------------------------------------------- + +module ocn_tracer_ideal_age + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_tracer_ideal_age_compute, & + ocn_tracer_ideal_age_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_tracer_ideal_age_compute +! +!> \brief computes a tracer tendency to approximate ideal age +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine computes a tracer tendency to approximate ideal age +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_ideal_age_compute(nTracers, nCellsSolve, maxLevelCell, layerThickness, & + idealAgeMask, tracers, tracer_tend, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + ! one dimensional arrays + integer, dimension(:), intent(in) :: & + maxLevelCell + + ! two dimensional arrays + real (kind=RKIND), dimension(:,:), intent(in) :: & + layerThickness, & + idealAgeMask + + integer, intent(in) :: nTracers, nCellsSolve + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + ! three dimensional arrays + real (kind=RKIND), dimension(:,:,:), intent(inout) :: & + tracers, & + tracer_tend + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell, iLevel, iTracer + + !move to ocean constants + real (kind=RKIND), parameter :: c0 = 0.0 + real (kind=RKIND), parameter :: c1 = 1.0 + + err = 0 + + ! zero tracers at surface to zero where idealAgeMask == zero + ! idealAgeMask should be equal to 1.0 elsewhere + tracers(:,1,:) = idealAgeMask(:,:) * tracers(:,1,:) + + ! add a tendency increment equivalent to "dt" to entire domain + do iCell=1,nCellsSolve + do iLevel=1,maxLevelCell(iCell) + do iTracer=1,nTracers + tracer_tend(iTracer, iLevel, iCell) = tracer_tend(iTracer, iLevel, iCell) + & + layerThickness(iLevel,iCell) * c1 + enddo + enddo + enddo + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_ideal_age_compute!}}} + +!*********************************************************************** +! +! routine ocn_tracer_ideal_age_init +! +!> \brief Initializes ocean ideal age +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine initializes fields required for tracer ideal age +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_ideal_age_init(err)!{{{ + + integer, intent(out) :: err !< Output: error flag + + err = 0 + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_ideal_age_init!}}} + +!*********************************************************************** + +end module ocn_tracer_ideal_age + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/shared/mpas_ocn_tracer_interior_restoring.F b/src/core_ocean/shared/mpas_ocn_tracer_interior_restoring.F new file mode 100644 index 0000000000..a1cad1db20 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tracer_interior_restoring.F @@ -0,0 +1,163 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tracer_interior_restoring +! +!> \brief MPAS ocean restoring +!> \author Todd Ringler +!> \date 06/08/2015 +!> \details +!> This module contains routines for computing the tracer tendency due to restoring +! +!----------------------------------------------------------------------- + +module ocn_tracer_interior_restoring + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_tracer_interior_restoring_compute, & + ocn_tracer_interior_restoring_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_tracer_interior_restoring_compute +! +!> \brief computes a tracer tendency due to interior restoring +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine computes a tracer tendency due to interior restoring +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_interior_restoring_compute(nTracers, nCellsSolve, maxLevelCell, layerThickness, & + tracers, tracersInteriorRestoringTimeScale, tracersInteriorRestoringValue, tracer_tend, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + ! one dimensional arrays + integer, dimension(:), intent(in) :: & + maxLevelCell + + ! two dimensional arrays + real (kind=RKIND), dimension(:,:), intent(in) :: & + layerThickness + + ! three dimensional arrays + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + tracers, & + tracersInteriorRestoringTimeScale, & + tracersInteriorRestoringValue + + ! scalars + integer, intent(in) :: nTracers, nCellsSolve + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:,:), intent(inout) :: & + tracer_tend + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell, iLevel, iTracer + + err = 0 + + do iCell=1,nCellsSolve + do iLevel=1,maxLevelCell(iCell) + do iTracer=1,nTracers + tracer_tend(iTracer, iLevel, iCell) = tracer_tend(iTracer, iLevel, iCell) & + - layerThickness(iLevel,iCell) * & + (tracers(iTracer, iLevel, iCell) - tracersInteriorRestoringValue(iTracer, iLevel, iCell)) & + / tracersInteriorRestoringTimeScale(iTracer, iLevel, iCell) + enddo + enddo + enddo + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_interior_restoring_compute!}}} + +!*********************************************************************** +! +! routine ocn_tracer_interior_restoring_init +! +!> \brief Initializes ocean interior restoring +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine initializes fields required for tracer interior restoring +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_interior_restoring_init(err)!{{{ + + integer, intent(out) :: err !< Output: error flag + + err = 0 + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_interior_restoring_init!}}} + +!*********************************************************************** + +end module ocn_tracer_interior_restoring + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/shared/mpas_ocn_tracer_surface_flux.F b/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F similarity index 98% rename from src/core_ocean/shared/mpas_ocn_tracer_surface_flux.F rename to src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F index f80dc624fd..4353e32ef2 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_surface_flux.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F @@ -7,7 +7,7 @@ ! !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! -! ocn_tracer_surface_flux +! ocn_tracer_surface_flux_to_tend ! !> \brief MPAS ocean tracer surface flux !> \author Doug Jacobsen @@ -18,7 +18,7 @@ ! !----------------------------------------------------------------------- -module ocn_tracer_surface_flux +module ocn_tracer_surface_flux_to_tend use mpas_derived_types use mpas_pool_routines @@ -190,7 +190,7 @@ end subroutine ocn_tracer_surface_flux_init!}}} !*********************************************************************** -end module ocn_tracer_surface_flux +end module ocn_tracer_surface_flux_to_tend !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! vim: foldmethod=marker diff --git a/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F b/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F new file mode 100644 index 0000000000..30a78485cc --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F @@ -0,0 +1,157 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tracer_surface_restoring +! +!> \brief MPAS ocean restoring +!> \author Todd Ringler +!> \date 06/08/2015 +!> \details +!> This module contains routines for computing the surface tracer flux due to restoring +! +!----------------------------------------------------------------------- + +module ocn_tracer_surface_restoring + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_tracer_surface_restoring_compute, & + ocn_tracer_surface_restoring_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_tracer_surface_restoring_compute +! +!> \brief computes a surface tracer flux due to surface restoring +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine computes a surface tracer flux due to surface restoring +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_surface_restoring_compute(nTracers, nCellsSolve, tracers, pistonVelocity, tracersSurfaceRestoringValue, tracersSurfaceFlux, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + ! scalars + integer, intent(in) :: & + nTracers, & + nCellsSolve + + ! three dimensional arrays + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + tracers + + ! two dimensional ararys + real (kind=RKIND), dimension(:,:), intent(in) :: & + pistonVelocity, & + tracersSurfaceRestoringValue + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:), intent(inout) :: & + tracersSurfaceFlux + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell, iLevel, iTracer + + err = 0 + + iLevel = 1 ! base surface flux restoring on tracer fields in the top layer + do iTracer=1,nTracers + do iCell=1,nCellsSolve + tracersSurfaceFlux(iTracer, iCell) = tracersSurfaceFlux(iTracer, iCell) - & + pistonVelocity(iTracer,iCell) * & + (tracers(iTracer, iLevel, iCell) - tracersSurfaceRestoringValue(iTracer,iCell)) + enddo + enddo + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_surface_restoring_compute!}}} + +!*********************************************************************** +! +! routine ocn_tracer_surface_restoring_init +! +!> \brief Initializes ocean surface restoring +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine initializes fields required for tracer surface flux restoring +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_surface_restoring_init(err)!{{{ + + integer, intent(out) :: err !< Output: error flag + + err = 0 + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_surface_restoring_init!}}} + +!*********************************************************************** + +end module ocn_tracer_surface_restoring + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/shared/mpas_ocn_vmix.F b/src/core_ocean/shared/mpas_ocn_vmix.F index 710ed6fc1e..553379b444 100644 --- a/src/core_ocean/shared/mpas_ocn_vmix.F +++ b/src/core_ocean/shared/mpas_ocn_vmix.F @@ -397,14 +397,14 @@ subroutine ocn_tracer_vmix_tend_implicit(meshPool, dt, vertDiffTopOfCell, layerT B(k) = 1 - A(k) - C(k) enddo - call tridiagonal_solve_mult(A(2:N),B,C(1:N-1),tracers(:,:,iCell), & - tracersTemp, N, nVertLevels,num_tracers) + call tridiagonal_solve_mult(A(2:N), B, C(1:N-1), tracers(:,:,iCell), & + tracersTemp, N, nVertLevels, num_tracers) tracers(:,1:N,iCell) = tracersTemp(:,1:N) tracers(:,N+1:nVertLevels,iCell) = -1e34 end do - deallocate(A,B,C,tracersTemp) + deallocate(A, B, C, tracersTemp) !-------------------------------------------------------------------- @@ -432,17 +432,22 @@ subroutine ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, err, time integer, intent(out) :: err integer, intent(in), optional :: timeLevelIn + type (mpas_pool_type), pointer :: tracersPool + integer :: timeLevel, k, cell1, cell2, iEdge integer, pointer :: nCells, nEdges real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, layerThickness, layerThicknessEdge, vertViscTopOfEdge, vertDiffTopOfCell, kineticEnergyCell real (kind=RKIND), dimension(:,:), pointer :: vertViscTopOfCell - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), pointer :: tracersGroup integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop integer, dimension(:,:), pointer :: cellsOnEdge logical, pointer :: config_use_cvmix + type (mpas_pool_iterator_type) :: groupItr err = 0 + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + if (present(timeLevelIn)) then timeLevel = timeLevelIn else @@ -452,7 +457,6 @@ subroutine ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, err, time call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix', config_use_cvmix) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) call mpas_pool_get_array(diagnosticsPool, 'kineticEnergyCell', kineticEnergyCell) @@ -488,10 +492,18 @@ subroutine ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, err, time call ocn_vel_vmix_tend_implicit(meshPool, dt, kineticEnergyCell, vertViscTopOfEdge, layerThickness, layerThicknessEdge, normalVelocity, err) ! - ! Implicit vertical solve for tracers + ! Implicit vertical solve for all tracers ! - call ocn_tracer_vmix_tend_implicit(meshPool, dt, vertDiffTopOfCell, layerThickness, tracers, err) + call mpas_pool_begin_iteration(tracersPool) + do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) + + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroup, timeLevel) + call ocn_tracer_vmix_tend_implicit(meshPool, dt, vertDiffTopOfCell, layerThickness, tracersGroup, err) + end if + end do + end subroutine ocn_vmix_implicit!}}} diff --git a/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F b/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F index 524cc0c7b7..f62d3d222d 100644 --- a/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F +++ b/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F @@ -71,7 +71,7 @@ module ocn_vmix_coefs_rich !> \date September 2011 !> \details !> This routine computes the vertical mixing coefficients for momentum -!> and tracers based user choices of mixing parameterization. +!> and activeTracers based user choices of mixing parameterization. ! !----------------------------------------------------------------------- subroutine ocn_vmix_coefs_rich_build(meshPool, statePool, diagnosticsPool, err, timeLevelIn)!{{{ @@ -114,14 +114,16 @@ subroutine ocn_vmix_coefs_rich_build(meshPool, statePool, diagnosticsPool, err, !----------------------------------------------------------------- integer :: err1, err2, err3, timeLevel - integer, pointer :: indexT, indexS + integer, pointer :: indexTemperature, indexSalinity + + type (mpas_pool_type), pointer :: tracersPool real (kind=RKIND), dimension(:,:), pointer :: & vertViscTopOfEdge, vertDiffTopOfCell, normalVelocity, layerThickness, layerThicknessEdge, density, displacedDensity real (kind=RKIND), dimension(:,:), pointer :: RiTopOfEdge, RiTopOfCell - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers !----------------------------------------------------------------- ! @@ -133,14 +135,16 @@ subroutine ocn_vmix_coefs_rich_build(meshPool, statePool, diagnosticsPool, err, err = 0 + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + if (present(timeLevelIn)) then timeLevel = timeLevelIn else timeLevel = 1 end if - call mpas_pool_get_dimension(statePool, 'index_temperature', indexT) - call mpas_pool_get_dimension(statePool, 'index_salinity', indexS) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) call mpas_pool_get_array(diagnosticsPool, 'vertViscTopOfEdge', vertViscTopOfEdge) call mpas_pool_get_array(diagnosticsPool, 'vertDiffTopOfCell', vertDiffTopOfCell) @@ -152,7 +156,7 @@ subroutine ocn_vmix_coefs_rich_build(meshPool, statePool, diagnosticsPool, err, call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) call mpas_timer_start("eos rich", .false., richEOSTimer) @@ -165,8 +169,8 @@ subroutine ocn_vmix_coefs_rich_build(meshPool, statePool, diagnosticsPool, err, call mpas_timer_stop("eos rich", richEOSTimer) - call ocn_vmix_get_rich_numbers(meshPool, indexT, indexS, normalVelocity, layerThickness, layerThicknessEdge, & - density, displacedDensity, tracers, RiTopOfEdge, RiTopOfCell, err1) + call ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, normalVelocity, layerThickness, layerThicknessEdge, & + density, displacedDensity, activeTracers, RiTopOfEdge, RiTopOfCell, err1) call ocn_vel_vmix_coefs_rich(meshPool, RiTopOfEdge, layerThicknessEdge, vertViscTopOfEdge, err2) call ocn_tracer_vmix_coefs_rich(meshPool, RiTopOfCell, layerThickness, vertDiffTopOfCell, err3) @@ -277,7 +281,7 @@ end subroutine ocn_vel_vmix_coefs_rich!}}} !> \author Mark Petersen !> \date September 2011 !> \details -!> This routine computes the richardson vertical mixing coefficients for tracers +!> This routine computes the richardson vertical mixing coefficients for activeTracers ! !----------------------------------------------------------------------- @@ -380,8 +384,8 @@ end subroutine ocn_tracer_vmix_coefs_rich!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vmix_get_rich_numbers(meshPool, indexT, indexS, normalVelocity, layerThickness, layerThicknessEdge, & !{{{ - density, displacedDensity, tracers, RiTopOfEdge, RiTopOfCell, err) + subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, normalVelocity, layerThickness, layerThicknessEdge, & !{{{ + density, displacedDensity, activeTracers, RiTopOfEdge, RiTopOfCell, err) !----------------------------------------------------------------- ! @@ -392,14 +396,14 @@ subroutine ocn_vmix_get_rich_numbers(meshPool, indexT, indexS, normalVelocity, l type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information - integer, intent(in) :: indexT !< Input: index for temperature - integer, intent(in) :: indexS !< Input: index for salinity + integer, intent(in) :: indexTemperature !< Input: index for temperature + integer, intent(in) :: indexSalinity !< Input: index for salinity real (kind=RKIND), dimension(:,:), intent(in) :: normalVelocity !< Input: horizontal velocity real (kind=RKIND), dimension(:,:), intent(in) :: layerThickness !< Input: thickness real (kind=RKIND), dimension(:,:), intent(in) :: layerThicknessEdge !< Input: thickness at edge - real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input: tracers + real (kind=RKIND), dimension(:,:,:), intent(in) :: activeTracers !< Input: activeTracers !----------------------------------------------------------------- ! From 196a75edbce876fb89bdc5c026328726dd18fc6b Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 29 Jul 2015 07:42:14 -0600 Subject: [PATCH 0162/1724] update mpas_ocn_init_baroclinic_channel.F to new tracer infrastructure --- .../mpas_ocn_init_baroclinic_channel.F | 20 ++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F b/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F index d340a3a8da..0e0b8dc514 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F @@ -87,6 +87,7 @@ subroutine ocn_init_setup_baroclinic_channel(domain, iErr)!{{{ type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tracersPool type (mpas_pool_type), pointer :: verticalMeshPool integer :: iCell, k, idx @@ -113,7 +114,7 @@ subroutine ocn_init_setup_baroclinic_channel(domain, iErr)!{{{ vertCoordMovementWeights, bottomDepth, & fCell, fEdge, fVertex, dcEdge real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers ! Define local interfaceLocations variable real (kind=RKIND), dimension(:), pointer :: interfaceLocations @@ -197,12 +198,13 @@ subroutine ocn_init_setup_baroclinic_channel(domain, iErr)!{{{ call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_salinity) call mpas_pool_get_array(meshPool, 'xCell', xCell) call mpas_pool_get_array(meshPool, 'yCell', yCell) @@ -214,7 +216,7 @@ subroutine ocn_init_setup_baroclinic_channel(domain, iErr)!{{{ call mpas_pool_get_array(meshPool, 'fEdge', fEdge) call mpas_pool_get_array(meshPool, 'fVertex', fVertex) - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) @@ -242,15 +244,15 @@ subroutine ocn_init_setup_baroclinic_channel(domain, iErr)!{{{ temperature = config_baroclinic_channel_bottom_temperature & + (config_baroclinic_channel_surface_temperature - config_baroclinic_channel_bottom_temperature) & * ( (refZMid(k) + refBottomDepth(nVertLevels)) / refBottomDepth(nVertLevels) ) - tracers(idx, k, iCell) = temperature + activeTracers(idx, k, iCell) = temperature end do if(yCell(iCell) < yMidGlobal - yOffset) then ! If cell is in the southern half, outside the sin width, subtract temperature difference - tracers(idx, :, iCell) = tracers(idx, :, iCell) - config_baroclinic_channel_temperature_difference + activeTracers(idx, :, iCell) = activeTracers(idx, :, iCell) - config_baroclinic_channel_temperature_difference else if(yCell(iCell) >= yMidGlobal - yOffset .and. & yCell(iCell) < yMidGlobal - yOffset + perturbationWidth) then - tracers(idx, :, iCell) = tracers(idx, :, iCell) - config_baroclinic_channel_temperature_difference * ( 1.0_RKIND - ( yCell(iCell) & + activeTracers(idx, :, iCell) = activeTracers(idx, :, iCell) - config_baroclinic_channel_temperature_difference * ( 1.0_RKIND - ( yCell(iCell) & - ((yMaxGlobal + yMinGlobal) * 0.5 - yOffset)) / perturbationWidth) end if @@ -264,14 +266,14 @@ subroutine ocn_init_setup_baroclinic_channel(domain, iErr)!{{{ do k = 1, nVertLevels - tracers(idx, k, iCell) = tracers(idx, k, iCell) + & + activeTracers(idx, k, iCell) = activeTracers(idx, k, iCell) + & 0.3_RKIND * ( 1.0_RKIND - ( ( yCell(iCell) - (yMidGlobal - yOffset)) /(0.5_RKIND * perturbationWidth))) end do end if ! Set salinity idx = index_salinity - tracers(idx, :, iCell) = config_baroclinic_channel_salinity + activeTracers(idx, :, iCell) = config_baroclinic_channel_salinity ! Set layerThickness and restingThickness do k = 1, nVertLevels From 5857f4e3133f9785c3e1c5cd7f0780190b93831a Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 29 Jul 2015 09:22:06 -0600 Subject: [PATCH 0163/1724] add debugTracers to baroclinic channel initial conditions --- .../mode_init/mpas_ocn_init_baroclinic_channel.F | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F b/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F index 0e0b8dc514..fb4ff2ddfe 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F @@ -106,7 +106,7 @@ subroutine ocn_init_setup_baroclinic_channel(domain, iErr)!{{{ ! Define dimension pointers integer, pointer :: nCellsSolve, nEdgesSolve, nVertLevels, nVertLevelsP1 - integer, pointer :: index_temperature, index_salinity + integer, pointer :: index_temperature, index_salinity, index_tracer1 ! Define variable pointers integer, dimension(:), pointer :: maxLevelCell @@ -114,7 +114,7 @@ subroutine ocn_init_setup_baroclinic_channel(domain, iErr)!{{{ vertCoordMovementWeights, bottomDepth, & fCell, fEdge, fVertex, dcEdge real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness - real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers, debugTracers ! Define local interfaceLocations variable real (kind=RKIND), dimension(:), pointer :: interfaceLocations @@ -205,6 +205,7 @@ subroutine ocn_init_setup_baroclinic_channel(domain, iErr)!{{{ call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_temperature) call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_salinity) + call mpas_pool_get_dimension(tracersPool, 'index_tracer1', index_tracer1) call mpas_pool_get_array(meshPool, 'xCell', xCell) call mpas_pool_get_array(meshPool, 'yCell', yCell) @@ -217,6 +218,7 @@ subroutine ocn_init_setup_baroclinic_channel(domain, iErr)!{{{ call mpas_pool_get_array(meshPool, 'fVertex', fVertex) call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + call mpas_pool_get_array(tracersPool, 'debugTracers', debugTracers, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) @@ -238,6 +240,12 @@ subroutine ocn_init_setup_baroclinic_channel(domain, iErr)!{{{ ! Determine cutoff location for large sin wave yOffset = perturbationWidth * sin (6.0_RKIND * pii * (xCell(iCell) - xMinGlobal) / (xMaxGlobal - xMinGlobal)) + ! Set debug tracer + idx = index_tracer1 + do k = 1, nVertLevels + debugTracers(idx, k, iCell) = 1.0_RKIND + enddo + ! Set stratification based on northern half of domain temperature idx = index_temperature do k = nVertLevels, 1, -1 From 0345c4f6ecc25739da79ff4744a34f660666a71d Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 29 Jul 2015 09:54:11 -0600 Subject: [PATCH 0164/1724] first cut at converting cvmix_WSwSBF --- .../mode_init/mpas_ocn_init_cvmix_WSwSBF.F | 42 +++++++------------ 1 file changed, 16 insertions(+), 26 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F index 32066d93d7..07e259fbb2 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F @@ -82,11 +82,11 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ type (block_type), pointer :: block_ptr - type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool + type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool, tracersPool type (mpas_pool_type), pointer :: diagnosticsPool, forcingPool integer, pointer :: nVertLevels, nVertLevelsP1, nCellsSolve, nEdgesSolve, nVerticesSolve - integer, pointer :: index_temperature, index_salinity + integer, pointer :: index_temperature, index_salinity, index_tracer1 integer, dimension(:), pointer :: maxLevelCell real (kind=RKIND), dimension(:), pointer :: refBottomDepth, refZMid, vertCoordMovementWeights @@ -96,7 +96,7 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ real (kind=RKIND), dimension(:), pointer :: salinityRestore, bottomDepth, angleEdge real (kind=RKIND), dimension(:), pointer :: fCell, fEdge, fVertex real (kind=RKIND), dimension(:, :), pointer :: layerThickness, restingThickness - real (kind=RKIND), dimension(:, :, :), pointer :: tracers + real (kind=RKIND), dimension(:, :, :), pointer :: activeTracers, debugTracers real (kind=RKIND), dimension(:), pointer :: interfaceLocations @@ -168,13 +168,10 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_dimension(meshPool, 'nVerticesSolve', nVerticesSolve) - write(6,*) nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve - - call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_salinity) + call mpas_pool_get_dimension(tracersPool, 'index_tracer1', index_tracer1) - write(6,*) index_temperature, index_salinity - call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) @@ -190,12 +187,10 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + call mpas_pool_get_array(tracersPool, 'debugTracers', debugTracers, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) - ! should be removed - ! call mpas_pool_get_array(diagnosticsPool, 'boundaryLayerDepth', boundaryLayerDepth) - call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) call mpas_pool_get_array(forcingPool, 'latentHeatFlux', latentHeatFlux) call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) @@ -216,13 +211,12 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ ! Set temperature and salinity do k = 1, nVertLevels temperature = config_cvmix_WSwSBF_surface_temperature + refZMid(k) * config_cvmix_WSwSBF_temperature_gradient - tracers(index_temperature, k, iCell) = temperature + activeTracers(index_temperature, k, iCell) = temperature salinity = config_cvmix_WSwSBF_surface_salinity + refZMid(k) * config_cvmix_WSwSBF_salinity_gradient - tracers(index_salinity, :, iCell) = salinity + activeTracers(index_salinity, :, iCell) = salinity + debugTracers(index_tracer1, :, iCell) = 1.0_RKIND end do - write(6,*) ' maxval ', maxval(tracers) - ! Set layerThickness do k = 1, nVertLevels layerThickness(k, iCell) = config_cvmix_WSwSBF_bottom_depth * (interfaceLocations(k+1) - interfaceLocations(k)) @@ -238,25 +232,21 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ salinityRestore(iCell) = config_cvmix_WSwSBF_surface_restoring_salinity ! Set sensible heat flux - ! sensibleHeatFlux(iCell) = config_cvmix_WSwSBF_sensible_heat_flux + sensibleHeatFlux(iCell) = config_cvmix_WSwSBF_sensible_heat_flux ! Set latent heat flux - ! latentHeatFlux(iCell) = config_cvmix_WSwSBF_latent_heat_flux + latentHeatFlux(iCell) = config_cvmix_WSwSBF_latent_heat_flux ! Set shortwave heat flux - ! shortWaveHeatFlux(iCell) = config_cvmix_WSwSBF_shortwave_heat_flux + shortWaveHeatFlux(iCell) = config_cvmix_WSwSBF_shortwave_heat_flux ! Set precipation and evaporation - ! rainFlux(iCell) = config_cvmix_WSwSBF_rain_flux - ! evaporationFlux(iCell) = config_cvmix_WSwSBF_evaporation_flux + rainFlux(iCell) = config_cvmix_WSwSBF_rain_flux + evaporationFlux(iCell) = config_cvmix_WSwSBF_evaporation_flux ! Set Coriolis parameter fCell(iCell) = config_cvmix_WSwSBF_coriolis_parameter - ! to be removed - ! Set boundary layer depth - ! boundaryLayerDepth(iCell) = 2.0_RKIND * (config_cvmix_shear_unit_test_bottom_depth / nVertLevels) - 1.0-4_RKIND - ! Set bottomDepth bottomDepth(iCell) = config_cvmix_WSwSBF_bottom_depth From 651b6298f4787c758445fee9003f651acb906902 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Wed, 29 Jul 2015 10:00:32 -0600 Subject: [PATCH 0165/1724] Fix an issue with tracer groups being used when disabled Previously, both time integration schemes would attempt to advance all tracer groups, even ones that were disabled. This commit only advances tracer groups that are enabled. --- .../mpas_ocn_time_integration_rk4.F | 48 ++++++++++++------- .../mpas_ocn_time_integration_split.F | 25 ++++++---- 2 files changed, 46 insertions(+), 27 deletions(-) diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F index 28d2daa9f0..82b08a4612 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F @@ -122,6 +122,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ logical, pointer :: config_filter_btr_mode, config_use_freq_filtered_thickness logical, pointer :: config_use_standardGM logical, pointer :: config_use_cvmix_kpp + logical, pointer :: config_use_tracerGroup real (kind=RKIND), pointer :: config_mom_del4 ! State indices @@ -180,6 +181,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ ! Tracer Group Iteartion type (mpas_pool_iterator_type) :: groupItr character (len=StrKIND) :: modifiedGroupName + character (len=StrKIND) :: configName ! Get config options call mpas_pool_get_config(domain % configs, 'config_mom_del4', config_mom_del4) @@ -527,19 +529,24 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_begin_iteration(tracersPool) do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) if ( groupItr % memberType == MPAS_POOL_FIELD ) then - call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersCur, 1) - call mpas_pool_get_array(provisTracersPool, groupItr % memberName, tracersGroupProvis, 1) + configName = 'config_use_' // trim(groupItr % memberName) + call mpas_pool_get_config(domain % configs, configName, config_use_tracerGroup) + + if ( config_use_tracerGroup ) then + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersCur, 1) + call mpas_pool_get_array(provisTracersPool, groupItr % memberName, tracersGroupProvis, 1) + + modifiedGroupName = trim(groupItr % memberName) // 'Tend' + call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersGroupProvis(:,k,iCell) = ( layerThicknessCur(k,iCell) * tracersCur(:,k,iCell) & + + rk_substep_weights(rk_step) * tracersGroupTend(:,k,iCell) & + ) / layerThicknessProvis(k,iCell) + end do - modifiedGroupName = trim(groupItr % memberName) // 'Tend' - call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) - do iCell = 1, nCells - do k = 1, maxLevelCell(iCell) - tracersGroupProvis(:,k,iCell) = ( layerThicknessCur(k,iCell) * tracersCur(:,k,iCell) & - + rk_substep_weights(rk_step) * tracersGroupTend(:,k,iCell) & - ) / layerThicknessProvis(k,iCell) end do - - end do + end if end if end do @@ -620,15 +627,20 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_begin_iteration(tracersPool) do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) if ( groupItr % memberType == MPAS_POOL_FIELD ) then - call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersNew, 2) + configName = 'config_use_' // trim(groupItr % memberName) + call mpas_pool_get_config(domain % configs, configName, config_use_tracerGroup) + + if ( config_use_tracerGroup ) then + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersNew, 2) - modifiedGroupName = trim(groupItr % memberName) // 'Tend' - call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) - do iCell = 1, nCells - do k = 1, maxLevelCell(iCell) - tracersNew(:,k,iCell) = tracersNew(:,k,iCell) + rk_weights(rk_step) * tracersGroupTend(:,k,iCell) + modifiedGroupName = trim(groupItr % memberName) // 'Tend' + call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersNew(:,k,iCell) = tracersNew(:,k,iCell) + rk_weights(rk_step) * tracersGroupTend(:,k,iCell) + end do end do - end do + end if end if end do diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F index 68ab20553f..8c4fd4c46c 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F @@ -131,6 +131,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ logical, pointer :: config_use_freq_filtered_thickness, config_btr_solve_SSH2, config_filter_btr_mode logical, pointer :: config_vel_correction, config_prescribe_velocity, config_prescribe_thickness logical, pointer :: config_use_cvmix_kpp + logical, pointer :: config_use_tracerGroup real (kind=RKIND), pointer :: config_mom_del4, config_btr_gam1_velWt1, config_btr_gam2_SSHWt1 real (kind=RKIND), pointer :: config_btr_gam3_velWt2 @@ -197,6 +198,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! tracer iterators type (mpas_pool_iterator_type) :: groupItr character (len=StrKIND) :: modifiedGroupName + character (len=StrKIND) :: configName call mpas_timer_start("se timestep", .false., timer_main) @@ -1406,18 +1408,23 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_begin_iteration(tracersPool) do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) if ( groupItr % memberType == MPAS_POOL_FIELD ) then - call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroupCur, 1) - call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroupNew, 2) + configName = 'config_use_' // trim(groupItr % memberName) + call mpas_pool_get_config(domain % configs, configName, config_use_tracerGroup) - modifiedGroupName = trim(groupItr % memberName) // 'Tend' - call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) + if ( config_use_tracerGroup ) then + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroupCur, 1) + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroupNew, 2) - do iCell = 1, nCells - do k = 1, maxLevelCell(iCell) - tracersGroupNew(:,k,iCell) = (tracersGroupCur(:,k,iCell) * layerThicknessCur(k,iCell) + dt * tracersGroupTend(:,k,iCell) ) & - / layerThicknessNew(k,iCell) + modifiedGroupName = trim(groupItr % memberName) // 'Tend' + call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) + + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersGroupNew(:,k,iCell) = (tracersGroupCur(:,k,iCell) * layerThicknessCur(k,iCell) + dt * tracersGroupTend(:,k,iCell) ) & + / layerThicknessNew(k,iCell) + end do end do - end do + end if end if end do From 5b4e1db74c98ca0b013eae8fd17c5d8db0b7c1f4 Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 29 Jul 2015 16:09:01 -0600 Subject: [PATCH 0166/1724] adding in hooks to surface restoring (values and piston velocity) --- .../mode_init/mpas_ocn_init_cvmix_WSwSBF.F | 56 +++++++++++-------- 1 file changed, 34 insertions(+), 22 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F index 07e259fbb2..f8909e2009 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F @@ -82,7 +82,8 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ type (block_type), pointer :: block_ptr - type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool, tracersPool + type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool + type (mpas_pool_type), pointer :: tracersPool, tracersSurfaceFluxPool, tracersSurfaceRestoringFieldsPool type (mpas_pool_type), pointer :: diagnosticsPool, forcingPool integer, pointer :: nVertLevels, nVertLevelsP1, nCellsSolve, nEdgesSolve, nVerticesSolve @@ -97,6 +98,7 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ real (kind=RKIND), dimension(:), pointer :: fCell, fEdge, fVertex real (kind=RKIND), dimension(:, :), pointer :: layerThickness, restingThickness real (kind=RKIND), dimension(:, :, :), pointer :: activeTracers, debugTracers + real (kind=RKIND), dimension(:, :), pointer :: activeTracersSurfaceFlux, activeTracersPistonVelocity, activeTracersSurfaceRestoringValue real (kind=RKIND), dimension(:), pointer :: interfaceLocations @@ -163,6 +165,10 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_subpool(block_ptr % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceFlux', tracersSurfaceFluxPool) + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) @@ -191,12 +197,15 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_array(tracersPool, 'debugTracers', debugTracers, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) - call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) - call mpas_pool_get_array(forcingPool, 'latentHeatFlux', latentHeatFlux) - call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) - call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) - call mpas_pool_get_array(forcingPool, 'evaporationFlux', evaporationFlux) - call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) + call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress, 1) + call mpas_pool_get_array(tracersSurfaceFluxPool, 'activeTracersSurfaceFlux', activeTracersSurfaceFlux, 1) + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersPistonVelocity', activeTracersPistonVelocity, 1) + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersSurfaceRestoringValue', activeTracersSurfaceRestoringValue, 1) + ! call mpas_pool_get_array(forcingPool, 'latentHeatFlux', latentHeatFlux) + ! call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) + ! call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) + ! call mpas_pool_get_array(forcingPool, 'evaporationFlux', evaporationFlux) + ! call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) ! Set refBottomDepth and refBottomDepthTopOfCell do k = 1, nVertLevels @@ -223,26 +232,29 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ restingThickness(k, iCell) = layerThickness(k, iCell) end do - write(6,*) maxval(layerThickness) - - ! Set temperatureRestore - temperatureRestore(iCell) = config_cvmix_WSwSBF_surface_restoring_temperature + ! Set temperature restoring value and rate + ! Value in units of C, piston velocity in units of m/s + activeTracersSurfaceRestoringValue(index_temperature, iCell) = config_cvmix_WSwSBF_surface_restoring_temperature + activeTracersPistonVelocity(index_temperature, iCell) = 10.0_RKIND / 30.0_RKIND / 86400.0_RKIND - ! Set salinityRestore - salinityRestore(iCell) = config_cvmix_WSwSBF_surface_restoring_salinity + ! Set salinity restoring value and rate + ! Value in units of PSU, piston velocity in units of m/s + activeTracersSurfaceRestoringValue(index_salinity, iCell) = config_cvmix_WSwSBF_surface_restoring_salinity + activeTracersPistonVelocity(index_salinity, iCell) = 10.0_RKIND / 30.0_RKIND / 86400.0_RKIND - ! Set sensible heat flux - sensibleHeatFlux(iCell) = config_cvmix_WSwSBF_sensible_heat_flux + ! TDR + ! ! Set sensible heat flux + ! sensibleHeatFlux(iCell) = config_cvmix_WSwSBF_sensible_heat_flux - ! Set latent heat flux - latentHeatFlux(iCell) = config_cvmix_WSwSBF_latent_heat_flux + ! ! Set latent heat flux + ! latentHeatFlux(iCell) = config_cvmix_WSwSBF_latent_heat_flux - ! Set shortwave heat flux - shortWaveHeatFlux(iCell) = config_cvmix_WSwSBF_shortwave_heat_flux + ! ! Set shortwave heat flux + ! shortWaveHeatFlux(iCell) = config_cvmix_WSwSBF_shortwave_heat_flux - ! Set precipation and evaporation - rainFlux(iCell) = config_cvmix_WSwSBF_rain_flux - evaporationFlux(iCell) = config_cvmix_WSwSBF_evaporation_flux + ! ! Set precipation and evaporation + ! rainFlux(iCell) = config_cvmix_WSwSBF_rain_flux + ! evaporationFlux(iCell) = config_cvmix_WSwSBF_evaporation_flux ! Set Coriolis parameter fCell(iCell) = config_cvmix_WSwSBF_coriolis_parameter From a9970bf611a0f99b8d724905fabc93b997219c35 Mon Sep 17 00:00:00 2001 From: toddringler Date: Thu, 30 Jul 2015 09:33:02 -0600 Subject: [PATCH 0167/1724] removed all of the old "tracerRestoring" infrastructure. removed two test cases. cleaned up src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F. --- src/core_ocean/Registry.xml | 29 -- .../mode_forward/mpas_ocn_forward_mode.F | 1 - src/core_ocean/mode_init/Makefile | 6 - .../mode_init/mpas_ocn_init_cvmix_WSwSBF.F | 4 +- ...mpas_ocn_init_cvmix_convection_unit_test.F | 265 ------------------ .../mpas_ocn_init_cvmix_shear_unit_test.F | 262 ----------------- .../mpas_ocn_init_global_realistic.F | 20 +- src/core_ocean/mode_init/mpas_ocn_init_mode.F | 8 - src/core_ocean/shared/mpas_ocn_forcing.F | 120 +------- .../shared/mpas_ocn_forcing_restoring.F | 183 ------------ 10 files changed, 13 insertions(+), 885 deletions(-) delete mode 100644 src/core_ocean/mode_init/mpas_ocn_init_cvmix_convection_unit_test.F delete mode 100644 src/core_ocean/mode_init/mpas_ocn_init_cvmix_shear_unit_test.F delete mode 100644 src/core_ocean/shared/mpas_ocn_forcing_restoring.F diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 24f73bf7e4..95a7c61045 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -585,23 +585,6 @@ description="Controls if a bulk thickness flux will be computed for surface forcing." possible_values=".true. or .false." /> - - - - - - - @@ -1044,8 +1025,6 @@ - - - - diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index ef759a4413..2293867f63 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -438,7 +438,6 @@ function ocn_forward_mode_run(domain) result(ierr)!{{{ call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) - call ocn_forcing_build_arrays(meshPool, statePool, forcingPool, ierr, 1) call ocn_forcing_build_fraction_absorbed_array(meshPool, statePool, forcingpool, ierr, 1) block_ptr => block_ptr % next end do diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile index e170051234..2e118be565 100644 --- a/src/core_ocean/mode_init/Makefile +++ b/src/core_ocean/mode_init/Makefile @@ -10,8 +10,6 @@ TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ mpas_ocn_init_lock_exchange.o \ mpas_ocn_init_internal_waves.o \ mpas_ocn_init_overflow.o \ - mpas_ocn_init_cvmix_convection_unit_test.o \ - mpas_ocn_init_cvmix_shear_unit_test.o \ mpas_ocn_init_cvmix_WSwSBF.o \ mpas_ocn_init_global_realistic.o #mpas_ocn_init_TEMPLATE.o @@ -36,10 +34,6 @@ mpas_ocn_init_internal_waves.o: $(UTILS) mpas_ocn_init_overflow.o: $(UTILS) -mpas_ocn_init_cvmix_convection_unit_test.o: $(UTILS) - -mpas_ocn_init_cvmix_shear_unit_test.o: $(UTILS) - mpas_ocn_init_global_realistic.o: $(UTILS) mpas_ocn_init_cvmix_WSwSBF.o: $(UTILS) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F index f8909e2009..e527d8aa56 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F @@ -91,7 +91,7 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ integer, dimension(:), pointer :: maxLevelCell real (kind=RKIND), dimension(:), pointer :: refBottomDepth, refZMid, vertCoordMovementWeights - real (kind=RKIND), dimension(:), pointer :: surfaceWindStress, boundaryLayerDepth, temperatureRestore + real (kind=RKIND), dimension(:), pointer :: surfaceWindStress real (kind=RKIND), dimension(:), pointer :: latentHeatFlux, sensibleHeatFlux, shortWaveHeatFlux real (kind=RKIND), dimension(:), pointer :: evaporationFlux, rainFlux real (kind=RKIND), dimension(:), pointer :: salinityRestore, bottomDepth, angleEdge @@ -181,8 +181,6 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(meshPool, 'temperatureRestore', temperatureRestore) - call mpas_pool_get_array(meshPool, 'salinityRestore', salinityRestore) call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_convection_unit_test.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_convection_unit_test.F deleted file mode 100644 index 3cd3b65d16..0000000000 --- a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_convection_unit_test.F +++ /dev/null @@ -1,265 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_init_cvmix_convection_unit_test -! -!> \brief MPAS ocean initialize case -- CVMix Convective Mixing Unit Test -!> \author Doug Jacobsen -!> \date 04/01/2015 -!> \details -!> This module contains the routines for initializing the -!> the cvmix convective mixing unit test case -! -!----------------------------------------------------------------------- - -module ocn_init_cvmix_convection_unit_test - - use mpas_kind_types - use mpas_io_units - use mpas_derived_types - use mpas_pool_routines - use mpas_constants - - use ocn_init_vertical_grids - use ocn_init_cell_markers - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_init_setup_cvmix_convection_unit_test, & - ocn_init_validate_cvmix_convection_unit_test - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - -!*********************************************************************** - -contains - -!*********************************************************************** -! -! routine ocn_init_setup_cvmix_convection_unit_test -! -!> \brief Setup for cvmix convective mixing unit test case -!> \author Doug Jacobsen -!> \date 04/01/2015 -!> \details -!> This routine sets up the initial conditions for the cvmix convective mixing unit test case. -! -!----------------------------------------------------------------------- - - subroutine ocn_init_setup_cvmix_convection_unit_test(domain, iErr)!{{{ - - !-------------------------------------------------------------------- - - type (domain_type), intent(inout) :: domain - integer, intent(out) :: iErr - real (kind=RKIND) :: maxMidDepth, temperature - - type (block_type), pointer :: block_ptr - - type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool - type (mpas_pool_type), pointer :: diagnosticsPool, forcingPool - - integer :: iCell, iEdge, k, idx - integer, pointer :: nCellsSolve, nEdgesSolve, nVertLevels, nVertLevelsP1 - integer, pointer :: index_temperature, index_salinity - - integer, dimension(:), pointer :: maxLevelCell - - real (kind=RKIND), dimension(:), pointer :: yCell, dcEdge, refBottomDepth, vertCoordMovementWeights - real (kind=RKIND), dimension(:), pointer :: temperatureRestore, salinityRestore, bottomDepth, boundaryLayerDepth - real (kind=RKIND), dimension(:), pointer :: surfaceWindStress, angleEdge, refZMid - real (kind=RKIND), dimension(:, :), pointer :: layerThickness, restingThickness - real (kind=RKIND), dimension(:, :, :), pointer :: tracers - - real (kind=RKIND), dimension(:), pointer :: interfaceLocations - - character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid - real (kind=RKIND), pointer :: config_cvmix_convection_unit_test_bottom_depth, config_cvmix_convection_unit_test_bottom_temperature, & - config_cvmix_convection_unit_test_surface_temperature, config_cvmix_convection_unit_test_salinity, & - config_cvmix_convection_unit_test_max_windstress - - - iErr = 0 - - call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) - - if(config_init_configuration .ne. trim('cvmix_convection_unit_test')) return - - call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) - call mpas_pool_get_config(domain % configs, 'config_vertical_grid', config_vertical_grid) - call mpas_pool_get_config(domain % configs, 'config_cvmix_convection_unit_test_bottom_depth', config_cvmix_convection_unit_test_bottom_depth) - call mpas_pool_get_config(domain % configs, 'config_cvmix_convection_unit_test_bottom_temperature', config_cvmix_convection_unit_test_bottom_temperature) - call mpas_pool_get_config(domain % configs, 'config_cvmix_convection_unit_test_surface_temperature', config_cvmix_convection_unit_test_surface_temperature) - call mpas_pool_get_config(domain % configs, 'config_cvmix_convection_unit_test_salinity', config_cvmix_convection_unit_test_salinity) - call mpas_pool_get_config(domain % configs, 'config_cvmix_convection_unit_test_max_windstress', config_cvmix_convection_unit_test_max_windstress) - - ! Determine vertical mesh interface locations - call mpas_pool_get_config(domain % configs, 'config_vertical_grid', config_vertical_grid) - call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nVertLevelsP1', nVertLevelsP1) - allocate(interfaceLocations(nVertLevelsP1)) - call ocn_generate_vertical_grid(config_vertical_grid, interfaceLocations) - - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) - call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) - call mpas_pool_get_subpool(block_ptr % structs, 'diagnostics', diagnosticsPool) - call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) - - call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) - call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) - call mpas_pool_get_array(meshPool, 'temperatureRestore', temperatureRestore) - call mpas_pool_get_array(meshPool, 'salinityRestore', salinityRestore) - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) - call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) - - call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) - call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) - - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) - call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) - - call mpas_pool_get_array(diagnosticsPool, 'boundaryLayerDepth', boundaryLayerDepth) - - call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) - - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) - - call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) - - ! Set refBottomDepth and refBottomDepthTopOfCell - do k = 1, nVertLevels - refBottomDepth(k) = config_cvmix_convection_unit_test_bottom_depth * interfaceLocations(k+1) - refZMid(k) = - config_cvmix_convection_unit_test_bottom_depth * ( interfaceLocations(k) + interfaceLocations(k+1) ) * 0.5_RKIND - end do - - maxMidDepth = -minval(refZMid(:)) - - ! Set vertCoordMovementWeights - vertCoordMovementWeights(:) = 1.0_RKIND - - do iCell = 1, nCellsSolve - ! Set stratified temperature - do k = nVertLevels, 1, -1 - temperature = config_cvmix_convection_unit_test_bottom_temperature & - + (config_cvmix_convection_unit_test_surface_temperature - config_cvmix_convection_unit_test_bottom_temperature) & - * ( (refZMid(k) - refZMid(nVertLevels)) / (-refZMid(nVertLevels) )) - tracers(index_temperature, k, iCell) = temperature - end do - - ! Set salinity - tracers(index_salinity, :, iCell) = config_cvmix_convection_unit_test_salinity - - ! Set layerThickness and restingThickness - do k = 1, nVertLevels - layerThickness(k, iCell) = config_cvmix_convection_unit_test_bottom_depth * ( interfaceLocations(k+1) - interfaceLocations(k) ) - restingThickness(k, iCell) = layerThickness(k, iCell) - end do - - ! Set temperatureRestore - temperatureRestore(iCell) = config_cvmix_convection_unit_test_surface_temperature - 10.0_RKIND - - ! Set salinityRestore - salinityRestore(iCell) = config_cvmix_convection_unit_test_salinity - - ! Set boundary layer depth - boundaryLayerDepth(iCell) = 2.0_RKIND * (config_cvmix_convection_unit_test_bottom_depth / nVertLevels) - 1.0-4_RKIND - - ! Set bottomDepth - bottomDepth(iCell) = config_cvmix_convection_unit_test_bottom_depth - - ! Set maxLevelCell - maxLevelCell(iCell) = nVertLevels - end do - - do iEdge = 1, nEdgesSolve - surfaceWindStress(iEdge) = config_cvmix_convection_unit_test_max_windstress * cos(angleEdge(iEdge)) - end do - - block_ptr => block_ptr % next - end do - - deallocate(interfaceLocations) - - !-------------------------------------------------------------------- - - end subroutine ocn_init_setup_cvmix_convection_unit_test!}}} - -!*********************************************************************** -! -! routine ocn_init_validate_cvmix_convection_unit_test -! -!> \brief Validation for cvmix convection unit test case -!> \author Doug Jacobsen -!> \date 04/01/2015 -!> \details -!> This routine validates the configuration options for the CVMix convective mixing unit test case. -! -!----------------------------------------------------------------------- - - subroutine ocn_init_validate_cvmix_convection_unit_test(configPool, packagePool, iErr)!{{{ - - !-------------------------------------------------------------------- - - type (mpas_pool_type), intent(in) :: configPool - type (mpas_pool_type), intent(in) :: packagePool - integer, intent(out) :: iErr - - character(len=StrKIND), pointer :: config_init_configuration - integer, pointer :: config_vert_levels, config_cvmix_convection_unit_test_vert_levels - - iErr = 0 - - call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) - - if(config_init_configuration .ne. trim('cvmix_convection_unit_test')) return - - call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) - call mpas_pool_get_config(configPool, 'config_cvmix_convection_unit_test_vert_levels', config_cvmix_convection_unit_test_vert_levels) - - if(config_vert_levels <= 0 .and. config_cvmix_convection_unit_test_vert_levels > 0) then - config_vert_levels = config_cvmix_convection_unit_test_vert_levels - else if(config_vert_levels <= 0) then - write(stderrUnit,*) 'ERROR: Validation failed for CVMix convection unit test case. Not given a usable value for vertical levels.' - iErr = 1 - end if - - !-------------------------------------------------------------------- - - end subroutine ocn_init_validate_cvmix_convection_unit_test!}}} - -!*********************************************************************** - -end module ocn_init_cvmix_convection_unit_test - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_shear_unit_test.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_shear_unit_test.F deleted file mode 100644 index 846e64d764..0000000000 --- a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_shear_unit_test.F +++ /dev/null @@ -1,262 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_init_cvmix_shear_unit_test -! -!> \brief MPAS ocean initialize case -- CVMix shear Mixing Unit Test -!> \author Doug Jacobsen -!> \date 04/01/2015 -!> \details -!> This module contains the routines for initializing the -!> the cvmix shear mixing unit test configuration -! -!----------------------------------------------------------------------- - -module ocn_init_cvmix_shear_unit_test - - use mpas_kind_types - use mpas_io_units - use mpas_derived_types - use mpas_pool_routines - use mpas_constants - - use ocn_init_cell_markers - use ocn_init_vertical_grids - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_init_setup_cvmix_shear_unit_test, & - ocn_init_validate_cvmix_shear_unit_test - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - -!*********************************************************************** - -contains - -!*********************************************************************** -! -! routine ocn_init_setup_cvmix_shear_unit_test -! -!> \brief Setup for cvmix shear mixing unit test configuration -!> \author Doug Jacobsen -!> \date 04/01/2015 -!> \details -!> This routine sets up the initial conditions for the cvmix shear mixing unit test configuration. -! -!----------------------------------------------------------------------- - - subroutine ocn_init_setup_cvmix_shear_unit_test(domain, iErr)!{{{ - - !-------------------------------------------------------------------- - - type (domain_type), intent(inout) :: domain - integer, intent(out) :: iErr - real (kind=RKIND) :: maxMidDepth, temperature - - type (block_type), pointer :: block_ptr - - type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool - type (mpas_pool_type), pointer :: diagnosticsPool, forcingPool - - integer, pointer :: nVertLevels, nVertLevelsP1, nCellsSolve, nEdgesSolve - integer, pointer :: index_temperature, index_salinity - - integer, dimension(:), pointer :: maxLevelCell - real (kind=RKIND), dimension(:), pointer :: refBottomDepth, refZMid, vertCoordMovementWeights - real (kind=RKIND), dimension(:), pointer :: surfaceWindStress, boundaryLayerDepth, temperatureRestore - real (kind=RKIND), dimension(:), pointer :: salinityRestore, bottomDepth, angleEdge - real (kind=RKIND), dimension(:, :), pointer :: layerThickness, restingThickness - real (kind=RKIND), dimension(:, :, :), pointer :: tracers - - real (kind=RKIND), dimension(:), pointer :: interfaceLocations - - integer :: iCell, iEdge, k, idx - - character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid - real (kind=RKIND), pointer :: config_cvmix_shear_unit_test_bottom_depth, config_cvmix_shear_unit_test_bottom_temperature, & - config_cvmix_shear_unit_test_surface_temperature, config_cvmix_shear_unit_test_salinity, & - config_cvmix_shear_unit_test_max_windstress - - iErr = 0 - - call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) - - if(config_init_configuration .ne. trim('cvmix_shear_unit_test')) return - - - call mpas_pool_get_config(domain % configs, 'config_cvmix_shear_unit_test_bottom_depth', config_cvmix_shear_unit_test_bottom_depth) - call mpas_pool_get_config(domain % configs, 'config_cvmix_shear_unit_test_bottom_temperature', config_cvmix_shear_unit_test_bottom_temperature) - call mpas_pool_get_config(domain % configs, 'config_cvmix_shear_unit_test_surface_temperature', config_cvmix_shear_unit_test_surface_temperature) - call mpas_pool_get_config(domain % configs, 'config_cvmix_shear_unit_test_salinity', config_cvmix_shear_unit_test_salinity) - call mpas_pool_get_config(domain % configs, 'config_cvmix_shear_unit_test_max_windstress', config_cvmix_shear_unit_test_max_windstress) - - call mpas_pool_get_config(domain % configs, 'config_vertical_grid', config_vertical_grid) - call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nVertLevelsP1', nVertLevelsP1) - allocate(interfaceLocations(nVertLevelsP1)) - call ocn_generate_vertical_grid(config_vertical_grid, interfaceLocations) - - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) - call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) - call mpas_pool_get_subpool(block_ptr % structs, 'diagnostics', diagnosticsPool) - call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) - - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) - - call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) - - call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) - call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(meshPool, 'temperatureRestore', temperatureRestore) - call mpas_pool_get_array(meshPool, 'salinityRestore', salinityRestore) - call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) - call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) - - call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) - call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) - - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) - call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) - - call mpas_pool_get_array(diagnosticsPool, 'boundaryLayerDepth', boundaryLayerDepth) - - call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) - - ! Set refBottomDepth and refBottomDepthTopOfCell - do k = 1, nVertLevels - refBottomDepth(k) = config_cvmix_shear_unit_test_bottom_depth * interfaceLocations(k+1) - refZMid(k) = - 0.5_RKIND * config_cvmix_shear_unit_test_bottom_depth * (interfaceLocations(k) + interfaceLocations(k+1)) - end do - - maxMidDepth = -minval(refZMid(:)) - - ! Set vertCoordMovementWeights - vertCoordMovementWeights(:) = 1.0_RKIND - - do iCell = 1, nCellsSolve - ! Set stratified temperature - do k = nVertLevels, 1, -1 - temperature = config_cvmix_shear_unit_test_bottom_temperature & - + (config_cvmix_shear_unit_test_surface_temperature - config_cvmix_shear_unit_test_bottom_temperature) & - * ( (refZMid(k) - refZMid(nVertLevels)) / ( - refZMid(nVertLevels) )) - tracers(index_temperature, k, iCell) = temperature - end do - - ! Set salinity - tracers(index_salinity, :, iCell) = config_cvmix_shear_unit_test_salinity - - ! Set layerThickness - do k = 1, nVertLevels - layerThickness(k, iCell) = config_cvmix_shear_unit_test_bottom_depth * (interfaceLocations(k+1) - interfaceLocations(k)) - restingThickness(k, iCell) = layerThickness(k, iCell) - end do - - ! Set temperatureRestore - temperatureRestore(iCell) = config_cvmix_shear_unit_test_surface_temperature + 10.0_RKIND - - ! Set salinityRestore - salinityRestore(iCell) = config_cvmix_shear_unit_test_salinity - - ! Set boundary layer depth - boundaryLayerDepth(iCell) = 2.0_RKIND * (config_cvmix_shear_unit_test_bottom_depth / nVertLevels) - 1.0-4_RKIND - - ! Set bottomDepth - bottomDepth(iCell) = config_cvmix_shear_unit_test_bottom_depth - - ! Set maxLevelCell - maxLevelCell(iCell) = nVertLevels - end do - - do iEdge = 1, nEdgesSolve - surfaceWindStress(iEdge) = config_cvmix_shear_unit_test_max_windstress * cos(angleEdge(iEdge)) - end do - - block_ptr => block_ptr % next - end do - - deallocate(interfaceLocations) - - !-------------------------------------------------------------------- - - end subroutine ocn_init_setup_cvmix_shear_unit_test!}}} - -!*********************************************************************** -! -! routine ocn_init_validate_cvmix_shear_unit_test -! -!> \brief Validation for CVMix shear mixing unit test case -!> \author Doug Jacobsen -!> \date 04/01/2015 -!> \details -!> This routine validates the configuration options for the CVMix shear mixing unit test configuration. -! -!----------------------------------------------------------------------- - - subroutine ocn_init_validate_cvmix_shear_unit_test(configPool, packagePool, iErr)!{{{ - - !-------------------------------------------------------------------- - - type (mpas_pool_type), intent(in) :: configPool - type (mpas_pool_type), intent(in) :: packagePool - integer, intent(out) :: iErr - - character (len=StrKIND), pointer :: config_init_configuration - integer, pointer :: config_vert_levels, config_cvmix_shear_unit_test_vert_levels - - iErr = 0 - - call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) - - if(config_init_configuration .ne. trim('cvmix_shear_unit_test')) return - - call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) - call mpas_pool_get_config(configPool, 'config_cvmix_shear_unit_test_vert_levels', config_cvmix_shear_unit_test_vert_levels) - - if(config_vert_levels <= 0 .and. config_cvmix_shear_unit_test_vert_levels > 0) then - config_vert_levels = config_cvmix_shear_unit_test_vert_levels - else if(config_vert_levels <= 0) then - write(stderrUnit,*) 'ERROR: Validation failed for CVMix shear mixing unit test case. Not given a usable value for vertical levels.' - iErr = 1 - end if - - !-------------------------------------------------------------------- - - end subroutine ocn_init_validate_cvmix_shear_unit_test!}}} - -!*********************************************************************** - -end module ocn_init_cvmix_shear_unit_test - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F b/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F index 05450f3391..43de98bc15 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F @@ -971,7 +971,8 @@ subroutine ocn_init_setup_global_realistic_interpolate_tracers(domain, iErr)!{{{ integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell integer, dimension(:, :), pointer :: cellsOnCell - real (kind=RKIND), dimension(:), pointer :: latCell, lonCell, temperatureRestore, salinityRestore + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + ! ToBeRemoved real (kind=RKIND), dimension(:), pointer :: temperatureRestore, salinityRestore real (kind=RKIND), dimension(:, :), pointer :: smoothedTemperature, smoothedSalinity real (kind=RKIND), dimension(:, :, :), pointer :: tracers @@ -999,8 +1000,8 @@ subroutine ocn_init_setup_global_realistic_interpolate_tracers(domain, iErr)!{{{ call mpas_pool_get_array(meshPool, 'latCell', latCell) call mpas_pool_get_array(meshPool, 'lonCell', lonCell) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(meshPool, 'temperatureRestore', temperatureRestore) - call mpas_pool_get_array(meshPool, 'salinityRestore', salinityRestore) + ! ToBeRemoved call mpas_pool_get_array(meshPool, 'temperatureRestore', temperatureRestore) + ! ToBeRemoved call mpas_pool_get_array(meshPool, 'salinityRestore', salinityRestore) call mpas_pool_get_array(statePool, 'tracers', tracers, 1) @@ -1127,12 +1128,13 @@ subroutine ocn_init_setup_global_realistic_interpolate_tracers(domain, iErr)!{{{ call mpas_dmpar_finalize(domain % dminfo) endif - if (config_global_realistic_tracer_restore) then - do iCell = 1, nCellsSolve - temperatureRestore(iCell) = tracers(idxTemperature, 1, iCell) - salinityRestore(iCell) = tracers(idxSalinity, 1, iCell) - end do - endif + ! ToBeRemoved + ! if (config_global_realistic_tracer_restore) then + ! do iCell = 1, nCellsSolve + ! temperatureRestore(iCell) = tracers(idxTemperature, 1, iCell) + ! salinityRestore(iCell) = tracers(idxSalinity, 1, iCell) + ! end do + ! endif block_ptr => block_ptr % next end do diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 3317fcd7cc..47613bad30 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -42,8 +42,6 @@ module ocn_init_mode use ocn_init_lock_exchange use ocn_init_internal_waves use ocn_init_overflow - use ocn_init_cvmix_convection_unit_test - use ocn_init_cvmix_shear_unit_test use ocn_init_global_realistic use ocn_init_cvmix_WSwSBF @@ -249,8 +247,6 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call ocn_init_setup_lock_exchange(domain, ierr) call ocn_init_setup_internal_waves(domain, ierr) call ocn_init_setup_overflow(domain, ierr) - call ocn_init_setup_cvmix_convection_unit_test(domain, ierr) - call ocn_init_setup_cvmix_shear_unit_test(domain, ierr) call ocn_init_setup_global_realistic(domain, ierr) call ocn_init_setup_cvmix_WSwSBF(domain, ierr) !call ocn_init_setup_TEMPLATE(domain, ierr) @@ -332,10 +328,6 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, iErr)!{ iErr = ior(iErr, err_tmp) call ocn_init_validate_overflow(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) - call ocn_init_validate_cvmix_convection_unit_test(configPool, packagePool, iErr=err_tmp) - iErr = ior(iErr, err_tmp) - call ocn_init_validate_cvmix_shear_unit_test(configPool, packagePool, iErr=err_tmp) - iErr = ior(iErr, err_tmp) call ocn_init_validate_global_realistic(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) call ocn_init_validate_cvmix_WSwSBF(configPool, packagePool, iErr=err_tmp) diff --git a/src/core_ocean/shared/mpas_ocn_forcing.F b/src/core_ocean/shared/mpas_ocn_forcing.F index 25a7f6b6fc..aec8584a4e 100644 --- a/src/core_ocean/shared/mpas_ocn_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_forcing.F @@ -25,7 +25,6 @@ module ocn_forcing use mpas_timekeeping use mpas_io_units use mpas_dmpar - use ocn_forcing_restoring use ocn_constants implicit none @@ -34,7 +33,6 @@ module ocn_forcing ! TRACER-CLEAN-UP ! Need to figure out what to do with absorption coefficient computation. - ! Also need to remove restoring stuff !-------------------------------------------------------------------- ! @@ -48,8 +46,7 @@ module ocn_forcing ! !-------------------------------------------------------------------- - public :: ocn_forcing_build_arrays, & - ocn_forcing_init, & + public :: ocn_forcing_init, & ocn_forcing_build_fraction_absorbed_array, & ocn_forcing_transmission @@ -61,108 +58,11 @@ module ocn_forcing real (kind=RKIND) :: attenuationCoefficient - logical :: restoringOn - !*********************************************************************** contains !*********************************************************************** -! -! routine ocn_forcing_build_arrays -! -!> \brief Determines the forcing arrays. -!> \author Doug Jacobsen -!> \date 12/13/12 -!> \details -!> This routine computes the forcing arrays used later in MPAS. -! -!----------------------------------------------------------------------- - - subroutine ocn_forcing_build_arrays(meshPool, statePool, forcingPool, err, timeLevelIn)!{{{ - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - - type (mpas_pool_type), intent(in) :: & - statePool, & !< Input: State information - meshPool !< Input: mesh information - - integer, intent(in), optional :: timeLevelIn - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - - type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - integer, intent(out) :: err !< Output: Error flag - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - - ! pool pointers - type (mpas_pool_type), pointer :: tracersPool - type (mpas_pool_type), pointer :: tracersSurfaceFluxPool - - ! scalar pointers - integer, pointer :: indexTemperature, indexSalinity - integer, pointer :: indexTemperatureSurfaceFlux, indexSalinitySurfaceFlux - - ! array pointers - real (kind=RKIND), dimension(:), pointer :: temperatureRestore, salinityRestore - real (kind=RKIND), dimension(:,:), pointer :: activeTracersSurfaceFlux - real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers - - ! local integer/real/logical - integer :: timeLevel - - call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) - call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceFlux', tracersSurfaceFluxPool) - - if (present(timeLevelIn)) then - timeLevel = timeLevelIn - else - timeLevel = 1 - end if - - if ( restoringOn ) then - call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) - call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) - - call mpas_pool_get_dimension(tracersSurfaceFluxPool, 'index_temperatureSurfaceFlux', indexTemperatureSurfaceFlux) - call mpas_pool_get_dimension(tracersSurfaceFluxPool, 'index_salinitySurfaceFlux', indexSalinitySurfaceFlux) - - call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) - - call mpas_pool_get_array(meshPool, 'temperatureRestore', temperatureRestore) - call mpas_pool_get_array(meshPool, 'salinityRestore', salinityRestore) - - call mpas_pool_get_array(tracersSurfaceFluxPool, 'activeTracersSurfaceFlux', activeTracersSurfaceFlux) - - call ocn_forcing_restoring_build_arrays(meshPool, indexTemperature, indexSalinity, & - indexTemperatureSurfaceFlux, indexSalinitySurfaceFlux, & - activeTracers, temperatureRestore, salinityRestore, & - activeTracersSurfaceFlux, err) - end if - - !-------------------------------------------------------------------- - - end subroutine ocn_forcing_build_arrays!}}} !*********************************************************************** ! @@ -180,32 +80,14 @@ subroutine ocn_forcing_init(err)!{{{ integer, intent(out) :: err !< Output: error flag - integer :: err1 - character (len=StrKIND), pointer :: config_forcing_type real (kind=RKIND), pointer :: config_flux_attenuation_coefficient - err = 0 - err1 = 0 - call mpas_pool_get_config(ocnConfigs, 'config_flux_attenuation_coefficient', config_flux_attenuation_coefficient) call mpas_pool_get_config(ocnConfigs, 'config_forcing_type', config_forcing_type) attenuationCoefficient = config_flux_attenuation_coefficient - if ( config_forcing_type == trim('restoring') ) then - call ocn_forcing_restoring_init(err1) - restoringOn = .true. - else if ( config_forcing_type == trim('off') ) then - restoringOn = .false. - else - write(stderrUnit, *) "ERROR: config_forcing_type not one of 'restoring', or 'off'." - err = 1 - call mpas_dmpar_global_abort("ERROR: config_forcing_type not one of 'restoring', or 'off'.") - end if - - err = ior(err,err1) - end subroutine ocn_forcing_init!}}} !*********************************************************************** diff --git a/src/core_ocean/shared/mpas_ocn_forcing_restoring.F b/src/core_ocean/shared/mpas_ocn_forcing_restoring.F deleted file mode 100644 index 1b01a479d2..0000000000 --- a/src/core_ocean/shared/mpas_ocn_forcing_restoring.F +++ /dev/null @@ -1,183 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_forcing_restoring -! -!> \brief MPAS ocean restoring -!> \author Doug Jacobsen -!> \date 10/28/2013 -!> \details -!> This module contains routines for building surface flux arrays based on restoring. -! -!----------------------------------------------------------------------- - -module ocn_forcing_restoring - - use mpas_derived_types - use mpas_pool_routines - use ocn_constants - - ! TRACER-CLEAN-UP - ! Need to remove this module at some point - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_forcing_restoring_build_arrays, & - ocn_forcing_restoring_init - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - - real (kind=RKIND) :: temperatureTimeScale, salinityTimeScale !< restoring timescales - real (kind=RKIND) :: temperatureLengthScale, salinityLengthScale !< restoring timescales - - -!*********************************************************************** - -contains - -!*********************************************************************** -! -! routine ocn_forcing_restoring_build_arrays -! -!> \brief Builds the forcing array for restoring -!> \author Doug Jacobsen -!> \date 10/29/2013 -!> \details -!> This routine builds the forcing array based on surface restoring. -! -!----------------------------------------------------------------------- - - subroutine ocn_forcing_restoring_build_arrays(meshPool, indexT, indexS, indexTFlux, indexSFlux, tracers, temperatureRestoring, salinityRestoring, surfaceTracerFluxes, err)!{{{ - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - - type (mpas_pool_type), intent(in) :: & - meshPool !< Input: mesh information - - real (kind=RKIND), dimension(:,:,:), intent(in) :: & - tracers !< Input: tracer quantities - - real (kind=RKIND), dimension(:), intent(in) :: & - temperatureRestoring, & !< Input: Restoring values for temperature - salinityRestoring !< Input: Restoring values for salinity - - integer, intent(in) :: indexT !< Input: index for temperature - integer, intent(in) :: indexS !< Input: index for salinity - integer, intent(in) :: indexTFlux !< Input: index for temperature flux - integer, intent(in) :: indexSFlux !< Input: index for salinity flux - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - - real (kind=RKIND), dimension(:,:), intent(out) :: & - surfaceTracerFluxes !< Input: tracer quantities - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - integer, intent(out) :: err !< Output: Error flag - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - - integer :: iCell, k - integer, pointer :: nCells - - real (kind=RKIND) :: invTemp, invSalinity - - err = 0 - - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - - invTemp = 1.0 / (temperatureTimeScale * 86400.0) - invSalinity = 1.0 / (salinityTimeScale * 86400.0) - - k = 1 ! restoring only in top layer - do iCell=1,nCells - surfaceTracerFluxes(indexTFlux, iCell) = - temperatureLengthScale * (tracers(indexT, k, iCell) - temperatureRestoring(iCell)) * invTemp - surfaceTracerFluxes(indexSFlux, iCell) = - salinityLengthScale * (tracers(indexS, k, iCell) - salinityRestoring(iCell)) * invSalinity - enddo - - !-------------------------------------------------------------------- - - end subroutine ocn_forcing_restoring_build_arrays!}}} - -!*********************************************************************** -! -! routine ocn_forcing_restoring_init -! -!> \brief Initializes ocean surface restoring -!> \author Doug Jacobsen -!> \date 10/29/2013 -!> \details -!> This routine initializes a variety of quantities related to -!> restoring in the ocean. -! -!----------------------------------------------------------------------- - - subroutine ocn_forcing_restoring_init(err)!{{{ - - integer, intent(out) :: err !< Output: error flag - - real (kind=RKIND), pointer :: config_restoreT_timescale, config_restoreT_lengthscale - real (kind=RKIND), pointer :: config_restoreS_timescale, config_restoreS_lengthscale - - err = 0 - - call mpas_pool_get_config(ocnConfigs, 'config_restoreT_timescale', config_restoreT_timescale) - call mpas_pool_get_config(ocnConfigs, 'config_restoreT_lengthscale', config_restoreT_lengthscale) - call mpas_pool_get_config(ocnConfigs, 'config_restoreS_timescale', config_restoreS_timescale) - call mpas_pool_get_config(ocnConfigs, 'config_restoreS_lengthscale', config_restoreS_lengthscale) - - temperatureTimeScale = config_restoreT_timescale - salinityTimeScale = config_restoreS_timescale - temperatureLengthScale = config_restoreT_lengthscale - salinityLengthScale = config_restoreS_lengthscale - - !-------------------------------------------------------------------- - - end subroutine ocn_forcing_restoring_init!}}} - -!*********************************************************************** - -end module ocn_forcing_restoring - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! vim: foldmethod=marker From f65aa9edc37f67d78511e6e5703fb2bc32ae6728 Mon Sep 17 00:00:00 2001 From: toddringler Date: Thu, 30 Jul 2015 09:46:29 -0600 Subject: [PATCH 0168/1724] remove old surface restoring package --- src/core_ocean/Registry.xml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 95a7c61045..843cdb6ce6 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -853,7 +853,6 @@ - From 36b3a8541fa80a6b232d0c2cd1cf4597c938e035 Mon Sep 17 00:00:00 2001 From: toddringler Date: Thu, 30 Jul 2015 11:18:33 -0600 Subject: [PATCH 0169/1724] remove old references to surfaceTracerFlux --- src/core_ocean/driver/mpas_ocn_core_interface.F | 6 ------ src/core_ocean/driver/mpas_ocn_mpas_core.F | 8 -------- src/core_ocean/shared/mpas_ocn_tendency.F | 5 ++--- 3 files changed, 2 insertions(+), 17 deletions(-) diff --git a/src/core_ocean/driver/mpas_ocn_core_interface.F b/src/core_ocean/driver/mpas_ocn_core_interface.F index 78faccc36f..59cd1baa12 100644 --- a/src/core_ocean/driver/mpas_ocn_core_interface.F +++ b/src/core_ocean/driver/mpas_ocn_core_interface.F @@ -106,7 +106,6 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ logical, pointer :: forwardModeActive, analysisModeActive, initModeActive logical, pointer :: thicknessFilterActive logical, pointer :: splitTimeIntegratorActive - logical, pointer :: surfaceRestoringActive logical, pointer :: windStressBulkPKGActive logical, pointer :: thicknessBulkPKGActive logical, pointer :: frazilIceActive @@ -141,7 +140,6 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ call mpas_pool_get_package(packagePool, 'initModeActive', initModeActive) call mpas_pool_get_package(packagePool, 'thicknessFilterActive', thicknessFilterActive) call mpas_pool_get_package(packagePool, 'splitTimeIntegratorActive', splitTimeIntegratorActive) - call mpas_pool_get_package(packagePool, 'surfaceRestoringActive', surfaceRestoringActive) call mpas_pool_get_package(packagePool, 'frazilIceActive', frazilIceActive) call mpas_pool_get_package(packagePool, 'inSituEOSActive', inSituEOSActive) call mpas_pool_get_package(packagePool, 'windStressBulkPKGActive', windStressBulkPKGActive) @@ -173,10 +171,6 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ splitTimeIntegratorActive = .true. end if - if (config_forcing_type == trim('restoring')) then - surfaceRestoringActive = .true. - end if - if ( config_use_bulk_wind_stress ) then windStressBulkPKGActive = .true. end if diff --git a/src/core_ocean/driver/mpas_ocn_mpas_core.F b/src/core_ocean/driver/mpas_ocn_mpas_core.F index c35ae9485d..ec5fb9259a 100644 --- a/src/core_ocean/driver/mpas_ocn_mpas_core.F +++ b/src/core_ocean/driver/mpas_ocn_mpas_core.F @@ -172,7 +172,6 @@ subroutine mpas_core_setup_packages(configPool, packagePool, ierr)!{{{ logical, pointer :: forwardModeActive, analysisModeActive, initModeActive logical, pointer :: thicknessFilterActive logical, pointer :: splitTimeIntegratorActive - logical, pointer :: surfaceRestoringActive logical, pointer :: bulkForcingActive logical, pointer :: frazilIceActive logical, pointer :: inSituEOSActive @@ -188,7 +187,6 @@ subroutine mpas_core_setup_packages(configPool, packagePool, ierr)!{{{ call mpas_pool_get_package(packagePool, 'initModeActive', initModeActive) call mpas_pool_get_package(packagePool, 'thicknessFilterActive', thicknessFilterActive) call mpas_pool_get_package(packagePool, 'splitTimeIntegratorActive', splitTimeIntegratorActive) - call mpas_pool_get_package(packagePool, 'surfaceRestoringActive', surfaceRestoringActive) call mpas_pool_get_package(packagePool, 'bulkForcingActive', bulkForcingActive) call mpas_pool_get_package(packagePool, 'frazilIceActive', frazilIceActive) call mpas_pool_get_package(packagePool, 'inSituEOSActive', inSituEOSActive) @@ -216,12 +214,6 @@ subroutine mpas_core_setup_packages(configPool, packagePool, ierr)!{{{ splitTimeIntegratorActive = .true. end if - if (config_forcing_type == trim('restoring')) then - surfaceRestoringActive = .true. - else if (config_forcing_type == trim('bulk')) then - bulkForcingActive = .true. - end if - if (config_frazil_ice_formation) then frazilIceActive = .true. end if diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index b41a676dba..cc2816da2e 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -630,10 +630,9 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! ! convert the surface tracer flux into a tracer tendency by distributing the flux across some number of surface layers ! - ! TRACER-CLEAN-UP surfaceTracerFlux - call mpas_timer_start("surface_flux", .false.) + call mpas_timer_start("surface_tracer_flux", .false.) call ocn_tracer_surface_flux_tend(meshPool, fractionAbsorbed, layerThickness, tracerGroupSurfaceFlux, tracerGroupTend, err) - call mpas_timer_stop("surface_flux") + call mpas_timer_stop("surface_tracer_flux") ! ! Performing shortwave absorption From 3c09d29dc0960b3deb3f4a442c4af7305d50679d Mon Sep 17 00:00:00 2001 From: toddringler Date: Thu, 30 Jul 2015 14:30:26 -0600 Subject: [PATCH 0170/1724] hardwiring index_{temperature,salinity}_flux because these can not be accessed from the forcing pool --- src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F index 6aa71c7c92..49bad1d47c 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F @@ -243,7 +243,6 @@ subroutine ocn_surface_bulk_forcing_thick(meshPool, forcingPool, surfaceThicknes !----------------------------------------------------------------- integer :: iCell - integer, pointer :: index_temperature_flux, index_salinity_flux integer, pointer :: nCells, nEdges integer, dimension(:,:), pointer :: cellsOnEdge @@ -366,8 +365,9 @@ subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracer call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_dimension(forcingPool, 'index_temperatureSurfaceFlux', index_temperature_flux) - call mpas_pool_get_dimension(forcingPool, 'index_salinitySurfaceFlux', index_salinity_flux) + ! CLEANUP + ! call mpas_pool_get_dimension(forcingPool, 'index_temperatureSurfaceFlux', index_temperature_flux) + ! call mpas_pool_get_dimension(forcingPool, 'index_salinitySurfaceFlux', index_salinity_flux) call mpas_pool_get_array(forcingPool, 'latentHeatFlux', latentHeatFlux) call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) @@ -383,12 +383,13 @@ subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracer call mpas_pool_get_array(forcingPool, 'penetrativeTemperatureFlux', penetrativeTemperatureFlux) ! Build surface fluxes at cell centers + ! CLEANUP do iCell = 1, nCells - tracersSurfaceFlux(index_temperature_flux, iCell) = tracersSurfaceFlux(index_temperature_flux, iCell) & + tracersSurfaceFlux(1, iCell) = tracersSurfaceFlux(1, iCell) & + (latentHeatFlux(iCell) + sensibleHeatFlux(iCell) + longWaveHeatFluxUp(iCell) + longWaveHeatFluxDown(iCell) & + seaIceHeatFlux(iCell) - (snowFlux(iCell) + iceRunoffFlux(iCell)) * latent_heat_fusion_mks) * hflux_factor - tracersSurfaceFlux(index_salinity_flux, iCell) = tracersSurfaceFlux(index_salinity_flux, iCell) & + tracersSurfaceFlux(2, iCell) = tracersSurfaceFlux(2, iCell) & + seaIceSalinityFlux(iCell) * sflux_factor end do From 264195f47ed42fc4dda495d93d3a88fc08153f93 Mon Sep 17 00:00:00 2001 From: toddringler Date: Fri, 14 Aug 2015 14:52:12 -0600 Subject: [PATCH 0171/1724] change interior restoring from a time scale (s) to a rate (1/s) so that regions with no restoring can be specified with values of zero. --- .../tracer_groups/Registry_activeTracers.xml | 10 +++++----- src/core_ocean/tracer_groups/Registry_debugTracers.xml | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/core_ocean/tracer_groups/Registry_activeTracers.xml b/src/core_ocean/tracer_groups/Registry_activeTracers.xml index 456555dbf8..4cec42428b 100644 --- a/src/core_ocean/tracer_groups/Registry_activeTracers.xml +++ b/src/core_ocean/tracer_groups/Registry_activeTracers.xml @@ -95,20 +95,20 @@ - - + - diff --git a/src/core_ocean/tracer_groups/Registry_debugTracers.xml b/src/core_ocean/tracer_groups/Registry_debugTracers.xml index b396bdf13a..50df60a628 100644 --- a/src/core_ocean/tracer_groups/Registry_debugTracers.xml +++ b/src/core_ocean/tracer_groups/Registry_debugTracers.xml @@ -80,14 +80,14 @@ - - + From ea398d819c513bf87a3953fbc81cc9616f564ce5 Mon Sep 17 00:00:00 2001 From: toddringler Date: Fri, 14 Aug 2015 14:54:51 -0600 Subject: [PATCH 0172/1724] add surface and interior restoring fields --- .../mode_init/Registry_cvmix_WSwSBF.xml | 17 ++++ .../mode_init/mpas_ocn_init_cvmix_WSwSBF.F | 88 +++++++++++++------ 2 files changed, 78 insertions(+), 27 deletions(-) diff --git a/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml b/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml index 6cb2a04e92..0394924aab 100644 --- a/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml +++ b/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml @@ -19,6 +19,14 @@ description="Salinity to restore towards when surface restoring is turned on." possible_values="Any real number" /> + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F index e527d8aa56..5ee0d96bce 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F @@ -83,22 +83,27 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ type (block_type), pointer :: block_ptr type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool - type (mpas_pool_type), pointer :: tracersPool, tracersSurfaceFluxPool, tracersSurfaceRestoringFieldsPool type (mpas_pool_type), pointer :: diagnosticsPool, forcingPool + type (mpas_pool_type), pointer :: tracersPool, & + tracersSurfaceFluxPool, & + tracersSurfaceRestoringFieldsPool, & + tracersInteriorRestoringFieldsPool + integer, pointer :: nVertLevels, nVertLevelsP1, nCellsSolve, nEdgesSolve, nVerticesSolve integer, pointer :: index_temperature, index_salinity, index_tracer1 integer, dimension(:), pointer :: maxLevelCell real (kind=RKIND), dimension(:), pointer :: refBottomDepth, refZMid, vertCoordMovementWeights - real (kind=RKIND), dimension(:), pointer :: surfaceWindStress + real (kind=RKIND), dimension(:), pointer :: windStressZonal, windStressMeridional real (kind=RKIND), dimension(:), pointer :: latentHeatFlux, sensibleHeatFlux, shortWaveHeatFlux real (kind=RKIND), dimension(:), pointer :: evaporationFlux, rainFlux real (kind=RKIND), dimension(:), pointer :: salinityRestore, bottomDepth, angleEdge real (kind=RKIND), dimension(:), pointer :: fCell, fEdge, fVertex real (kind=RKIND), dimension(:, :), pointer :: layerThickness, restingThickness real (kind=RKIND), dimension(:, :, :), pointer :: activeTracers, debugTracers - real (kind=RKIND), dimension(:, :), pointer :: activeTracersSurfaceFlux, activeTracersPistonVelocity, activeTracersSurfaceRestoringValue + real (kind=RKIND), dimension(:, :), pointer :: activeTracersPistonVelocity, activeTracersSurfaceRestoringValue + real (kind=RKIND), dimension(:, :, :), pointer :: activeTracersInteriorRestoringValue, activeTracersInteriorRestoringRate real (kind=RKIND), dimension(:), pointer :: interfaceLocations @@ -113,11 +118,15 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ config_cvmix_WSwSBF_surface_salinity, & config_cvmix_WSwSBF_surface_restoring_temperature, & config_cvmix_WSwSBF_surface_restoring_salinity, & + config_cvmix_WSwSBF_surface_temperature_piston_velocity, & + config_cvmix_WSwSBF_surface_salinity_piston_velocity, & config_cvmix_WSwSBF_sensible_heat_flux, & config_cvmix_WSwSBF_latent_heat_flux, & config_cvmix_WSwSBF_shortwave_heat_flux, & config_cvmix_WSwSBF_rain_flux, & config_cvmix_WSwSBF_evaporation_flux, & + config_cvmix_WSwSBF_interior_temperature_restoring_rate, & + config_cvmix_WSwSBF_interior_salinity_restoring_rate, & config_cvmix_WSwSBF_temperature_gradient, & config_cvmix_WSwSBF_salinity_gradient, & config_cvmix_WSwSBF_bottom_depth, & @@ -142,11 +151,15 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_salinity', config_cvmix_WSwSBF_surface_salinity) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_restoring_temperature', config_cvmix_WSwSBF_surface_restoring_temperature) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_restoring_salinity', config_cvmix_WSwSBF_surface_restoring_salinity) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_temperature_piston_velocity', config_cvmix_WSwSBF_surface_temperature_piston_velocity) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_salinity_piston_velocity', config_cvmix_WSwSBF_surface_salinity_piston_velocity) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_sensible_heat_flux', config_cvmix_WSwSBF_sensible_heat_flux) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_latent_heat_flux', config_cvmix_WSwSBF_latent_heat_flux) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_shortwave_heat_flux', config_cvmix_WSwSBF_shortwave_heat_flux) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_rain_flux', config_cvmix_WSwSBF_rain_flux) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_evaporation_flux', config_cvmix_WSwSBF_evaporation_flux) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_interior_temperature_restoring_rate', config_cvmix_WSwSBF_interior_temperature_restoring_rate) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_interior_salinity_restoring_rate', config_cvmix_WSwSBF_interior_salinity_restoring_rate) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_temperature_gradient', config_cvmix_WSwSBF_temperature_gradient) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_salinity_gradient', config_cvmix_WSwSBF_salinity_gradient) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_bottom_depth', config_cvmix_WSwSBF_bottom_depth) @@ -168,6 +181,7 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceFlux', tracersSurfaceFluxPool) call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) + call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) @@ -195,15 +209,18 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_array(tracersPool, 'debugTracers', debugTracers, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) - call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress, 1) - call mpas_pool_get_array(tracersSurfaceFluxPool, 'activeTracersSurfaceFlux', activeTracersSurfaceFlux, 1) + call mpas_pool_get_array(forcingPool, 'windStressZonal', windStressZonal, 1) + call mpas_pool_get_array(forcingPool, 'windStressMeridional', windStressMeridional, 1) call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersPistonVelocity', activeTracersPistonVelocity, 1) call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersSurfaceRestoringValue', activeTracersSurfaceRestoringValue, 1) - ! call mpas_pool_get_array(forcingPool, 'latentHeatFlux', latentHeatFlux) - ! call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) - ! call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) - ! call mpas_pool_get_array(forcingPool, 'evaporationFlux', evaporationFlux) - ! call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringRate', activeTracersInteriorRestoringRate, 1) + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringValue', activeTracersInteriorRestoringValue, 1) + call mpas_pool_get_array(forcingPool, 'latentHeatFlux', latentHeatFlux) + call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) + call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) + call mpas_pool_get_array(forcingPool, 'evaporationFlux', evaporationFlux) + ! TDR + ! call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) ! Set refBottomDepth and refBottomDepthTopOfCell do k = 1, nVertLevels @@ -220,8 +237,8 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ temperature = config_cvmix_WSwSBF_surface_temperature + refZMid(k) * config_cvmix_WSwSBF_temperature_gradient activeTracers(index_temperature, k, iCell) = temperature salinity = config_cvmix_WSwSBF_surface_salinity + refZMid(k) * config_cvmix_WSwSBF_salinity_gradient - activeTracers(index_salinity, :, iCell) = salinity - debugTracers(index_tracer1, :, iCell) = 1.0_RKIND + activeTracers(index_salinity, k, iCell) = salinity + debugTracers(index_tracer1, k, iCell) = 1.0_RKIND end do ! Set layerThickness @@ -230,29 +247,41 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ restingThickness(k, iCell) = layerThickness(k, iCell) end do - ! Set temperature restoring value and rate + ! Set surface temperature restoring value and rate ! Value in units of C, piston velocity in units of m/s activeTracersSurfaceRestoringValue(index_temperature, iCell) = config_cvmix_WSwSBF_surface_restoring_temperature - activeTracersPistonVelocity(index_temperature, iCell) = 10.0_RKIND / 30.0_RKIND / 86400.0_RKIND + activeTracersPistonVelocity(index_temperature, iCell) = config_cvmix_WSwSBF_surface_temperature_piston_velocity - ! Set salinity restoring value and rate + ! Set surface salinity restoring value and rate ! Value in units of PSU, piston velocity in units of m/s activeTracersSurfaceRestoringValue(index_salinity, iCell) = config_cvmix_WSwSBF_surface_restoring_salinity - activeTracersPistonVelocity(index_salinity, iCell) = 10.0_RKIND / 30.0_RKIND / 86400.0_RKIND + activeTracersPistonVelocity(index_salinity, iCell) = config_cvmix_WSwSBF_surface_salinity_piston_velocity + + ! Set sensible heat flux + sensibleHeatFlux(iCell) = config_cvmix_WSwSBF_sensible_heat_flux + + ! Set latent heat flux + latentHeatFlux(iCell) = config_cvmix_WSwSBF_latent_heat_flux - ! TDR - ! ! Set sensible heat flux - ! sensibleHeatFlux(iCell) = config_cvmix_WSwSBF_sensible_heat_flux + ! Set shortwave heat flux + shortWaveHeatFlux(iCell) = config_cvmix_WSwSBF_shortwave_heat_flux - ! ! Set latent heat flux - ! latentHeatFlux(iCell) = config_cvmix_WSwSBF_latent_heat_flux + ! Set precipation and evaporation + ! TDR + ! rainFlux(iCell) = config_cvmix_WSwSBF_rain_flux + ! evaporationFlux(iCell) = config_cvmix_WSwSBF_evaporation_flux - ! ! Set shortwave heat flux - ! shortWaveHeatFlux(iCell) = config_cvmix_WSwSBF_shortwave_heat_flux + ! Set interior temperature restoring value and rate + do k = 1, nVertLevels + activeTracersInteriorRestoringValue(index_temperature, k, iCell) = activeTracers(index_temperature, k, iCell) + activeTracersInteriorRestoringRate(index_temperature, k, iCell) = config_cvmix_WSwSBF_interior_temperature_restoring_rate + enddo - ! ! Set precipation and evaporation - ! rainFlux(iCell) = config_cvmix_WSwSBF_rain_flux - ! evaporationFlux(iCell) = config_cvmix_WSwSBF_evaporation_flux + ! Set interior salinity restoring value and rate + do k = 1, nVertLevels + activeTracersInteriorRestoringValue(index_salinity, k, iCell) = activeTracers(index_salinity, k, iCell) + activeTracersInteriorRestoringRate(index_salinity, k, iCell) = config_cvmix_WSwSBF_interior_salinity_restoring_rate + enddo ! Set Coriolis parameter fCell(iCell) = config_cvmix_WSwSBF_coriolis_parameter @@ -264,8 +293,13 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ maxLevelCell(iCell) = nVertLevels end do + ! TDR + ! do iCell = 1, nCellsSolve + ! windStressZonal(iCell) = config_cvmix_WSwSBF_max_windstress + ! windStressMeridional(iCell) = 0.0_RKIND + ! enddo + do iEdge = 1, nEdgesSolve - surfaceWindStress(iEdge) = config_cvmix_WSwSBF_max_windstress * cos(angleEdge(iEdge)) fEdge(iEdge) = config_cvmix_WSwSBF_coriolis_parameter end do From ddcbc51e79c783d511006d201ea5418e3710480a Mon Sep 17 00:00:00 2001 From: toddringler Date: Fri, 14 Aug 2015 14:55:36 -0600 Subject: [PATCH 0173/1724] add init package to forcing var_struct --- src/core_ocean/Registry.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 843cdb6ce6..6b420b9220 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -572,7 +572,7 @@ possible_values="Any positive value" /> - + Date: Fri, 14 Aug 2015 14:56:06 -0600 Subject: [PATCH 0174/1724] add some (temporary) debugging code. interior restoring uses rates (instead of time scale) --- src/core_ocean/shared/mpas_ocn_tendency.F | 19 +++++++++++++++---- .../mpas_ocn_tracer_interior_restoring.F | 6 +++--- .../mpas_ocn_tracer_surface_restoring.F | 2 ++ 3 files changed, 20 insertions(+), 7 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index cc2816da2e..eebef64c97 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -398,7 +398,7 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me real (kind=RKIND), dimension(:,:,:), pointer :: & tracerGroup, tracerGroupTend, vertNonLocalFlux - real (kind=RKIND), dimension(:,:,:), pointer :: tracerGroupInteriorRestoringTimeScale, tracerGroupInteriorRestoringValue + real (kind=RKIND), dimension(:,:,:), pointer :: tracerGroupInteriorRestoringRate, tracerGroupInteriorRestoringValue ! ! Field pointers @@ -531,6 +531,7 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! if (config_use_tracerGroup_surface_bulk_forcing) then call mpas_timer_start("bulk_" // trim(groupItr % memberName), .false.) + write(6,*) 'yes: ', "bulk_" // trim(groupItr % memberName) call ocn_surface_bulk_forcing_tracers(meshPool, groupItr % memberName, forcingPool, tracerGroupSurfaceFlux, err) call mpas_timer_stop("bulk_" // trim(groupItr % memberName)) end if @@ -539,12 +540,17 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! ocean surface restoring ! if (config_use_tracerGroup_surface_restoring) then + call mpas_timer_start("surface_restoring_" // trim(groupItr % memberName), .false.) call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) modifiedGroupName = trim(groupItr % memberName) // "PistonVelocity" call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, trim(modifiedGroupName), tracerGroupPistonVelocity) modifiedGroupName = trim(groupItr % memberName) // "SurfaceRestoringValue" call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, trim(modifiedGroupName), tracerGroupSurfaceRestoringValue) + write(6,*) 'yes: ', "surface_restoring_" // trim(groupItr % memberName) + write(6,*) trim(groupItr % memberName) // "SurfaceRestoringValue" + write(6,*) maxval(tracerGroupSurfaceRestoringValue), size(tracerGroupSurfaceRestoringValue) call ocn_tracer_surface_restoring_compute(nTracerGroup, nCellsSolve, tracerGroup, tracerGroupPistonVelocity, tracerGroupSurfaceRestoringValue, tracerGroupSurfaceFlux, err) + call mpas_timer_stop("surface_restoring_" // trim(groupItr % memberName)) endif ! land-ice / ocean interface flux @@ -565,13 +571,18 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! interior restoring forcing tendency ! if (config_use_tracerGroup_interior_restoring) then + call mpas_timer_start("interior_restoring_" // trim(groupItr % memberName), .false.) call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) - modifiedGroupName = trim(groupItr % memberName) // "InteriorRestoringTimeScale" - call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, trim(modifiedGroupName), tracerGroupInteriorRestoringTimeScale) + modifiedGroupName = trim(groupItr % memberName) // "InteriorRestoringRate" + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, trim(modifiedGroupName), tracerGroupInteriorRestoringRate) modifiedGroupName = trim(groupItr % memberName) // "InteriorRestoringValue" call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, trim(modifiedGroupName),tracerGroupInteriorRestoringValue) + write(6,*) 'yes: ', "interior_restoring_" // trim(groupItr % memberName) + write(6,*) trim(groupItr % memberName) // "InteriorRestoringValue" + write(6,*) maxval(tracerGroupInteriorRestoringValue), size(tracerGroupInteriorRestoringValue) call ocn_tracer_interior_restoring_compute(nTracerGroup, nCellsSolve, maxLevelCell, layerThickness, & - tracerGroup, tracerGroupInteriorRestoringTimeScale, tracerGroupInteriorRestoringValue, tracerGroupTend, err) + tracerGroup, tracerGroupInteriorRestoringRate, tracerGroupInteriorRestoringValue, tracerGroupTend, err) + call mpas_timer_stop("interior_restoring_" // trim(groupItr % memberName)) endif ! diff --git a/src/core_ocean/shared/mpas_ocn_tracer_interior_restoring.F b/src/core_ocean/shared/mpas_ocn_tracer_interior_restoring.F index a1cad1db20..5c8262df99 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_interior_restoring.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_interior_restoring.F @@ -66,7 +66,7 @@ module ocn_tracer_interior_restoring !----------------------------------------------------------------------- subroutine ocn_tracer_interior_restoring_compute(nTracers, nCellsSolve, maxLevelCell, layerThickness, & - tracers, tracersInteriorRestoringTimeScale, tracersInteriorRestoringValue, tracer_tend, err)!{{{ + tracers, tracersInteriorRestoringRate, tracersInteriorRestoringValue, tracer_tend, err)!{{{ !----------------------------------------------------------------- ! @@ -85,7 +85,7 @@ subroutine ocn_tracer_interior_restoring_compute(nTracers, nCellsSolve, maxLevel ! three dimensional arrays real (kind=RKIND), dimension(:,:,:), intent(in) :: & tracers, & - tracersInteriorRestoringTimeScale, & + tracersInteriorRestoringRate, & tracersInteriorRestoringValue ! scalars @@ -124,7 +124,7 @@ subroutine ocn_tracer_interior_restoring_compute(nTracers, nCellsSolve, maxLevel tracer_tend(iTracer, iLevel, iCell) = tracer_tend(iTracer, iLevel, iCell) & - layerThickness(iLevel,iCell) * & (tracers(iTracer, iLevel, iCell) - tracersInteriorRestoringValue(iTracer, iLevel, iCell)) & - / tracersInteriorRestoringTimeScale(iTracer, iLevel, iCell) + * tracersInteriorRestoringRate(iTracer, iLevel, iCell) enddo enddo enddo diff --git a/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F b/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F index 30a78485cc..56a4be0763 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F @@ -120,6 +120,8 @@ subroutine ocn_tracer_surface_restoring_compute(nTracers, nCellsSolve, tracers, tracersSurfaceFlux(iTracer, iCell) = tracersSurfaceFlux(iTracer, iCell) - & pistonVelocity(iTracer,iCell) * & (tracers(iTracer, iLevel, iCell) - tracersSurfaceRestoringValue(iTracer,iCell)) + write(6,10) iCell,iTracer,tracersSurfaceFlux(iTracer, iCell), pistonVelocity(iTracer,iCell), tracersSurfaceRestoringValue(iTracer,iCell), tracers(iTracer, iLevel, iCell) + 10 format(5x,2i4,4e12.2) enddo enddo From c9d706f9ad85e99a215a5a62fdbd0bab06fd294e Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 18 Aug 2015 16:14:10 -0600 Subject: [PATCH 0175/1724] allow some packages to be turned on when in init and/or analysis mode. re-arrange the testing of packages to make the code easier to understand --- .../driver/mpas_ocn_core_interface.F | 152 ++++++++++++------ 1 file changed, 100 insertions(+), 52 deletions(-) diff --git a/src/core_ocean/driver/mpas_ocn_core_interface.F b/src/core_ocean/driver/mpas_ocn_core_interface.F index 59cd1baa12..43fdf07bfd 100644 --- a/src/core_ocean/driver/mpas_ocn_core_interface.F +++ b/src/core_ocean/driver/mpas_ocn_core_interface.F @@ -103,7 +103,9 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ integer :: err_tmp - logical, pointer :: forwardModeActive, analysisModeActive, initModeActive + logical, pointer :: forwardModeActive + logical, pointer :: analysisModeActive + logical, pointer :: initModeActive logical, pointer :: thicknessFilterActive logical, pointer :: splitTimeIntegratorActive logical, pointer :: windStressBulkPKGActive @@ -119,14 +121,19 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ logical, pointer :: tracerGroupIdealAgePKGActive logical, pointer :: tracerGroupTTDPKGActive - logical, pointer :: config_use_tracerGroup, config_use_tracerGroup_surface_bulk_forcing, config_use_tracerGroup_surface_restoring, & - config_use_tracerGroup_interior_restoring, config_use_tracerGroup_exponential_decay, config_use_tracerGroup_idealAge_forcing, & - config_use_tracerGroup_ttd_forcing + logical, pointer :: config_use_tracerGroup + logical, pointer :: config_use_tracerGroup_surface_bulk_forcing + logical, pointer :: config_use_tracerGroup_surface_restoring + logical, pointer :: config_use_tracerGroup_interior_restoring + logical, pointer :: config_use_tracerGroup_exponential_decay + logical, pointer :: config_use_tracerGroup_idealAge_forcing + logical, pointer :: config_use_tracerGroup_ttd_forcing logical, pointer :: config_use_freq_filtered_thickness logical, pointer :: config_frazil_ice_formation - character (len=StrKIND), pointer :: config_time_integrator, config_forcing_type - character (len=StrKIND), pointer :: config_ocean_run_mode, config_pressure_gradient_type + character (len=StrKIND), pointer :: config_time_integrator + character (len=StrKIND), pointer :: config_ocean_run_mode + character (len=StrKIND), pointer :: config_pressure_gradient_type logical, pointer :: config_use_bulk_wind_stress logical, pointer :: config_use_bulk_thickness_flux @@ -134,70 +141,106 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ character (len=StrKIND) :: tracerGroupName, configName, packageName integer :: startIndex, strLen - ! Get Packages + ierr = 0 + + ! + ! determine the mode being used + ! call mpas_pool_get_package(packagePool, 'forwardModeActive', forwardModeActive) call mpas_pool_get_package(packagePool, 'analysisModeActive', analysisModeActive) call mpas_pool_get_package(packagePool, 'initModeActive', initModeActive) - call mpas_pool_get_package(packagePool, 'thicknessFilterActive', thicknessFilterActive) - call mpas_pool_get_package(packagePool, 'splitTimeIntegratorActive', splitTimeIntegratorActive) - call mpas_pool_get_package(packagePool, 'frazilIceActive', frazilIceActive) - call mpas_pool_get_package(packagePool, 'inSituEOSActive', inSituEOSActive) - call mpas_pool_get_package(packagePool, 'windStressBulkPKGActive', windStressBulkPKGActive) - call mpas_pool_get_package(packagePool, 'thicknessBulkPKGActive', thicknessBulkPKGActive) - call mpas_pool_get_config(configPool, 'config_ocean_run_mode', config_ocean_run_mode) - - ierr = 0 - if ( trim(config_ocean_run_mode) == 'forward' ) then forwardModeActive = .true. + endif + if ( trim(config_ocean_run_mode) == 'analysis') then + analysisModeActive = .true. + endif + if ( trim(config_ocean_run_mode) == 'init') then + initModeActive = .true. + endif - call mpas_pool_get_config(configPool, 'config_use_freq_filtered_thickness', config_use_freq_filtered_thickness) - call mpas_pool_get_config(configPool, 'config_time_integrator', config_time_integrator) - call mpas_pool_get_config(configPool, 'config_forcing_type', config_forcing_type) - call mpas_pool_get_config(configPool, 'config_frazil_ice_formation', config_frazil_ice_formation) - call mpas_pool_get_config(configPool, 'config_pressure_gradient_type', config_pressure_gradient_type) - - call mpas_pool_get_config(configPool, 'config_use_bulk_wind_stress', config_use_bulk_wind_stress) - call mpas_pool_get_config(configPool, 'config_use_bulk_thickness_flux', config_use_bulk_thickness_flux) - - if (config_use_freq_filtered_thickness) then - thicknessFilterActive = .true. - end if - - if (config_time_integrator == trim('split_explicit') & + ! + ! test for integration scheme + ! (TDR: this makes no sense, if split or unsplit then splitTimeIntegratorActive = .true.) + ! + call mpas_pool_get_package(packagePool, 'splitTimeIntegratorActive', splitTimeIntegratorActive) + call mpas_pool_get_config(configPool, 'config_time_integrator', config_time_integrator) + if ( forwardModeActive ) then + if ( config_time_integrator == trim('split_explicit') & .or. config_time_integrator == trim('unsplit_explicit') ) then - splitTimeIntegratorActive = .true. end if + endif - if ( config_use_bulk_wind_stress ) then - windStressBulkPKGActive = .true. - end if - - if ( config_use_bulk_thickness_flux ) then - thicknessBulkPKGActive = .true. + ! + ! test for time filtering scheme + ! + call mpas_pool_get_package(packagePool, 'thicknessFilterActive', thicknessFilterActive) + call mpas_pool_get_config(configPool, 'config_use_freq_filtered_thickness', config_use_freq_filtered_thickness) + if ( forwardModeActive ) then + if (config_use_freq_filtered_thickness) then + thicknessFilterActive = .true. end if + endif - if (config_frazil_ice_formation) then - frazilIceActive = .true. - end if + ! + ! test for bulk forcing of layer thickness, thicknessBulkPKG + ! + call mpas_pool_get_package(packagePool, 'thicknessBulkPKGActive', thicknessBulkPKGActive) + call mpas_pool_get_config(configPool, 'config_use_bulk_thickness_flux', config_use_bulk_thickness_flux) + if ( config_use_bulk_thickness_flux ) then + thicknessBulkPKGActive = .true. + end if - if (config_pressure_gradient_type.eq.'Jacobian_from_TS') then - inSituEOSActive = .true. - end if + ! + ! test for bulk forcing of momentum by wind stress, windStressBulkPKG + ! + call mpas_pool_get_package(packagePool, 'windStressBulkPKGActive', windStressBulkPKGActive) + call mpas_pool_get_config(configPool, 'config_use_bulk_wind_stress', config_use_bulk_wind_stress) + if ( config_use_bulk_wind_stress ) then + windStressBulkPKGActive = .true. + end if - call ocn_analysis_setup_packages(configPool, packagePool, err_tmp) - ierr = ior(ierr, err_tmp) - else if (trim(config_ocean_run_mode) == 'analysis' ) then - analysisModeActive = .true. - else if (trim(config_ocean_run_mode) == 'init' ) then - initModeActive = .true. + ! + ! test for use of frazil ice formation, frazilIceActive + ! + ! TDR: need to add PKG + call mpas_pool_get_package(packagePool, 'frazilIceActive', frazilIceActive) + call mpas_pool_get_config(configPool, 'config_frazil_ice_formation', config_frazil_ice_formation) + if (config_frazil_ice_formation) then + frazilIceActive = .true. end if - call ocn_analysis_setup_packages(configPool, packagePool, ierr) - call ocn_init_mode_validate_configuration(configPool, packagePool, ierr) + ! + ! test for form of pressure gradient computation + ! + ! TDR: need to add PKG + call mpas_pool_get_package(packagePool, 'inSituEOSActive', inSituEOSActive) + call mpas_pool_get_config(configPool, 'config_pressure_gradient_type', config_pressure_gradient_type) + if (config_pressure_gradient_type.eq.'Jacobian_from_TS') then + inSituEOSActive = .true. + end if + ! + ! call into analysis member driver to set analysis member packages + ! + call ocn_analysis_setup_packages(configPool, packagePool, err_tmp) + ierr = ior(ierr, err_tmp) + + + ! + ! if in init mode, validate configuration + ! + if ( initModeActive ) then + call ocn_init_mode_validate_configuration(configPool, packagePool, ierr) + endif + + ! + ! iterate over tracer groups + ! each tracer group is toggleed on/off using packages + ! test each package + ! call mpas_pool_begin_iteration(packagePool) do while ( mpas_pool_get_next_member(packagePool, groupItr) ) startIndex = index(groupItr % memberName, 'TracersPKG') @@ -265,6 +308,11 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ end if end do + ! + ! test for conflicts, i.e. package settings that are inconsistent in combination + ! + + end function ocn_setup_packages!}}} From e61c87d0859d14db0367bd1f2f496b47100ada92 Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 18 Aug 2015 16:16:07 -0600 Subject: [PATCH 0176/1724] add a stream that will hold all data used to force the ocean simulations --- src/core_ocean/Registry.xml | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 6b420b9220..1b1babe54c 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1195,6 +1195,18 @@ + + + + + + + Date: Tue, 18 Aug 2015 16:16:49 -0600 Subject: [PATCH 0177/1724] changes required to get streams to behave properly in init mode --- src/core_ocean/mode_init/mpas_ocn_init_mode.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 47613bad30..583d34e9ad 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -118,7 +118,7 @@ function ocn_init_mode_init(domain, startTimeStamp) result(ierr)!{{{ call mpas_timer_start('reset_io_alarms', .false.) call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID='input_init', ierr=err_tmp) - call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) + ! call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) call mpas_timer_stop('reset_io_alarms') ! @@ -252,7 +252,7 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ !call ocn_init_setup_TEMPLATE(domain, ierr) call mpas_timer_start('io_write', .false.) - call mpas_stream_mgr_write(domain % streamManager, streamID='output_init', forceWriteNow=.true., ierr=ierr) + call mpas_stream_mgr_write(domain % streamManager, ierr=ierr) call mpas_timer_stop('io_write') call mpas_timer_start('reset_io_alarms', .false.) call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) From 791af6ceea680c505c1ae9eefbc0d775362eb572 Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 18 Aug 2015 16:17:28 -0600 Subject: [PATCH 0178/1724] uncommenting out fields not that streams are working properly --- .../mode_init/mpas_ocn_init_cvmix_WSwSBF.F | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F index 5ee0d96bce..f2ccde953b 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F @@ -219,8 +219,7 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) call mpas_pool_get_array(forcingPool, 'evaporationFlux', evaporationFlux) - ! TDR - ! call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) + call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) ! Set refBottomDepth and refBottomDepthTopOfCell do k = 1, nVertLevels @@ -267,9 +266,8 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ shortWaveHeatFlux(iCell) = config_cvmix_WSwSBF_shortwave_heat_flux ! Set precipation and evaporation - ! TDR - ! rainFlux(iCell) = config_cvmix_WSwSBF_rain_flux - ! evaporationFlux(iCell) = config_cvmix_WSwSBF_evaporation_flux + rainFlux(iCell) = config_cvmix_WSwSBF_rain_flux + evaporationFlux(iCell) = config_cvmix_WSwSBF_evaporation_flux ! Set interior temperature restoring value and rate do k = 1, nVertLevels @@ -293,11 +291,10 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ maxLevelCell(iCell) = nVertLevels end do - ! TDR - ! do iCell = 1, nCellsSolve - ! windStressZonal(iCell) = config_cvmix_WSwSBF_max_windstress - ! windStressMeridional(iCell) = 0.0_RKIND - ! enddo + do iCell = 1, nCellsSolve + windStressZonal(iCell) = config_cvmix_WSwSBF_max_windstress + windStressMeridional(iCell) = 0.0_RKIND + enddo do iEdge = 1, nEdgesSolve fEdge(iEdge) = config_cvmix_WSwSBF_coriolis_parameter From 96d641a09308acd034518b3b2df49c431b11ba7e Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 19 Aug 2015 12:02:39 -0600 Subject: [PATCH 0179/1724] remove all occurrences of config_forcing_type --- src/core_ocean/mode_forward/mpas_ocn_forward_mode.F | 6 ++++++ src/core_ocean/shared/mpas_ocn_forcing.F | 2 -- src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F | 1 + src/core_ocean/shared/mpas_ocn_tendency.F | 1 + src/core_ocean/shared/mpas_ocn_thick_surface_flux.F | 7 ------- .../shared/mpas_ocn_tracer_surface_flux_to_tend.F | 6 ------ src/core_ocean/shared/mpas_ocn_vel_forcing.F | 1 + src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F | 8 +------- 8 files changed, 10 insertions(+), 22 deletions(-) diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index 2293867f63..a1044ed507 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -49,6 +49,8 @@ module ocn_forward_mode use ocn_vel_hmix use ocn_vel_forcing use ocn_vel_coriolis + use ocn_vel_forcing_windstress + use ocn_surface_bulk_forcing use ocn_tracer_hmix use ocn_tracer_surface_flux_to_tend @@ -175,6 +177,10 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ ierr = ior(ierr, err_tmp) call ocn_vel_forcing_init(err_tmp) ierr = ior(ierr, err_tmp) + call ocn_vel_forcing_windstress_init(err_tmp) + ierr = ior(ierr, err_tmp) + call ocn_surface_bulk_forcing_init(err_tmp) + ierr = ior(ierr, err_tmp) call ocn_tracer_hmix_init(err_tmp) ierr = ior(ierr, err_tmp) diff --git a/src/core_ocean/shared/mpas_ocn_forcing.F b/src/core_ocean/shared/mpas_ocn_forcing.F index aec8584a4e..6724ca2691 100644 --- a/src/core_ocean/shared/mpas_ocn_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_forcing.F @@ -80,11 +80,9 @@ subroutine ocn_forcing_init(err)!{{{ integer, intent(out) :: err !< Output: error flag - character (len=StrKIND), pointer :: config_forcing_type real (kind=RKIND), pointer :: config_flux_attenuation_coefficient call mpas_pool_get_config(ocnConfigs, 'config_flux_attenuation_coefficient', config_flux_attenuation_coefficient) - call mpas_pool_get_config(ocnConfigs, 'config_forcing_type', config_forcing_type) attenuationCoefficient = config_flux_attenuation_coefficient diff --git a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F index 49bad1d47c..199836e874 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F @@ -169,6 +169,7 @@ subroutine ocn_surface_bulk_forcing_vel(meshPool, forcingPool, surfaceWindStress err = 0 + write(6,*) 'bulkWindStressOn',bulkWindStressOn if ( .not. bulkWindStressOn ) return call mpas_pool_get_dimension(meshPool, 'nCells', nCells) diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index eebef64c97..2af031f87a 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -315,6 +315,7 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP ! call mpas_timer_start("forcings", .false., velForceTimer) + write(6,*) 'calling ocn_vel_forcing_tend' call ocn_vel_forcing_tend(meshPool, normalVelocity, surfaceWindStress, layerThicknessEdge, tend_normalVelocity, err) call mpas_timer_stop("forcings", velForceTimer) diff --git a/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F b/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F index 8593715cd2..14b49049d9 100644 --- a/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F +++ b/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F @@ -172,12 +172,10 @@ subroutine ocn_thick_surface_flux_init(err)!{{{ integer, intent(out) :: err !< Output: error flag logical, pointer :: config_disable_thick_sflux - character (len=StrKIND), pointer :: config_forcing_type err = 0 call mpas_pool_get_config(ocnConfigs, 'config_disable_thick_sflux', config_disable_thick_sflux) - call mpas_pool_get_config(ocnConfigs, 'config_forcing_type', config_forcing_type) surfaceThicknessFluxOn = .true. @@ -185,11 +183,6 @@ subroutine ocn_thick_surface_flux_init(err)!{{{ surfaceThicknessFluxOn = .false. end if - if (config_forcing_type == trim('off')) then - surfaceThicknessFluxOn = .false. - end if - - !-------------------------------------------------------------------- end subroutine ocn_thick_surface_flux_init!}}} diff --git a/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F b/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F index 4353e32ef2..6ef82bd3f2 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F @@ -169,12 +169,10 @@ subroutine ocn_tracer_surface_flux_init(err)!{{{ integer, intent(out) :: err !< Output: error flag logical, pointer :: config_disable_tr_sflux - character (len=StrKIND), pointer :: config_forcing_type err = 0 call mpas_pool_get_config(ocnConfigs, 'config_disable_tr_sflux', config_disable_tr_sflux) - call mpas_pool_get_config(ocnConfigs, 'config_forcing_type', config_forcing_type) surfaceTracerFluxOn = .true. @@ -182,10 +180,6 @@ subroutine ocn_tracer_surface_flux_init(err)!{{{ surfaceTracerFluxOn = .false. end if - if (config_forcing_type == trim('off')) then - surfaceTracerFluxOn = .false. - end if - end subroutine ocn_tracer_surface_flux_init!}}} !*********************************************************************** diff --git a/src/core_ocean/shared/mpas_ocn_vel_forcing.F b/src/core_ocean/shared/mpas_ocn_vel_forcing.F index fced50b619..6b17ca5922 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing.F @@ -128,6 +128,7 @@ subroutine ocn_vel_forcing_tend(meshPool, normalVelocity, surfaceWindStress, lay ! !----------------------------------------------------------------- + write(6,*) ' calling ocn_vel_forcing_windstress_tend' call ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThicknessEdge, tend, err1) call ocn_vel_forcing_rayleigh_tend(meshPool, normalVelocity, tend, err2) diff --git a/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F b/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F index 1043e9c9f5..ce5a4f1d69 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F @@ -129,6 +129,7 @@ subroutine ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThi err = 0 + write(6,*) 'windStressOn',windStressOn if ( .not. windStressOn ) return call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) @@ -194,20 +195,13 @@ subroutine ocn_vel_forcing_windstress_init(err)!{{{ integer, intent(out) :: err !< Output: error flag logical, pointer :: config_disable_vel_windstress - character (len=StrKIND), pointer :: config_forcing_type call mpas_pool_get_config(ocnConfigs, 'config_disable_vel_windstress', config_disable_vel_windstress) - call mpas_pool_get_config(ocnConfigs, 'config_forcing_type', config_forcing_type) windStressOn = .true. if(config_disable_vel_windstress) windStressOn = .false. - if (config_forcing_type == trim('off')) then - windStressOn = .false. - end if - - err = 0 !-------------------------------------------------------------------- From aaa40c7c7c0a051ac32e6c21a8d41a1638936b8d Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 19 Aug 2015 14:53:37 -0600 Subject: [PATCH 0180/1724] removed write statement --- src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F | 1 - 1 file changed, 1 deletion(-) diff --git a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F index 199836e874..49bad1d47c 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F @@ -169,7 +169,6 @@ subroutine ocn_surface_bulk_forcing_vel(meshPool, forcingPool, surfaceWindStress err = 0 - write(6,*) 'bulkWindStressOn',bulkWindStressOn if ( .not. bulkWindStressOn ) return call mpas_pool_get_dimension(meshPool, 'nCells', nCells) From 7828a0f4369abc7db29f6635019b55e08c3b7dbd Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 19 Aug 2015 15:00:13 -0600 Subject: [PATCH 0181/1724] debugging --- src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F b/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F index 6ef82bd3f2..e66bf88f0e 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F @@ -120,6 +120,7 @@ subroutine ocn_tracer_surface_flux_tend(meshPool, fractionAbsorbed, layerThickne err = 0 + write(6,*) 'surfaceTracerFluxOn',surfaceTracerFluxOn if (.not. surfaceTracerFluxOn) return call mpas_pool_get_dimension(meshPool, 'nCells', nCells) From efabd60448d1f625653229ec91b8b6b4e625e006 Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Thu, 20 Aug 2015 19:33:31 -0600 Subject: [PATCH 0182/1724] remove use of cellMask (array is still created at init, but not needed in these routines) --- src/core_ocean/shared/mpas_ocn_thick_surface_flux.F | 6 ++---- src/core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F | 8 +++----- .../shared/mpas_ocn_tracer_surface_flux_to_tend.F | 7 ++----- 3 files changed, 7 insertions(+), 14 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F b/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F index 14b49049d9..7a7cf59fb4 100644 --- a/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F +++ b/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F @@ -116,7 +116,6 @@ subroutine ocn_thick_surface_flux_tend(meshPool, transmissionCoefficients, layer integer :: iCell, k integer, pointer :: nCells, nVertLevels integer, dimension(:), pointer :: maxLevelCell - integer, dimension(:,:), pointer :: cellMask real (kind=RKIND) :: remainingFlux @@ -125,7 +124,6 @@ subroutine ocn_thick_surface_flux_tend(meshPool, transmissionCoefficients, layer if (.not. surfaceThicknessFluxOn) return call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(meshPool, 'cellMask', cellMask) call mpas_pool_get_dimension(meshPool, 'nCells', nCells) @@ -134,11 +132,11 @@ subroutine ocn_thick_surface_flux_tend(meshPool, transmissionCoefficients, layer do k = 1, maxLevelCell(iCell) remainingFlux = remainingFlux - transmissionCoefficients(k, iCell) - tend(k, iCell) = tend(k, iCell) + cellMask(k, iCell) * surfaceThicknessFlux(iCell) * transmissionCoefficients(k, iCell) + tend(k, iCell) = tend(k, iCell) + surfaceThicknessFlux(iCell) * transmissionCoefficients(k, iCell) end do if(maxLevelCell(iCell) > 0 .and. remainingFlux > 0.0_RKIND) then - tend(maxLevelCell(iCell), iCell) = tend(maxLevelCell(iCell), iCell) + cellMask(maxLevelCell(iCell), iCell) * remainingFlux * surfaceThicknessFlux(iCell) + tend(maxLevelCell(iCell), iCell) = tend(maxLevelCell(iCell), iCell) + remainingFlux * surfaceThicknessFlux(iCell) end if end do diff --git a/src/core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F b/src/core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F index e44d7512f6..b8245d1275 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F @@ -110,7 +110,6 @@ subroutine ocn_tracer_nonlocalflux_tend(meshPool, vertNonLocalFlux, surfaceTrace integer :: iCell, k, iTracer, nTracers integer, pointer :: nCells, nVertLevels integer, dimension(:), pointer :: maxLevelCell - integer, dimension(:,:), pointer :: cellMask real (kind=RKIND) :: fluxTopOfCell, fluxBottomOfCell err = 0 @@ -122,7 +121,6 @@ subroutine ocn_tracer_nonlocalflux_tend(meshPool, vertNonLocalFlux, surfaceTrace nTracers = size(tend, dim=1) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(meshPool, 'cellMask', cellMask) do iCell = 1, nCells do k = 2, maxLevelCell(iCell)-1 @@ -131,7 +129,7 @@ subroutine ocn_tracer_nonlocalflux_tend(meshPool, vertNonLocalFlux, surfaceTrace do iTracer = 1, nTracers fluxTopOfCell = surfaceTracerFlux(iTracer, iCell) * vertNonLocalFlux(1, k, iCell) fluxBottomOfCell = surfaceTracerFlux(iTracer, iCell) * vertNonLocalFlux(1, k+1, iCell) - tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + cellMask(k, icell) * (fluxTopOfCell-fluxBottomOfCell) + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + (fluxTopOfCell-fluxBottomOfCell) end do end do @@ -140,7 +138,7 @@ subroutine ocn_tracer_nonlocalflux_tend(meshPool, vertNonLocalFlux, surfaceTrace do iTracer = 1, nTracers fluxTopOfCell = surfaceTracerFlux(iTracer, iCell) * vertNonLocalFlux(1, k, iCell) fluxBottomOfCell = 0.0 - tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + cellMask(k, icell) * (fluxTopOfCell-fluxBottomOfCell) + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + (fluxTopOfCell-fluxBottomOfCell) end do ! enforce boundary conditions at top of column @@ -148,7 +146,7 @@ subroutine ocn_tracer_nonlocalflux_tend(meshPool, vertNonLocalFlux, surfaceTrace do iTracer = 1, nTracers fluxTopOfCell = 0.0 fluxBottomOfCell = surfaceTracerFlux(iTracer, iCell) * vertNonLocalFlux(1, k+1, iCell) - tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + cellMask(k, icell) * (fluxTopOfCell-fluxBottomOfCell) + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + (fluxTopOfCell-fluxBottomOfCell) end do end do diff --git a/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F b/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F index e66bf88f0e..3b8a59ae30 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F @@ -114,13 +114,11 @@ subroutine ocn_tracer_surface_flux_tend(meshPool, fractionAbsorbed, layerThickne integer :: iCell, k, iTracer, nTracers integer, pointer :: nCells, nVertLevels integer, dimension(:), pointer :: maxLevelCell - integer, dimension(:,:), pointer :: cellMask real (kind=RKIND) :: remainingFlux err = 0 - write(6,*) 'surfaceTracerFluxOn',surfaceTracerFluxOn if (.not. surfaceTracerFluxOn) return call mpas_pool_get_dimension(meshPool, 'nCells', nCells) @@ -128,7 +126,6 @@ subroutine ocn_tracer_surface_flux_tend(meshPool, fractionAbsorbed, layerThickne nTracers = size(tend, dim=1) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(meshPool, 'cellMask', cellMask) do iCell = 1, nCells remainingFlux = 1.0_RKIND @@ -136,13 +133,13 @@ subroutine ocn_tracer_surface_flux_tend(meshPool, fractionAbsorbed, layerThickne remainingFlux = remainingFlux - fractionAbsorbed(k, iCell) do iTracer = 1, nTracers - tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + cellMask(k, icell) * surfaceTracerFlux(iTracer, iCell) * fractionAbsorbed(k, iCell) + tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + surfaceTracerFlux(iTracer, iCell) * fractionAbsorbed(k, iCell) end do end do if(maxLevelCell(iCell) > 0 .and. remainingFlux > 0.0_RKIND) then do iTracer = 1, nTracers - tend(iTracer, maxLevelCell(iCell), iCell) = tend(iTracer, maxLevelCell(iCell), iCell) + cellMask(k, iCell) * surfaceTracerFlux(iTracer, iCell) * remainingFlux + tend(iTracer, maxLevelCell(iCell), iCell) = tend(iTracer, maxLevelCell(iCell), iCell) + surfaceTracerFlux(iTracer, iCell) * remainingFlux end do end if end do From e0fb3cfcfe08b74991fc60ed6ebb0149ab59eeaa Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Fri, 21 Aug 2015 17:35:05 -0600 Subject: [PATCH 0183/1724] clean up of debugging statements added write to stdout for those parts not fully tested --- src/core_ocean/shared/mpas_ocn_tendency.F | 15 ++++----------- 1 file changed, 4 insertions(+), 11 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index 2af031f87a..e7aedc5d9e 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -315,7 +315,6 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP ! call mpas_timer_start("forcings", .false., velForceTimer) - write(6,*) 'calling ocn_vel_forcing_tend' call ocn_vel_forcing_tend(meshPool, normalVelocity, surfaceWindStress, layerThicknessEdge, tend_normalVelocity, err) call mpas_timer_stop("forcings", velForceTimer) @@ -466,11 +465,9 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) call mpas_pool_get_field(scratchPool, 'normalThicknessFlux', normalThicknessFluxField) - call mpas_allocate_scratch_field(normalThicknessFluxField, .true.) normalThicknessFlux => normalThicknessFluxField % array - if(config_disable_tr_all_tend) return ! @@ -532,7 +529,6 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! if (config_use_tracerGroup_surface_bulk_forcing) then call mpas_timer_start("bulk_" // trim(groupItr % memberName), .false.) - write(6,*) 'yes: ', "bulk_" // trim(groupItr % memberName) call ocn_surface_bulk_forcing_tracers(meshPool, groupItr % memberName, forcingPool, tracerGroupSurfaceFlux, err) call mpas_timer_stop("bulk_" // trim(groupItr % memberName)) end if @@ -547,16 +543,13 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, trim(modifiedGroupName), tracerGroupPistonVelocity) modifiedGroupName = trim(groupItr % memberName) // "SurfaceRestoringValue" call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, trim(modifiedGroupName), tracerGroupSurfaceRestoringValue) - write(6,*) 'yes: ', "surface_restoring_" // trim(groupItr % memberName) - write(6,*) trim(groupItr % memberName) // "SurfaceRestoringValue" - write(6,*) maxval(tracerGroupSurfaceRestoringValue), size(tracerGroupSurfaceRestoringValue) call ocn_tracer_surface_restoring_compute(nTracerGroup, nCellsSolve, tracerGroup, tracerGroupPistonVelocity, tracerGroupSurfaceRestoringValue, tracerGroupSurfaceFlux, err) call mpas_timer_stop("surface_restoring_" // trim(groupItr % memberName)) endif ! land-ice / ocean interface flux ! this is a flux at the top ocean surface -- so these fluxes should be added into tracerGroupSurfaceFlux - ! if (put correct logic here, only 'active' only when coupling is turned on) + ! if (put correct logic here, only 'active' when coupling is turned on) ! call ocn_tracer_landIce_ocean_coupling(tracerGroup, tracerGroupSurfaceFlux) ! endif @@ -578,9 +571,6 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, trim(modifiedGroupName), tracerGroupInteriorRestoringRate) modifiedGroupName = trim(groupItr % memberName) // "InteriorRestoringValue" call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, trim(modifiedGroupName),tracerGroupInteriorRestoringValue) - write(6,*) 'yes: ', "interior_restoring_" // trim(groupItr % memberName) - write(6,*) trim(groupItr % memberName) // "InteriorRestoringValue" - write(6,*) maxval(tracerGroupInteriorRestoringValue), size(tracerGroupInteriorRestoringValue) call ocn_tracer_interior_restoring_compute(nTracerGroup, nCellsSolve, maxLevelCell, layerThickness, & tracerGroup, tracerGroupInteriorRestoringRate, tracerGroupInteriorRestoringValue, tracerGroupTend, err) call mpas_timer_stop("interior_restoring_" // trim(groupItr % memberName)) @@ -590,6 +580,7 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! exponential decay tendency ! if (config_use_tracerGroup_exponential_decay) then + write (stderrUnit,'(a)') 'exponential decay not fully tested' call mpas_pool_get_subpool(forcingPool, 'tracersExponentialDecayFields', tracersExponentialDecayFieldsPool) modifiedGroupName = trim(groupItr % memberName) // "ExponentialDecayRate" call mpas_pool_get_array(tracersExponentialDecayFieldsPool, trim(modifiedGroupName), tracerGroupExponentialDecayRate) @@ -602,6 +593,7 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! note: ocn_tracer_ideal_age_compute resets tracers in top layer to zero ! if (config_use_tracerGroup_idealAge_forcing) then + write (stderrUnit,'(a)') 'ideal age not fully tested' call mpas_pool_get_subpool(forcingPool, 'tracersIdealAgeFields', tracersIdealAgeFieldsPool) modifiedGroupName = trim(groupItr % memberName) // "IdealAgeMask" call mpas_pool_get_array(tracersIdealAgeFieldsPool, trim(modifiedGroupName), tracerGroupIdealAgeMask) @@ -615,6 +607,7 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! note: rather, tracerGroup is reset to tracerGroupTTDMask in top-most layer ! if (config_use_tracerGroup_ttd_forcing) then + write (stderrUnit,'(a)') 'ideal age not fully tested' call mpas_pool_get_subpool(forcingPool, 'tracersTTDFields', tracersTTDFieldsPool) modifiedGroupName = trim(groupItr % memberName) // "TTDMask" call mpas_pool_get_array(tracersTTDFieldsPool, trim(modifiedGroupName), tracerGroupTTDMask) From a8ee9c70d6f63360cec2a753da92055c1207a17f Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Fri, 21 Aug 2015 17:40:59 -0600 Subject: [PATCH 0184/1724] removing this test case --- .../Registry_cvmix_convection_unit_test.xml | 27 ------------------- 1 file changed, 27 deletions(-) delete mode 100644 src/core_ocean/mode_init/Registry_cvmix_convection_unit_test.xml diff --git a/src/core_ocean/mode_init/Registry_cvmix_convection_unit_test.xml b/src/core_ocean/mode_init/Registry_cvmix_convection_unit_test.xml deleted file mode 100644 index d3a3468ccb..0000000000 --- a/src/core_ocean/mode_init/Registry_cvmix_convection_unit_test.xml +++ /dev/null @@ -1,27 +0,0 @@ - - - - - - - - - From a7ff2f9d4de559db8dd9976d923498309ab79670 Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Fri, 21 Aug 2015 17:41:49 -0600 Subject: [PATCH 0185/1724] removing test case --- .../Registry_cvmix_shear_unit_test.xml | 27 ------------------- 1 file changed, 27 deletions(-) delete mode 100644 src/core_ocean/mode_init/Registry_cvmix_shear_unit_test.xml diff --git a/src/core_ocean/mode_init/Registry_cvmix_shear_unit_test.xml b/src/core_ocean/mode_init/Registry_cvmix_shear_unit_test.xml deleted file mode 100644 index 748a13b7d3..0000000000 --- a/src/core_ocean/mode_init/Registry_cvmix_shear_unit_test.xml +++ /dev/null @@ -1,27 +0,0 @@ - - - - - - - - - From 55f6ad411b913fcbbdcd1a95e826e0df8b8d1de6 Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Fri, 21 Aug 2015 17:58:02 -0600 Subject: [PATCH 0186/1724] removed deleted test cases from Registry.xml update internal wave, lock exchange and overflow to new tracer code --- src/core_ocean/mode_init/Registry.xml | 2 -- .../mode_init/mpas_ocn_init_internal_waves.F | 31 ++++++++++++------- .../mode_init/mpas_ocn_init_lock_exchange.F | 25 +++++++++------ .../mode_init/mpas_ocn_init_overflow.F | 26 +++++++++++----- 4 files changed, 53 insertions(+), 31 deletions(-) diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml index 34421ca0c7..df78ae51f5 100644 --- a/src/core_ocean/mode_init/Registry.xml +++ b/src/core_ocean/mode_init/Registry.xml @@ -2,8 +2,6 @@ #include "Registry_lock_exchange.xml" #include "Registry_internal_waves.xml" #include "Registry_overflow.xml" -#include "Registry_cvmix_convection_unit_test.xml" -#include "Registry_cvmix_shear_unit_test.xml" #include "Registry_global_realistic.xml" #include "Registry_cvmix_WSwSBF.xml" // #include "Registry_TEMPLATE.xml" diff --git a/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F b/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F index 98a7919230..5911ec3320 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F @@ -77,11 +77,11 @@ subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ integer, intent(out) :: iErr ! Define pool pointers - type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool + type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool, tracersPool ! Define dimension pointers integer, pointer :: nVertLevels, nVertLevelsP1, nCells, nEdges, nVertices - integer, pointer :: nCellsSolve, nEdgesSolve, index_temperature, index_salinity + integer, pointer :: nCellsSolve, nEdgesSolve, index_temperature, index_salinity, index_tracer1 ! Define array pointers integer, dimension(:), pointer :: maxLevelCell @@ -89,8 +89,7 @@ subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ real (kind=RKIND), dimension(:), pointer :: xCell, yCell, bottomDepth, dcEdge real (kind=RKIND), dimension(:), pointer :: refBottomDepth, refZMid, vertCoordMovementWeights real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness - real (kind=RKIND), dimension(:,:,:), pointer :: tracers - + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers, debugTracers real (kind=RKIND) :: yMin, yMax, xMin, xMax, dcEdgeMin real (kind=RKIND) :: yMinGlobal, yMaxGlobal, yMidGlobal, xMinGlobal, xMaxGlobal, dcEdgeMinGlobal @@ -106,7 +105,7 @@ subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ type (block_type), pointer :: block_ptr - integer :: iCell, k, idx + integer :: iCell, k real (kind=RKIND) :: deltaTemperature real (kind=RKIND), dimension(:), pointer :: zTop, refTemperature, refTemperatureTop, refZTop @@ -184,6 +183,7 @@ subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) @@ -197,10 +197,12 @@ subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) - call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_salinity) + call mpas_pool_get_dimension(tracersPool, 'index_tracer1', index_tracer1) - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + call mpas_pool_get_array(tracersPool, 'debugTracers', debugTracers, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) call ocn_mark_north_boundary(meshPool, yMaxGlobal, dcEdgeMinGlobal, iErr) @@ -236,6 +238,11 @@ subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ do iCell = 1, nCellsSolve + ! Set debug tracer + do k = 1, nVertLevels + debugTracers(index_tracer1, k, iCell) = 1.0_RKIND + enddo + if ( trim(config_internal_waves_layer_type) == 'z-level' ) then ! Set stratified temperature @@ -243,7 +250,7 @@ subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ temperature = config_internal_waves_bottom_temperature & + (config_internal_waves_surface_temperature - config_internal_waves_bottom_temperature) & * ( (refZMid(k) - refZMid(nVertLevels)) / (-refZMid(nVertLevels) )) - tracers(index_temperature, k, iCell) = temperature + activeTracers(index_temperature, k, iCell) = temperature end do if ( abs(yCell(iCell) - yMidGlobal) < perturbationWidth ) then @@ -252,7 +259,7 @@ subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ temperature = -config_internal_waves_temperature_difference * cos(0.5_RKIND * pii * (yCell(iCell) - yMidGlobal) / perturbationWidth) & * sin ( pii * refBottomDepth(k-1) / refBottomDepth(nVertLevels-1) ) - tracers(index_temperature, k, iCell) = tracers(index_temperature, k, iCell) + temperature + activeTracers(index_temperature, k, iCell) = activeTracers(index_temperature, k, iCell) + temperature end do end if @@ -263,7 +270,7 @@ subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ else if ( trim(config_internal_waves_layer_type) == 'isopycnal' ) then ! Set stratified temperature - tracers(index_temperature, :, iCell) = refTemperature(:) + activeTracers(index_temperature, :, iCell) = refTemperature(:) ! Set layerThickness if ( abs(yCell(iCell) - yMidGlobal) < perturbationWidth) then @@ -289,7 +296,7 @@ subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ endif ! Set salinity - tracers(index_salinity, :, iCell) = config_internal_waves_salinity + activeTracers(index_salinity, :, iCell) = config_internal_waves_salinity ! Set bottomDepth bottomDepth(iCell) = config_internal_waves_bottom_depth diff --git a/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F b/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F index e5eb5e7f9c..940aa50c9e 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F @@ -86,11 +86,11 @@ subroutine ocn_init_setup_lock_exchange(domain, iErr)!{{{ type (block_type), pointer :: block_ptr - type (mpas_pool_type), pointer :: meshPool, statePool, verticalMeshPool + type (mpas_pool_type), pointer :: meshPool, statePool, verticalMeshPool, tracersPool character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid, config_lock_exchange_layer_type - integer, pointer :: nCellsSolve, nEdgesSolve, nVertLevels, nVertLevelsP1, index_temperature, index_salinity + integer, pointer :: nCellsSolve, nEdgesSolve, nVertLevels, nVertLevelsP1, index_temperature, index_salinity, index_tracer1 integer, dimension(:), pointer :: maxLevelCell @@ -99,7 +99,7 @@ subroutine ocn_init_setup_lock_exchange(domain, iErr)!{{{ real (kind=RKIND), dimension(:), pointer :: xCell, yCell, bottomDepth, refBottomDepthTopOfCell, refBottomDepth, vertCoordMovementWeights, dcEdge real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers, debugTracers real (kind=RKIND), dimension(:), pointer :: interfaceLocations @@ -173,12 +173,14 @@ subroutine ocn_init_setup_lock_exchange(domain, iErr)!{{{ call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + call mpas_pool_get_dimension(tracersPool, 'index_tracer1', index_tracer1) call mpas_pool_get_array(meshPool, 'yCell', yCell) call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) @@ -187,7 +189,8 @@ subroutine ocn_init_setup_lock_exchange(domain, iErr)!{{{ call mpas_pool_get_array(meshPool, 'refBottomDepthTopOfCell', refBottomDepthTopOfCell) call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + call mpas_pool_get_array(tracersPool, 'debugTracers', debugTracers, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) @@ -201,9 +204,9 @@ subroutine ocn_init_setup_lock_exchange(domain, iErr)!{{{ ! Set temperature, layerThickness, and restingThickness if ( trim(config_lock_exchange_layer_type) == 'z-level' ) then if(yCell(iCell) < (yMaxGlobal - yMinGlobal) * 0.5_RKIND) then - tracers(index_temperature, :, iCell) = config_lock_exchange_south_temp + activeTracers(index_temperature, :, iCell) = config_lock_exchange_south_temp else - tracers(index_temperature, :, iCell) = config_lock_exchange_north_temp + activeTracers(index_temperature, :, iCell) = config_lock_exchange_north_temp end if ! Set layerThickness and restingThickness @@ -212,8 +215,8 @@ subroutine ocn_init_setup_lock_exchange(domain, iErr)!{{{ restingThickness(k, iCell) = layerThickness(k, iCell) end do else if ( trim(config_lock_exchange_layer_type) == 'isopycnal' ) then - tracers(index_temperature, 1, iCell) = config_lock_exchange_north_temp - tracers(index_temperature, 2:nVertLevels, iCell) = config_lock_exchange_south_temp + activeTracers(index_temperature, 1, iCell) = config_lock_exchange_north_temp + activeTracers(index_temperature, 2:nVertLevels, iCell) = config_lock_exchange_south_temp if(yCell(iCell) < (yMaxGlobal - yMinGlobal) * 0.5_RKIND) then layerThickness(1, iCell) = config_lock_exchange_isopycnal_min_thickness @@ -227,8 +230,12 @@ subroutine ocn_init_setup_lock_exchange(domain, iErr)!{{{ end if ! Set salinity - tracers(index_salinity, :, iCell) = config_lock_exchange_salinity + activeTracers(index_salinity, :, iCell) = config_lock_exchange_salinity + ! Set debugging tracer + do k = 1, nVertLevels + debugTracers(index_tracer1, k, iCell) = 1.0_RKIND + enddo ! Set bottomDepth bottomDepth(iCell) = config_lock_exchange_bottom_depth diff --git a/src/core_ocean/mode_init/mpas_ocn_init_overflow.F b/src/core_ocean/mode_init/mpas_ocn_init_overflow.F index f86bbfa322..0e224a1de1 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_overflow.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_overflow.F @@ -86,18 +86,19 @@ subroutine ocn_init_setup_overflow(domain, iErr)!{{{ type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: statePool type (mpas_pool_type), pointer :: verticalMeshPool + type (mpas_pool_type), pointer :: tracersPool integer :: iCell, k ! Define dimensions integer, pointer :: nCellsSolve, nEdgesSolve, nVertLevels, nVertLevelsP1 - integer, pointer :: index_temperature, index_salinity + integer, pointer :: index_temperature, index_salinity, index_tracer1 ! Define arrays integer, dimension(:), pointer :: maxLevelCell real (kind=RKIND), dimension(:), pointer :: yCell, refBottomDepth, bottomDepth, vertCoordMovementWeights, dcEdge real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers, debugTracers ! Define configs character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid, config_overflow_layer_type @@ -186,19 +187,22 @@ subroutine ocn_init_setup_overflow(domain, iErr)!{{{ call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + call mpas_pool_get_dimension(tracersPool, 'index_tracer1', index_tracer1) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + call mpas_pool_get_array(tracersPool, 'debugTracers', debugTracers, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) @@ -239,14 +243,14 @@ subroutine ocn_init_setup_overflow(domain, iErr)!{{{ if ( trim(config_overflow_layer_type) == 'sigma' .or. trim(config_overflow_layer_type) == 'z-level' ) then do k = 1, maxLevelCell(iCell) if(yCell(iCell) < yMinGlobal + plugWidth) then - tracers(index_temperature, k, iCell) = config_overflow_plug_temperature + activeTracers(index_temperature, k, iCell) = config_overflow_plug_temperature else - tracers(index_temperature, k, iCell) = config_overflow_domain_temperature + activeTracers(index_temperature, k, iCell) = config_overflow_domain_temperature end if end do else if ( trim(config_overflow_layer_type) == 'isopycnal' ) then - tracers(index_temperature, 1, :) = config_overflow_domain_temperature - tracers(index_temperature, 2:nVertLevels, :) = config_overflow_plug_temperature + activeTracers(index_temperature, 1, :) = config_overflow_domain_temperature + activeTracers(index_temperature, 2:nVertLevels, :) = config_overflow_plug_temperature end if ! Set layerThickness and restingThickness @@ -274,7 +278,13 @@ subroutine ocn_init_setup_overflow(domain, iErr)!{{{ end if ! Set salinity - tracers(index_salinity, :, iCell) = config_overflow_salinity + activeTracers(index_salinity, :, iCell) = config_overflow_salinity + + ! Set debug tracer + do k = 1, nVertLevels + debugTracers(index_tracer1, k, iCell) = 1.0_RKIND + enddo + end do ! Set vertCoordMovementWeights From 16eb39bebe64212643085bc53cd73a2ec48ad66e Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Sat, 22 Aug 2015 14:38:43 -0600 Subject: [PATCH 0187/1724] adding Idealized Southern Ocean (ISO) configuration --- src/core_ocean/mode_init/Makefile | 3 + src/core_ocean/mode_init/Registry_iso.xml | 354 ++++++ .../mode_init/mpas_ocn_init_cvmix_WSwSBF.F | 2 - src/core_ocean/mode_init/mpas_ocn_init_iso.F | 1000 +++++++++++++++++ 4 files changed, 1357 insertions(+), 2 deletions(-) create mode 100644 src/core_ocean/mode_init/Registry_iso.xml create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_iso.F diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile index 2e118be565..53bc8508f9 100644 --- a/src/core_ocean/mode_init/Makefile +++ b/src/core_ocean/mode_init/Makefile @@ -11,6 +11,7 @@ TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ mpas_ocn_init_internal_waves.o \ mpas_ocn_init_overflow.o \ mpas_ocn_init_cvmix_WSwSBF.o \ + mpas_ocn_init_iso.o \ mpas_ocn_init_global_realistic.o #mpas_ocn_init_TEMPLATE.o @@ -28,6 +29,8 @@ mpas_ocn_init_vertical_grids.o: mpas_ocn_init_baroclinic_channel.o: $(UTILS) +mpas_ocn_init_iso.o: $(UTILS) + mpas_ocn_init_lock_exchange.o: $(UTILS) mpas_ocn_init_internal_waves.o: $(UTILS) diff --git a/src/core_ocean/mode_init/Registry_iso.xml b/src/core_ocean/mode_init/Registry_iso.xml new file mode 100644 index 0000000000..520e510d27 --- /dev/null +++ b/src/core_ocean/mode_init/Registry_iso.xml @@ -0,0 +1,354 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F index f2ccde953b..5cd9c516a2 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F @@ -86,7 +86,6 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ type (mpas_pool_type), pointer :: diagnosticsPool, forcingPool type (mpas_pool_type), pointer :: tracersPool, & - tracersSurfaceFluxPool, & tracersSurfaceRestoringFieldsPool, & tracersInteriorRestoringFieldsPool @@ -179,7 +178,6 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) - call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceFlux', tracersSurfaceFluxPool) call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_iso.F b/src/core_ocean/mode_init/mpas_ocn_init_iso.F new file mode 100644 index 0000000000..0f7a33f026 --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_iso.F @@ -0,0 +1,1000 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_iso +! +!> \brief MPAS ocean initialize case -- Idealized Southern Ocean (ISO) +!> \author Juan A. Saenz, based on idealized_acc and others +!> \date 12/08/2014 +!> \details +!> This module contains the routines for initializing the +!> the idealized Southern Ocean (ISO) test case +! +!----------------------------------------------------------------------- + +module ocn_init_iso + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + + use ocn_constants + use ocn_init_vertical_grids + use ocn_init_cell_markers + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_iso, & + ocn_init_validate_iso + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_iso +! +!> \brief Setup for ISO test case +!> \author Juan A. Saenz +!> \date 02/26/2014 +!> \details +!> This routine sets up the initial conditions for the +!> Idealized Southern Ocean configuration. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_iso(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + ! local work variables + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool, forcingPool, tracersPool + type (mpas_pool_type), pointer :: tracersSurfaceRestoringFieldsPool, tracersInteriorRestoringFieldsPool + + integer :: iCell, k, idx + + real (kind=RKIND) :: distance, xDistance, yDistance, zMid, sphereRadius + real (kind=RKIND) :: currentLon, currentLat + real (kind=RKIND) :: location, amplitude + real (kind=RKIND) :: Tbottom, Tmin, TminGlobal + real (kind=RKIND) :: depth, contSlopeWidthRad, widthWindASFRad, windStress + real (kind=RKIND) :: widthQSouth, widthQMiddle, widthQNorth, heatFluxZonal, heatFlux1, heatFlux2 + real (kind=RKIND) :: temperature + real (kind=RKIND), dimension(100) :: dzarray + real (kind=RKIND), dimension(30) :: featureDepth + + + ! Define config variable pointers + character (len=StrKIND), pointer :: config_init_configuration + + integer, pointer :: config_iso_vert_levels + real (kind=RKIND), pointer :: config_iso_main_channel_depth + real (kind=RKIND), pointer :: config_iso_north_wall_lat + real (kind=RKIND), pointer :: config_iso_south_wall_lat + logical, pointer :: config_iso_ridge_flag + real (kind=RKIND), pointer :: config_iso_ridge_center_lon + real (kind=RKIND), pointer :: config_iso_ridge_height + real (kind=RKIND), pointer :: config_iso_ridge_width + logical, pointer :: config_iso_plateau_flag + real (kind=RKIND), pointer :: config_iso_plateau_center_lon + real (kind=RKIND), pointer :: config_iso_plateau_center_lat + real (kind=RKIND), pointer :: config_iso_plateau_height + real (kind=RKIND), pointer :: config_iso_plateau_radius + real (kind=RKIND), pointer :: config_iso_plateau_slope_width + logical, pointer :: config_iso_shelf_flag + real (kind=RKIND), pointer :: config_iso_shelf_depth + real (kind=RKIND), pointer :: config_iso_shelf_width + logical, pointer :: config_iso_cont_slope_flag + real (kind=RKIND), pointer :: config_iso_max_cont_slope + logical, pointer :: config_iso_embayment_flag + real (kind=RKIND), pointer :: config_iso_embayment_radius + real (kind=RKIND), pointer :: config_iso_embayment_depth + real (kind=RKIND), pointer :: config_iso_embayment_center_lon + real (kind=RKIND), pointer :: config_iso_embayment_center_lat + logical, pointer :: config_iso_depression_flag + real (kind=RKIND), pointer :: config_iso_depression_width + real (kind=RKIND), pointer :: config_iso_depression_depth + real (kind=RKIND), pointer :: config_iso_depression_center_lon + real (kind=RKIND), pointer :: config_iso_depression_south_lat + real (kind=RKIND), pointer :: config_iso_depression_north_lat + real (kind=RKIND), pointer :: config_iso_salinity + real (kind=RKIND), pointer :: config_iso_wind_stress_max + real (kind=RKIND), pointer :: config_iso_asf_wind + real (kind=RKIND), pointer :: config_iso_acc_wind + real (kind=RKIND), pointer :: config_iso_wind_trans + real (kind=RKIND), pointer :: config_iso_heat_flux_south + real (kind=RKIND), pointer :: config_iso_heat_flux_middle + real (kind=RKIND), pointer :: config_iso_heat_flux_north + real (kind=RKIND), pointer :: config_iso_heat_flux_lat_ss + real (kind=RKIND), pointer :: config_iso_heat_flux_lat_sm + real (kind=RKIND), pointer :: config_iso_heat_flux_lat_mn + real (kind=RKIND), pointer :: config_iso_initial_temp_t1 + real (kind=RKIND), pointer :: config_iso_initial_temp_t2 + real (kind=RKIND), pointer :: config_iso_initial_temp_h0 + real (kind=RKIND), pointer :: config_iso_initial_temp_h1 + real (kind=RKIND), pointer :: config_iso_initial_temp_mt + real (kind=RKIND), pointer :: config_iso_initial_temp_latS + real (kind=RKIND), pointer :: config_iso_initial_temp_latN + real (kind=RKIND), pointer :: config_iso_region1_center_lon + real (kind=RKIND), pointer :: config_iso_region1_center_lat + real (kind=RKIND), pointer :: config_iso_region2_center_lon + real (kind=RKIND), pointer :: config_iso_region2_center_lat + real (kind=RKIND), pointer :: config_iso_region3_center_lon + real (kind=RKIND), pointer :: config_iso_region3_center_lat + real (kind=RKIND), pointer :: config_iso_region4_center_lon + real (kind=RKIND), pointer :: config_iso_region4_center_lat + logical, pointer :: config_iso_heat_flux_region1_flag + real (kind=RKIND), pointer :: config_iso_heat_flux_region1 + real (kind=RKIND), pointer :: config_iso_heat_flux_region1_radius + logical, pointer :: config_iso_heat_flux_region2_flag + real (kind=RKIND), pointer :: config_iso_heat_flux_region2 + real (kind=RKIND), pointer :: config_iso_heat_flux_region2_radius + real (kind=RKIND), pointer :: config_iso_temperature_sponge_t1 + real (kind=RKIND), pointer :: config_iso_temperature_sponge_h1 + real (kind=RKIND), pointer :: config_iso_temperature_sponge_l1 + + logical, pointer :: config_iso_temperature_restore_region1_flag + real (kind=RKIND), pointer :: config_iso_temperature_restore_t1 + real (kind=RKIND), pointer :: config_iso_temperature_restore_lcx1 + real (kind=RKIND), pointer :: config_iso_temperature_restore_lcy1 + logical, pointer :: config_iso_temperature_restore_region2_flag + real (kind=RKIND), pointer :: config_iso_temperature_restore_t2 + real (kind=RKIND), pointer :: config_iso_temperature_restore_lcx2 + real (kind=RKIND), pointer :: config_iso_temperature_restore_lcy2 + logical, pointer :: config_iso_temperature_restore_region3_flag + real (kind=RKIND), pointer :: config_iso_temperature_restore_t3 + real (kind=RKIND), pointer :: config_iso_temperature_restore_lcx3 + real (kind=RKIND), pointer :: config_iso_temperature_restore_lcy3 + logical, pointer :: config_iso_temperature_restore_region4_flag + real (kind=RKIND), pointer :: config_iso_temperature_restore_t4 + real (kind=RKIND), pointer :: config_iso_temperature_restore_lcx4 + real (kind=RKIND), pointer :: config_iso_temperature_restore_lcy4 + + ! Define dimension pointers + integer, pointer :: nVertLevels, nCellsSolve + integer, pointer :: index_temperature, index_salinity, index_tracer1 + + ! Define variable pointers + logical, pointer :: on_a_sphere + integer, dimension(:), pointer :: maxLevelCell + real (kind=RKIND), dimension(:), pointer :: refBottomDepth, refZMid + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness + real (kind=RKIND), pointer :: sphere_radius + real (kind=RKIND), dimension(:), pointer :: lonCell, latCell, bottomDepth + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers, debugTracers + real (kind=RKIND), dimension(:), pointer :: sensibleHeatFlux + real (kind=RKIND), dimension(:), pointer :: windStressZonal, windStressMeridional + real (kind=RKIND), dimension(:, :), pointer :: activeTracersPistonVelocity, activeTracersSurfaceRestoringValue + real (kind=RKIND), dimension(:, :, :), pointer :: activeTracersInteriorRestoringValue, activeTracersInteriorRestoringRate + + ! Define variables for the config_iso_ variables + real (kind=RKIND) :: mainChannelDepth, northWallLat, southWallLat + logical :: ridgeFlag + real (kind=RKIND) :: ridgeCenterLon, ridgeHeight, ridgeWidth + logical :: plateauFlag + real (kind=RKIND) :: plateauCenterLon, plateauCenterLat + real (kind=RKIND) :: plateauHeight, plateauRadius, plateauSlopeWidth + logical :: shelfFlag + real (kind=RKIND) :: shelfDepth, shelfWidth + logical :: contSlopeFlag + real (kind=RKIND) :: maxContSlope + logical :: embaymentFlag + real (kind=RKIND) :: embaymentRadius, embaymentDepth, embaymentCenterLon, embaymentCenterLat + logical :: depressionFlag + real (kind=RKIND) :: depressionWidth, depressionDepth + real (kind=RKIND) :: depressionCenterLon, depressionSouthLat, depressionNorthLat + real (kind=RKIND) :: salinity0 + real (kind=RKIND) :: windStressMax, windASF, windACC, latWindTrans + real (kind=RKIND) :: QSouth, QNorth, QMiddle, transSS, transSM, transMN + real (kind=RKIND) :: tempT1, tempT2, temph1, tempmT, temph0, tempLatS, tempLatN + real (kind=RKIND) :: regionCenterLat1, regionCenterLon1, regionCenterLat2, regionCenterLon2 + real (kind=RKIND) :: regionCenterLat3, regionCenterLon3, regionCenterLat4, regionCenterLon4 + logical :: heatRegionFlag1 + real (kind=RKIND) :: heatRegion1flux, heatRegion1Radius + logical :: heatRegionFlag2 + real (kind=RKIND) :: heatRegion2flux, heatRegion2Radius + real (kind=RKIND) :: tempSpongeT1, tempSpongeh1, tempSpongeWeightL1 + logical :: tempRestoreFlag1 + real (kind=RKIND) :: tempRestoreT1, tempRestoreLcx1, tempRestoreLcy1 + logical :: tempRestoreFlag2 + real (kind=RKIND) :: tempRestoreT2, tempRestoreLcx2, tempRestoreLcy2 + logical :: tempRestoreFlag3 + real (kind=RKIND) :: tempRestoreT3, tempRestoreLcx3, tempRestoreLcy3 + logical :: tempRestoreFlag4 + real (kind=RKIND) :: tempRestoreT4, tempRestoreLcx4, tempRestoreLcy4 + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) + if(config_init_configuration .ne. trim('iso')) return + + ! get config variables + call mpas_pool_get_config(domain % configs, 'config_iso_vert_levels', config_iso_vert_levels) + call mpas_pool_get_config(domain % configs, 'config_iso_main_channel_depth', config_iso_main_channel_depth) + call mpas_pool_get_config(domain % configs, 'config_iso_north_wall_lat', config_iso_north_wall_lat) + call mpas_pool_get_config(domain % configs, 'config_iso_south_wall_lat', config_iso_south_wall_lat) + call mpas_pool_get_config(domain % configs, 'config_iso_ridge_flag', config_iso_ridge_flag) + call mpas_pool_get_config(domain % configs, 'config_iso_ridge_center_lon', config_iso_ridge_center_lon) + call mpas_pool_get_config(domain % configs, 'config_iso_ridge_height', config_iso_ridge_height) + call mpas_pool_get_config(domain % configs, 'config_iso_ridge_width', config_iso_ridge_width) + call mpas_pool_get_config(domain % configs, 'config_iso_plateau_flag', config_iso_plateau_flag) + call mpas_pool_get_config(domain % configs, 'config_iso_plateau_center_lon', config_iso_plateau_center_lon) + call mpas_pool_get_config(domain % configs, 'config_iso_plateau_center_lat', config_iso_plateau_center_lat) + call mpas_pool_get_config(domain % configs, 'config_iso_plateau_height', config_iso_plateau_height) + call mpas_pool_get_config(domain % configs, 'config_iso_plateau_radius', config_iso_plateau_radius) + call mpas_pool_get_config(domain % configs, 'config_iso_plateau_slope_width', config_iso_plateau_slope_width) + call mpas_pool_get_config(domain % configs, 'config_iso_shelf_flag', config_iso_shelf_flag) + call mpas_pool_get_config(domain % configs, 'config_iso_shelf_depth', config_iso_shelf_depth) + call mpas_pool_get_config(domain % configs, 'config_iso_shelf_width', config_iso_shelf_width) + call mpas_pool_get_config(domain % configs, 'config_iso_cont_slope_flag', config_iso_cont_slope_flag) + call mpas_pool_get_config(domain % configs, 'config_iso_max_cont_slope', config_iso_max_cont_slope) + call mpas_pool_get_config(domain % configs, 'config_iso_embayment_flag', config_iso_embayment_flag) + call mpas_pool_get_config(domain % configs, 'config_iso_embayment_radius', config_iso_embayment_radius) + call mpas_pool_get_config(domain % configs, 'config_iso_embayment_depth', config_iso_embayment_depth) + call mpas_pool_get_config(domain % configs, 'config_iso_embayment_center_lon', config_iso_embayment_center_lon) + call mpas_pool_get_config(domain % configs, 'config_iso_embayment_center_lat', config_iso_embayment_center_lat) + call mpas_pool_get_config(domain % configs, 'config_iso_depression_flag', config_iso_depression_flag) + call mpas_pool_get_config(domain % configs, 'config_iso_depression_width', config_iso_depression_width) + call mpas_pool_get_config(domain % configs, 'config_iso_depression_depth', config_iso_depression_depth) + call mpas_pool_get_config(domain % configs, 'config_iso_depression_center_lon', config_iso_depression_center_lon) + call mpas_pool_get_config(domain % configs, 'config_iso_depression_south_lat', config_iso_depression_south_lat) + call mpas_pool_get_config(domain % configs, 'config_iso_depression_north_lat', config_iso_depression_north_lat) + call mpas_pool_get_config(domain % configs, 'config_iso_salinity', config_iso_salinity) + call mpas_pool_get_config(domain % configs, 'config_iso_wind_stress_max', config_iso_wind_stress_max) + call mpas_pool_get_config(domain % configs, 'config_iso_asf_wind', config_iso_asf_wind) + call mpas_pool_get_config(domain % configs, 'config_iso_acc_wind', config_iso_acc_wind) + call mpas_pool_get_config(domain % configs, 'config_iso_wind_trans', config_iso_wind_trans) + call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_south', config_iso_heat_flux_south) + call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_middle', config_iso_heat_flux_middle) + call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_north', config_iso_heat_flux_north) + call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_lat_ss', config_iso_heat_flux_lat_ss) + call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_lat_sm', config_iso_heat_flux_lat_sm) + call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_lat_mn', config_iso_heat_flux_lat_mn) + call mpas_pool_get_config(domain % configs, 'config_iso_initial_temp_t1', config_iso_initial_temp_t1) + call mpas_pool_get_config(domain % configs, 'config_iso_initial_temp_t2', config_iso_initial_temp_t2) + call mpas_pool_get_config(domain % configs, 'config_iso_initial_temp_h0', config_iso_initial_temp_h0) + call mpas_pool_get_config(domain % configs, 'config_iso_initial_temp_h1', config_iso_initial_temp_h1) + call mpas_pool_get_config(domain % configs, 'config_iso_initial_temp_mt', config_iso_initial_temp_mt) + call mpas_pool_get_config(domain % configs, 'config_iso_initial_temp_latS', config_iso_initial_temp_latS) + call mpas_pool_get_config(domain % configs, 'config_iso_initial_temp_latN', config_iso_initial_temp_latN) + call mpas_pool_get_config(domain % configs, 'config_iso_region1_center_lon', config_iso_region1_center_lon) + call mpas_pool_get_config(domain % configs, 'config_iso_region1_center_lat', config_iso_region1_center_lat) + call mpas_pool_get_config(domain % configs, 'config_iso_region2_center_lon', config_iso_region2_center_lon) + call mpas_pool_get_config(domain % configs, 'config_iso_region2_center_lat', config_iso_region2_center_lat) + call mpas_pool_get_config(domain % configs, 'config_iso_region3_center_lon', config_iso_region3_center_lon) + call mpas_pool_get_config(domain % configs, 'config_iso_region3_center_lat', config_iso_region3_center_lat) + call mpas_pool_get_config(domain % configs, 'config_iso_region4_center_lon', config_iso_region4_center_lon) + call mpas_pool_get_config(domain % configs, 'config_iso_region4_center_lat', config_iso_region4_center_lat) + call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_region1_flag', config_iso_heat_flux_region1_flag) + call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_region1', config_iso_heat_flux_region1) + call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_region1_radius', config_iso_heat_flux_region1_radius) + call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_region2_flag', config_iso_heat_flux_region2_flag) + call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_region2', config_iso_heat_flux_region2) + call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_region2_radius', config_iso_heat_flux_region2_radius) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_sponge_t1', config_iso_temperature_sponge_t1) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_sponge_h1', config_iso_temperature_sponge_h1) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_sponge_l1', config_iso_temperature_sponge_l1) + + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_region1_flag', config_iso_temperature_restore_region1_flag) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_t1', config_iso_temperature_restore_t1) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_lcx1', config_iso_temperature_restore_lcx1) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_lcy1', config_iso_temperature_restore_lcy1) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_region2_flag', config_iso_temperature_restore_region2_flag) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_t2', config_iso_temperature_restore_t2) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_lcx2', config_iso_temperature_restore_lcx2) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_lcy2', config_iso_temperature_restore_lcy2) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_region3_flag', config_iso_temperature_restore_region3_flag) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_t3', config_iso_temperature_restore_t3) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_lcx3', config_iso_temperature_restore_lcx3) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_lcy3', config_iso_temperature_restore_lcy3) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_region4_flag', config_iso_temperature_restore_region4_flag) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_t4', config_iso_temperature_restore_t4) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_lcx4', config_iso_temperature_restore_lcx4) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_lcy4', config_iso_temperature_restore_lcy4) + + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(meshPool, 'sphere_radius', sphere_radius) + sphereRadius = sphere_radius + + + if(.not. on_a_sphere) then + write(stderrUnit, *) 'ERROR: ISO test case can only be defined on a spherical mesh.' + iErr = 1 + return + end if + + + ! assign config variables + nVertLevels = config_iso_vert_levels + mainChannelDepth = config_iso_main_channel_depth + northWallLat = config_iso_north_wall_lat * pii/180.0 + southWallLat = config_iso_south_wall_lat * pii/180.0 + ridgeFlag = config_iso_ridge_flag + ridgeCenterLon = config_iso_ridge_center_lon * pii/180.0 + ridgeHeight = config_iso_ridge_height + ridgeWidth = config_iso_ridge_width + plateauFlag = config_iso_plateau_flag + plateauCenterLon = config_iso_plateau_center_lon * pii/180.0 + plateauCenterLat = config_iso_plateau_center_lat * pii/180.0 + plateauHeight = config_iso_plateau_height + plateauRadius = config_iso_plateau_radius + plateauSlopeWidth = config_iso_plateau_slope_width + shelfFlag = config_iso_shelf_flag + shelfDepth = config_iso_shelf_depth + shelfWidth = config_iso_shelf_width + contSlopeFlag = config_iso_cont_slope_flag + maxContSlope = config_iso_max_cont_slope + embaymentFlag = config_iso_embayment_flag + embaymentRadius = config_iso_embayment_radius + embaymentDepth = config_iso_embayment_depth + embaymentCenterLon = config_iso_embayment_center_lon * pii/180.0 + embaymentCenterLat = config_iso_embayment_center_lat * pii/180.0 + depressionFlag = config_iso_depression_flag + depressionWidth = config_iso_depression_width + depressionDepth = config_iso_depression_depth + depressionCenterLon = config_iso_depression_center_lon * pii/180.0 + depressionSouthLat = config_iso_depression_south_lat * pii/180.0 + depressionNorthLat = config_iso_depression_north_lat * pii/180.0 + salinity0 = config_iso_salinity + windStressMax = config_iso_wind_stress_max + windASF = config_iso_asf_wind + windACC = config_iso_acc_wind + latWindTrans = config_iso_wind_trans * pii/180.0 + QSouth = config_iso_heat_flux_south + QMiddle = config_iso_heat_flux_middle + QNorth = config_iso_heat_flux_north + transSS = config_iso_heat_flux_lat_ss * pii/180.0 + transSM = config_iso_heat_flux_lat_sm * pii/180.0 + transMN = config_iso_heat_flux_lat_mn * pii/180.0 + tempT1 = config_iso_initial_temp_t1 + tempT2 = config_iso_initial_temp_t2 + temph0 = config_iso_initial_temp_h0 + temph1 = config_iso_initial_temp_h1 + tempmT = config_iso_initial_temp_mt + tempLatS = config_iso_initial_temp_latS * pii/180.0 + tempLatN = config_iso_initial_temp_latN * pii/180.0 + regionCenterLon1 = config_iso_region1_center_lon * pii/180.0 + regionCenterLat1 = config_iso_region1_center_lat * pii/180.0 + regionCenterLon2 = config_iso_region2_center_lon * pii/180.0 + regionCenterLat2 = config_iso_region2_center_lat * pii/180.0 + regionCenterLon3 = config_iso_region3_center_lon * pii/180.0 + regionCenterLat3 = config_iso_region3_center_lat * pii/180.0 + regionCenterLon4 = config_iso_region4_center_lon * pii/180.0 + regionCenterLat4 = config_iso_region4_center_lat * pii/180.0 + heatRegionFlag1 = config_iso_heat_flux_region1_flag + heatRegion1flux = config_iso_heat_flux_region1 + heatRegion1Radius = config_iso_heat_flux_region1_radius + heatRegionFlag2 = config_iso_heat_flux_region2_flag + heatRegion2flux = config_iso_heat_flux_region2 + heatRegion2Radius = config_iso_heat_flux_region2_radius + tempSpongeT1 = config_iso_temperature_sponge_t1 + tempSpongeh1 = config_iso_temperature_sponge_h1 + tempSpongeWeightL1 = config_iso_temperature_sponge_l1 + + tempRestoreFlag1 = config_iso_temperature_restore_region1_flag + tempRestoreT1 = config_iso_temperature_restore_t1 + tempRestoreLcx1 = config_iso_temperature_restore_lcx1 + tempRestoreLcy1 = config_iso_temperature_restore_lcy1 + tempRestoreFlag2 = config_iso_temperature_restore_region2_flag + tempRestoreT2 = config_iso_temperature_restore_t2 + tempRestoreLcx2 = config_iso_temperature_restore_lcx2 + tempRestoreLcy2 = config_iso_temperature_restore_lcy2 + tempRestoreFlag3 = config_iso_temperature_restore_region3_flag + tempRestoreT3 = config_iso_temperature_restore_t3 + tempRestoreLcx3 = config_iso_temperature_restore_lcx3 + tempRestoreLcy3 = config_iso_temperature_restore_lcy3 + tempRestoreFlag4 = config_iso_temperature_restore_region4_flag + tempRestoreT4 = config_iso_temperature_restore_t4 + tempRestoreLcx4 = config_iso_temperature_restore_lcx4 + tempRestoreLcy4 = config_iso_temperature_restore_lcy4 + + + !!!!!!!!!!!!!!!!!!!!!!!!! + ! Setup the vertical grid + !!!!!!!!!!!!!!!!!!!!!!!!! + write(*,*) 'setting up vertical grid' + + ! get the layer thickness array + call get_thickness_array(dzarray) + dzarray = dzarray * mainChannelDepth + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + + ! Set refBottomDepth + call set_layerBottomDepth_from_layerThickness(nVertLevels, dzarray, refBottomDepth) + ! Set refZMid + call set_zMid_from_layerThickness(nVertLevels, dzarray, refZMid) + ! Set layerThickness and restingThickness + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + ! Set layerThicknes + layerThickness(k, iCell) = dzarray(k) + ! Set restingThickness + restingThickness(k, iCell) = dzarray(k) + end do + end do + + block_ptr => block_ptr % next + + end do + + + + !!!!!!!!!!!!!!!!!!!!!!!!! + ! Set Topography + !!!!!!!!!!!!!!!!!!!!!!!!! + write(*,*) 'setting up topography' + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + + ! calculate the width of the continental slope, + ! based on the specified max value of the slope of the continental slope, maxContSlope + contSlopeWidthRad = & + pii * 0.5 * (-shelfDepth + mainChannelDepth) / maxContSlope / sphereRadius + + do iCell = 1, nCellsSolve + currentLon = lonCell(iCell) + currentLat = latCell(iCell) + + bottomDepth(iCell) = 0.0 + + !!!!!!!!!!!!!!!!!!!!!!!!! + ! Main channel + if (currentLat <= northWallLat .and. currentLat >= southWallLat) then + bottomDepth(iCell) = mainChannelDepth + endif + + !!!!!!!!!!!!!!!!!!!!!!!!! + ! set up fill-in features + featureDepth = 1.0E6 + + ! feature 1: Add Ridge + if (ridgeFlag) then + distance = (currentLon - ridgeCenterLon) & + *sphereRadius*cos(currentLat) + if ( abs(distance) <= 0.6 * ridgeWidth ) then + featureDepth(1) = mainChannelDepth - & + ridgeHeight * exp(-2.0*(distance / ridgeWidth / 0.4)**2) + endif + endif + + ! feature 2: Add Plateau + if (plateauFlag) then + distance = sqrt( & + ( (currentLon - plateauCenterLon) * sphereRadius*cos(currentLat) )**2 & + + ( (currentLat - plateauCenterLat) * sphereRadius )**2 & + ) + if (abs(distance) <= plateauRadius) then + featureDepth(2) = mainChannelDepth - plateauHeight + else if (abs(distance) > plateauRadius .and. abs(distance) < plateauSlopeWidth) then + featureDepth(2) = mainChannelDepth - plateauHeight * & + exp( -2 * ( (abs(distance)-plateauRadius) / plateauSlopeWidth / 0.4 ) **2 ) + endif + endif + + ! feature 3: Add continental slope, or continental shelf break + if (contSlopeFlag) then + zMid = 0.5*(mainChannelDepth+shelfDepth) + amplitude = 0.5*(-shelfDepth+mainChannelDepth) + if (currentLat <= southWallLat + contSlopeWidthRad& + .and. currentLat > southWallLat) then + featureDepth(3) = zMid - amplitude * sin( 0.5*pii + pii/contSlopeWidthRad & + *(currentLat-southWallLat) ) + endif + endif + + ! choose the shallowest + bottomDepth(iCell) = min(minval(featureDepth), bottomDepth(iCell)) + + + + + !!!!!!!!!!!!!!!!!!!!!!!!! + ! Set up dig-out features + featureDepth = 0.0 + + ! feature 1: Continental shelf + if (shelfFlag) then + if (currentLat <= southWallLat .and. currentLat >= southWallLat-shelfWidth/sphereRadius) then + featureDepth(1) = shelfDepth + endif + endif + + ! feature 2: Embayment + if (embaymentFlag) then + distance = sqrt( & + ( (currentLon - embaymentCenterLon) * sphereRadius*cos(currentLat) )**2 & + + ( (currentLat - embaymentCenterLat) * sphereRadius )**2 & + ) + if(distance <= embaymentRadius .and. currentLat < embaymentCenterLat) then + featureDepth(2) = embaymentDepth + endif + endif + + ! feature 3: depression + if (depressionFlag) then + distance = (currentLon - depressionCenterLon) * sphereRadius*cos(currentLat) + if( abs(distance) <= 0.5*depressionWidth & + .and. currentLat >= depressionSouthLat .and. currentLat <= depressionNorthLat ) & + then + featureDepth(3) = depressionDepth + endif + endif + + ! choose the deepest one + bottomDepth(iCell) = max(maxval(featureDepth), bottomDepth(iCell)) + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Set maxLevelCell to -1 for cells to be culled + if (bottomDepth(iCell) > 0.0) then + maxLevelCell(iCell) = 1 + else + maxLevelCell(iCell) = -1 + endif + + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Determine maxLevelCell based on bottomDepth and refBottomDepth + ! Also set botomDepth based on refBottomDepth, since + ! above bottomDepth was set with continuous analytical functions, + ! and needs to be discrete + if (maxLevelCell(iCell) > 0) then + maxLevelCell(iCell) = nVertLevels + if (nVertLevels .gt. 1) then + do k = 1, nVertLevels + if (bottomDepth(iCell) < refBottomDepth(k) ) then + maxLevelCell(iCell) = k-1 + bottomDepth(iCell) = refBottomDepth(k-1) + exit + end if + end do + end if + end if + + + + enddo ! Looping through with iCell + + block_ptr => block_ptr % next + enddo ! done setting topography + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Set forcing boundary conditions and initial conditions + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(*,*) 'setting up forcing and boundary conditions' + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) + call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) + call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + call mpas_pool_get_dimension(tracersPool, 'index_tracer1', index_tracer1) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + call mpas_pool_get_array(tracersPool, 'debugTracers', debugTracers, 1) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) + call mpas_pool_get_array(forcingPool, 'windStressZonal', windStressZonal) + call mpas_pool_get_array(forcingPool, 'windStressMeridional', windStressMeridional, 1) + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersPistonVelocity', activeTracersPistonVelocity, 1) + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersSurfaceRestoringValue', activeTracersSurfaceRestoringValue, 1) + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringRate', activeTracersInteriorRestoringRate, 1) + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringValue', activeTracersInteriorRestoringValue, 1) + + do iCell = 1, nCellsSolve + currentLon = lonCell(iCell) + currentLat = latCell(iCell) + + ! Set initial temperature + idx = index_temperature + do k = 1, nVertLevels + zMid = refZMid(k) + !temperature = tempT1 + tempT2*tanh(zMid/temph1) + tempmT * zMid + temperature = (tempT1 + tempT2*tanh((zMid+temph0)/temph1) + tempmT * zMid) & + * (-tempLatS+currentLat)*( 1.0/(-tempLatS+tempLatN) ) + activeTracers(idx, k, iCell) = temperature + enddo + + ! Set initial salinity + idx = index_salinity + activeTracers(idx, :, iCell) = salinity0 + + ! Set up debugging tracers + idx = index_tracer1 + debugTracers(idx, :, iCell) = 1.0_RKIND + + + ! Heat fluxes + heatFluxZonal = 0.0_RKIND + heatFlux1 = 0.0_RKIND + heatFlux2 = 0.0_RKIND + + ! Setup zonally constant surface heat fluxes + widthQSouth = transSM - transSS + widthQMiddle = transMN - transSM + widthQNorth = northWallLat - transMN + if (currentLat > transSS .and. currentLat < transSM) then + heatFluxZonal = QSouth*sin(pii*(currentLat-transSM)/widthQSouth)**2 + elseif (currentLat > transSM .and. currentLat < transMN) then + heatFluxZonal = QMiddle*sin(pii*(currentLat-transMN)/widthQMiddle)**2 + elseif (currentLat > transMN .and. currentLat < northWallLat) then + heatFluxZonal = QNorth*sin(pii*(currentLat-northWallLat)/widthQNorth)**2 + endif + + ! Setup heat flux over localized region 1 + if (heatRegionFlag1) then + distance = sqrt( & + ( (currentLon - regionCenterLon1) * sphereRadius*cos(currentLat) )**2 & + + ( (currentLat - regionCenterLat1) * sphereRadius )**2 & + ) + if (abs(distance) <= heatRegion1Radius) then + heatFlux1 = heatRegion1flux * exp(-2.0_RKIND*(distance / 2.0_RKIND / heatRegion1Radius / 0.4_RKIND)**2) + endif + endif + ! Setup heat flux over localized region 2 + if (heatRegionFlag2) then + distance = sqrt( & + ( (currentLon - regionCenterLon2) * sphereRadius*cos(currentLat) )**2 & + + ( (currentLat - regionCenterLat2) * sphereRadius )**2 & + ) + if (abs(distance) <= heatRegion2Radius) then + heatFlux2 = heatRegion2flux * exp(-2.0_RKIND*(distance / 2.0_RKIND / heatRegion2Radius / 0.4_RKIND)**2) + endif + endif + + + if (currentLat < transSM) then + sensibleHeatFlux(iCell) = min(heatFluxZonal, heatFlux1, heatFlux2) + else + sensibleHeatFlux(iCell) = heatFluxZonal + endif + + + ! Set interior restoring + do k = 1, nVertLevels + zMid = refZMid(k) + + !Temperature + !Interior restoring along northern wall + distance = sphereRadius * ( currentLat - northWallLat) + if(abs(distance) <= 3.0_RKIND*tempSpongeWeightL1) then + idx = index_temperature + temperature = tempSpongeT1 * exp(zMid/tempSpongeh1) + activeTracersInteriorRestoringValue(idx,k,iCell) = temperature + + idx = index_temperature + ! note to juan: activeTracersInteriorRestoringRate has units of 1/s throughout + activeTracersInteriorRestoringRate(idx, k,iCell) = exp(-abs(distance)/tempSpongeWeightL1) + endif + + ! Interior restoring at localized region 1 + if (tempRestoreFlag1) then + xDistance = (currentLon - regionCenterLon1) * sphereRadius*cos(currentLat) + yDistance = (currentLat - regionCenterLat1) * sphereRadius + if (abs(yDistance) <= tempRestoreLcy1 .and. abs(xDistance) <= tempRestoreLcx1) then + idx = index_temperature + activeTracersInteriorRestoringValue(idx,k,iCell) = TempRestoreT1 + + idx = index_temperature + activeTracersInteriorRestoringRate(idx, k,iCell) = & + exp(-(2.0_RKIND*xDistance/tempRestoreLcx1)**2 - (2.0_RKIND*yDistance/tempRestoreLcy1)**2 ) + endif + endif + + ! Interior restoring at localized region 2 + if (tempRestoreFlag2) then + xDistance = (currentLon - regionCenterLon2) * sphereRadius*cos(currentLat) + yDistance = (currentLat - regionCenterLat2) * sphereRadius + if (abs(yDistance) <= tempRestoreLcy2 .and. abs(xDistance) <= tempRestoreLcx2) then + idx = index_temperature + activeTracersInteriorRestoringValue(idx,k,iCell) = TempRestoreT2 + + idx = index_temperature + activeTracersInteriorRestoringRate(idx, k,iCell) = & + exp(-(2.0_RKIND*xDistance/tempRestoreLcx2)**2 - (2.0_RKIND*yDistance/tempRestoreLcy2)**2 ) + endif + endif + + ! Interior restoring at localized region 3 + if (tempRestoreFlag3) then + xDistance = (currentLon - regionCenterLon3) * sphereRadius*cos(currentLat) + yDistance = (currentLat - regionCenterLat3) * sphereRadius + if (abs(yDistance) <= tempRestoreLcy3 .and. abs(xDistance) <= tempRestoreLcx3) then + idx = index_temperature + activeTracersInteriorRestoringValue(idx,k,iCell) = TempRestoreT3 + + idx = index_temperature + activeTracersInteriorRestoringRate(idx, k,iCell) = & + exp(-(2.0_RKIND*xDistance/tempRestoreLcx3)**2 - (2.0_RKIND*yDistance/tempRestoreLcy3)**2 ) + endif + endif + + ! Interior restoring at localized region 4 + if (tempRestoreFlag4) then + xDistance = (currentLon - regionCenterLon4) * sphereRadius*cos(currentLat) + yDistance = (currentLat - regionCenterLat4) * sphereRadius + if (abs(yDistance) <= tempRestoreLcy4 .and. abs(xDistance) <= tempRestoreLcx4) then + idx = index_temperature + activeTracersInteriorRestoringValue(idx,k,iCell) = TempRestoreT4 + + idx = index_temperature + activeTracersInteriorRestoringRate(idx, k,iCell) = & + exp(-(2.0_RKIND*xDistance/tempRestoreLcx4)**2 - (2.0_RKIND*yDistance/tempRestoreLcy4)**2 ) + endif + endif + + ! Salinity + idx = index_salinity + activeTracersInteriorRestoringValue(idx,k,iCell) = salinity0 + idx = index_salinity + activeTracersInteriorRestoringRate(idx, k,iCell) = 0.0_RKIND + + enddo ! k = 1, nVertLevels, interior restoring loop + + + end do ! iCell = 1, nCellsSolve + + ! juan: add code here for surface restoring. can be toggled on/off at runtime + ! fill activeTracersSurfaceRestoringValue with correct values + ! fill activeTracersPistonVelocity with correct values + activeTracersSurfaceRestoringValue(:,:) = 0.0_RKIND + activeTracersPistonVelocity(:,:) = 0.0_RKIND + + ! Set wind stress + widthWindASFRad = 1.1*contSlopeWidthRad + do iCell = 1, nCellsSolve + currentLon = lonCell(iCell) + currentLat = latCell(iCell) + windStress = 0.0 + + ! Set wind stress over the ACC, or main channel + if (currentLat > latWindTrans) then + windStress = windACC * & + sin( pii * (currentLat - latWindTrans) & + / (northWallLat-latWindTrans) )**2 + ! Set the wind over the continental slope front, over continental slope region + else if (currentLat > latWindTrans - widthWindASFRad .and. currentLat < latWindTrans) then + windStress = windASF * sin( pii * (latWindTrans-currentLat) / widthWindASFRad )**2 + endif + windStressZonal(iCell) = windStress + windStressMeridional(iCell) = 0.0_RKIND + end do + + + block_ptr => block_ptr % next + end do + + write(*,*) 'exiting ocn_init_setup_iso' + + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_iso!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_iso +! +!> \brief Validation for ISO test case +!> \author Juan A. Saenz +!> \date 02/26/2014 +!> \details +!> This routine validates the configuration options for the ISO test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_iso(configPool, packagePool, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: configPool, packagePool + integer, intent(out) :: iErr + + character (len=StrKIND), pointer :: config_init_configuration + integer, pointer :: config_vert_levels, config_iso_vert_levels + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + if(config_init_configuration .ne. trim('iso')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_iso_vert_levels', config_iso_vert_levels) + + if(config_vert_levels <= 0 .and. config_iso_vert_levels > 0) then + config_vert_levels = config_iso_vert_levels + else if (config_vert_levels <= 0) then + write(stderrUnit,*) 'ERROR: Validation failed for ISO. Not given a usable value for vertical levels.' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_iso!}}} + +!*********************************************************************** +! +! routine get_thickness_array +! +!> \brief Define the thickness array +!> \author Juan A. Saenz +!> \date 01/27/2015 +!> \details +!> This routine sets up a vertical grid with 100 levels. +!> It uses dz output from todd's cvt_1d code with hashtag: f0c6bda0 +! +!----------------------------------------------------------------------- + + subroutine get_thickness_array(dzarray)!{{{ + + real (kind=RKIND), dimension(100) :: dzarray + + ! --- the parameters define below result in the folloing + ! -------- dz(1)=1.51 m + ! -------- dz(nVertLevels)=221.1 m + ! -------- 25 layers in the top 100 m + ! -------- 61 layers in the top 1000 m + integer, parameter :: nVertLevels=100 + real*8, parameter :: stretch1=1.0770 + real*8, parameter :: stretch2=1.0275 + real*8, parameter :: dzTopLayer=1.2 + real*8, parameter :: maxBottomDepth=4000.0 + + real*8 totalDepth, stretch + real*8, dimension(nVertLevels) :: dz, zMid, zTop + + integer :: k + + ! compute profile starting at top and stretch dz as we move down + dz(1) = dzTopLayer + zMid(1) = -dz(1)/2.0; + zTop(1) = 0.0 + totalDepth = dz(1) + do k=2,nVertLevels + stretch = stretch1 + (stretch2-stretch1)*k/nVertLevels + dz(k)=stretch*dz(k-1); + zMid(k) = zMid(k-1) - (dz(k-1)+dz(k))/2.0; + zTop(k) = zTop(k-1) - dz(k-1); + totalDepth = totalDepth + dz(k) + enddo + + ! normalize to that positions span 0 to 1 + dz(:) = dz(:) / totalDepth + zMid(:) = zMid(:) / totalDepth + zTop(:) = zTop(:) / totalDepth + + dzarray = dz + + ! force the sum to be equal to 1 + dzarray(100) = 1.0-sum(dzarray(1:99)) - 1.0E-10 + + end subroutine get_thickness_array!}}} + + +!*********************************************************************** +! +! routine set_layerBottomDepth_from_layerThickness +! +!> \brief Set layer bottom depths using layerThickness +!> \author Juan A. Saenz +!> \date 01/27/2015 +!> \details +!> This routine sets layer bottom depths using layerThickness. +!> It can be used to define refBottomDepth. +! +!----------------------------------------------------------------------- + + subroutine set_layerBottomDepth_from_layerThickness(nVertLevels, dzarray, layerBottomDepth)!{{{ + + integer, intent(in) :: nVertLevels + real (kind=RKIND), dimension(:), intent(in) :: dzarray + real (kind=RKIND), dimension(:), intent(out) :: layerBottomDepth + + integer :: k + + layerBottomDepth(1) = dzarray(1) + do k = 2, nVertLevels + layerBottomDepth(k) = layerBottomDepth(k-1) + dzarray(k) + end do + + end subroutine set_layerBottomDepth_from_layerThickness!}}} + + +!*********************************************************************** +! +! routine set_zMid_from_layerThickness +! +!> \brief Set zMid using layerThickness +!> \author Juan A. Saenz +!> \date 01/27/2015 +!> \details +!> This routine sets zMid, the depth at middle of layers, using layerThickness. +!> It can be used to define refZMid +! +!----------------------------------------------------------------------- + + subroutine set_zMid_from_layerThickness(nVertLevels, dzarray, zMid)!{{{ + + integer, intent(in) :: nVertLevels + real (kind=RKIND), dimension(:), intent(in) :: dzarray + real (kind=RKIND), dimension(:), intent(out) :: zMid + + integer :: k + + zMid(1) = - dzarray(1) / 2.0 + do k = 2, nVertLevels + zMid(k) = zMid(k-1) - (dzarray(k-1) + dzarray(k) ) / 2.0 + end do + + end subroutine set_zMid_from_layerThickness!}}} + +end module ocn_init_iso + + + + + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker From e0c89748d7d45f1ab4feae32e0dc0959a751adbd Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Mon, 24 Aug 2015 07:49:06 -0600 Subject: [PATCH 0188/1724] adding iso registry to list of includes --- src/core_ocean/mode_init/Registry.xml | 1 + src/core_ocean/mode_init/Registry_iso.xml | 244 +++++++++++----------- 2 files changed, 123 insertions(+), 122 deletions(-) diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml index df78ae51f5..5b5fd1e01b 100644 --- a/src/core_ocean/mode_init/Registry.xml +++ b/src/core_ocean/mode_init/Registry.xml @@ -4,4 +4,5 @@ #include "Registry_overflow.xml" #include "Registry_global_realistic.xml" #include "Registry_cvmix_WSwSBF.xml" +#include "Registry_iso.xml" // #include "Registry_TEMPLATE.xml" diff --git a/src/core_ocean/mode_init/Registry_iso.xml b/src/core_ocean/mode_init/Registry_iso.xml index 520e510d27..313a8e516d 100644 --- a/src/core_ocean/mode_init/Registry_iso.xml +++ b/src/core_ocean/mode_init/Registry_iso.xml @@ -130,79 +130,79 @@ description="Salinity of the water in the ISO." possible_values="Any positive real number." /> - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + - - - - - - - - - + + + + + + + - - - + - - - - - - - - - - - - - - - Date: Mon, 24 Aug 2015 20:39:32 -0600 Subject: [PATCH 0189/1724] add hooks for iso into init driver --- src/core_ocean/mode_init/mpas_ocn_init_iso.F | 365 +++++++----------- src/core_ocean/mode_init/mpas_ocn_init_mode.F | 5 + 2 files changed, 135 insertions(+), 235 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_iso.F b/src/core_ocean/mode_init/mpas_ocn_init_iso.F index 0f7a33f026..326662ecac 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_iso.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_iso.F @@ -94,12 +94,13 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ real (kind=RKIND) :: depth, contSlopeWidthRad, widthWindASFRad, windStress real (kind=RKIND) :: widthQSouth, widthQMiddle, widthQNorth, heatFluxZonal, heatFlux1, heatFlux2 real (kind=RKIND) :: temperature - real (kind=RKIND), dimension(100) :: dzarray real (kind=RKIND), dimension(30) :: featureDepth + + real (kind=RKIND), dimension(:), pointer :: interfaceLocations ! Define config variable pointers - character (len=StrKIND), pointer :: config_init_configuration + character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid integer, pointer :: config_iso_vert_levels real (kind=RKIND), pointer :: config_iso_main_channel_depth @@ -185,13 +186,13 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ real (kind=RKIND), pointer :: config_iso_temperature_restore_lcy4 ! Define dimension pointers - integer, pointer :: nVertLevels, nCellsSolve + integer, pointer :: nVertLevels, nCells, nVertLevelsP1 integer, pointer :: index_temperature, index_salinity, index_tracer1 ! Define variable pointers logical, pointer :: on_a_sphere integer, dimension(:), pointer :: maxLevelCell - real (kind=RKIND), dimension(:), pointer :: refBottomDepth, refZMid + real (kind=RKIND), dimension(:), pointer :: refBottomDepth, bottomCell, refZMid real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness real (kind=RKIND), pointer :: sphere_radius real (kind=RKIND), dimension(:), pointer :: lonCell, latCell, bottomDepth @@ -238,11 +239,14 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ real (kind=RKIND) :: tempRestoreT4, tempRestoreLcx4, tempRestoreLcy4 iErr = 0 + + write(stderrUnit, *) ' iso start 0' call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) if(config_init_configuration .ne. trim('iso')) return ! get config variables + call mpas_pool_get_config(domain % configs, 'config_vertical_grid', config_vertical_grid) call mpas_pool_get_config(domain % configs, 'config_iso_vert_levels', config_iso_vert_levels) call mpas_pool_get_config(domain % configs, 'config_iso_main_channel_depth', config_iso_main_channel_depth) call mpas_pool_get_config(domain % configs, 'config_iso_north_wall_lat', config_iso_north_wall_lat) @@ -328,6 +332,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nVertLevelsP1', nVertLevelsP1) call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(meshPool, 'sphere_radius', sphere_radius) sphereRadius = sphere_radius @@ -339,6 +344,13 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ return end if + write(stderrUnit, *) 'iso 1', nVertLevelsP1 + + ! Define interface locations + allocate( interfaceLocations( nVertLevelsP1 ) ) + call ocn_generate_vertical_grid( config_vertical_grid, interfaceLocations ) + + write(stderrUnit, *) ' iso 2', interfaceLocations ! assign config variables nVertLevels = config_iso_vert_levels @@ -425,46 +437,41 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ tempRestoreLcy4 = config_iso_temperature_restore_lcy4 + write(stderrUnit, *) 'iso 3' + !!!!!!!!!!!!!!!!!!!!!!!!! ! Setup the vertical grid !!!!!!!!!!!!!!!!!!!!!!!!! - write(*,*) 'setting up vertical grid' - - ! get the layer thickness array - call get_thickness_array(dzarray) - dzarray = dzarray * mainChannelDepth block_ptr => domain % blocklist do while(associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) - call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) - - ! Set refBottomDepth - call set_layerBottomDepth_from_layerThickness(nVertLevels, dzarray, refBottomDepth) - ! Set refZMid - call set_zMid_from_layerThickness(nVertLevels, dzarray, refZMid) ! Set layerThickness and restingThickness - do iCell = 1, nCellsSolve - do k = 1, nVertLevels - ! Set layerThicknes - layerThickness(k, iCell) = dzarray(k) - ! Set restingThickness - restingThickness(k, iCell) = dzarray(k) - end do + do k = 1, nVertLevels + layerThickness(k, :) = config_iso_main_channel_depth * ( interfaceLocations(k+1) - interfaceLocations(k) ) + restingThickness(k, :) = layerThickness(k, :) end do + ! Set refBottomDepth + do k = 1, nVertLevels + refBottomDepth(k) = config_iso_main_channel_depth * interfaceLocations(k+1) + refZMid(k) = -config_iso_main_channel_depth * (interfaceLocations(k)+interfaceLocations(k+1))/2.0_RKIND + end do + block_ptr => block_ptr % next end do - + write(stderrUnit, *) 'iso 4', refZMid + !!!!!!!!!!!!!!!!!!!!!!!!! ! Set Topography @@ -484,7 +491,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ contSlopeWidthRad = & pii * 0.5 * (-shelfDepth + mainChannelDepth) / maxContSlope / sphereRadius - do iCell = 1, nCellsSolve + do iCell = 1, nCells currentLon = lonCell(iCell) currentLat = latCell(iCell) @@ -537,8 +544,6 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ ! choose the shallowest bottomDepth(iCell) = min(minval(featureDepth), bottomDepth(iCell)) - - !!!!!!!!!!!!!!!!!!!!!!!!! @@ -585,8 +590,6 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ maxLevelCell(iCell) = -1 endif - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Determine maxLevelCell based on bottomDepth and refBottomDepth @@ -605,15 +608,24 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ end do end if end if - - enddo ! Looping through with iCell block_ptr => block_ptr % next enddo ! done setting topography - + write(stderrUnit, *) 'iso 5', maxval(bottomDepth), maxval(maxLevelCell) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! mark cells for culling + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call ocn_mark_maxlevelcell(meshPool, iErr) + block_ptr => block_ptr % next + end do + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Set forcing boundary conditions and initial conditions @@ -626,10 +638,8 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ call mpas_pool_get_array(meshPool, 'latCell', latCell) call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) - call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) - call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) - call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_salinity) call mpas_pool_get_dimension(tracersPool, 'index_tracer1', index_tracer1) call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) call mpas_pool_get_array(tracersPool, 'debugTracers', debugTracers, 1) @@ -639,12 +649,14 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) call mpas_pool_get_array(forcingPool, 'windStressZonal', windStressZonal) call mpas_pool_get_array(forcingPool, 'windStressMeridional', windStressMeridional, 1) + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) + call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersPistonVelocity', activeTracersPistonVelocity, 1) call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersSurfaceRestoringValue', activeTracersSurfaceRestoringValue, 1) call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringRate', activeTracersInteriorRestoringRate, 1) call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringValue', activeTracersInteriorRestoringValue, 1) - do iCell = 1, nCellsSolve + do iCell = 1, nCells currentLon = lonCell(iCell) currentLat = latCell(iCell) @@ -666,7 +678,6 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ idx = index_tracer1 debugTracers(idx, :, iCell) = 1.0_RKIND - ! Heat fluxes heatFluxZonal = 0.0_RKIND heatFlux1 = 0.0_RKIND @@ -705,97 +716,97 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ endif endif - if (currentLat < transSM) then sensibleHeatFlux(iCell) = min(heatFluxZonal, heatFlux1, heatFlux2) else sensibleHeatFlux(iCell) = heatFluxZonal endif - - ! Set interior restoring - do k = 1, nVertLevels - zMid = refZMid(k) - - !Temperature - !Interior restoring along northern wall - distance = sphereRadius * ( currentLat - northWallLat) - if(abs(distance) <= 3.0_RKIND*tempSpongeWeightL1) then - idx = index_temperature - temperature = tempSpongeT1 * exp(zMid/tempSpongeh1) - activeTracersInteriorRestoringValue(idx,k,iCell) = temperature + ! Set interior restoring + do k = 1, nVertLevels + zMid = refZMid(k) - idx = index_temperature - ! note to juan: activeTracersInteriorRestoringRate has units of 1/s throughout - activeTracersInteriorRestoringRate(idx, k,iCell) = exp(-abs(distance)/tempSpongeWeightL1) - endif + !Temperature + !Interior restoring along northern wall + distance = sphereRadius * ( currentLat - northWallLat) + if(abs(distance) <= 3.0_RKIND*tempSpongeWeightL1) then + idx = index_temperature + temperature = tempSpongeT1 * exp(zMid/tempSpongeh1) + activeTracersInteriorRestoringValue(idx, k, iCell) = temperature - ! Interior restoring at localized region 1 - if (tempRestoreFlag1) then - xDistance = (currentLon - regionCenterLon1) * sphereRadius*cos(currentLat) - yDistance = (currentLat - regionCenterLat1) * sphereRadius - if (abs(yDistance) <= tempRestoreLcy1 .and. abs(xDistance) <= tempRestoreLcx1) then - idx = index_temperature - activeTracersInteriorRestoringValue(idx,k,iCell) = TempRestoreT1 - - idx = index_temperature - activeTracersInteriorRestoringRate(idx, k,iCell) = & - exp(-(2.0_RKIND*xDistance/tempRestoreLcx1)**2 - (2.0_RKIND*yDistance/tempRestoreLcy1)**2 ) - endif - endif + idx = index_temperature + ! note to juan: activeTracersInteriorRestoringRate has units of 1/s throughout + activeTracersInteriorRestoringRate(idx, k, iCell) = exp(-abs(distance)/tempSpongeWeightL1) + endif + + ! Interior restoring at localized region 1 + if (tempRestoreFlag1) then + xDistance = (currentLon - regionCenterLon1) * sphereRadius*cos(currentLat) + yDistance = (currentLat - regionCenterLat1) * sphereRadius + if (abs(yDistance) <= tempRestoreLcy1 .and. abs(xDistance) <= tempRestoreLcx1) then + idx = index_temperature + activeTracersInteriorRestoringValue(idx, k, iCell) = TempRestoreT1 + + idx = index_temperature + activeTracersInteriorRestoringRate(idx, k, iCell) = & + exp(-(2.0_RKIND*xDistance/tempRestoreLcx1)**2 - (2.0_RKIND*yDistance/tempRestoreLcy1)**2 ) + endif + endif - ! Interior restoring at localized region 2 - if (tempRestoreFlag2) then - xDistance = (currentLon - regionCenterLon2) * sphereRadius*cos(currentLat) - yDistance = (currentLat - regionCenterLat2) * sphereRadius - if (abs(yDistance) <= tempRestoreLcy2 .and. abs(xDistance) <= tempRestoreLcx2) then - idx = index_temperature - activeTracersInteriorRestoringValue(idx,k,iCell) = TempRestoreT2 - - idx = index_temperature - activeTracersInteriorRestoringRate(idx, k,iCell) = & - exp(-(2.0_RKIND*xDistance/tempRestoreLcx2)**2 - (2.0_RKIND*yDistance/tempRestoreLcy2)**2 ) - endif - endif - - ! Interior restoring at localized region 3 - if (tempRestoreFlag3) then - xDistance = (currentLon - regionCenterLon3) * sphereRadius*cos(currentLat) - yDistance = (currentLat - regionCenterLat3) * sphereRadius - if (abs(yDistance) <= tempRestoreLcy3 .and. abs(xDistance) <= tempRestoreLcx3) then - idx = index_temperature - activeTracersInteriorRestoringValue(idx,k,iCell) = TempRestoreT3 - - idx = index_temperature - activeTracersInteriorRestoringRate(idx, k,iCell) = & - exp(-(2.0_RKIND*xDistance/tempRestoreLcx3)**2 - (2.0_RKIND*yDistance/tempRestoreLcy3)**2 ) - endif - endif - - ! Interior restoring at localized region 4 - if (tempRestoreFlag4) then - xDistance = (currentLon - regionCenterLon4) * sphereRadius*cos(currentLat) - yDistance = (currentLat - regionCenterLat4) * sphereRadius - if (abs(yDistance) <= tempRestoreLcy4 .and. abs(xDistance) <= tempRestoreLcx4) then - idx = index_temperature - activeTracersInteriorRestoringValue(idx,k,iCell) = TempRestoreT4 - - idx = index_temperature - activeTracersInteriorRestoringRate(idx, k,iCell) = & - exp(-(2.0_RKIND*xDistance/tempRestoreLcx4)**2 - (2.0_RKIND*yDistance/tempRestoreLcy4)**2 ) - endif + ! Interior restoring at localized region 2 + if (tempRestoreFlag2) then + xDistance = (currentLon - regionCenterLon2) * sphereRadius*cos(currentLat) + yDistance = (currentLat - regionCenterLat2) * sphereRadius + if (abs(yDistance) <= tempRestoreLcy2 .and. abs(xDistance) <= tempRestoreLcx2) then + idx = index_temperature + activeTracersInteriorRestoringValue(idx, k, iCell) = TempRestoreT2 + + idx = index_temperature + activeTracersInteriorRestoringRate(idx, k, iCell) = & + exp(-(2.0_RKIND*xDistance/tempRestoreLcx2)**2 - (2.0_RKIND*yDistance/tempRestoreLcy2)**2 ) + endif + endif + + ! Interior restoring at localized region 3 + if (tempRestoreFlag3) then + xDistance = (currentLon - regionCenterLon3) * sphereRadius*cos(currentLat) + yDistance = (currentLat - regionCenterLat3) * sphereRadius + if (abs(yDistance) <= tempRestoreLcy3 .and. abs(xDistance) <= tempRestoreLcx3) then + idx = index_temperature + activeTracersInteriorRestoringValue(idx, k, iCell) = TempRestoreT3 + + idx = index_temperature + activeTracersInteriorRestoringRate(idx, k, iCell) = & + exp(-(2.0_RKIND*xDistance/tempRestoreLcx3)**2 - (2.0_RKIND*yDistance/tempRestoreLcy3)**2 ) + endif + endif + + ! Interior restoring at localized region 4 + if (tempRestoreFlag4) then + xDistance = (currentLon - regionCenterLon4) * sphereRadius*cos(currentLat) + yDistance = (currentLat - regionCenterLat4) * sphereRadius + if (abs(yDistance) <= tempRestoreLcy4 .and. abs(xDistance) <= tempRestoreLcx4) then + idx = index_temperature + activeTracersInteriorRestoringValue(idx, k, iCell) = TempRestoreT4 + + idx = index_temperature + activeTracersInteriorRestoringRate(idx, k, iCell) = & + exp(-(2.0_RKIND*xDistance/tempRestoreLcx4)**2 - (2.0_RKIND*yDistance/tempRestoreLcy4)**2 ) + endif endif - - ! Salinity - idx = index_salinity - activeTracersInteriorRestoringValue(idx,k,iCell) = salinity0 - idx = index_salinity - activeTracersInteriorRestoringRate(idx, k,iCell) = 0.0_RKIND - - enddo ! k = 1, nVertLevels, interior restoring loop - + + ! Salinity + idx = index_salinity + activeTracersInteriorRestoringValue(idx, k, iCell) = salinity0 + idx = index_salinity + activeTracersInteriorRestoringRate(idx, k, iCell) = 0.0_RKIND + + enddo ! k = 1, nVertLevels, interior restoring loop + - end do ! iCell = 1, nCellsSolve + end do ! iCell = 1, nCells + + write(stderrUnit, *) 'iso 6' ! juan: add code here for surface restoring. can be toggled on/off at runtime ! fill activeTracersSurfaceRestoringValue with correct values @@ -805,7 +816,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ ! Set wind stress widthWindASFRad = 1.1*contSlopeWidthRad - do iCell = 1, nCellsSolve + do iCell = 1, nCells currentLon = lonCell(iCell) currentLat = latCell(iCell) windStress = 0.0 @@ -874,122 +885,6 @@ subroutine ocn_init_validate_iso(configPool, packagePool, iErr)!{{{ end subroutine ocn_init_validate_iso!}}} -!*********************************************************************** -! -! routine get_thickness_array -! -!> \brief Define the thickness array -!> \author Juan A. Saenz -!> \date 01/27/2015 -!> \details -!> This routine sets up a vertical grid with 100 levels. -!> It uses dz output from todd's cvt_1d code with hashtag: f0c6bda0 -! -!----------------------------------------------------------------------- - - subroutine get_thickness_array(dzarray)!{{{ - - real (kind=RKIND), dimension(100) :: dzarray - - ! --- the parameters define below result in the folloing - ! -------- dz(1)=1.51 m - ! -------- dz(nVertLevels)=221.1 m - ! -------- 25 layers in the top 100 m - ! -------- 61 layers in the top 1000 m - integer, parameter :: nVertLevels=100 - real*8, parameter :: stretch1=1.0770 - real*8, parameter :: stretch2=1.0275 - real*8, parameter :: dzTopLayer=1.2 - real*8, parameter :: maxBottomDepth=4000.0 - - real*8 totalDepth, stretch - real*8, dimension(nVertLevels) :: dz, zMid, zTop - - integer :: k - - ! compute profile starting at top and stretch dz as we move down - dz(1) = dzTopLayer - zMid(1) = -dz(1)/2.0; - zTop(1) = 0.0 - totalDepth = dz(1) - do k=2,nVertLevels - stretch = stretch1 + (stretch2-stretch1)*k/nVertLevels - dz(k)=stretch*dz(k-1); - zMid(k) = zMid(k-1) - (dz(k-1)+dz(k))/2.0; - zTop(k) = zTop(k-1) - dz(k-1); - totalDepth = totalDepth + dz(k) - enddo - - ! normalize to that positions span 0 to 1 - dz(:) = dz(:) / totalDepth - zMid(:) = zMid(:) / totalDepth - zTop(:) = zTop(:) / totalDepth - - dzarray = dz - - ! force the sum to be equal to 1 - dzarray(100) = 1.0-sum(dzarray(1:99)) - 1.0E-10 - - end subroutine get_thickness_array!}}} - - -!*********************************************************************** -! -! routine set_layerBottomDepth_from_layerThickness -! -!> \brief Set layer bottom depths using layerThickness -!> \author Juan A. Saenz -!> \date 01/27/2015 -!> \details -!> This routine sets layer bottom depths using layerThickness. -!> It can be used to define refBottomDepth. -! -!----------------------------------------------------------------------- - - subroutine set_layerBottomDepth_from_layerThickness(nVertLevels, dzarray, layerBottomDepth)!{{{ - - integer, intent(in) :: nVertLevels - real (kind=RKIND), dimension(:), intent(in) :: dzarray - real (kind=RKIND), dimension(:), intent(out) :: layerBottomDepth - - integer :: k - - layerBottomDepth(1) = dzarray(1) - do k = 2, nVertLevels - layerBottomDepth(k) = layerBottomDepth(k-1) + dzarray(k) - end do - - end subroutine set_layerBottomDepth_from_layerThickness!}}} - - -!*********************************************************************** -! -! routine set_zMid_from_layerThickness -! -!> \brief Set zMid using layerThickness -!> \author Juan A. Saenz -!> \date 01/27/2015 -!> \details -!> This routine sets zMid, the depth at middle of layers, using layerThickness. -!> It can be used to define refZMid -! -!----------------------------------------------------------------------- - - subroutine set_zMid_from_layerThickness(nVertLevels, dzarray, zMid)!{{{ - - integer, intent(in) :: nVertLevels - real (kind=RKIND), dimension(:), intent(in) :: dzarray - real (kind=RKIND), dimension(:), intent(out) :: zMid - - integer :: k - - zMid(1) = - dzarray(1) / 2.0 - do k = 2, nVertLevels - zMid(k) = zMid(k-1) - (dzarray(k-1) + dzarray(k) ) / 2.0 - end do - - end subroutine set_zMid_from_layerThickness!}}} - end module ocn_init_iso diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 583d34e9ad..142df531e1 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -44,6 +44,7 @@ module ocn_init_mode use ocn_init_overflow use ocn_init_global_realistic use ocn_init_cvmix_WSwSBF + use ocn_init_iso implicit none private @@ -249,6 +250,8 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call ocn_init_setup_overflow(domain, ierr) call ocn_init_setup_global_realistic(domain, ierr) call ocn_init_setup_cvmix_WSwSBF(domain, ierr) + call ocn_init_setup_iso(domain, ierr) + write(stderrUnit, *) ' return from init_setup' !call ocn_init_setup_TEMPLATE(domain, ierr) call mpas_timer_start('io_write', .false.) @@ -332,6 +335,8 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, iErr)!{ iErr = ior(iErr, err_tmp) call ocn_init_validate_cvmix_WSwSBF(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) + call ocn_init_validate_iso(configPool, packagePool, iErr=err_tmp) + iErr = ior(iErr, err_tmp) ! call ocn_config_TEMPLATE_validate(configPool, packagePool, iErr=err_tmp) ! iErr = ior(iErr, err_tmp) end subroutine ocn_init_mode_validate_configuration!}}} From d0f6c7f193d9d9bf45ed29122686034f5e579d53 Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Tue, 25 Aug 2015 07:20:59 -0600 Subject: [PATCH 0190/1724] adding SOMA test case --- src/core_ocean/mode_init/Makefile | 3 + src/core_ocean/mode_init/Registry.xml | 1 + src/core_ocean/mode_init/mpas_ocn_init_soma.F | 418 ++++++++++++++++++ 3 files changed, 422 insertions(+) create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_soma.F diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile index 53bc8508f9..5fcec0d34f 100644 --- a/src/core_ocean/mode_init/Makefile +++ b/src/core_ocean/mode_init/Makefile @@ -12,6 +12,7 @@ TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ mpas_ocn_init_overflow.o \ mpas_ocn_init_cvmix_WSwSBF.o \ mpas_ocn_init_iso.o \ + mpas_ocn_init_soma.o \ mpas_ocn_init_global_realistic.o #mpas_ocn_init_TEMPLATE.o @@ -31,6 +32,8 @@ mpas_ocn_init_baroclinic_channel.o: $(UTILS) mpas_ocn_init_iso.o: $(UTILS) +mpas_ocn_init_soma.o: $(UTILS) + mpas_ocn_init_lock_exchange.o: $(UTILS) mpas_ocn_init_internal_waves.o: $(UTILS) diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml index 5b5fd1e01b..9280fcf29c 100644 --- a/src/core_ocean/mode_init/Registry.xml +++ b/src/core_ocean/mode_init/Registry.xml @@ -5,4 +5,5 @@ #include "Registry_global_realistic.xml" #include "Registry_cvmix_WSwSBF.xml" #include "Registry_iso.xml" +#include "Registry_soma.xml" // #include "Registry_TEMPLATE.xml" diff --git a/src/core_ocean/mode_init/mpas_ocn_init_soma.F b/src/core_ocean/mode_init/mpas_ocn_init_soma.F new file mode 100644 index 0000000000..7958433f44 --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_soma.F @@ -0,0 +1,418 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_soma +! +!> \brief MPAS ocean initialize case -- Simulating Ocean Mesoscale Activity (SOMA) +!> \author Todd Ringler +!> \date 10/08/2013 +!> \details +!> This module contains the routines for initializing the +!> the idealized SOMA test case +! +!----------------------------------------------------------------------- + +module ocn_init_soma + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + + use ocn_constants + use ocn_init_vertical_grids + use ocn_init_cell_markers + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_soma, & + ocn_init_validate_soma + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_soma +! +!> \brief Setup for soma test case +!> \author Todd Ringler +!> \date 02/26/2014 +!> \details +!> This routine sets up the initial conditions for the +!> Idealized Southern Ocean configuration. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_soma(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + ! local work variables + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool, forcingPool, tracersPool + type (mpas_pool_type), pointer :: tracersSurfaceRestoringFieldsPool, tracersInteriorRestoringFieldsPool + + integer :: iCell, k + real (kind=RKIND) :: distance, zMid, sphereRadius + real (kind=RKIND) :: currentLon, currentLat + real (kind=RKIND) :: deltay, depth, factor, latCenter, lonCenter, windStress + real (kind=RKIND) :: temperature, salinity + real (kind=RKIND), dimension(:), pointer :: interfaceLocations + + ! Define config variable pointers + character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid + + ! SOMA test case run-time configuration parameters + integer, pointer :: config_soma_vert_levels + real, pointer :: config_soma_center_latitude + real, pointer :: config_soma_center_longitude + real, pointer :: config_soma_domain_width + real, pointer :: config_soma_shelf_width + real, pointer :: config_soma_bottom_depth + real, pointer :: config_soma_phi + real, pointer :: config_soma_ref_density + real, pointer :: config_soma_density_difference + + ! Define dimension pointers + integer, pointer :: nVertLevels, nCells, nVertLevelsP1 + integer, pointer :: index_temperature, index_salinity, index_tracer1 + + ! Define variable pointers + logical, pointer :: on_a_sphere + integer, dimension(:), pointer :: maxLevelCell + real (kind=RKIND), dimension(:), pointer :: refBottomDepth, bottomCell, refZMid + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness + real (kind=RKIND), pointer :: sphere_radius + real (kind=RKIND), dimension(:), pointer :: lonCell, latCell, bottomDepth + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers, debugTracers + real (kind=RKIND), dimension(:), pointer :: sensibleHeatFlux + real (kind=RKIND), dimension(:), pointer :: windStressZonal, windStressMeridional + real (kind=RKIND), dimension(:, :), pointer :: activeTracersPistonVelocity, activeTracersSurfaceRestoringValue + real (kind=RKIND), dimension(:, :, :), pointer :: activeTracersInteriorRestoringValue, activeTracersInteriorRestoringRate + +! TDR SOMA variable here + ! Define variables for SOMA test case + real (kind=RKIND) :: tmpREAL + logical :: tmpLOGICAL + + iErr = 0 + + write(stderrUnit, *) ' soma start 0' + + call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) + if(config_init_configuration .ne. trim('soma')) return + + ! get config variables + call mpas_pool_get_config(domain % configs, 'config_vertical_grid', config_vertical_grid) + call mpas_pool_get_config(domain % configs, 'config_soma_vert_levels', config_soma_vert_levels) + call mpas_pool_get_config(domain % configs, 'config_soma_center_latitude', config_soma_center_latitude) + call mpas_pool_get_config(domain % configs, 'config_soma_center_longitude', config_soma_center_longitude) + call mpas_pool_get_config(domain % configs, 'config_soma_domain_width', config_soma_domain_width) + call mpas_pool_get_config(domain % configs, 'config_soma_shelf_width', config_soma_shelf_width) + call mpas_pool_get_config(domain % configs, 'config_soma_bottom_depth', config_soma_bottom_depth) + call mpas_pool_get_config(domain % configs, 'config_soma_phi', config_soma_phi) + call mpas_pool_get_config(domain % configs, 'config_soma_ref_density', config_soma_ref_density) + call mpas_pool_get_config(domain % configs, 'config_soma_density_difference', config_soma_density_difference) + + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nVertLevelsP1', nVertLevelsP1) + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(meshPool, 'sphere_radius', sphere_radius) + + if(.not. on_a_sphere) then + write(stderrUnit, *) 'ERROR: SOMA test case can only be defined on a spherical mesh.' + iErr = 1 + return + end if + + write(stderrUnit, *) 'soma 1', nVertLevelsP1 + + ! Define interface locations + allocate( interfaceLocations( nVertLevelsP1 ) ) + call ocn_generate_vertical_grid( config_vertical_grid, interfaceLocations ) + + write(stderrUnit, *) ' soma 2', interfaceLocations + + ! assign config variables + nVertLevels = config_soma_vert_levels + +!TDR assign variables here + + ! Convert center locations to radians from degrees + latCenter = config_soma_center_latitude * pii / 180.0 + lonCenter = config_soma_center_longitude * pii / 180.0 + + write(stderrUnit, *) 'soma 3' + + !!!!!!!!!!!!!!!!!!!!!!!!! + ! Setup the vertical grid + !!!!!!!!!!!!!!!!!!!!!!!!! + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + + ! Set layerThickness and restingThickness + do k = 1, nVertLevels + layerThickness(k, :) = config_soma_basin_depth * ( interfaceLocations(k+1) - interfaceLocations(k) ) + restingThickness(k, :) = layerThickness(k, :) + end do + + ! Set refBottomDepth + do k = 1, nVertLevels + refBottomDepth(k) = config_soma_basin_depth * interfaceLocations(k+1) + refZMid(k) = -config_soma_basin_depth * (interfaceLocations(k)+interfaceLocations(k+1))/2.0_RKIND + end do + + block_ptr => block_ptr % next + + end do + + write(stderrUnit, *) 'soma 4', refZMid + + + !!!!!!!!!!!!!!!!!!!!!!!!! + ! Set Topography + !!!!!!!!!!!!!!!!!!!!!!!!! + write(*,*) 'setting up topography' + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + + ! set bottomDepth + bottomDepth(:) = 0.0_RKIND + do iCell = 1, nCells + currentLon = lonCell(iCell) + currentLat = latCell(iCell) + + distance = sqrt( sin(0.5*(latCenter-currentLat))**2 + & + cos(latCell)*cos(latCenter)*sin(0.5*(lonCenter-currentLon))**2 ) + distance = 2.0 * sphere_radius * asin(distance) + distance = 1.0 - distance**2 / config_soma_domain_width**2 + + if(distance > config_soma_shelf_width) then + depth = -100.0 - (config_soma_bottom_depth-100.0)/2.0 * (1.0 + tanh(distance/config_soma_phi)) + else + depth = 100.0 + endif + bottomDepth(iCell) = -depth + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Set maxLevelCell to -1 for cells to be culled + if (bottomDepth(iCell) > 0.0) then + maxLevelCell(iCell) = 1 + else + maxLevelCell(iCell) = -1 + endif + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Determine maxLevelCell based on bottomDepth and refBottomDepth + ! Also set botomDepth based on refBottomDepth, since + ! above bottomDepth was set with continuous analytical functions, + ! and needs to be discrete + if (maxLevelCell(iCell) > 0) then + maxLevelCell(iCell) = nVertLevels + if (nVertLevels .gt. 1) then + do k = 1, nVertLevels + if (bottomDepth(iCell) < refBottomDepth(k) ) then + maxLevelCell(iCell) = k-1 + bottomDepth(iCell) = refBottomDepth(k-1) + exit + end if + end do + end if + end if + + enddo ! Looping through with iCell + + block_ptr => block_ptr % next + + enddo ! done setting topography + + write(stderrUnit, *) 'soma 5', maxval(bottomDepth), maxval(maxLevelCell) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! mark cells for culling + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call ocn_mark_maxlevelcell(meshPool, iErr) + block_ptr => block_ptr % next + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Set forcing boundary conditions and initial conditions + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(*,*) 'setting up forcing and boundary conditions' + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_salinity) + call mpas_pool_get_dimension(tracersPool, 'index_tracer1', index_tracer1) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + call mpas_pool_get_array(tracersPool, 'debugTracers', debugTracers, 1) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + call mpas_pool_get_array(forcingPool, 'sensibleHeatFlux', sensibleHeatFlux) + call mpas_pool_get_array(forcingPool, 'windStressZonal', windStressZonal) + call mpas_pool_get_array(forcingPool, 'windStressMeridional', windStressMeridional, 1) + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) + call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersPistonVelocity', activeTracersPistonVelocity, 1) + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersSurfaceRestoringValue', activeTracersSurfaceRestoringValue, 1) + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringRate', activeTracersInteriorRestoringRate, 1) + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringValue', activeTracersInteriorRestoringValue, 1) + + do iCell = 1, nCells + currentLon = lonCell(iCell) + currentLat = latCell(iCell) + + ! Set initial temperature and salinity + do k = 1, nVertLevels + zMid = refZMid(k) + + distance = config_soma_ref_density - (1.0 - 0.05) * config_soma_density_difference * tanh(zMid / 300.0) & + - 0.05 * config_soma_density_difference * zMid / config_soma_bottom_depth + factor = (config_soma_ref_density - distance) / 0.25_RKIND + temperature = 20.0 + factor + factor = - zMid / 1250.0_RKIND + salinity = 34.0 + factor + + activeTracers(index_temperature, k, iCell) = temperature + activeTracers(index_salinity, k, iCell) = salinity + + enddo + + ! Set up debugging tracers + debugTracers(index_tracer1, :, iCell) = 1.0_RKIND + + end do ! iCell = 1, nCells + + write(stderrUnit, *) 'soma 6' + + ! Set wind stress + do iCell = 1, nCells + currentLon = lonCell(iCell) + currentLat = latCell(iCell) + + deltay = sphere_radius * ( currentLat - latCenter * pii / 180.0) + factor = 1.0 - 0.5 * deltay / config_soma_domain_width + windstress = factor * 0.1 * exp( -(deltay / config_soma_domain_width)**2 ) & + * cos(pii * deltay / config_soma_domain_width) + + windStressZonal(iCell) = windStress + windStressMeridional(iCell) = 0.0_RKIND + + end do + + block_ptr => block_ptr % next + end do + + write(*,*) 'exiting ocn_init_setup_soma' + + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_soma!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_soma +! +!> \brief Validation for SOMA test case +!> \author Todd Ringler +!> \date 02/26/2014 +!> \details +!> This routine validates the configuration options for the SOMA test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_soma(configPool, packagePool, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: configPool, packagePool + integer, intent(out) :: iErr + + character (len=StrKIND), pointer :: config_init_configuration + integer, pointer :: config_vert_levels, config_soma_vert_levels + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + if(config_init_configuration .ne. trim('soma')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_soma_vert_levels', config_soma_vert_levels) + + if(config_vert_levels <= 0 .and. config_soma_vert_levels > 0) then + config_vert_levels = config_soma_vert_levels + else if (config_vert_levels <= 0) then + write(stderrUnit,*) 'ERROR: Validation failed for SOMA. Not given a usable value for vertical levels.' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_soma!}}} + +end module ocn_init_soma + + + + + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker From 15202c154885aafba607979f94cbc40e0c97e877 Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 25 Aug 2015 10:26:19 -0600 Subject: [PATCH 0191/1724] finish first draft of SOMA test case sort out a few bugs related to sphere_radius --- src/core_ocean/mode_init/Registry_soma.xml | 38 ++++++++ src/core_ocean/mode_init/mpas_ocn_init_iso.F | 17 +--- src/core_ocean/mode_init/mpas_ocn_init_mode.F | 6 +- src/core_ocean/mode_init/mpas_ocn_init_soma.F | 87 +++++++++---------- .../mode_init/mpas_ocn_init_spherical_utils.F | 2 + 5 files changed, 87 insertions(+), 63 deletions(-) create mode 100644 src/core_ocean/mode_init/Registry_soma.xml diff --git a/src/core_ocean/mode_init/Registry_soma.xml b/src/core_ocean/mode_init/Registry_soma.xml new file mode 100644 index 0000000000..d62cd760bb --- /dev/null +++ b/src/core_ocean/mode_init/Registry_soma.xml @@ -0,0 +1,38 @@ + + + + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_iso.F b/src/core_ocean/mode_init/mpas_ocn_init_iso.F index 326662ecac..cc75694c86 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_iso.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_iso.F @@ -240,8 +240,6 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ iErr = 0 - write(stderrUnit, *) ' iso start 0' - call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) if(config_init_configuration .ne. trim('iso')) return @@ -342,16 +340,14 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ write(stderrUnit, *) 'ERROR: ISO test case can only be defined on a spherical mesh.' iErr = 1 return + else + write(stderrUnit, *) 'ISO test case using spherical radius of size: ', sphereRadius end if - write(stderrUnit, *) 'iso 1', nVertLevelsP1 - ! Define interface locations allocate( interfaceLocations( nVertLevelsP1 ) ) call ocn_generate_vertical_grid( config_vertical_grid, interfaceLocations ) - write(stderrUnit, *) ' iso 2', interfaceLocations - ! assign config variables nVertLevels = config_iso_vert_levels mainChannelDepth = config_iso_main_channel_depth @@ -437,8 +433,6 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ tempRestoreLcy4 = config_iso_temperature_restore_lcy4 - write(stderrUnit, *) 'iso 3' - !!!!!!!!!!!!!!!!!!!!!!!!! ! Setup the vertical grid !!!!!!!!!!!!!!!!!!!!!!!!! @@ -470,9 +464,6 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ end do - write(stderrUnit, *) 'iso 4', refZMid - - !!!!!!!!!!!!!!!!!!!!!!!!! ! Set Topography !!!!!!!!!!!!!!!!!!!!!!!!! @@ -614,8 +605,6 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ block_ptr => block_ptr % next enddo ! done setting topography - write(stderrUnit, *) 'iso 5', maxval(bottomDepth), maxval(maxLevelCell) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! mark cells for culling !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -806,8 +795,6 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ end do ! iCell = 1, nCells - write(stderrUnit, *) 'iso 6' - ! juan: add code here for surface restoring. can be toggled on/off at runtime ! fill activeTracersSurfaceRestoringValue with correct values ! fill activeTracersPistonVelocity with correct values diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 142df531e1..1b274879aa 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -45,6 +45,7 @@ module ocn_init_mode use ocn_init_global_realistic use ocn_init_cvmix_WSwSBF use ocn_init_iso + use ocn_init_soma implicit none private @@ -251,9 +252,10 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call ocn_init_setup_global_realistic(domain, ierr) call ocn_init_setup_cvmix_WSwSBF(domain, ierr) call ocn_init_setup_iso(domain, ierr) - write(stderrUnit, *) ' return from init_setup' + call ocn_init_setup_soma(domain, ierr) !call ocn_init_setup_TEMPLATE(domain, ierr) + write(stderrUnit, *) ' Completed setup of: ' // trim(config_init_configuration) call mpas_timer_start('io_write', .false.) call mpas_stream_mgr_write(domain % streamManager, ierr=ierr) call mpas_timer_stop('io_write') @@ -337,6 +339,8 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, iErr)!{ iErr = ior(iErr, err_tmp) call ocn_init_validate_iso(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) + call ocn_init_validate_soma(configPool, packagePool, iErr=err_tmp) + iErr = ior(iErr, err_tmp) ! call ocn_config_TEMPLATE_validate(configPool, packagePool, iErr=err_tmp) ! iErr = ior(iErr, err_tmp) end subroutine ocn_init_mode_validate_configuration!}}} diff --git a/src/core_ocean/mode_init/mpas_ocn_init_soma.F b/src/core_ocean/mode_init/mpas_ocn_init_soma.F index 7958433f44..0654cc0bc4 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_soma.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_soma.F @@ -86,8 +86,8 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ type (mpas_pool_type), pointer :: tracersSurfaceRestoringFieldsPool, tracersInteriorRestoringFieldsPool integer :: iCell, k - real (kind=RKIND) :: distance, zMid, sphereRadius - real (kind=RKIND) :: currentLon, currentLat + real (kind=RKIND) :: distance, deltaLon, deltaLat, xDistance, yDistance, zMid, sphereRadius + real (kind=RKIND) :: lonCurrent, latCurrent real (kind=RKIND) :: deltay, depth, factor, latCenter, lonCenter, windStress real (kind=RKIND) :: temperature, salinity real (kind=RKIND), dimension(:), pointer :: interfaceLocations @@ -123,15 +123,8 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ real (kind=RKIND), dimension(:, :), pointer :: activeTracersPistonVelocity, activeTracersSurfaceRestoringValue real (kind=RKIND), dimension(:, :, :), pointer :: activeTracersInteriorRestoringValue, activeTracersInteriorRestoringRate -! TDR SOMA variable here - ! Define variables for SOMA test case - real (kind=RKIND) :: tmpREAL - logical :: tmpLOGICAL - iErr = 0 - write(stderrUnit, *) ' soma start 0' - call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) if(config_init_configuration .ne. trim('soma')) return @@ -152,36 +145,31 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ call mpas_pool_get_dimension(meshPool, 'nVertLevelsP1', nVertLevelsP1) call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(meshPool, 'sphere_radius', sphere_radius) + sphereRadius = sphere_radius if(.not. on_a_sphere) then write(stderrUnit, *) 'ERROR: SOMA test case can only be defined on a spherical mesh.' iErr = 1 return + else + write(stderrUnit, *) 'SOMA test case using spherical radius of size: ', sphereRadius end if - write(stderrUnit, *) 'soma 1', nVertLevelsP1 - ! Define interface locations allocate( interfaceLocations( nVertLevelsP1 ) ) call ocn_generate_vertical_grid( config_vertical_grid, interfaceLocations ) - write(stderrUnit, *) ' soma 2', interfaceLocations - ! assign config variables nVertLevels = config_soma_vert_levels -!TDR assign variables here - ! Convert center locations to radians from degrees latCenter = config_soma_center_latitude * pii / 180.0 lonCenter = config_soma_center_longitude * pii / 180.0 - write(stderrUnit, *) 'soma 3' - !!!!!!!!!!!!!!!!!!!!!!!!! ! Setup the vertical grid !!!!!!!!!!!!!!!!!!!!!!!!! - + block_ptr => domain % blocklist do while(associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) @@ -195,27 +183,26 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ ! Set layerThickness and restingThickness do k = 1, nVertLevels - layerThickness(k, :) = config_soma_basin_depth * ( interfaceLocations(k+1) - interfaceLocations(k) ) + layerThickness(k, :) = config_soma_bottom_depth * ( interfaceLocations(k+1) - interfaceLocations(k) ) restingThickness(k, :) = layerThickness(k, :) end do ! Set refBottomDepth do k = 1, nVertLevels - refBottomDepth(k) = config_soma_basin_depth * interfaceLocations(k+1) - refZMid(k) = -config_soma_basin_depth * (interfaceLocations(k)+interfaceLocations(k+1))/2.0_RKIND + refBottomDepth(k) = config_soma_bottom_depth * interfaceLocations(k+1) + refZMid(k) = -config_soma_bottom_depth * (interfaceLocations(k)+interfaceLocations(k+1))/2.0_RKIND end do + block_ptr => block_ptr % next end do - write(stderrUnit, *) 'soma 4', refZMid - !!!!!!!!!!!!!!!!!!!!!!!!! ! Set Topography !!!!!!!!!!!!!!!!!!!!!!!!! - write(*,*) 'setting up topography' + write(stderrUnit,*) 'setting up topography' block_ptr => domain % blocklist do while(associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) @@ -228,20 +215,30 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ ! set bottomDepth bottomDepth(:) = 0.0_RKIND do iCell = 1, nCells - currentLon = lonCell(iCell) - currentLat = latCell(iCell) - - distance = sqrt( sin(0.5*(latCenter-currentLat))**2 + & - cos(latCell)*cos(latCenter)*sin(0.5*(lonCenter-currentLon))**2 ) - distance = 2.0 * sphere_radius * asin(distance) - distance = 1.0 - distance**2 / config_soma_domain_width**2 - - if(distance > config_soma_shelf_width) then - depth = -100.0 - (config_soma_bottom_depth-100.0)/2.0 * (1.0 + tanh(distance/config_soma_phi)) + lonCurrent = lonCell(iCell) + latCurrent = latCell(iCell) + + sphereRadius = 6371.0*1000.0 + deltaLon = abs (mod(lonCurrent - lonCenter, 2.0_RKIND*pii)) + deltaLat = abs (latCurrent - latCenter) + xDistance = deltaLon * sphereRadius * cos(latCurrent) + yDistance = deltaLat * sphereRadius + distance = sqrt( xDistance**2 + yDistance**2 ) + factor = 1.0 - distance**2 / config_soma_domain_width**2 + + write(20,10) iCell, deltaLon, deltaLat, xDistance, yDistance, distance + 10 format(i6, 6e14.4) + + if(distance < config_soma_domain_width) then + if(factor > config_soma_shelf_width) then + depth = 100.0 + (config_soma_bottom_depth-100.0)/2.0 * (1.0 + tanh(distance/config_soma_phi)) + else + depth = 100.0 + endif + bottomDepth(iCell) = depth else - depth = 100.0 + bottomDepth(iCell) = -1.0_RKIND endif - bottomDepth(iCell) = -depth !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Set maxLevelCell to -1 for cells to be culled @@ -275,8 +272,6 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ enddo ! done setting topography - write(stderrUnit, *) 'soma 5', maxval(bottomDepth), maxval(maxLevelCell) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! mark cells for culling !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -290,7 +285,7 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Set forcing boundary conditions and initial conditions !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - write(*,*) 'setting up forcing and boundary conditions' + write(stderrUnit,*) 'setting up forcing and boundary conditions' block_ptr => domain % blocklist do while(associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) @@ -317,8 +312,8 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringValue', activeTracersInteriorRestoringValue, 1) do iCell = 1, nCells - currentLon = lonCell(iCell) - currentLat = latCell(iCell) + lonCurrent = lonCell(iCell) + latCurrent = latCell(iCell) ! Set initial temperature and salinity do k = 1, nVertLevels @@ -341,14 +336,12 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ end do ! iCell = 1, nCells - write(stderrUnit, *) 'soma 6' - ! Set wind stress do iCell = 1, nCells - currentLon = lonCell(iCell) - currentLat = latCell(iCell) + lonCurrent = lonCell(iCell) + latCurrent = latCell(iCell) - deltay = sphere_radius * ( currentLat - latCenter * pii / 180.0) + deltay = sphereRadius * ( latCurrent - latCenter ) factor = 1.0 - 0.5 * deltay / config_soma_domain_width windstress = factor * 0.1 * exp( -(deltay / config_soma_domain_width)**2 ) & * cos(pii * deltay / config_soma_domain_width) @@ -361,7 +354,7 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ block_ptr => block_ptr % next end do - write(*,*) 'exiting ocn_init_setup_soma' + write(stderrUnit,*) 'exiting ocn_init_setup_soma' !-------------------------------------------------------------------- diff --git a/src/core_ocean/mode_init/mpas_ocn_init_spherical_utils.F b/src/core_ocean/mode_init/mpas_ocn_init_spherical_utils.F index ed911e1c0b..6acf1ab44b 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_spherical_utils.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_spherical_utils.F @@ -243,7 +243,9 @@ subroutine ocn_init_expand_sphere(domain, stream_manager, newRadius, err)!{{{ end do block_ptr % domain % sphere_radius = newRadius + sphere_radius = newRadius block_ptr => block_ptr % next + end do !-------------------------------------------------------------------- From 175b625de0b3695fd11c8bf8f14cce1794aacf63 Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 25 Aug 2015 14:37:52 -0600 Subject: [PATCH 0192/1724] more minor edits --- src/core_ocean/mode_init/mpas_ocn_init_iso.F | 5 +++-- src/core_ocean/mode_init/mpas_ocn_init_soma.F | 11 +++++------ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_iso.F b/src/core_ocean/mode_init/mpas_ocn_init_iso.F index cc75694c86..b9f81b5ec3 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_iso.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_iso.F @@ -798,8 +798,9 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ ! juan: add code here for surface restoring. can be toggled on/off at runtime ! fill activeTracersSurfaceRestoringValue with correct values ! fill activeTracersPistonVelocity with correct values - activeTracersSurfaceRestoringValue(:,:) = 0.0_RKIND - activeTracersPistonVelocity(:,:) = 0.0_RKIND + activeTracersSurfaceRestoringValue(index_temperature,:) = activeTracers(index_temperature, 1, :) + activeTracersSurfaceRestoringValue(index_salinity,:) = activeTracers(index_salinity, 1, :) + activeTracersPistonVelocity(:,:) = 0.0 ! Set wind stress widthWindASFRad = 1.1*contSlopeWidthRad diff --git a/src/core_ocean/mode_init/mpas_ocn_init_soma.F b/src/core_ocean/mode_init/mpas_ocn_init_soma.F index 0654cc0bc4..880af5b09a 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_soma.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_soma.F @@ -218,16 +218,15 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ lonCurrent = lonCell(iCell) latCurrent = latCell(iCell) - sphereRadius = 6371.0*1000.0 - deltaLon = abs (mod(lonCurrent - lonCenter, 2.0_RKIND*pii)) - deltaLat = abs (latCurrent - latCenter) + deltaLon = abs(lonCurrent - lonCenter) + if (deltaLon .gt. pii) deltaLon = deltaLon - 2.0_RKIND*pii + deltaLat = latCurrent - latCenter xDistance = deltaLon * sphereRadius * cos(latCurrent) yDistance = deltaLat * sphereRadius distance = sqrt( xDistance**2 + yDistance**2 ) factor = 1.0 - distance**2 / config_soma_domain_width**2 - - write(20,10) iCell, deltaLon, deltaLat, xDistance, yDistance, distance - 10 format(i6, 6e14.4) + write(20,10) iCell, deltaLon, deltaLat, sphereRadius, distance + 10 format(i5,4e20.10) if(distance < config_soma_domain_width) then if(factor > config_soma_shelf_width) then From 1bbbeb95178a2a0e93e87aa45c2beb92471726b0 Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 25 Aug 2015 15:24:30 -0600 Subject: [PATCH 0193/1724] formatting clean up fixing restoring (surface and interior) --- src/core_ocean/mode_init/Registry_iso.xml | 484 +++++++++---------- src/core_ocean/mode_init/mpas_ocn_init_iso.F | 34 +- 2 files changed, 254 insertions(+), 264 deletions(-) diff --git a/src/core_ocean/mode_init/Registry_iso.xml b/src/core_ocean/mode_init/Registry_iso.xml index 313a8e516d..07d97485aa 100644 --- a/src/core_ocean/mode_init/Registry_iso.xml +++ b/src/core_ocean/mode_init/Registry_iso.xml @@ -1,135 +1,128 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - - + + + + + + + - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_iso.F b/src/core_ocean/mode_init/mpas_ocn_init_iso.F index b9f81b5ec3..0e3ae31d78 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_iso.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_iso.F @@ -143,6 +143,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ real (kind=RKIND), pointer :: config_iso_heat_flux_lat_ss real (kind=RKIND), pointer :: config_iso_heat_flux_lat_sm real (kind=RKIND), pointer :: config_iso_heat_flux_lat_mn + real (kind=RKIND), pointer :: config_iso_surface_temp_piston_vel real (kind=RKIND), pointer :: config_iso_initial_temp_t1 real (kind=RKIND), pointer :: config_iso_initial_temp_t2 real (kind=RKIND), pointer :: config_iso_initial_temp_h0 @@ -167,6 +168,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ real (kind=RKIND), pointer :: config_iso_temperature_sponge_t1 real (kind=RKIND), pointer :: config_iso_temperature_sponge_h1 real (kind=RKIND), pointer :: config_iso_temperature_sponge_l1 + real (kind=RKIND), pointer :: config_iso_temperature_sponge_tau1 logical, pointer :: config_iso_temperature_restore_region1_flag real (kind=RKIND), pointer :: config_iso_temperature_restore_t1 @@ -221,14 +223,14 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ real (kind=RKIND) :: salinity0 real (kind=RKIND) :: windStressMax, windASF, windACC, latWindTrans real (kind=RKIND) :: QSouth, QNorth, QMiddle, transSS, transSM, transMN - real (kind=RKIND) :: tempT1, tempT2, temph1, tempmT, temph0, tempLatS, tempLatN + real (kind=RKIND) :: tempPistonVel, tempT1, tempT2, temph1, tempmT, temph0, tempLatS, tempLatN real (kind=RKIND) :: regionCenterLat1, regionCenterLon1, regionCenterLat2, regionCenterLon2 real (kind=RKIND) :: regionCenterLat3, regionCenterLon3, regionCenterLat4, regionCenterLon4 logical :: heatRegionFlag1 real (kind=RKIND) :: heatRegion1flux, heatRegion1Radius logical :: heatRegionFlag2 real (kind=RKIND) :: heatRegion2flux, heatRegion2Radius - real (kind=RKIND) :: tempSpongeT1, tempSpongeh1, tempSpongeWeightL1 + real (kind=RKIND) :: tempSpongeT1, tempSpongeh1, tempSpongeWeightL1, tempSpongeTau1 logical :: tempRestoreFlag1 real (kind=RKIND) :: tempRestoreT1, tempRestoreLcx1, tempRestoreLcy1 logical :: tempRestoreFlag2 @@ -286,6 +288,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_lat_ss', config_iso_heat_flux_lat_ss) call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_lat_sm', config_iso_heat_flux_lat_sm) call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_lat_mn', config_iso_heat_flux_lat_mn) + call mpas_pool_get_config(domain % configs, 'config_iso_surface_temp_piston_vel', config_iso_surface_temp_piston_vel) call mpas_pool_get_config(domain % configs, 'config_iso_initial_temp_t1', config_iso_initial_temp_t1) call mpas_pool_get_config(domain % configs, 'config_iso_initial_temp_t2', config_iso_initial_temp_t2) call mpas_pool_get_config(domain % configs, 'config_iso_initial_temp_h0', config_iso_initial_temp_h0) @@ -310,6 +313,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ call mpas_pool_get_config(domain % configs, 'config_iso_temperature_sponge_t1', config_iso_temperature_sponge_t1) call mpas_pool_get_config(domain % configs, 'config_iso_temperature_sponge_h1', config_iso_temperature_sponge_h1) call mpas_pool_get_config(domain % configs, 'config_iso_temperature_sponge_l1', config_iso_temperature_sponge_l1) + call mpas_pool_get_config(domain % configs, 'config_iso_temperature_sponge_tau1', config_iso_temperature_sponge_tau1) call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_region1_flag', config_iso_temperature_restore_region1_flag) call mpas_pool_get_config(domain % configs, 'config_iso_temperature_restore_t1', config_iso_temperature_restore_t1) @@ -390,6 +394,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ transSS = config_iso_heat_flux_lat_ss * pii/180.0 transSM = config_iso_heat_flux_lat_sm * pii/180.0 transMN = config_iso_heat_flux_lat_mn * pii/180.0 + tempPistonVel = config_iso_surface_temp_piston_vel tempT1 = config_iso_initial_temp_t1 tempT2 = config_iso_initial_temp_t2 temph0 = config_iso_initial_temp_h0 @@ -414,6 +419,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ tempSpongeT1 = config_iso_temperature_sponge_t1 tempSpongeh1 = config_iso_temperature_sponge_h1 tempSpongeWeightL1 = config_iso_temperature_sponge_l1 + tempSpongeTau1 = config_iso_temperature_sponge_tau1 tempRestoreFlag1 = config_iso_temperature_restore_region1_flag tempRestoreT1 = config_iso_temperature_restore_t1 @@ -645,6 +651,11 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringRate', activeTracersInteriorRestoringRate, 1) call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringValue', activeTracersInteriorRestoringValue, 1) + activeTracersInteriorRestoringRate(:,:,:) = 0.0_RKIND + activeTracersInteriorRestoringValue(:,:,:) = 0.0_RKIND + activeTracersPistonVelocity(:,:) = 0.0_RKIND + activeTracersSurfaceRestoringValue(:,:) = 0.0_RKIND + do iCell = 1, nCells currentLon = lonCell(iCell) currentLat = latCell(iCell) @@ -724,8 +735,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ activeTracersInteriorRestoringValue(idx, k, iCell) = temperature idx = index_temperature - ! note to juan: activeTracersInteriorRestoringRate has units of 1/s throughout - activeTracersInteriorRestoringRate(idx, k, iCell) = exp(-abs(distance)/tempSpongeWeightL1) + activeTracersInteriorRestoringRate(idx, k, iCell) = exp(-abs(distance)/tempSpongeWeightL1) * ( 1.0_RKIND / (tempSpongeTau1*86400.0_RKIND)) endif ! Interior restoring at localized region 1 @@ -737,7 +747,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ activeTracersInteriorRestoringValue(idx, k, iCell) = TempRestoreT1 idx = index_temperature - activeTracersInteriorRestoringRate(idx, k, iCell) = & + activeTracersInteriorRestoringRate(idx, k, iCell) = ( 1.0_RKIND / (tempSpongeTau1*86400.0_RKIND)) * & exp(-(2.0_RKIND*xDistance/tempRestoreLcx1)**2 - (2.0_RKIND*yDistance/tempRestoreLcy1)**2 ) endif endif @@ -751,7 +761,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ activeTracersInteriorRestoringValue(idx, k, iCell) = TempRestoreT2 idx = index_temperature - activeTracersInteriorRestoringRate(idx, k, iCell) = & + activeTracersInteriorRestoringRate(idx, k, iCell) = ( 1.0_RKIND / (tempSpongeTau1*86400.0_RKIND)) * & exp(-(2.0_RKIND*xDistance/tempRestoreLcx2)**2 - (2.0_RKIND*yDistance/tempRestoreLcy2)**2 ) endif endif @@ -765,7 +775,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ activeTracersInteriorRestoringValue(idx, k, iCell) = TempRestoreT3 idx = index_temperature - activeTracersInteriorRestoringRate(idx, k, iCell) = & + activeTracersInteriorRestoringRate(idx, k, iCell) = ( 1.0_RKIND / (tempSpongeTau1*86400.0_RKIND)) * & exp(-(2.0_RKIND*xDistance/tempRestoreLcx3)**2 - (2.0_RKIND*yDistance/tempRestoreLcy3)**2 ) endif endif @@ -779,7 +789,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ activeTracersInteriorRestoringValue(idx, k, iCell) = TempRestoreT4 idx = index_temperature - activeTracersInteriorRestoringRate(idx, k, iCell) = & + activeTracersInteriorRestoringRate(idx, k, iCell) = ( 1.0_RKIND / (tempSpongeTau1*86400.0_RKIND)) * & exp(-(2.0_RKIND*xDistance/tempRestoreLcx4)**2 - (2.0_RKIND*yDistance/tempRestoreLcy4)**2 ) endif endif @@ -795,12 +805,12 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ end do ! iCell = 1, nCells - ! juan: add code here for surface restoring. can be toggled on/off at runtime - ! fill activeTracersSurfaceRestoringValue with correct values - ! fill activeTracersPistonVelocity with correct values + ! fill activeTracersSurfaceRestoringValue surface restoring values + ! fill activeTracersPistonVelocity with surface restoring rate activeTracersSurfaceRestoringValue(index_temperature,:) = activeTracers(index_temperature, 1, :) + activeTracersPistonVelocity(index_temperature,:) = tempPistonVel activeTracersSurfaceRestoringValue(index_salinity,:) = activeTracers(index_salinity, 1, :) - activeTracersPistonVelocity(:,:) = 0.0 + activeTracersPistonVelocity(index_salinity,:) = 0.0_RKIND ! Set wind stress widthWindASFRad = 1.1*contSlopeWidthRad From 7dd1920cce8848535c5046088f990bfebc751673 Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 25 Aug 2015 16:07:26 -0600 Subject: [PATCH 0194/1724] add runtime config controlling depth of continental shelf fixed log controlling size of basin --- src/core_ocean/mode_init/Registry_soma.xml | 4 ++++ src/core_ocean/mode_init/mpas_ocn_init_soma.F | 17 ++++++----------- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/src/core_ocean/mode_init/Registry_soma.xml b/src/core_ocean/mode_init/Registry_soma.xml index d62cd760bb..b1c9c8e0c0 100644 --- a/src/core_ocean/mode_init/Registry_soma.xml +++ b/src/core_ocean/mode_init/Registry_soma.xml @@ -27,6 +27,10 @@ description="Width of the continential shelf." possible_values="Any real number" /> + config_soma_shelf_width) then - depth = 100.0 + (config_soma_bottom_depth-100.0)/2.0 * (1.0 + tanh(distance/config_soma_phi)) - else - depth = 100.0 - endif - bottomDepth(iCell) = depth + + if(factor > config_soma_shelf_width) then + bottomDepth(iCell) = config_soma_shelf_depth + (config_soma_bottom_depth-config_soma_shelf_depth)/2.0 * (1.0 + tanh(factor/config_soma_phi)) else - bottomDepth(iCell) = -1.0_RKIND + bottomDepth(iCell) = -1.0_RKIND endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 316715a679bb02d1a2a758aef97c84f0028ba36d Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Tue, 25 Aug 2015 17:18:12 -0600 Subject: [PATCH 0195/1724] removed all "hard-wired" constants and moved these values into run-time configure variables --- src/core_ocean/mode_init/Registry_soma.xml | 30 +++++++-- src/core_ocean/mode_init/mpas_ocn_init_soma.F | 64 ++++++++++--------- 2 files changed, 56 insertions(+), 38 deletions(-) diff --git a/src/core_ocean/mode_init/Registry_soma.xml b/src/core_ocean/mode_init/Registry_soma.xml index b1c9c8e0c0..a771be4049 100644 --- a/src/core_ocean/mode_init/Registry_soma.xml +++ b/src/core_ocean/mode_init/Registry_soma.xml @@ -4,8 +4,8 @@ possible_values="Any positive integer. Typically 40 or larger." /> - + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_soma.F b/src/core_ocean/mode_init/mpas_ocn_init_soma.F index 2f70f7b7a8..994c155a0b 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_soma.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_soma.F @@ -68,7 +68,7 @@ module ocn_init_soma !> \date 02/26/2014 !> \details !> This routine sets up the initial conditions for the -!> Idealized Southern Ocean configuration. +!> SOMA configuration. ! !----------------------------------------------------------------------- @@ -97,6 +97,11 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ ! SOMA test case run-time configuration parameters integer, pointer :: config_soma_vert_levels + real, pointer :: config_eos_linear_alpha + real, pointer :: config_soma_surface_salinity + real, pointer :: config_soma_surface_temperature + real, pointer :: config_soma_density_difference_linear + real, pointer :: config_soma_thermocline_depth real, pointer :: config_soma_center_latitude real, pointer :: config_soma_center_longitude real, pointer :: config_soma_domain_width @@ -124,12 +129,19 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ real (kind=RKIND), dimension(:, :), pointer :: activeTracersPistonVelocity, activeTracersSurfaceRestoringValue real (kind=RKIND), dimension(:, :, :), pointer :: activeTracersInteriorRestoringValue, activeTracersInteriorRestoringRate + ! assume no error iErr = 0 + ! test if SOMA is the desired configuration call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) if(config_init_configuration .ne. trim('soma')) return ! get config variables + call mpas_pool_get_config(domain % configs, 'config_eos_linear_alpha', config_eos_linear_alpha) + call mpas_pool_get_config(domain % configs, 'config_soma_density_difference_linear', config_soma_density_difference_linear) + call mpas_pool_get_config(domain % configs, 'config_soma_thermocline_depth', config_soma_thermocline_depth) + call mpas_pool_get_config(domain % configs, 'config_soma_surface_temperature', config_soma_surface_temperature) + call mpas_pool_get_config(domain % configs, 'config_soma_surface_salinity', config_soma_surface_salinity) call mpas_pool_get_config(domain % configs, 'config_vertical_grid', config_vertical_grid) call mpas_pool_get_config(domain % configs, 'config_soma_vert_levels', config_soma_vert_levels) call mpas_pool_get_config(domain % configs, 'config_soma_center_latitude', config_soma_center_latitude) @@ -149,6 +161,7 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ call mpas_pool_get_config(meshPool, 'sphere_radius', sphere_radius) sphereRadius = sphere_radius + ! error checking if(.not. on_a_sphere) then write(stderrUnit, *) 'ERROR: SOMA test case can only be defined on a spherical mesh.' iErr = 1 @@ -163,15 +176,15 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ ! assign config variables nVertLevels = config_soma_vert_levels - + nVertLevelsP1 = nVertLevels + 1 + + ! set center of SOMA domain ! Convert center locations to radians from degrees latCenter = config_soma_center_latitude * pii / 180.0 lonCenter = config_soma_center_longitude * pii / 180.0 - !!!!!!!!!!!!!!!!!!!!!!!!! - ! Setup the vertical grid - !!!!!!!!!!!!!!!!!!!!!!!!! - + ! Setup the vertical grid and layerThickness initial condition + write(stderrUnit,*) 'setting up vertical grid and layer thickness' block_ptr => domain % blocklist do while(associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) @@ -184,6 +197,7 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) ! Set layerThickness and restingThickness + ! Uniform layer thickness across lat/lon do k = 1, nVertLevels layerThickness(k, :) = config_soma_bottom_depth * ( interfaceLocations(k+1) - interfaceLocations(k) ) restingThickness(k, :) = layerThickness(k, :) @@ -195,16 +209,12 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ refZMid(k) = -config_soma_bottom_depth * (interfaceLocations(k)+interfaceLocations(k+1))/2.0_RKIND end do - block_ptr => block_ptr % next end do - - !!!!!!!!!!!!!!!!!!!!!!!!! - ! Set Topography - !!!!!!!!!!!!!!!!!!!!!!!!! - write(stderrUnit,*) 'setting up topography' + ! Set bathymetry + write(stderrUnit,*) 'setting up bathymetry' block_ptr => domain % blocklist do while(associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) @@ -234,7 +244,6 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ bottomDepth(iCell) = -1.0_RKIND endif - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Set maxLevelCell to -1 for cells to be culled if (bottomDepth(iCell) > 0.0) then maxLevelCell(iCell) = 1 @@ -242,7 +251,6 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ maxLevelCell(iCell) = -1 endif - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Determine maxLevelCell based on bottomDepth and refBottomDepth ! Also set botomDepth based on refBottomDepth, since ! above bottomDepth was set with continuous analytical functions, @@ -264,11 +272,9 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ block_ptr => block_ptr % next - enddo ! done setting topography + enddo ! done setting bathymetry - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! mark cells for culling - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! block_ptr => domain % blocklist do while (associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) @@ -276,10 +282,8 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ block_ptr => block_ptr % next end do - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Set forcing boundary conditions and initial conditions - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - write(stderrUnit,*) 'setting up forcing and boundary conditions' + ! Set forcing boundary conditions and initial conditions for temperature and salinity + write(stderrUnit,*) 'setting up forcing and initial T/S conditions' block_ptr => domain % blocklist do while(associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) @@ -313,12 +317,14 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ do k = 1, nVertLevels zMid = refZMid(k) - distance = config_soma_ref_density - (1.0 - 0.05) * config_soma_density_difference * tanh(zMid / 300.0) & - - 0.05 * config_soma_density_difference * zMid / config_soma_bottom_depth - factor = (config_soma_ref_density - distance) / 0.25_RKIND - temperature = 20.0 + factor - factor = - zMid / 1250.0_RKIND - salinity = 34.0 + factor + distance = config_soma_ref_density & + - (1.0_RKIND - config_soma_density_difference_linear) * config_soma_density_difference * tanh(zMid / config_soma_thermocline_depth) & + - config_soma_density_difference_linear * config_soma_density_difference * zMid / config_soma_bottom_depth + factor = (config_soma_ref_density - distance) / config_eos_linear_alpha + temperature = config_soma_surface_temperature + factor + + factor = - zMid / config_soma_bottom_depth + salinity = config_soma_surface_salinity + factor activeTracers(index_temperature, k, iCell) = temperature activeTracers(index_salinity, k, iCell) = salinity @@ -397,9 +403,5 @@ end subroutine ocn_init_validate_soma!}}} end module ocn_init_soma - - - - !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! vim: foldmethod=marker From f2dc93c204a7ce3dc2c8b452277a1d5a90004ac1 Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 26 Aug 2015 16:40:35 -0600 Subject: [PATCH 0196/1724] transitioning global ocean configuration to new tracer infrastructure --- src/core_ocean/mode_init/Makefile | 4 +- src/core_ocean/mode_init/Registry.xml | 2 +- .../mode_init/Registry_global_ocean.xml | 176 ++ .../mpas_ocn_init_global_realistic.F | 1699 ----------------- src/core_ocean/mode_init/mpas_ocn_init_mode.F | 6 +- 5 files changed, 182 insertions(+), 1705 deletions(-) create mode 100644 src/core_ocean/mode_init/Registry_global_ocean.xml delete mode 100644 src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile index 5fcec0d34f..340225be48 100644 --- a/src/core_ocean/mode_init/Makefile +++ b/src/core_ocean/mode_init/Makefile @@ -13,7 +13,7 @@ TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ mpas_ocn_init_cvmix_WSwSBF.o \ mpas_ocn_init_iso.o \ mpas_ocn_init_soma.o \ - mpas_ocn_init_global_realistic.o + mpas_ocn_init_global_ocean.o #mpas_ocn_init_TEMPLATE.o all: init_mode @@ -40,7 +40,7 @@ mpas_ocn_init_internal_waves.o: $(UTILS) mpas_ocn_init_overflow.o: $(UTILS) -mpas_ocn_init_global_realistic.o: $(UTILS) +mpas_ocn_init_global_ocean.o: $(UTILS) mpas_ocn_init_cvmix_WSwSBF.o: $(UTILS) diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml index 9280fcf29c..949da12c45 100644 --- a/src/core_ocean/mode_init/Registry.xml +++ b/src/core_ocean/mode_init/Registry.xml @@ -2,7 +2,7 @@ #include "Registry_lock_exchange.xml" #include "Registry_internal_waves.xml" #include "Registry_overflow.xml" -#include "Registry_global_realistic.xml" +#include "Registry_global_ocean.xml" #include "Registry_cvmix_WSwSBF.xml" #include "Registry_iso.xml" #include "Registry_soma.xml" diff --git a/src/core_ocean/mode_init/Registry_global_ocean.xml b/src/core_ocean/mode_init/Registry_global_ocean.xml new file mode 100644 index 0000000000..ee5bdc7f28 --- /dev/null +++ b/src/core_ocean/mode_init/Registry_global_ocean.xml @@ -0,0 +1,176 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F b/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F deleted file mode 100644 index 43de98bc15..0000000000 --- a/src/core_ocean/mode_init/mpas_ocn_init_global_realistic.F +++ /dev/null @@ -1,1699 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_init_global_realistic -! -!> \brief MPAS ocean initialize case -- Global Realistic -!> \author Doug Jacobsen -!> \date 03/04/2014 -!> \details -!> This module contains the routines for initializing the -!> the global realistic test case -! -!----------------------------------------------------------------------- - -module ocn_init_global_realistic - - use mpas_kind_types - use mpas_io_units - use mpas_derived_types - use mpas_pool_routines - use mpas_constants - use mpas_io - use mpas_io_streams - use mpas_dmpar - - use ocn_init_cell_markers - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_init_setup_global_realistic, & - ocn_init_validate_global_realistic - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - - integer :: nDepth - integer :: nLatTracer, nLonTracer - integer :: nLatWind, nLonWind - integer :: nLatTopo, nLonTopo - type (field1DReal) :: depthIC - type (field1DReal) :: windLat, windLon - type (field1DReal) :: topoLat, topoLon - type (field1DReal) :: tracerLat, tracerLon - type (field2DReal) :: topoIC, zonalWindIC, meridionalWindIC - type (field3DReal) :: temperatureIC, salinityIC - -!*********************************************************************** - -contains - -!*********************************************************************** -! -! routine ocn_init_setup_global_realistic -! -!> \brief Setup for global realistic test case -!> \author Doug Jacobsen -!> \date 03/04/2014 -!> \details -!> This routine sets up the initial conditions for the global realistic test case. -! -!----------------------------------------------------------------------- - - subroutine ocn_init_setup_global_realistic(domain, iErr)!{{{ - - !-------------------------------------------------------------------- - - type (domain_type), intent(inout) :: domain - type (mpas_pool_type), pointer :: meshPool - integer, intent(out) :: iErr - - character (len=StrKIND), pointer :: config_init_configuration - logical, pointer :: config_global_realistic_cull_inland_seas - - logical, pointer :: on_a_sphere - - iErr = 0 - - call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) - - if (trim(config_init_configuration) /= "global_realistic") return - - call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) - call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) - - if ( .not. on_a_sphere ) call mpas_dmpar_global_abort('ERROR: The global realistic configuration can only be applied to a spherical mesh. Exiting...') - - call mpas_pool_get_config(domain % configs, 'config_global_realistic_cull_inland_seas', config_global_realistic_cull_inland_seas) - - write(stderrUnit,*) 'Reading depth levels.' - call ocn_init_setup_global_realistic_read_depth_levels(domain, iErr) - - write(stderrUnit,*) 'Reading topography data.' - call ocn_init_setup_global_realistic_read_topo(domain, iErr) - write(stderrUnit,*) 'Interpolating topography data.' - call ocn_init_setup_global_realistic_interpolate_topo(domain, iErr) - write(stderrUnit,*) 'Cleaning up topography IC fields' - call ocn_init_global_realistic_destroy_topo_fields() - - if (config_global_realistic_cull_inland_seas) then - write(stderrUnit,*) 'Removing inland seas.' - call ocn_init_setup_global_realistic_cull_inland_seas(domain, iErr) - end if - - - write(stderrUnit,*) 'Reading temperature IC.' - call ocn_init_setup_global_realistic_read_temperature(domain, iErr) - write(stderrUnit,*) 'Reading salinity IC.' - call ocn_init_setup_global_realistic_read_salinity(domain, iErr) - write(stderrUnit,*) 'Reading Lat/Lon tracer coordinates' - call ocn_init_setup_global_realistic_read_tracer_lat_lon(domain, iErr) - write(stderrUnit,*) 'Interpolating tracers' - call ocn_init_setup_global_realistic_interpolate_tracers(domain, iErr) - write(stderrUnit,*) 'Cleaning up tracer IC fields' - call ocn_init_global_realistic_destroy_tracer_fields() - - write(stderrUnit,*) 'Reading windstress IC.' - call ocn_init_setup_global_realistic_read_windstress(domain, iErr) - write(stderrUnit,*) 'Interpolating windstress.' - call ocn_init_setup_global_realistic_interpolate_windstress(domain, iErr) - write(stderrUnit,*) 'Destroying windstress fields' - call ocn_init_global_realistic_destroy_windstress_fields() - - !-------------------------------------------------------------------- - - end subroutine ocn_init_setup_global_realistic!}}} - -!*********************************************************************** -! -! routine ocn_init_setup_global_realistic_read_topo -! -!> \brief Read the topography IC file -!> \author Doug Jacobsen -!> \date 03/04/2014 -!> \details -!> This routine reads the topography IC file, including latitude and longitude -!> information for topography data. -! -!----------------------------------------------------------------------- - - subroutine ocn_init_setup_global_realistic_read_topo(domain, iErr)!{{{ - type (domain_type), intent(inout) :: domain - integer, intent(out) :: iErr - - type (block_type), pointer :: block_ptr - - type (MPAS_Stream_type) :: topographyStream - - character (len=StrKIND), pointer :: config_global_realistic_topography_file, config_global_realistic_topography_lat_varname, & - config_global_realistic_topography_nlat_dimname, config_global_realistic_topography_lon_varname, & - config_global_realistic_topography_nlon_dimname, config_global_realistic_topography_varname - - logical, pointer :: config_global_realistic_topography_latlon_degrees - - integer :: iLat, iLon - - iErr = 0 - - call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_file', config_global_realistic_topography_file) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_lat_varname', config_global_realistic_topography_lat_varname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_nlat_dimname', config_global_realistic_topography_nlat_dimname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_lon_varname', config_global_realistic_topography_lon_varname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_nlon_dimname', config_global_realistic_topography_nlon_dimname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_varname', config_global_realistic_topography_varname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_topography_latlon_degrees', config_global_realistic_topography_latlon_degrees) - - ! Define stream for depth levels - call MPAS_createStream(topographyStream, config_global_realistic_topography_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) - - ! Setup topoLat, topoLon, and topoIC fields for stream to be read in - topoLat % fieldName = trim(config_global_realistic_topography_lat_varname) - topoLat % dimSizes(1) = nLatTopo - topoLat % dimNames(1) = trim(config_global_realistic_topography_nlat_dimname) - topoLat % isVarArray = .false. - topoLat % isPersistent = .true. - topoLat % isActive = .true. - topoLat % hasTimeDimension = .false. - topoLat % block => domain % blocklist - allocate(topoLat % array(nLatTopo)) - - topoLon % fieldName = trim(config_global_realistic_topography_lon_varname) - topoLon % dimSizes(1) = nLonTopo - topoLon % dimNames(1) = trim(config_global_realistic_topography_nlon_dimname) - topoLon % isVarArray = .false. - topoLon % isPersistent = .true. - topoLon % isActive = .true. - topoLon % hasTimeDimension = .false. - topoLon % block => domain % blocklist - allocate(topoLon % array(nLonTopo)) - - topoIC % fieldName = trim(config_global_realistic_topography_varname) - topoIC % dimSizes(1) = nLonTopo - topoIC % dimSizes(2) = nLatTopo - topoIC % dimNames(1) = trim(config_global_realistic_topography_nlon_dimname) - topoIC % dimNames(2) = trim(config_global_realistic_topography_nlat_dimname) - topoIC % isVarArray = .false. - topoIC % isPersistent = .true. - topoIC % isActive = .true. - topoIC % hasTimeDimension = .false. - topoIC % block => domain % blocklist - allocate(topoIC % array(nLonTopo, nLatTopo)) - - ! Add topoLat, topoLon, and topoIC fields to stream - call MPAS_streamAddField(topographyStream, topoLat, iErr) - call MPAS_streamAddField(topographyStream, topoLon, iErr) - call MPAS_streamAddField(topographyStream, topoIC, iErr) - - ! Read stream - call MPAS_readStream(topographyStream, 1, iErr) - - ! Close stream - call MPAS_closeStream(topographyStream) - - if (config_global_realistic_topography_latlon_degrees) then - topoLat % array(:) = topoLat % array(:) * pii / 180.0_RKIND - topoLon % array(:) = topoLon % array(:) * pii / 180.0_RKIND - end if - - do iLon = 1, nLonTopo - if (topoLon % array(iLon) < 0.0_RKIND) then - topoLon % array(iLon) = 2.0_RKIND * pii + topoLon % array(iLon) - end if - end do - - end subroutine ocn_init_setup_global_realistic_read_topo!}}} - -!*********************************************************************** -! -! routine ocn_init_setup_global_realistic_interpolate_topo -! -!> \brief Interpolate the topography IC to MPAS mesh -!> \author Doug Jacobsen -!> \date 03/04/2014 -!> \details -!> This routine interpolates topography data to the MPAS mesh. Currently it -!> uses a bilinear interpolation -! -!----------------------------------------------------------------------- - - subroutine ocn_init_setup_global_realistic_interpolate_topo(domain, iErr)!{{{ - type (domain_type), intent(inout) :: domain - integer, intent(out) :: iErr - - type (block_type), pointer :: block_ptr - - type (mpas_pool_type), pointer :: meshPool, scratchPool, statePool, verticalMeshPool - - real (kind=RKIND) :: currentLat, currentLon - real (kind=RKIND) :: dist, minDist, depth - real (kind=RKIND) :: alpha, beta, depthLat1, depthLat2, proposedDepth - - real (kind=RKIND), dimension(:), pointer :: latCell, lonCell, bottomDepth, refBottomDepth - real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness - - integer, pointer :: nCells, nCellsSolve, nVertLevels - - type (field1DInteger), pointer :: maxLevelCellField, smoothedLevelsField - integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell - integer, dimension(:, :), pointer :: cellsOnCell - - integer :: latSearch, lonSearch, searchIdx - integer :: iCell, coc, j, k, maxLevel - - logical, pointer :: config_global_realistic_smooth_topography - integer, pointer :: config_global_realistic_minimum_levels - - iErr = 0 - - call mpas_pool_get_config(domain % configs, 'config_global_realistic_minimum_levels', config_global_realistic_minimum_levels) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_smooth_topography', config_global_realistic_smooth_topography) - - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - - call mpas_pool_get_array(meshPool, 'latCell', latCell) - call mpas_pool_get_array(meshPool, 'lonCell', lonCell) - call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) - call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - - do iCell = 1, nCells - currentLat = latCell(iCell) - currentLon = lonCell(iCell) - - lonSearch = 1 - minDist = 2.0_RKIND * pii - do searchIdx = 1, nLonTopo - dist = abs(currentLon - topoLon % array(searchIdx)) - if (dist < minDist) then - minDist = dist - lonSearch = searchIdx - end if - end do - - latSearch = 1 - minDist = 2.0_RKIND * pii - do searchIdx = 1, nLatTopo - dist = abs(currentLat - topoLat % array(searchIdx)) - if (dist < minDist) then - minDist = dist - latSearch = searchIdx - end if - end do - - if (topoIC % array(lonSearch, latSearch) < 0.0_RKIND) then - bottomDepth(iCell) = abs(topoIC % array(lonSearch, latSearch)) - maxLevelCell(iCell) = -1 - do k = 1, nVertLevels - depth = refBottomDepth(k) - - if (depth > bottomDepth(iCell) .and. maxLevelCell(iCell) == -1) then - maxLevelCell(iCell) = k - end if - end do - - if (maxLevelCell(iCell) == -1) then - maxLevelCell(iCell) = nVertLevels - bottomDepth(iCell) = refBottomDepth( nVertLevels ) - else if (maxLevelCell(iCell) <= config_global_realistic_minimum_levels) then - maxLevelCell(iCell) = config_global_realistic_minimum_levels - bottomDepth(iCell) = refBottomDepth( config_global_realistic_minimum_levels ) - end if - - - - else - bottomDepth(iCell) = 0.0_RKIND - maxLevelCell(iCell) = -1 - end if - end do - - ! Smooth depth levels. Enforce different in maxLevelCell to only be a maximum - ! of 1 vertical level between two neighboring cells. - if (config_global_realistic_smooth_topography) then - call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) - - call mpas_pool_get_field(scratchPool, 'smoothedLevels', smoothedLevelsField) - - call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) - - call mpas_allocate_scratch_field(smoothedLevelsField, .true.) - - maxLevelCell(nCells+1) = -1 - smoothedLevelsField % array = maxLevelCell - - do iCell = 1, nCellsSolve - maxLevel = 0 - do j = 1, nEdgesOnCell(iCell) - coc = cellsOnCell(j, iCell) - maxLevel = max(maxLevel, maxLevelCell(coc)) - end do - - if (maxLevel < maxLevelCell(iCell) ) then - smoothedLevelsField % array(iCell) = maxLevel + 1 - bottomDepth(iCell) = refBottomDepth(maxLevel + 1) - end if - end do - - maxLevelCell(:) = smoothedLevelsField % array(:) - - call mpas_deallocate_scratch_field(smoothedLevelsField, .true.) - end if - - ! Enforce minimum number of layers in ocean cells. - do iCell = 1, nCells - if (maxLevelCell(iCell) > 0 .and. maxLevelCell(iCell) < config_global_realistic_minimum_levels) then - maxLevelCell(iCell) = config_global_realistic_minimum_levels - bottomDepth(iCell) = refBottomDepth(config_global_realistic_minimum_levels) - end if - end do - - block_ptr => block_ptr % next - end do - - call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) - call mpas_pool_get_field(meshPool, 'maxLevelCell', maxLevelCellField) - call mpas_dmpar_exch_halo_field(maxLevelCellField) - - ! Set layerThickness based on refBottomDepth and bottomDepth - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) - call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) - - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - - call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) - - call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) - - call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) - - do iCell = 1, nCellsSolve - if (maxLevelCell(iCell) > 0) then - - ! By going to maxLevelCell, this loop sets the layer Thickness as the full cell at the bottom. - layerThickness(1, iCell) = refBottomDepth(1) - do k = 2, maxLevelCell(iCell) - layerThickness(k, iCell) = refBottomDepth(k) - refBottomDepth(k-1) - end do - - ! The following lines could be used for partial bottom cells, but only if the temperature is interpolated in the vertical as well. - ! In version 3.0, one may alter the IC for partial bottom cells on start-up in MPAS. - !k = maxLevelCell(iCell) - !layerThickness(k, iCell) = bottomDepth(iCell) - refBottomDepth(k-1) - - restingThickness(:, iCell) = layerThickness(:, iCell) - end if - end do - - block_ptr => block_ptr % next - end do - - end subroutine ocn_init_setup_global_realistic_interpolate_topo!}}} - -!*********************************************************************** -! -! routine ocn_init_setup_global_realistic_cull_inland_seas -! -!> \brief Read the topography IC file -!> \author Doug Jacobsen -!> \date 03/04/2014 -!> \details -!> This routine removes all inland seas. These are defined as isolated ocean cells. -!> It uses a parallel version of an advancing front algorithm which might not be -!> optimal for this purpose. -! -!----------------------------------------------------------------------- - - subroutine ocn_init_setup_global_realistic_cull_inland_seas(domain, iErr)!{{{ - type (domain_type), intent(inout) :: domain - integer, intent(out) :: iErr - - type (block_type), pointer :: block_ptr - - type (mpas_pool_type), pointer :: scratchPool, meshPool - - type (field1DInteger), pointer :: cullStackField, touchedCellField, oceanCellField - - real, dimension(:), pointer :: latCell, lonCell, bottomDepth - integer, dimension(:), pointer :: stack, oceanMask, touchMask - integer, pointer :: stackSize - - real (kind=RKIND) :: currentLat, currentLon - real (kind=RKIND) :: dist, minDist - - integer :: iCell - integer :: localStackSize, globalStackSize - integer :: j, coc - integer :: touched - - integer, pointer :: nCells, nCellsSolve, nVertLevels - integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell - integer, dimension(:, :), pointer :: cellsOnCell - - iErr = 0 - - call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) - - call mpas_pool_get_field(scratchPool, 'cullStack', cullStackField) - call mpas_pool_get_field(scratchPool, 'touchedCell', touchedCellField) - call mpas_pool_get_field(scratchPool, 'oceanCell', oceanCellField) - - call mpas_allocate_scratch_field(cullStackField, .false.) - call mpas_allocate_scratch_field(touchedCellField, .false.) - call mpas_allocate_scratch_field(oceanCellField, .false.) - - ! Seed all deepest points for advancing front algorithm - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) - - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - - call mpas_pool_get_array(meshPool, 'latCell', latCell) - call mpas_pool_get_array(meshPool, 'lonCell', lonCell) - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - - call mpas_pool_get_array(scratchPool, 'cullStack', stack) - call mpas_pool_get_array(scratchPool, 'oceanCell', oceanMask) - call mpas_pool_get_array(scratchPool, 'touchedCell', touchMask) - call mpas_pool_get_array(scratchPool, 'cullStackSize', stackSize) - - stack(:) = 0 - oceanMask(:) = 0 - touchMask(:) = 0 - stackSize = 0 - - ! Add all cells that have maxLevelCell == nVertLevels to stack - do iCell = 1, nCellsSolve - if (maxLevelCell(iCell) == nVertLevels) then - stackSize = stackSize + 1 - stack(stackSize) = iCell - touchMask(iCell) = 1 - oceanMask(iCell) = 1 - end if - end do - - block_ptr => block_ptr % next - end do - - ! Advancing front algorithm continues until all stacks on all processes are empty. - globalStackSize = 1 - do while(globalStackSize /= 0) - ! Advance front on each block with a non-zero stack until stack is empty. - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) - - call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) - call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) - - call mpas_pool_get_array(scratchPool, 'cullStack', stack) - call mpas_pool_get_array(scratchPool, 'oceanCell', oceanMask) - call mpas_pool_get_array(scratchPool, 'touchedCell', touchMask) - call mpas_pool_get_array(scratchPool, 'cullStackSize', stackSize) - - touched = 0 - do while(stackSize > 0) - iCell = stack(stackSize) - stackSize = stackSize - 1 - do j = 1, nEdgesOnCell(iCell) - coc = cellsOnCell(j, iCell) - if (touchMask(coc) == 0 .and. bottomDepth(coc) > 0.0_RKIND) then - oceanMask(coc) = 1 - stackSize = stackSize + 1 - stack(stackSize) = coc - end if - touchMask(coc) = 1 - touched = touched + 1 - end do - end do - - block_ptr => block_ptr % next - end do - - ! Perform a halo exchange on oceanMask - call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) - call mpas_pool_get_field(scratchPool, 'oceanCell', oceanCellField) - call mpas_dmpar_exch_halo_field(oceanCellField) - - ! Check to see if any cells have been masked as ocean in the halo that have not been touched. - ! If there are any, add them to the stack. Also, compute globalStackSize - localStackSize = 0 - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) - - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - - call mpas_pool_get_array(scratchPool, 'cullStack', stack) - call mpas_pool_get_array(scratchPool, 'oceanCell', oceanMask) - call mpas_pool_get_array(scratchPool, 'touchedCell', touchMask) - call mpas_pool_get_array(scratchPool, 'cullStackSize', stackSize) - - do iCell = nCellsSolve, nCells - if (oceanMask(iCell) == 1 .and. touchMask(iCell) == 0) then - stackSize = stackSize + 1 - stack(stackSize) = iCell - touchMask(iCell) = 1 - end if - end do - - localStackSize = localStackSize + stackSize - block_ptr => block_ptr % next - end do - - call mpas_dmpar_sum_int(domain % dminfo, localStackSize, globalStackSize) - end do - - ! Mark all cells that aren't ocean cells for removal - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) - - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - - call mpas_pool_get_array(scratchPool, 'oceanCell', oceanMask) - - do iCell = 1, nCellsSolve - if (oceanMask(iCell) == 0) then - maxLevelCell(iCell) = -1 - end if - end do - block_ptr => block_ptr % next - end do - - call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) - - call mpas_pool_get_field(scratchPool, 'cullStack', cullStackField) - call mpas_pool_get_field(scratchPool, 'touchedCell', touchedCellField) - call mpas_pool_get_field(scratchPool, 'oceanCell', oceanCellField) - - call mpas_deallocate_scratch_field(cullStackField, .false.) - call mpas_deallocate_scratch_field(touchedCellField, .false.) - call mpas_deallocate_scratch_field(oceanCellField, .false.) - - block_ptr => domain % blocklist - do while (associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - - call ocn_mark_maxlevelcell(meshPool, iErr) - block_ptr => block_ptr % next - end do - - end subroutine ocn_init_setup_global_realistic_cull_inland_seas!}}} - -!*********************************************************************** -! -! routine ocn_init_setup_global_realistic_read_depth_levels -! -!> \brief Read depth levels for global realistic test case -!> \author Doug Jacobsen -!> \date 03/04/2014 -!> \details -!> This routine reads the depth levels from the temperature IC file and sets -!> refBottomDepth accordingly -! -!----------------------------------------------------------------------- - - subroutine ocn_init_setup_global_realistic_read_depth_levels(domain, iErr)!{{{ - type (domain_type), intent(inout) :: domain - integer, intent(out) :: iErr - - type (block_type), pointer :: block_ptr - - type (MPAS_Stream_type) :: depthStream - - type (mpas_pool_type), pointer :: meshPool - - character (len=StrKIND), pointer :: config_global_realistic_depth_file, config_global_realistic_depth_varname, & - config_global_realistic_depth_dimname - - real (kind=RKIND), pointer :: config_global_realistic_depth_conversion_factor - - integer :: k, iCell - - real (kind=RKIND), dimension(:), pointer :: refBottomDepth - - iErr = 0 - - call mpas_pool_get_config(domain % configs, 'config_global_realistic_depth_file', config_global_realistic_depth_file) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_depth_varname', config_global_realistic_depth_varname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_depth_dimname', config_global_realistic_depth_dimname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_depth_conversion_factor', config_global_realistic_depth_conversion_factor) - - ! Define stream for depth levels - call MPAS_createStream(depthStream, config_global_realistic_depth_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) - - ! Setup depth field for stream to be read in - depthIC % fieldName = trim(config_global_realistic_depth_varname) - depthIC % dimSizes(1) = nDepth - depthIC % dimNames(1) = trim(config_global_realistic_depth_dimname) - depthIC % isVarArray = .false. - depthIC % isPersistent = .true. - depthIC % isActive = .true. - depthIC % hasTimeDimension = .false. - depthIC % block => domain % blocklist - allocate(depthIC % array(nDepth)) - - ! Add depth field to stream - call MPAS_streamAddField(depthStream, depthIC, iErr) - - ! Read stream - call MPAS_readStream(depthStream, 1, iErr) - - ! Close stream - call MPAS_closeStream(depthStream) - depthIC % array(:) = depthIC % array(:) * config_global_realistic_depth_conversion_factor - - ! Set refBottomDepth depending on depth levels. And convert appropriately - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - - call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) - refBottomDepth(:) = depthIC % array(:) - - block_ptr => block_ptr % next - end do - - end subroutine ocn_init_setup_global_realistic_read_depth_levels!}}} - -!*********************************************************************** -! -! routine ocn_init_setup_global_realistic_read_tracer_lat_lon -! -!> \brief Read Lat/Lon for tracers in global realistic test case -!> \author Doug Jacobsen -!> \date 03/04/2014 -!> \details -!> This routine reads the latitude and longitude coordinats for tracers from the temperature IC file. -! -!----------------------------------------------------------------------- - - subroutine ocn_init_setup_global_realistic_read_tracer_lat_lon(domain, iErr)!{{{ - type (domain_type), intent(inout) :: domain - integer, intent(out) :: iErr - - type (block_type), pointer :: block_ptr - - type (MPAS_Stream_type) :: tracerStream - - character (len=StrKIND), pointer :: config_global_realistic_temperature_file, config_global_realistic_tracer_lat_varname, & - config_global_realistic_tracer_nlat_dimname, config_global_realistic_tracer_lon_varname, & - config_global_realistic_tracer_nlon_dimname - - logical, pointer :: config_global_realistic_tracer_latlon_degrees - - integer :: iLat, iLon - - iErr = 0 - - call mpas_pool_get_config(domain % configs, 'config_global_realistic_temperature_file', config_global_realistic_temperature_file) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_lat_varname', config_global_realistic_tracer_lat_varname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_nlat_dimname', config_global_realistic_tracer_nlat_dimname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_lon_varname', config_global_realistic_tracer_lon_varname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_nlon_dimname', config_global_realistic_tracer_nlon_dimname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_latlon_degrees', config_global_realistic_tracer_latlon_degrees) - - ! Define stream for depth levels - call MPAS_createStream(tracerStream, config_global_realistic_temperature_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) - - ! Setup tracerLat and tracerLon fields for stream to be read in - tracerLat % fieldName = trim(config_global_realistic_tracer_lat_varname) - tracerLat % dimSizes(1) = nLatTracer - tracerLat % dimNames(1) = trim(config_global_realistic_tracer_nlat_dimname) - tracerLat % isVarArray = .false. - tracerLat % isPersistent = .true. - tracerLat % isActive = .true. - tracerLat % hasTimeDimension = .false. - tracerLat % block => domain % blocklist - allocate(tracerLat % array(nLatTracer)) - - tracerLon % fieldName = trim(config_global_realistic_tracer_lon_varname) - tracerLon % dimSizes(1) = nLonTracer - tracerLon % dimNames(1) = trim(config_global_realistic_tracer_nlon_dimname) - tracerLon % isVarArray = .false. - tracerLon % isPersistent = .true. - tracerLon % isActive = .true. - tracerLon % hasTimeDimension = .false. - tracerLon % block => domain % blocklist - allocate(tracerLon % array(nLonTracer)) - - ! Add tracerLat and tracerLon fields to stream - call MPAS_streamAddField(tracerStream, tracerLat, iErr) - call MPAS_streamAddField(tracerStream, tracerLon, iErr) - - ! Read stream - call MPAS_readStream(tracerStream, 1, iErr) - - ! Close stream - call MPAS_closeStream(tracerStream) - - if (config_global_realistic_tracer_latlon_degrees) then - do iLat = 1, nLatTracer - tracerLat % array(iLat) = tracerLat % array(iLat) * pii / 180.0_RKIND - end do - - do iLon = 1, nLonTracer - tracerLon % array(iLon) = tracerLon % array(iLon) * pii / 180.0_RKIND - end do - end if - - do iLon = 1, nLonTracer - if (tracerLon % array(iLon) < 0.0_RKIND) then - tracerLon % array(iLon) = 2.0_RKIND * pii + tracerLon % array(iLon) - end if - end do - - end subroutine ocn_init_setup_global_realistic_read_tracer_lat_lon!}}} - -!*********************************************************************** -! -! routine ocn_init_setup_global_realistic_read_temperature -! -!> \brief Read temperature ICs for global realistic test case -!> \author Doug Jacobsen -!> \date 03/04/2014 -!> \details -!> This routine reads the temperature field from the temperature IC file. -! -!----------------------------------------------------------------------- - - subroutine ocn_init_setup_global_realistic_read_temperature(domain, iErr)!{{{ - type (domain_type), intent(inout) :: domain - integer, intent(out) :: iErr - - type (block_type), pointer :: block_ptr - - type (MPAS_Stream_type) :: temperatureStream - - character (len=StrKIND), pointer :: config_global_realistic_temperature_file, config_global_realistic_temperature_varname, & - config_global_realistic_tracer_nlon_dimname, config_global_realistic_tracer_nlat_dimname, & - config_global_realistic_depth_dimname - - integer :: k - - iErr = 0 - - call mpas_pool_get_config(domain % configs, 'config_global_realistic_temperature_file', config_global_realistic_temperature_file) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_temperature_varname', config_global_realistic_temperature_varname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_nlon_dimname', config_global_realistic_tracer_nlon_dimname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_nlat_dimname', config_global_realistic_tracer_nlat_dimname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_depth_dimname', config_global_realistic_depth_dimname) - - ! Define stream for temperature IC - call MPAS_createStream(temperatureStream, config_global_realistic_temperature_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) - - ! Setup temperature field for stream to be read in - temperatureIC % fieldName = trim(config_global_realistic_temperature_varname) - temperatureIC % dimSizes(1) = nLonTracer - temperatureIC % dimSizes(2) = nLatTracer - temperatureIC % dimSizes(3) = nDepth - temperatureIC % dimNames(1) = trim(config_global_realistic_tracer_nlon_dimname) - temperatureIC % dimNames(2) = trim(config_global_realistic_tracer_nlat_dimname) - temperatureIC % dimNames(3) = trim(config_global_realistic_depth_dimname) - temperatureIC % isVarArray = .false. - temperatureIC % isPersistent = .true. - temperatureIC % isActive = .true. - temperatureIC % hasTimeDimension = .false. - temperatureIC % block => domain % blocklist - allocate(temperatureIC % array(nLonTracer, nLatTracer, nDepth)) - - ! Add temperature field to stream - call MPAS_streamAddField(temperatureStream, temperatureIC, iErr) - - ! Read stream - call MPAS_readStream(temperatureStream, 1, iErr) - - ! Close stream - call MPAS_closeStream(temperatureStream) - - end subroutine ocn_init_setup_global_realistic_read_temperature!}}} - -!*********************************************************************** -! -! routine ocn_init_setup_global_realistic_read_salinity -! -!> \brief Read salinity ICs for global realistic test case -!> \author Doug Jacobsen -!> \date 03/04/2014 -!> \details -!> This routine reads the salinity field from the salinity IC file. -! -!----------------------------------------------------------------------- - - subroutine ocn_init_setup_global_realistic_read_salinity(domain, iErr)!{{{ - type (domain_type), intent(inout) :: domain - integer, intent(out) :: iErr - - type (block_type), pointer :: block_ptr - - type (MPAS_Stream_type) :: salinityStream - - character (len=StrKIND), pointer :: config_global_realistic_salinity_file, config_global_realistic_salinity_varname, & - config_global_realistic_tracer_nlon_dimname, config_global_realistic_tracer_nlat_dimname, & - config_global_realistic_depth_dimname - - integer :: k - - iErr = 0 - - call mpas_pool_get_config(domain % configs, 'config_global_realistic_salinity_file', config_global_realistic_salinity_file) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_salinity_varname', config_global_realistic_salinity_varname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_nlon_dimname', config_global_realistic_tracer_nlon_dimname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_nlat_dimname', config_global_realistic_tracer_nlat_dimname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_depth_dimname', config_global_realistic_depth_dimname) - - ! Define stream for salinity IC - call MPAS_createStream(salinityStream, config_global_realistic_salinity_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) - - ! Setup salinity field for stream to be read in - salinityIC % fieldName = trim(config_global_realistic_salinity_varname) - salinityIC % dimSizes(1) = nLonTracer - salinityIC % dimSizes(2) = nLatTracer - salinityIC % dimSizes(3) = nDepth - salinityIC % dimNames(1) = trim(config_global_realistic_tracer_nlon_dimname) - salinityIC % dimNames(2) = trim(config_global_realistic_tracer_nlat_dimname) - salinityIC % dimNames(3) = trim(config_global_realistic_depth_dimname) - salinityIC % isVarArray = .false. - salinityIC % isPersistent = .true. - salinityIC % isActive = .true. - salinityIC % hasTimeDimension = .false. - salinityIC % block => domain % blocklist - allocate(salinityIC % array(nLonTracer, nLatTracer, nDepth)) - - ! Add salinity field to stream - call MPAS_streamAddField(salinityStream, salinityIC, iErr) - - ! Read stream - call MPAS_readStream(salinityStream, 1, iErr) - - ! Close stream - call MPAS_closeStream(salinityStream) - - end subroutine ocn_init_setup_global_realistic_read_salinity!}}} - -!*********************************************************************** -! -! routine ocn_init_setup_global_realistic_interoplate_tracers -! -!> \brief Interpolate tracer quantities to MPAS grid -!> \author Doug Jacobsen -!> \date 03/05/2014 -!> \details -!> This routine interpolates the temperature/salinity data read in from the -!> initial condition file to the MPAS grid. Currently it uses a nearest neighbor interpolation. -! -!----------------------------------------------------------------------- - - subroutine ocn_init_setup_global_realistic_interpolate_tracers(domain, iErr)!{{{ - type (domain_type), intent(inout) :: domain - integer, intent(out) :: iErr - - type (block_type), pointer :: block_ptr - type (mpas_pool_type), pointer :: meshPool, statePool, scratchPool - - real (kind=RKIND) :: currentLat, currentLon, counter - real (kind=RKIND) :: minDist, dist - real (kind=RKIND) :: x, x1, x2, y, y1, y2, coef, coef11, coef12, coef21, coef22 - integer :: iLat, iLon, iSmooth, j, coc - integer :: latSearch, lonSearch - integer :: iCell, k - integer :: xInd1, xInd2, yInd1, yInd2 - integer, pointer :: idxSalinity, idxTemperature, nCells, nCellsSolve - - type (field2DReal), pointer :: smoothedTemperatureField, smoothedSalinityField - type (field3DReal), pointer :: tracersField - - integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell - integer, dimension(:, :), pointer :: cellsOnCell - - real (kind=RKIND), dimension(:), pointer :: latCell, lonCell - ! ToBeRemoved real (kind=RKIND), dimension(:), pointer :: temperatureRestore, salinityRestore - real (kind=RKIND), dimension(:, :), pointer :: smoothedTemperature, smoothedSalinity - real (kind=RKIND), dimension(:, :, :), pointer :: tracers - - character (len=StrKIND), pointer :: config_global_realistic_tracer_method - logical, pointer :: config_global_realistic_tracer_restore - integer, pointer :: config_global_realistic_smooth_TS_iterations - - iErr = 0 - - call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_method', config_global_realistic_tracer_method) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_tracer_restore', config_global_realistic_tracer_restore) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_smooth_TS_iterations', config_global_realistic_smooth_TS_iterations) - - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) - - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - - call mpas_pool_get_dimension(statePool, 'index_temperature', idxTemperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', idxSalinity) - - call mpas_pool_get_array(meshPool, 'latCell', latCell) - call mpas_pool_get_array(meshPool, 'lonCell', lonCell) - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - ! ToBeRemoved call mpas_pool_get_array(meshPool, 'temperatureRestore', temperatureRestore) - ! ToBeRemoved call mpas_pool_get_array(meshPool, 'salinityRestore', salinityRestore) - - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) - - if (config_global_realistic_tracer_method .eq. "nearest_neighbor") then - do iCell = 1, nCells - currentLat = latCell(iCell) - currentLon = lonCell(iCell) - - lonSearch = 1 - minDist = 2.0_RKIND * pii - do iLon = 1, nLonTracer - dist = abs(currentLon - tracerLon % array(iLon)) - if (dist < minDist) then - minDist = dist - lonSearch = iLon - end if - end do - - latSearch = 1 - minDist = 2.0_RKIND * pii - do iLat = 1, nLatTracer - dist = abs(currentLat - tracerLat % array(iLat)) - if (dist < minDist) then - minDist = dist - latSearch = iLat - end if - end do - - do k = 1, maxLevelCell(iCell) - tracers(idxTemperature, k, iCell) = temperatureIC % array(lonSearch, latSearch, k) - tracers(idxSalinity, k, iCell) = salinityIC % array(lonSearch, latSearch, k) - end do - end do - - elseif (config_global_realistic_tracer_method .eq. "bilinear_interpolation") then - - do iCell = 1, nCells - x = lonCell(iCell) - y = latCell(iCell) - - ! Set up bilinear interpolation indices in longitude, watching for periodic boundary at 0 and 2 pi - xInd1 = 0 - if (x .le. tracerLon % array(1)) then - xInd1 = nLonTracer - xInd2 = 1 - x1 = tracerLon % array(xInd1) - 2.0*pii - x2 = tracerLon % array(xInd2) - elseif (x .ge. tracerLon % array(nLonTracer)) then - xInd1 = nLonTracer - xInd2 = 1 - x1 = tracerLon % array(xInd1) - x2 = tracerLon % array(xInd2) + 2.0*pii - else - do iLon = 1, nLonTracer-1 - if (x .le. tracerLon % array(iLon+1)) then - xInd1 = iLon - xInd2 = iLon+1 - x1 = tracerLon % array(xInd1) - x2 = tracerLon % array(xInd2) - exit - end if - end do - endif - - yInd1 = 0 - if (y .le. tracerLat % array(1)) then - ! if south of the southernmost data point, extrapolate as a constant in latitude - yInd1 = 1 - yInd2 = 1 - coef = 1.0_RKIND/(x2-x1) - coef11 = 1.0_RKIND*(x2-x ) - coef21 = 1.0_RKIND*(x -x1) - coef12 = 0.0_RKIND - coef22 = 0.0_RKIND - elseif (y .ge. tracerLat % array(nLatTracer)) then - ! if north of the northernmost data point, extrapolate as a constant in latitude - yInd1 = nLatTracer - yInd2 = nLatTracer - coef = 1.0_RKIND/(x2-x1) - coef11 = 1.0_RKIND*(x2-x ) - coef21 = 1.0_RKIND*(x -x1) - coef12 = 0.0_RKIND - coef22 = 0.0_RKIND - else - ! Set up bilinear interpolation coefficients in latitude - do iLat = 1, nLatTracer-1 - if (y .le. tracerLat % array(iLat+1)) then - yInd1 = iLat - yInd2 = iLat+1 - exit - end if - end do - y1 = tracerLat % array(yInd1) - y2 = tracerLat % array(yInd2) - coef = 1.0_RKIND/(x2-x1)/(y2-y1) - coef11 = 1.0_RKIND*(x2-x )*(y2-y ) - coef21 = 1.0_RKIND*(x -x1)*(y2-y ) - coef12 = 1.0_RKIND*(x2-x )*(y -y1) - coef22 = 1.0_RKIND*(x -x1)*(y -y1) - endif - - ! Assign T&S using bilinear interpolation - ! formulas from http://en.wikipedia.org/wiki/Bilinear_interpolation - do k = 1, maxLevelCell(iCell) - - tracers(idxTemperature, k, iCell) = coef*( & - coef11* temperatureIC % array(xInd1,yInd1, k) & - + coef21* temperatureIC % array(xInd2,yInd1, k) & - + coef12* temperatureIC % array(xInd1,yInd2, k) & - + coef22* temperatureIC % array(xInd2,yInd2, k) ) - - tracers(idxSalinity, k, iCell) = coef*( & - coef11* salinityIC % array(xInd1,yInd1, k) & - + coef21* salinityIC % array(xInd2,yInd1, k) & - + coef12* salinityIC % array(xInd1,yInd2, k) & - + coef22* salinityIC % array(xInd2,yInd2, k) ) - - end do - end do - - else - write(stderrUnit,*) 'ERROR: Invalid choice of config_global_realistic_tracer_method.' - iErr = 1 - call mpas_dmpar_finalize(domain % dminfo) - endif - - ! ToBeRemoved - ! if (config_global_realistic_tracer_restore) then - ! do iCell = 1, nCellsSolve - ! temperatureRestore(iCell) = tracers(idxTemperature, 1, iCell) - ! salinityRestore(iCell) = tracers(idxSalinity, 1, iCell) - ! end do - ! endif - - block_ptr => block_ptr % next - end do - - ! Smooth temperature and salinity. - if (config_global_realistic_smooth_TS_iterations .gt. 0) then - call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) - - call mpas_pool_get_field(scratchPool, 'smoothedTemperature', smoothedTemperatureField) - call mpas_pool_get_field(scratchPool, 'smoothedSalinity', smoothedSalinityField) - - call mpas_allocate_scratch_field(smoothedTemperatureField, .false.) - call mpas_allocate_scratch_field(smoothedSalinityField, .false.) - - do iSmooth = 1,config_global_realistic_smooth_TS_iterations - - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) - call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) - - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - - call mpas_pool_get_dimension(statePool, 'index_temperature', idxTemperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', idxSalinity) - - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) - - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) - - call mpas_pool_get_array(scratchPool, 'smoothedTemperature', smoothedTemperature) - call mpas_pool_get_array(scratchPool, 'smoothedSalinity', smoothedSalinity) - - maxLevelCell(nCells+1) = -1 - - do iCell = 1, nCells - do k = 1, maxLevelCell(iCell) - smoothedtemperature(k, iCell) = tracers(idxTemperature, k, iCell) - smoothedsalinity(k, iCell) = tracers(idxSalinity, k, iCell) - counter = 1 - - do j = 1, nEdgesOnCell(iCell) - coc = cellsOnCell(j, iCell) - ! check if coc not 0 (or nCells+1)? - if (k .le. maxLevelCell(coc)) then - - smoothedtemperature(k, iCell) = smoothedtemperature(k, iCell) + tracers (idxTemperature, k, coc) - smoothedsalinity(k, iCell) = smoothedsalinity(k, iCell) + tracers(idxSalinity, k, coc) - counter = counter + 1 - - end if - end do ! edgesOnCell - - smoothedtemperature(k, iCell) = smoothedtemperature(k, iCell) / counter - smoothedsalinity(k, iCell) = smoothedsalinity(k, iCell) / counter - - end do ! k level - - end do ! iCell - - tracers(idxTemperature, :, :) = smoothedtemperature(:,:) - tracers(idxSalinity, :, :) = smoothedsalinity(:,:) - - block_ptr => block_ptr % next - end do - - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) - call mpas_pool_get_field(statePool, 'tracers', tracersField, 1) - - call mpas_dmpar_exch_halo_field(tracersField) - - end do ! iSmooth - - call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) - call mpas_pool_get_field(scratchPool, 'smoothedTemperature', smoothedTemperatureField) - call mpas_pool_get_field(scratchPool, 'smoothedSalinity', smoothedSalinityField) - call mpas_deallocate_scratch_field(smoothedTemperatureField, .false.) - call mpas_deallocate_scratch_field(smoothedSalinityField, .false.) - endif - - end subroutine ocn_init_setup_global_realistic_interpolate_tracers!}}} - -!*********************************************************************** -! -! routine ocn_init_setup_global_realistic_read_windstress -! -!> \brief Read the windstress IC file -!> \author Doug Jacobsen -!> \date 03/07/2014 -!> \details -!> This routine reads the windstress IC file, including latitude and longitude -!> information for windstress data. -! -!----------------------------------------------------------------------- - - subroutine ocn_init_setup_global_realistic_read_windstress(domain, iErr)!{{{ - type (domain_type), intent(inout) :: domain - integer, intent(out) :: iErr - - type (block_type), pointer :: block_ptr - - type (MPAS_Stream_type) :: windstressStream - - integer :: iLat, iLon - - character (len=StrKIND), pointer :: config_global_realistic_windstress_file, config_global_realistic_windstress_lat_varname, & - config_global_realistic_windstress_nlat_dimname, config_global_realistic_windstress_lon_varname, & - config_global_realistic_windstress_nlon_dimname, config_global_realistic_windstress_zonal_varname, & - config_global_realistic_windstress_meridional_varname - - logical, pointer :: config_global_realistic_windstress_latlon_degrees - - iErr = 0 - - call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_file', config_global_realistic_windstress_file) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_lat_varname', config_global_realistic_windstress_lat_varname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_nlat_dimname', config_global_realistic_windstress_nlat_dimname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_lon_varname', config_global_realistic_windstress_lon_varname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_nlon_dimname', config_global_realistic_windstress_nlon_dimname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_zonal_varname', config_global_realistic_windstress_zonal_varname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_meridional_varname', config_global_realistic_windstress_meridional_varname) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_latlon_degrees', config_global_realistic_windstress_latlon_degrees) - - ! Define stream for depth levels - call MPAS_createStream(windstressStream, config_global_realistic_windstress_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) - - ! Setup windLat, windLon, and windIC fields for stream to be read in - windLat % fieldName = trim(config_global_realistic_windstress_lat_varname) - windLat % dimSizes(1) = nLatWind - windLat % dimNames(1) = trim(config_global_realistic_windstress_nlat_dimname) - windLat % isVarArray = .false. - windLat % isPersistent = .true. - windLat % isActive = .true. - windLat % hasTimeDimension = .false. - windLat % block => domain % blocklist - allocate(windLat % array(nLatWind)) - - windLon % fieldName = trim(config_global_realistic_windstress_lon_varname) - windLon % dimSizes(1) = nLonWind - windLon % dimNames(1) = trim(config_global_realistic_windstress_nlon_dimname) - windLon % isVarArray = .false. - windLon % isPersistent = .true. - windLon % isActive = .true. - windLon % hasTimeDimension = .false. - windLon % block => domain % blocklist - allocate(windLon % array(nLonWind)) - - zonalWindIC % fieldName = trim(config_global_realistic_windstress_zonal_varname) - zonalWindIC % dimSizes(1) = nLonWind - zonalWindIC % dimSizes(2) = nLatWind - zonalWindIC % dimNames(1) = trim(config_global_realistic_windstress_nlon_dimname) - zonalWindIC % dimNames(2) = trim(config_global_realistic_windstress_nlat_dimname) - zonalWindIC % isVarArray = .false. - zonalWindIC % isPersistent = .true. - zonalWindIC % isActive = .true. - zonalWindIC % hasTimeDimension = .false. - zonalWindIC % block => domain % blocklist - allocate(zonalWindIC % array(nLonWind, nLatWind)) - - meridionalWindIC % fieldName = trim(config_global_realistic_windstress_meridional_varname) - meridionalWindIC % dimSizes(1) = nLonWind - meridionalWindIC % dimSizes(2) = nLatWind - meridionalWindIC % dimNames(1) = trim(config_global_realistic_windstress_nlon_dimname) - meridionalWindIC % dimNames(2) = trim(config_global_realistic_windstress_nlat_dimname) - meridionalWindIC % isVarArray = .false. - meridionalWindIC % isPersistent = .true. - meridionalWindIC % isActive = .true. - meridionalWindIC % hasTimeDimension = .false. - meridionalWindIC % block => domain % blocklist - allocate(meridionalWindIC % array(nLonWind, nLatWind)) - - ! Add windLat, windLon, and windIC fields to stream - call MPAS_streamAddField(windstressStream, windLat, iErr) - call MPAS_streamAddField(windstressStream, windLon, iErr) - call MPAS_streamAddField(windstressStream, zonalWindIC, iErr) - call MPAS_streamAddField(windstressStream, meridionalWindIC, iErr) - - ! Read stream - call MPAS_readStream(windstressStream, 1, iErr) - - ! Close stream - call MPAS_closeStream(windstressStream) - - if (config_global_realistic_windstress_latlon_degrees) then - windLat % array(:) = windLat % array(:) * pii / 180.0_RKIND - windLon % array(:) = windLon % array(:) * pii / 180.0_RKIND - end if - - do iLon = 1, nLonWind - if (windLon % array(iLon) < 0.0_RKIND) then - windLon % array(iLon) = 2.0_RKIND * pii + windLon % array(iLon) - end if - end do - - end subroutine ocn_init_setup_global_realistic_read_windstress!}}} - -!*********************************************************************** -! -! routine ocn_init_setup_global_realistic_interpolate_windstress -! -!> \brief Interpolate the windstress IC to MPAS mesh -!> \author Doug Jacobsen -!> \date 03/07/2014 -!> \details -!> This routine interpolates windstress data to the MPAS mesh. Currently it -!> uses a bilinear interpolation -! -!----------------------------------------------------------------------- - - subroutine ocn_init_setup_global_realistic_interpolate_windstress(domain, iErr)!{{{ - type (domain_type), intent(inout) :: domain - integer, intent(out) :: iErr - - type (block_type), pointer :: block_ptr - - type (mpas_pool_type), pointer :: meshPool, forcingPool - - real (kind=RKIND) :: currentLat, currentLon - real (kind=RKIND) :: zonalWind, meridionalWind - real (kind=RKIND) :: angle - real (kind=RKIND) :: dist, minDist - real (kind=RKIND) :: x, x1, x2, y, y1, y2, coef, coef11, coef12, coef21, coef22 - - integer :: ilat, iLon - integer :: latSearch, lonSearch - integer :: iEdge - integer :: xInd1, xInd2, yInd1, yInd2 - - real (kind=RKIND), dimension(:), pointer :: latEdge, lonEdge, angleEdge, surfaceWindStress - - integer, pointer :: nEdgesSolve, nEdges - - character (len=StrKIND), pointer :: config_global_realistic_windstress_method - real (kind=RKIND), pointer :: config_global_realistic_windstress_conversion_factor - - iErr = 0 - - call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_method', config_global_realistic_windstress_method) - call mpas_pool_get_config(domain % configs, 'config_global_realistic_windstress_conversion_factor', config_global_realistic_windstress_conversion_factor) - - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) - - call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) - - call mpas_pool_get_array(meshPool, 'latEdge', latEdge) - call mpas_pool_get_array(meshPool, 'lonEdge', lonEdge) - call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) - - call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) - - if (config_global_realistic_windstress_method .eq. "nearest_neighbor") then - do iEdge = 1, nEdgesSolve - currentLat = latEdge(iEdge) - currentLon = lonEdge(iEdge) - angle = angleEdge(iEdge) - - minDist = 2.0_RKIND * pii - lonSearch = 1 - do iLon = 1, nLonWind - dist = abs(currentLon - windLon % array(iLon)) - if (dist < minDist) then - minDist = dist - lonSearch = iLon - end if - end do - - minDist = 2.0_RKIND * pii - latSearch = 1 - do iLat = 1, nLatWind - dist = abs(currentLat - windLat % array(iLat)) - if (dist < minDist) then - minDist = dist - latSearch = iLat - end if - end do - - zonalWind = zonalWindIC % array(lonSearch, latSearch) * config_global_realistic_windstress_conversion_factor - meridionalWind = meridionalWindIC % array(lonSearch, latSearch) * config_global_realistic_windstress_conversion_factor - - surfaceWindStress(iEdge) = zonalWind * cos(angle) + meridionalWind * sin(angle) - end do - - elseif (config_global_realistic_windstress_method .eq. "bilinear_interpolation") then - - do iEdge = 1, nEdges - x = lonEdge(iEdge) - y = latEdge(iEdge) - angle = angleEdge(iEdge) - - ! Set up bilinear interpolation indices in longitude, watching for periodic boundary at 0 and 2 pi - xInd1 = 0 - if (x .le. windLon % array(1)) then - xInd1 = nLonWind - xInd2 = 1 - x1 = windLon % array(xInd1) - 2.0_RKIND*pii - x2 = windLon % array(xInd2) - elseif (x .ge. windLon % array(nLonWind)) then - xInd1 = nLonWind - xInd2 = 1 - x1 = windLon % array(xInd1) - x2 = windLon % array(xInd2) + 2.0_RKIND*pii - else - do iLon = 1, nLonWind-1 - if (x .le. windLon % array(iLon+1)) then - xInd1 = iLon - xInd2 = iLon+1 - x1 = windLon % array(xInd1) - x2 = windLon % array(xInd2) - exit - end if - end do - endif - - yInd1 = 0 - if (y .le. windLat % array(1)) then - ! if south of the southernmost data point, extrapolate as a constant in latitude - yInd1 = 1 - yInd2 = 1 - coef = 1.0_RKIND/(x2-x1) - coef11 = 1.0_RKIND*(x2-x ) - coef21 = 1.0_RKIND*(x -x1) - coef12 = 0.0_RKIND - coef22 = 0.0_RKIND - elseif (y .ge. windLat % array(nLatWind)) then - ! if north of the northernmost data point, extrapolate as a constant in latitude - yInd1 = nLatWind - yInd2 = nLatWind - coef = 1.0_RKIND/(x2-x1) - coef11 = 1.0_RKIND*(x2-x ) - coef21 = 1.0_RKIND*(x -x1) - coef12 = 0.0_RKIND - coef22 = 0.0_RKIND - else - ! Set up bilinear interpolation coefficients in latitude - do iLat = 1, nLatWind-1 - if (y .le. windLat % array(iLat+1)) then - yInd1 = iLat - yInd2 = iLat+1 - exit - end if - end do - y1 = windLat % array(yInd1) - y2 = windLat % array(yInd2) - coef = 1.0_RKIND/(x2-x1)/(y2-y1) - coef11 = 1.0_RKIND*(x2-x )*(y2-y ) - coef21 = 1.0_RKIND*(x -x1)*(y2-y ) - coef12 = 1.0_RKIND*(x2-x )*(y -y1) - coef22 = 1.0_RKIND*(x -x1)*(y -y1) - endif - - zonalWind = coef*config_global_realistic_windstress_conversion_factor*( & - coef11* zonalWindIC % array(xInd1, yInd1) & - + coef21* zonalWindIC % array(xInd2, yInd1) & - + coef12* zonalWindIC % array(xInd1, yInd2) & - + coef22* zonalWindIC % array(xInd2, yInd2) ) - - meridionalWind = coef*config_global_realistic_windstress_conversion_factor*( & - coef11* meridionalWindIC % array(xInd1, yInd1) & - + coef21* meridionalWindIC % array(xInd2, yInd1) & - + coef12* meridionalWindIC % array(xInd1, yInd2) & - + coef22* meridionalWindIC % array(xInd2, yInd2) ) - - surfaceWindStress(iEdge) = zonalWind * cos(angle) + meridionalWind * sin(angle) - - end do - - else - write(stderrUnit,*) 'ERROR: Invalid choice of config_global_realistic_windstress_method.' - iErr = 1 - call mpas_dmpar_finalize(domain % dminfo) - endif - - block_ptr => block_ptr % next - end do - - end subroutine ocn_init_setup_global_realistic_interpolate_windstress!}}} - -!*********************************************************************** -! -! routine ocn_init_global_realistic_destroy_tracer_fields -! -!> \brief Tracer field cleanup routine -!> \author Doug Jacobsen -!> \date 03/04/2014 -!> \details -!> This routine destroys the fields that were created to hold tracer -!> initial condition information -! -!----------------------------------------------------------------------- - - subroutine ocn_init_global_realistic_destroy_tracer_fields()!{{{ - deallocate(temperatureIC % array) - deallocate(salinityIC % array) - deallocate(tracerLat % array) - deallocate(tracerLon % array) - end subroutine ocn_init_global_realistic_destroy_tracer_fields!}}} - -!*********************************************************************** -! -! routine ocn_init_global_realistic_destroy_topo_fields -! -!> \brief Topography field cleanup routine -!> \author Doug Jacobsen -!> \date 03/07/2014 -!> \details -!> This routine destroys the fields that were created to hold topography -!> initial condition information -! -!----------------------------------------------------------------------- - - subroutine ocn_init_global_realistic_destroy_topo_fields()!{{{ - deallocate(topoIC % array) - deallocate(topoLat % array) - deallocate(topoLon % array) - end subroutine ocn_init_global_realistic_destroy_topo_fields!}}} - -!*********************************************************************** -! -! routine ocn_init_global_realistic_destroy_windstress_fields -! -!> \brief Windstress field cleanup routine -!> \author Doug Jacobsen -!> \date 03/07/2014 -!> \details -!> This routine destroys the fields that were created to hold windstress -!> initial condition information -! -!----------------------------------------------------------------------- - - subroutine ocn_init_global_realistic_destroy_windstress_fields()!{{{ - deallocate(zonalWindIC % array) - deallocate(meridionalWindIC % array) - deallocate(windLat % array) - deallocate(windLon % array) - end subroutine ocn_init_global_realistic_destroy_windstress_fields!}}} - -!*********************************************************************** -! -! routine ocn_init_validate_global_realistic -! -!> \brief Validation for global realistic test case -!> \author Doug Jacobsen -!> \date 03/04/2014 -!> \details -!> This routine validates the configuration options for the global realistic test case. -! -!----------------------------------------------------------------------- - - subroutine ocn_init_validate_global_realistic(configPool, packagePool, iErr)!{{{ - - !-------------------------------------------------------------------- - - type (mpas_pool_type), intent(in) :: configPool, packagePool - integer, intent(out) :: iErr - type (MPAS_IO_Handle_type) :: inputFile - - character (len=StrKIND), pointer :: config_init_configuration, config_global_realistic_depth_file, & - config_global_realistic_depth_dimname, config_global_realistic_temperature_file, & - config_global_realistic_salinity_file, config_global_realistic_tracer_nlat_dimname, & - config_global_realistic_tracer_nlon_dimname, config_global_realistic_topography_file, & - config_global_realistic_topography_nlat_dimname, config_global_realistic_topography_nlon_dimname, & - config_global_realistic_windstress_file, config_global_realistic_windstress_nlat_dimname, & - config_global_realistic_windstress_nlon_dimname - - integer, pointer :: config_vert_levels - - iErr = 0 - - call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) - - if(config_init_configuration .ne. trim('global_realistic')) return - - call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) - call mpas_pool_get_config(configPool, 'config_global_realistic_depth_file', config_global_realistic_depth_file) - call mpas_pool_get_config(configPool, 'config_global_realistic_depth_dimname', config_global_realistic_depth_dimname) - call mpas_pool_get_config(configPool, 'config_global_realistic_temperature_file', config_global_realistic_temperature_file) - call mpas_pool_get_config(configPool, 'config_global_realistic_salinity_file', config_global_realistic_salinity_file) - call mpas_pool_get_config(configPool, 'config_global_realistic_tracer_nlat_dimname', config_global_realistic_tracer_nlat_dimname) - call mpas_pool_get_config(configPool, 'config_global_realistic_tracer_nlon_dimname', config_global_realistic_tracer_nlon_dimname) - call mpas_pool_get_config(configPool, 'config_global_realistic_topography_file', config_global_realistic_topography_file) - call mpas_pool_get_config(configPool, 'config_global_realistic_topography_nlat_dimname', config_global_realistic_topography_nlat_dimname) - call mpas_pool_get_config(configPool, 'config_global_realistic_topography_nlon_dimname', config_global_realistic_topography_nlon_dimname) - call mpas_pool_get_config(configPool, 'config_global_realistic_windstress_file', config_global_realistic_windstress_file) - call mpas_pool_get_config(configPool, 'config_global_realistic_windstress_nlat_dimname', config_global_realistic_windstress_nlat_dimname) - call mpas_pool_get_config(configPool, 'config_global_realistic_windstress_nlon_dimname', config_global_realistic_windstress_nlon_dimname) - - inputFile = MPAS_io_open(config_global_realistic_depth_file, MPAS_IO_READ, MPAS_IO_NETCDF, ierr=iErr) - - call MPAS_io_inq_dim(inputFile, config_global_realistic_depth_dimname, nDepth, iErr) - - call MPAS_io_close(inputFile, iErr) - - inputFile = MPAS_io_open(config_global_realistic_temperature_file, MPAS_IO_READ, MPAS_IO_NETCDF, ierr=iErr) - - call MPAS_io_inq_dim(inputFile, config_global_realistic_tracer_nlat_dimname, nLatTracer, iErr) - call MPAS_io_inq_dim(inputFile, config_global_realistic_tracer_nlon_dimname, nLonTracer, iErr) - - call MPAS_io_close(inputFile, iErr) - - inputFile = MPAS_io_open(config_global_realistic_topography_file, MPAS_IO_READ, MPAS_IO_NETCDF, ierr=iErr) - - call MPAS_io_inq_dim(inputFile, config_global_realistic_topography_nlat_dimname, nLatTopo, iErr) - call MPAS_io_inq_dim(inputFile, config_global_realistic_topography_nlon_dimname, nLonTopo, iErr) - - call MPAS_io_close(inputFile, iErr) - - inputFile = MPAS_io_open(config_global_realistic_windstress_file, MPAS_IO_READ, MPAS_IO_NETCDF, ierr=iErr) - - call MPAS_io_inq_dim(inputFile, config_global_realistic_windstress_nlat_dimname, nLatWind, iErr) - call MPAS_io_inq_dim(inputFile, config_global_realistic_windstress_nlon_dimname, nLonWind, iErr) - - call MPAS_io_close(inputFile, iErr) - - if (config_vert_levels <= 0 .and. nDepth > 0) then - config_vert_levels = nDepth - else if(config_vert_levels <= 0) then - write(stderrUnit,*) 'ERROR: Validation failed for global realistic. Not given a usable value for vertical levels.' - iErr = 1 - end if - - if (trim(config_global_realistic_temperature_file) == 'none') then - write(stderrUnit,*) 'ERROR: Validation failed for global realistic. Invalid filename for config_global_realistic_temperature_file' - iErr = 1 - end if - - if (trim(config_global_realistic_salinity_file) == 'none') then - write(stderrUnit,*) 'ERROR: Validation failed for global realistic. Invalid filename for config_global_realistic_salinity_file' - iErr = 1 - end if - - if (trim(config_global_realistic_depth_file) == 'none') then - write(stderrUnit,*) 'ERROR: Validation failed for global realistic. Invalid filename for config_global_realistic_depth_file' - iErr = 1 - end if - - if (trim(config_global_realistic_topography_file) == 'none') then - write(stderrUnit,*) 'ERROR: Validation failed for global realistic. Invalid filename for config_global_realistic_topography_file' - iErr = 1 - end if - - if (trim(config_global_realistic_windstress_file) == 'none') then - write(stderrUnit,*) 'ERROR: Validation failed for global realistic. Invalid filename for config_global_realistic_windstress_file' - iErr = 1 - end if - - !-------------------------------------------------------------------- - - end subroutine ocn_init_validate_global_realistic!}}} - -!*********************************************************************** - -end module ocn_init_global_realistic - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 1b274879aa..89b057694e 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -42,7 +42,7 @@ module ocn_init_mode use ocn_init_lock_exchange use ocn_init_internal_waves use ocn_init_overflow - use ocn_init_global_realistic + use ocn_init_global_ocean use ocn_init_cvmix_WSwSBF use ocn_init_iso use ocn_init_soma @@ -249,7 +249,7 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call ocn_init_setup_lock_exchange(domain, ierr) call ocn_init_setup_internal_waves(domain, ierr) call ocn_init_setup_overflow(domain, ierr) - call ocn_init_setup_global_realistic(domain, ierr) + call ocn_init_setup_global_ocean(domain, ierr) call ocn_init_setup_cvmix_WSwSBF(domain, ierr) call ocn_init_setup_iso(domain, ierr) call ocn_init_setup_soma(domain, ierr) @@ -333,7 +333,7 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, iErr)!{ iErr = ior(iErr, err_tmp) call ocn_init_validate_overflow(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) - call ocn_init_validate_global_realistic(configPool, packagePool, iErr=err_tmp) + call ocn_init_validate_global_ocean(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) call ocn_init_validate_cvmix_WSwSBF(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) From cbed715c89543ccb63451b58381245b61b0692ff Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Wed, 26 Aug 2015 17:51:35 -0600 Subject: [PATCH 0197/1724] adding config parameters to control surface restoring and interior restoring --- .../mode_init/Registry_global_ocean.xml | 10 +- .../mode_init/mpas_ocn_init_global_ocean.F | 1736 +++++++++++++++++ 2 files changed, 1743 insertions(+), 3 deletions(-) create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F diff --git a/src/core_ocean/mode_init/Registry_global_ocean.xml b/src/core_ocean/mode_init/Registry_global_ocean.xml index ee5bdc7f28..9587c31861 100644 --- a/src/core_ocean/mode_init/Registry_global_ocean.xml +++ b/src/core_ocean/mode_init/Registry_global_ocean.xml @@ -63,9 +63,13 @@ description="Number of smoothing iterations on temperature and salinity." possible_values="Any positive integer value greater or equal to 0." /> - \brief MPAS ocean initialize case -- Global Ocean +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This module contains the routines for initializing the +!> the global ocean test case +! +!----------------------------------------------------------------------- + +module ocn_init_global_ocean + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + use mpas_io + use mpas_io_streams + use mpas_dmpar + + use ocn_init_cell_markers + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_global_ocean, & + ocn_init_validate_global_ocean + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + integer :: nDepth + integer :: nLatTracer, nLonTracer + integer :: nLatWind, nLonWind + integer :: nLatTopo, nLonTopo + type (field1DReal) :: depthIC + type (field1DReal) :: windLat, windLon + type (field1DReal) :: topoLat, topoLon + type (field1DReal) :: tracerLat, tracerLon + type (field2DReal) :: topoIC, zonalWindIC, meridionalWindIC + type (field3DReal) :: temperatureIC, salinityIC + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_global_ocean +! +!> \brief Setup for global ocean test case +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine sets up the initial conditions for the global ocean test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_ocean(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + type (mpas_pool_type), pointer :: meshPool + integer, intent(out) :: iErr + + character (len=StrKIND), pointer :: config_init_configuration + logical, pointer :: config_global_ocean_cull_inland_seas + + logical, pointer :: on_a_sphere + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) + + if (trim(config_init_configuration) /= "global_ocean") return + + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + + if ( .not. on_a_sphere ) call mpas_dmpar_global_abort('ERROR: The global ocean configuration can only be applied to a spherical mesh. Exiting...') + + call mpas_pool_get_config(domain % configs, 'config_global_ocean_cull_inland_seas', config_global_ocean_cull_inland_seas) + + write(stderrUnit,*) 'Reading depth levels.' + call ocn_init_setup_global_ocean_read_depth_levels(domain, iErr) + + write(stderrUnit,*) 'Reading topography data.' + call ocn_init_setup_global_ocean_read_topo(domain, iErr) + write(stderrUnit,*) 'Interpolating topography data.' + call ocn_init_setup_global_ocean_interpolate_topo(domain, iErr) + write(stderrUnit,*) 'Cleaning up topography IC fields' + call ocn_init_global_ocean_destroy_topo_fields() + + if (config_global_ocean_cull_inland_seas) then + write(stderrUnit,*) 'Removing inland seas.' + call ocn_init_setup_global_ocean_cull_inland_seas(domain, iErr) + end if + + + write(stderrUnit,*) 'Reading temperature IC.' + call ocn_init_setup_global_ocean_read_temperature(domain, iErr) + write(stderrUnit,*) 'Reading salinity IC.' + call ocn_init_setup_global_ocean_read_salinity(domain, iErr) + write(stderrUnit,*) 'Reading Lat/Lon tracer coordinates' + call ocn_init_setup_global_ocean_read_tracer_lat_lon(domain, iErr) + write(stderrUnit,*) 'Interpolating tracers' + call ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr) + write(stderrUnit,*) 'Cleaning up tracer IC fields' + call ocn_init_global_ocean_destroy_tracer_fields() + + write(stderrUnit,*) 'Reading windstress IC.' + call ocn_init_setup_global_ocean_read_windstress(domain, iErr) + write(stderrUnit,*) 'Interpolating windstress.' + call ocn_init_setup_global_ocean_interpolate_windstress(domain, iErr) + write(stderrUnit,*) 'Destroying windstress fields' + call ocn_init_global_ocean_destroy_windstress_fields() + + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_global_ocean!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_ocean_read_topo +! +!> \brief Read the topography IC file +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine reads the topography IC file, including latitude and longitude +!> information for topography data. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_ocean_read_topo(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (MPAS_Stream_type) :: topographyStream + + character (len=StrKIND), pointer :: config_global_ocean_topography_file, config_global_ocean_topography_lat_varname, & + config_global_ocean_topography_nlat_dimname, config_global_ocean_topography_lon_varname, & + config_global_ocean_topography_nlon_dimname, config_global_ocean_topography_varname + + logical, pointer :: config_global_ocean_topography_latlon_degrees + + integer :: iLat, iLon + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_ocean_topography_file', config_global_ocean_topography_file) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_topography_lat_varname', config_global_ocean_topography_lat_varname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_topography_nlat_dimname', config_global_ocean_topography_nlat_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_topography_lon_varname', config_global_ocean_topography_lon_varname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_topography_nlon_dimname', config_global_ocean_topography_nlon_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_topography_varname', config_global_ocean_topography_varname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_topography_latlon_degrees', config_global_ocean_topography_latlon_degrees) + + ! Define stream for depth levels + call MPAS_createStream(topographyStream, config_global_ocean_topography_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) + + ! Setup topoLat, topoLon, and topoIC fields for stream to be read in + topoLat % fieldName = trim(config_global_ocean_topography_lat_varname) + topoLat % dimSizes(1) = nLatTopo + topoLat % dimNames(1) = trim(config_global_ocean_topography_nlat_dimname) + topoLat % isVarArray = .false. + topoLat % isPersistent = .true. + topoLat % isActive = .true. + topoLat % hasTimeDimension = .false. + topoLat % block => domain % blocklist + allocate(topoLat % array(nLatTopo)) + + topoLon % fieldName = trim(config_global_ocean_topography_lon_varname) + topoLon % dimSizes(1) = nLonTopo + topoLon % dimNames(1) = trim(config_global_ocean_topography_nlon_dimname) + topoLon % isVarArray = .false. + topoLon % isPersistent = .true. + topoLon % isActive = .true. + topoLon % hasTimeDimension = .false. + topoLon % block => domain % blocklist + allocate(topoLon % array(nLonTopo)) + + topoIC % fieldName = trim(config_global_ocean_topography_varname) + topoIC % dimSizes(1) = nLonTopo + topoIC % dimSizes(2) = nLatTopo + topoIC % dimNames(1) = trim(config_global_ocean_topography_nlon_dimname) + topoIC % dimNames(2) = trim(config_global_ocean_topography_nlat_dimname) + topoIC % isVarArray = .false. + topoIC % isPersistent = .true. + topoIC % isActive = .true. + topoIC % hasTimeDimension = .false. + topoIC % block => domain % blocklist + allocate(topoIC % array(nLonTopo, nLatTopo)) + + ! Add topoLat, topoLon, and topoIC fields to stream + call MPAS_streamAddField(topographyStream, topoLat, iErr) + call MPAS_streamAddField(topographyStream, topoLon, iErr) + call MPAS_streamAddField(topographyStream, topoIC, iErr) + + ! Read stream + call MPAS_readStream(topographyStream, 1, iErr) + + ! Close stream + call MPAS_closeStream(topographyStream) + + if (config_global_ocean_topography_latlon_degrees) then + topoLat % array(:) = topoLat % array(:) * pii / 180.0_RKIND + topoLon % array(:) = topoLon % array(:) * pii / 180.0_RKIND + end if + + do iLon = 1, nLonTopo + if (topoLon % array(iLon) < 0.0_RKIND) then + topoLon % array(iLon) = 2.0_RKIND * pii + topoLon % array(iLon) + end if + end do + + end subroutine ocn_init_setup_global_ocean_read_topo!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_ocean_interpolate_topo +! +!> \brief Interpolate the topography IC to MPAS mesh +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine interpolates topography data to the MPAS mesh. Currently it +!> uses a bilinear interpolation +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_ocean_interpolate_topo(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool, scratchPool, statePool, verticalMeshPool + + real (kind=RKIND) :: currentLat, currentLon + real (kind=RKIND) :: dist, minDist, depth + real (kind=RKIND) :: alpha, beta, depthLat1, depthLat2, proposedDepth + + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell, bottomDepth, refBottomDepth + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness + + integer, pointer :: nCells, nCellsSolve, nVertLevels + + type (field1DInteger), pointer :: maxLevelCellField, smoothedLevelsField + integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell + integer, dimension(:, :), pointer :: cellsOnCell + + integer :: latSearch, lonSearch, searchIdx + integer :: iCell, coc, j, k, maxLevel + + logical, pointer :: config_global_ocean_smooth_topography + integer, pointer :: config_global_ocean_minimum_levels + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_ocean_minimum_levels', config_global_ocean_minimum_levels) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_smooth_topography', config_global_ocean_smooth_topography) + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + do iCell = 1, nCells + currentLat = latCell(iCell) + currentLon = lonCell(iCell) + + lonSearch = 1 + minDist = 2.0_RKIND * pii + do searchIdx = 1, nLonTopo + dist = abs(currentLon - topoLon % array(searchIdx)) + if (dist < minDist) then + minDist = dist + lonSearch = searchIdx + end if + end do + + latSearch = 1 + minDist = 2.0_RKIND * pii + do searchIdx = 1, nLatTopo + dist = abs(currentLat - topoLat % array(searchIdx)) + if (dist < minDist) then + minDist = dist + latSearch = searchIdx + end if + end do + + if (topoIC % array(lonSearch, latSearch) < 0.0_RKIND) then + bottomDepth(iCell) = abs(topoIC % array(lonSearch, latSearch)) + maxLevelCell(iCell) = -1 + do k = 1, nVertLevels + depth = refBottomDepth(k) + + if (depth > bottomDepth(iCell) .and. maxLevelCell(iCell) == -1) then + maxLevelCell(iCell) = k + end if + end do + + if (maxLevelCell(iCell) == -1) then + maxLevelCell(iCell) = nVertLevels + bottomDepth(iCell) = refBottomDepth( nVertLevels ) + else if (maxLevelCell(iCell) <= config_global_ocean_minimum_levels) then + maxLevelCell(iCell) = config_global_ocean_minimum_levels + bottomDepth(iCell) = refBottomDepth( config_global_ocean_minimum_levels ) + end if + + + + else + bottomDepth(iCell) = 0.0_RKIND + maxLevelCell(iCell) = -1 + end if + end do + + ! Smooth depth levels. Enforce different in maxLevelCell to only be a maximum + ! of 1 vertical level between two neighboring cells. + if (config_global_ocean_smooth_topography) then + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call mpas_pool_get_field(scratchPool, 'smoothedLevels', smoothedLevelsField) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + + call mpas_allocate_scratch_field(smoothedLevelsField, .true.) + + maxLevelCell(nCells+1) = -1 + smoothedLevelsField % array = maxLevelCell + + do iCell = 1, nCellsSolve + maxLevel = 0 + do j = 1, nEdgesOnCell(iCell) + coc = cellsOnCell(j, iCell) + maxLevel = max(maxLevel, maxLevelCell(coc)) + end do + + if (maxLevel < maxLevelCell(iCell) ) then + smoothedLevelsField % array(iCell) = maxLevel + 1 + bottomDepth(iCell) = refBottomDepth(maxLevel + 1) + end if + end do + + maxLevelCell(:) = smoothedLevelsField % array(:) + + call mpas_deallocate_scratch_field(smoothedLevelsField, .true.) + end if + + ! Enforce minimum number of layers in ocean cells. + do iCell = 1, nCells + if (maxLevelCell(iCell) > 0 .and. maxLevelCell(iCell) < config_global_ocean_minimum_levels) then + maxLevelCell(iCell) = config_global_ocean_minimum_levels + bottomDepth(iCell) = refBottomDepth(config_global_ocean_minimum_levels) + end if + end do + + block_ptr => block_ptr % next + end do + + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_field(meshPool, 'maxLevelCell', maxLevelCellField) + call mpas_dmpar_exch_halo_field(maxLevelCellField) + + ! Set layerThickness based on refBottomDepth and bottomDepth + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + + do iCell = 1, nCellsSolve + if (maxLevelCell(iCell) > 0) then + + ! By going to maxLevelCell, this loop sets the layer Thickness as the full cell at the bottom. + layerThickness(1, iCell) = refBottomDepth(1) + do k = 2, maxLevelCell(iCell) + layerThickness(k, iCell) = refBottomDepth(k) - refBottomDepth(k-1) + end do + + ! The following lines could be used for partial bottom cells, but only if the temperature is interpolated in the vertical as well. + ! In version 3.0, one may alter the IC for partial bottom cells on start-up in MPAS. + !k = maxLevelCell(iCell) + !layerThickness(k, iCell) = bottomDepth(iCell) - refBottomDepth(k-1) + + restingThickness(:, iCell) = layerThickness(:, iCell) + end if + end do + + block_ptr => block_ptr % next + end do + + end subroutine ocn_init_setup_global_ocean_interpolate_topo!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_ocean_cull_inland_seas +! +!> \brief Read the topography IC file +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine removes all inland seas. These are defined as isolated ocean cells. +!> It uses a parallel version of an advancing front algorithm which might not be +!> optimal for this purpose. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_ocean_cull_inland_seas(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: scratchPool, meshPool + + type (field1DInteger), pointer :: cullStackField, touchedCellField, oceanCellField + + real, dimension(:), pointer :: latCell, lonCell, bottomDepth + integer, dimension(:), pointer :: stack, oceanMask, touchMask + integer, pointer :: stackSize + + real (kind=RKIND) :: currentLat, currentLon + real (kind=RKIND) :: dist, minDist + + integer :: iCell + integer :: localStackSize, globalStackSize + integer :: j, coc + integer :: touched + + integer, pointer :: nCells, nCellsSolve, nVertLevels + integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell + integer, dimension(:, :), pointer :: cellsOnCell + + iErr = 0 + + call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) + + call mpas_pool_get_field(scratchPool, 'cullStack', cullStackField) + call mpas_pool_get_field(scratchPool, 'touchedCell', touchedCellField) + call mpas_pool_get_field(scratchPool, 'oceanCell', oceanCellField) + + call mpas_allocate_scratch_field(cullStackField, .false.) + call mpas_allocate_scratch_field(touchedCellField, .false.) + call mpas_allocate_scratch_field(oceanCellField, .false.) + + ! Seed all deepest points for advancing front algorithm + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + call mpas_pool_get_array(scratchPool, 'cullStack', stack) + call mpas_pool_get_array(scratchPool, 'oceanCell', oceanMask) + call mpas_pool_get_array(scratchPool, 'touchedCell', touchMask) + call mpas_pool_get_array(scratchPool, 'cullStackSize', stackSize) + + stack(:) = 0 + oceanMask(:) = 0 + touchMask(:) = 0 + stackSize = 0 + + ! Add all cells that have maxLevelCell == nVertLevels to stack + do iCell = 1, nCellsSolve + if (maxLevelCell(iCell) == nVertLevels) then + stackSize = stackSize + 1 + stack(stackSize) = iCell + touchMask(iCell) = 1 + oceanMask(iCell) = 1 + end if + end do + + block_ptr => block_ptr % next + end do + + ! Advancing front algorithm continues until all stacks on all processes are empty. + globalStackSize = 1 + do while(globalStackSize /= 0) + ! Advance front on each block with a non-zero stack until stack is empty. + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + + call mpas_pool_get_array(scratchPool, 'cullStack', stack) + call mpas_pool_get_array(scratchPool, 'oceanCell', oceanMask) + call mpas_pool_get_array(scratchPool, 'touchedCell', touchMask) + call mpas_pool_get_array(scratchPool, 'cullStackSize', stackSize) + + touched = 0 + do while(stackSize > 0) + iCell = stack(stackSize) + stackSize = stackSize - 1 + do j = 1, nEdgesOnCell(iCell) + coc = cellsOnCell(j, iCell) + if (touchMask(coc) == 0 .and. bottomDepth(coc) > 0.0_RKIND) then + oceanMask(coc) = 1 + stackSize = stackSize + 1 + stack(stackSize) = coc + end if + touchMask(coc) = 1 + touched = touched + 1 + end do + end do + + block_ptr => block_ptr % next + end do + + ! Perform a halo exchange on oceanMask + call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) + call mpas_pool_get_field(scratchPool, 'oceanCell', oceanCellField) + call mpas_dmpar_exch_halo_field(oceanCellField) + + ! Check to see if any cells have been masked as ocean in the halo that have not been touched. + ! If there are any, add them to the stack. Also, compute globalStackSize + localStackSize = 0 + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_array(scratchPool, 'cullStack', stack) + call mpas_pool_get_array(scratchPool, 'oceanCell', oceanMask) + call mpas_pool_get_array(scratchPool, 'touchedCell', touchMask) + call mpas_pool_get_array(scratchPool, 'cullStackSize', stackSize) + + do iCell = nCellsSolve, nCells + if (oceanMask(iCell) == 1 .and. touchMask(iCell) == 0) then + stackSize = stackSize + 1 + stack(stackSize) = iCell + touchMask(iCell) = 1 + end if + end do + + localStackSize = localStackSize + stackSize + block_ptr => block_ptr % next + end do + + call mpas_dmpar_sum_int(domain % dminfo, localStackSize, globalStackSize) + end do + + ! Mark all cells that aren't ocean cells for removal + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + call mpas_pool_get_array(scratchPool, 'oceanCell', oceanMask) + + do iCell = 1, nCellsSolve + if (oceanMask(iCell) == 0) then + maxLevelCell(iCell) = -1 + end if + end do + block_ptr => block_ptr % next + end do + + call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) + + call mpas_pool_get_field(scratchPool, 'cullStack', cullStackField) + call mpas_pool_get_field(scratchPool, 'touchedCell', touchedCellField) + call mpas_pool_get_field(scratchPool, 'oceanCell', oceanCellField) + + call mpas_deallocate_scratch_field(cullStackField, .false.) + call mpas_deallocate_scratch_field(touchedCellField, .false.) + call mpas_deallocate_scratch_field(oceanCellField, .false.) + + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call ocn_mark_maxlevelcell(meshPool, iErr) + block_ptr => block_ptr % next + end do + + end subroutine ocn_init_setup_global_ocean_cull_inland_seas!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_ocean_read_depth_levels +! +!> \brief Read depth levels for global ocean test case +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine reads the depth levels from the temperature IC file and sets +!> refBottomDepth accordingly +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_ocean_read_depth_levels(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (MPAS_Stream_type) :: depthStream + + type (mpas_pool_type), pointer :: meshPool + + character (len=StrKIND), pointer :: config_global_ocean_depth_file, config_global_ocean_depth_varname, & + config_global_ocean_depth_dimname + + real (kind=RKIND), pointer :: config_global_ocean_depth_conversion_factor + + integer :: k, iCell + + real (kind=RKIND), dimension(:), pointer :: refBottomDepth + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_ocean_depth_file', config_global_ocean_depth_file) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_depth_varname', config_global_ocean_depth_varname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_depth_dimname', config_global_ocean_depth_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_depth_conversion_factor', config_global_ocean_depth_conversion_factor) + + ! Define stream for depth levels + call MPAS_createStream(depthStream, config_global_ocean_depth_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) + + ! Setup depth field for stream to be read in + depthIC % fieldName = trim(config_global_ocean_depth_varname) + depthIC % dimSizes(1) = nDepth + depthIC % dimNames(1) = trim(config_global_ocean_depth_dimname) + depthIC % isVarArray = .false. + depthIC % isPersistent = .true. + depthIC % isActive = .true. + depthIC % hasTimeDimension = .false. + depthIC % block => domain % blocklist + allocate(depthIC % array(nDepth)) + + ! Add depth field to stream + call MPAS_streamAddField(depthStream, depthIC, iErr) + + ! Read stream + call MPAS_readStream(depthStream, 1, iErr) + + ! Close stream + call MPAS_closeStream(depthStream) + depthIC % array(:) = depthIC % array(:) * config_global_ocean_depth_conversion_factor + + ! Set refBottomDepth depending on depth levels. And convert appropriately + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + refBottomDepth(:) = depthIC % array(:) + + block_ptr => block_ptr % next + end do + + end subroutine ocn_init_setup_global_ocean_read_depth_levels!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_ocean_read_tracer_lat_lon +! +!> \brief Read Lat/Lon for tracers in global ocean test case +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine reads the latitude and longitude coordinats for tracers from the temperature IC file. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_ocean_read_tracer_lat_lon(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (MPAS_Stream_type) :: tracerStream + + character (len=StrKIND), pointer :: config_global_ocean_temperature_file, config_global_ocean_tracer_lat_varname, & + config_global_ocean_tracer_nlat_dimname, config_global_ocean_tracer_lon_varname, & + config_global_ocean_tracer_nlon_dimname + + logical, pointer :: config_global_ocean_tracer_latlon_degrees + + integer :: iLat, iLon + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_ocean_temperature_file', config_global_ocean_temperature_file) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_tracer_lat_varname', config_global_ocean_tracer_lat_varname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_tracer_nlat_dimname', config_global_ocean_tracer_nlat_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_tracer_lon_varname', config_global_ocean_tracer_lon_varname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_tracer_nlon_dimname', config_global_ocean_tracer_nlon_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_tracer_latlon_degrees', config_global_ocean_tracer_latlon_degrees) + + ! Define stream for depth levels + call MPAS_createStream(tracerStream, config_global_ocean_temperature_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) + + ! Setup tracerLat and tracerLon fields for stream to be read in + tracerLat % fieldName = trim(config_global_ocean_tracer_lat_varname) + tracerLat % dimSizes(1) = nLatTracer + tracerLat % dimNames(1) = trim(config_global_ocean_tracer_nlat_dimname) + tracerLat % isVarArray = .false. + tracerLat % isPersistent = .true. + tracerLat % isActive = .true. + tracerLat % hasTimeDimension = .false. + tracerLat % block => domain % blocklist + allocate(tracerLat % array(nLatTracer)) + + tracerLon % fieldName = trim(config_global_ocean_tracer_lon_varname) + tracerLon % dimSizes(1) = nLonTracer + tracerLon % dimNames(1) = trim(config_global_ocean_tracer_nlon_dimname) + tracerLon % isVarArray = .false. + tracerLon % isPersistent = .true. + tracerLon % isActive = .true. + tracerLon % hasTimeDimension = .false. + tracerLon % block => domain % blocklist + allocate(tracerLon % array(nLonTracer)) + + ! Add tracerLat and tracerLon fields to stream + call MPAS_streamAddField(tracerStream, tracerLat, iErr) + call MPAS_streamAddField(tracerStream, tracerLon, iErr) + + ! Read stream + call MPAS_readStream(tracerStream, 1, iErr) + + ! Close stream + call MPAS_closeStream(tracerStream) + + if (config_global_ocean_tracer_latlon_degrees) then + do iLat = 1, nLatTracer + tracerLat % array(iLat) = tracerLat % array(iLat) * pii / 180.0_RKIND + end do + + do iLon = 1, nLonTracer + tracerLon % array(iLon) = tracerLon % array(iLon) * pii / 180.0_RKIND + end do + end if + + do iLon = 1, nLonTracer + if (tracerLon % array(iLon) < 0.0_RKIND) then + tracerLon % array(iLon) = 2.0_RKIND * pii + tracerLon % array(iLon) + end if + end do + + end subroutine ocn_init_setup_global_ocean_read_tracer_lat_lon!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_ocean_read_temperature +! +!> \brief Read temperature ICs for global ocean test case +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine reads the temperature field from the temperature IC file. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_ocean_read_temperature(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (MPAS_Stream_type) :: temperatureStream + + character (len=StrKIND), pointer :: config_global_ocean_temperature_file, config_global_ocean_temperature_varname, & + config_global_ocean_tracer_nlon_dimname, config_global_ocean_tracer_nlat_dimname, & + config_global_ocean_depth_dimname + + integer :: k + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_ocean_temperature_file', config_global_ocean_temperature_file) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_temperature_varname', config_global_ocean_temperature_varname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_tracer_nlon_dimname', config_global_ocean_tracer_nlon_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_tracer_nlat_dimname', config_global_ocean_tracer_nlat_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_depth_dimname', config_global_ocean_depth_dimname) + + ! Define stream for temperature IC + call MPAS_createStream(temperatureStream, config_global_ocean_temperature_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) + + ! Setup temperature field for stream to be read in + temperatureIC % fieldName = trim(config_global_ocean_temperature_varname) + temperatureIC % dimSizes(1) = nLonTracer + temperatureIC % dimSizes(2) = nLatTracer + temperatureIC % dimSizes(3) = nDepth + temperatureIC % dimNames(1) = trim(config_global_ocean_tracer_nlon_dimname) + temperatureIC % dimNames(2) = trim(config_global_ocean_tracer_nlat_dimname) + temperatureIC % dimNames(3) = trim(config_global_ocean_depth_dimname) + temperatureIC % isVarArray = .false. + temperatureIC % isPersistent = .true. + temperatureIC % isActive = .true. + temperatureIC % hasTimeDimension = .false. + temperatureIC % block => domain % blocklist + allocate(temperatureIC % array(nLonTracer, nLatTracer, nDepth)) + + ! Add temperature field to stream + call MPAS_streamAddField(temperatureStream, temperatureIC, iErr) + + ! Read stream + call MPAS_readStream(temperatureStream, 1, iErr) + + ! Close stream + call MPAS_closeStream(temperatureStream) + + end subroutine ocn_init_setup_global_ocean_read_temperature!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_ocean_read_salinity +! +!> \brief Read salinity ICs for global ocean test case +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine reads the salinity field from the salinity IC file. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_ocean_read_salinity(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (MPAS_Stream_type) :: salinityStream + + character (len=StrKIND), pointer :: config_global_ocean_salinity_file, config_global_ocean_salinity_varname, & + config_global_ocean_tracer_nlon_dimname, config_global_ocean_tracer_nlat_dimname, & + config_global_ocean_depth_dimname + + integer :: k + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_ocean_salinity_file', config_global_ocean_salinity_file) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_salinity_varname', config_global_ocean_salinity_varname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_tracer_nlon_dimname', config_global_ocean_tracer_nlon_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_tracer_nlat_dimname', config_global_ocean_tracer_nlat_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_depth_dimname', config_global_ocean_depth_dimname) + + ! Define stream for salinity IC + call MPAS_createStream(salinityStream, config_global_ocean_salinity_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) + + ! Setup salinity field for stream to be read in + salinityIC % fieldName = trim(config_global_ocean_salinity_varname) + salinityIC % dimSizes(1) = nLonTracer + salinityIC % dimSizes(2) = nLatTracer + salinityIC % dimSizes(3) = nDepth + salinityIC % dimNames(1) = trim(config_global_ocean_tracer_nlon_dimname) + salinityIC % dimNames(2) = trim(config_global_ocean_tracer_nlat_dimname) + salinityIC % dimNames(3) = trim(config_global_ocean_depth_dimname) + salinityIC % isVarArray = .false. + salinityIC % isPersistent = .true. + salinityIC % isActive = .true. + salinityIC % hasTimeDimension = .false. + salinityIC % block => domain % blocklist + allocate(salinityIC % array(nLonTracer, nLatTracer, nDepth)) + + ! Add salinity field to stream + call MPAS_streamAddField(salinityStream, salinityIC, iErr) + + ! Read stream + call MPAS_readStream(salinityStream, 1, iErr) + + ! Close stream + call MPAS_closeStream(salinityStream) + + end subroutine ocn_init_setup_global_ocean_read_salinity!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_ocean_interoplate_tracers +! +!> \brief Interpolate tracer quantities to MPAS grid +!> \author Doug Jacobsen +!> \date 03/05/2014 +!> \details +!> This routine interpolates the temperature/salinity data read in from the +!> initial condition file to the MPAS grid. Currently it uses a nearest neighbor interpolation. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + type (mpas_pool_type), pointer :: meshPool, statePool, scratchPool, tracersPool, forcingPool + type (mpas_pool_type), pointer :: tracersSurfaceRestoringFieldsPool, tracersInteriorRestoringFieldsPool + + real (kind=RKIND) :: currentLat, currentLon, counter + real (kind=RKIND) :: minDist, dist + real (kind=RKIND) :: x, x1, x2, y, y1, y2, coef, coef11, coef12, coef21, coef22 + integer :: iLat, iLon, iSmooth, j, coc + integer :: latSearch, lonSearch + integer :: iCell, k + integer :: xInd1, xInd2, yInd1, yInd2 + integer, pointer :: idxSalinity, idxTemperature, nCells, nCellsSolve, idxTracer1 + + type (field2DReal), pointer :: smoothedTemperatureField, smoothedSalinityField + type (field3DReal), pointer :: tracersField + + integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell + integer, dimension(:, :), pointer :: cellsOnCell + + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + real (kind=RKIND), dimension(:, :), pointer :: smoothedTemperature, smoothedSalinity + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers, debugTracers + real (kind=RKIND), dimension(:, :), pointer :: activeTracersPistonVelocity, activeTracersSurfaceRestoringValue + real (kind=RKIND), dimension(:, :, :), pointer :: activeTracersInteriorRestoringValue, activeTracersInteriorRestoringRate + + character (len=StrKIND), pointer :: config_global_ocean_tracer_method + integer, pointer :: config_global_ocean_smooth_TS_iterations + real (kind=RKIND), pointer :: config_global_ocean_piston_velocity + real (kind=RKIND), pointer :: config_global_ocean_interior_restore_rate + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_ocean_tracer_method', config_global_ocean_tracer_method) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_smooth_TS_iterations', config_global_ocean_smooth_TS_iterations) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_piston_velocity', config_global_ocean_piston_velocity) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_interior_restore_rate', config_global_ocean_interior_restore_rate) + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) + call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) + + call mpas_pool_get_dimension(tracersPool, 'index_temperature', idxTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', idxSalinity) + call mpas_pool_get_dimension(tracersPool, 'index_tracer1', idxTracer1) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + call mpas_pool_get_array(tracersPool, 'debugTracers', debugTracers, 1) + + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) + call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersPistonVelocity', activeTracersPistonVelocity, 1) + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersSurfaceRestoringValue', activeTracersSurfaceRestoringValue, 1) + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringRate', activeTracersInteriorRestoringRate, 1) + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringValue', activeTracersInteriorRestoringValue, 1) + + if (config_global_ocean_tracer_method .eq. "nearest_neighbor") then + do iCell = 1, nCells + currentLat = latCell(iCell) + currentLon = lonCell(iCell) + + lonSearch = 1 + minDist = 2.0_RKIND * pii + do iLon = 1, nLonTracer + dist = abs(currentLon - tracerLon % array(iLon)) + if (dist < minDist) then + minDist = dist + lonSearch = iLon + end if + end do + + latSearch = 1 + minDist = 2.0_RKIND * pii + do iLat = 1, nLatTracer + dist = abs(currentLat - tracerLat % array(iLat)) + if (dist < minDist) then + minDist = dist + latSearch = iLat + end if + end do + + do k = 1, maxLevelCell(iCell) + activeTracers(idxTemperature, k, iCell) = temperatureIC % array(lonSearch, latSearch, k) + activeTracers(idxSalinity, k, iCell) = salinityIC % array(lonSearch, latSearch, k) + end do + end do + + elseif (config_global_ocean_tracer_method .eq. "bilinear_interpolation") then + + do iCell = 1, nCells + x = lonCell(iCell) + y = latCell(iCell) + + ! Set up bilinear interpolation indices in longitude, watching for periodic boundary at 0 and 2 pi + xInd1 = 0 + if (x .le. tracerLon % array(1)) then + xInd1 = nLonTracer + xInd2 = 1 + x1 = tracerLon % array(xInd1) - 2.0*pii + x2 = tracerLon % array(xInd2) + elseif (x .ge. tracerLon % array(nLonTracer)) then + xInd1 = nLonTracer + xInd2 = 1 + x1 = tracerLon % array(xInd1) + x2 = tracerLon % array(xInd2) + 2.0*pii + else + do iLon = 1, nLonTracer-1 + if (x .le. tracerLon % array(iLon+1)) then + xInd1 = iLon + xInd2 = iLon+1 + x1 = tracerLon % array(xInd1) + x2 = tracerLon % array(xInd2) + exit + end if + end do + endif + + yInd1 = 0 + if (y .le. tracerLat % array(1)) then + ! if south of the southernmost data point, extrapolate as a constant in latitude + yInd1 = 1 + yInd2 = 1 + coef = 1.0_RKIND/(x2-x1) + coef11 = 1.0_RKIND*(x2-x ) + coef21 = 1.0_RKIND*(x -x1) + coef12 = 0.0_RKIND + coef22 = 0.0_RKIND + elseif (y .ge. tracerLat % array(nLatTracer)) then + ! if north of the northernmost data point, extrapolate as a constant in latitude + yInd1 = nLatTracer + yInd2 = nLatTracer + coef = 1.0_RKIND/(x2-x1) + coef11 = 1.0_RKIND*(x2-x ) + coef21 = 1.0_RKIND*(x -x1) + coef12 = 0.0_RKIND + coef22 = 0.0_RKIND + else + ! Set up bilinear interpolation coefficients in latitude + do iLat = 1, nLatTracer-1 + if (y .le. tracerLat % array(iLat+1)) then + yInd1 = iLat + yInd2 = iLat+1 + exit + end if + end do + y1 = tracerLat % array(yInd1) + y2 = tracerLat % array(yInd2) + coef = 1.0_RKIND/(x2-x1)/(y2-y1) + coef11 = 1.0_RKIND*(x2-x )*(y2-y ) + coef21 = 1.0_RKIND*(x -x1)*(y2-y ) + coef12 = 1.0_RKIND*(x2-x )*(y -y1) + coef22 = 1.0_RKIND*(x -x1)*(y -y1) + endif + + ! Assign T&S using bilinear interpolation + ! formulas from http://en.wikipedia.org/wiki/Bilinear_interpolation + do k = 1, maxLevelCell(iCell) + + activeTracers(idxTemperature, k, iCell) = coef*( & + coef11* temperatureIC % array(xInd1,yInd1, k) & + + coef21* temperatureIC % array(xInd2,yInd1, k) & + + coef12* temperatureIC % array(xInd1,yInd2, k) & + + coef22* temperatureIC % array(xInd2,yInd2, k) ) + + activeTracers(idxSalinity, k, iCell) = coef*( & + coef11* salinityIC % array(xInd1,yInd1, k) & + + coef21* salinityIC % array(xInd2,yInd1, k) & + + coef12* salinityIC % array(xInd1,yInd2, k) & + + coef22* salinityIC % array(xInd2,yInd2, k) ) + + end do + + end do + + else + write(stderrUnit,*) 'ERROR: Invalid choice of config_global_ocean_tracer_method.' + iErr = 1 + call mpas_dmpar_finalize(domain % dminfo) + endif + + ! set surface restoring values and rate + do iCell=1,nCells + activeTracersSurfaceRestoringValue(idxTemperature, iCell) = activeTracers(idxTemperature, 1, iCell) + activeTracersSurfaceRestoringValue(idxSalinity, iCell) = activeTracers(idxSalinity, 1, iCell) + activeTracersPistonVelocity(idxTemperature, iCell) = config_global_ocean_piston_velocity + activeTracersPistonVelocity(idxSalinity, iCell) = config_global_ocean_piston_velocity + enddo + + ! set interior restoring values and rate + do iCell=1,nCells + do k = 1, maxLevelCell(iCell) + activeTracersInteriorRestoringValue(idxTemperature, k, iCell) = activeTracers(idxTemperature, k, iCell) + activeTracersInteriorRestoringValue(idxSalinity, k, iCell) = activeTracers(idxSalinity, k, iCell) + activeTracersInteriorRestoringRate(idxTemperature, k, iCell) = config_global_ocean_interior_restore_rate + activeTracersInteriorRestoringRate(idxSalinity, k, iCell) = config_global_ocean_interior_restore_rate + enddo + enddo + + block_ptr => block_ptr % next + end do + + ! Smooth temperature and salinity. + if (config_global_ocean_smooth_TS_iterations .gt. 0) then + call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) + + call mpas_pool_get_field(scratchPool, 'smoothedTemperature', smoothedTemperatureField) + call mpas_pool_get_field(scratchPool, 'smoothedSalinity', smoothedSalinityField) + + call mpas_allocate_scratch_field(smoothedTemperatureField, .false.) + call mpas_allocate_scratch_field(smoothedSalinityField, .false.) + + do iSmooth = 1,config_global_ocean_smooth_TS_iterations + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) + call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', idxTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', idxSalinity) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) + call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersSurfaceRestoringValue', activeTracersSurfaceRestoringValue, 1) + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringValue', activeTracersInteriorRestoringValue, 1) + + call mpas_pool_get_array(scratchPool, 'smoothedTemperature', smoothedTemperature) + call mpas_pool_get_array(scratchPool, 'smoothedSalinity', smoothedSalinity) + + maxLevelCell(nCells+1) = -1 + + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + smoothedtemperature(k, iCell) = activeTracers(idxTemperature, k, iCell) + smoothedsalinity(k, iCell) = activeTracers(idxSalinity, k, iCell) + counter = 1 + + do j = 1, nEdgesOnCell(iCell) + coc = cellsOnCell(j, iCell) + ! check if coc not 0 (or nCells+1)? + if (k .le. maxLevelCell(coc)) then + + smoothedtemperature(k, iCell) = smoothedtemperature(k, iCell) + activeTracers (idxTemperature, k, coc) + smoothedsalinity(k, iCell) = smoothedsalinity(k, iCell) + activeTracers(idxSalinity, k, coc) + counter = counter + 1 + + end if + end do ! edgesOnCell + + smoothedtemperature(k, iCell) = smoothedtemperature(k, iCell) / counter + smoothedsalinity(k, iCell) = smoothedsalinity(k, iCell) / counter + + end do ! k level + + end do ! iCell + + activeTracers(idxTemperature, :, :) = smoothedtemperature(:,:) + activeTracers(idxSalinity, :, :) = smoothedsalinity(:,:) + + activeTracersInteriorRestoringValue(:,:,:) = activeTracers(:,:,:) + activeTracersSurfaceRestoringValue(:,:) = activeTracers(:,1,:) + + block_ptr => block_ptr % next + end do + + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_field(statePool, 'tracers', tracersField, 1) + + call mpas_dmpar_exch_halo_field(tracersField) + + end do ! iSmooth + + call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) + call mpas_pool_get_field(scratchPool, 'smoothedTemperature', smoothedTemperatureField) + call mpas_pool_get_field(scratchPool, 'smoothedSalinity', smoothedSalinityField) + call mpas_deallocate_scratch_field(smoothedTemperatureField, .false.) + call mpas_deallocate_scratch_field(smoothedSalinityField, .false.) + endif + + end subroutine ocn_init_setup_global_ocean_interpolate_tracers!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_ocean_read_windstress +! +!> \brief Read the windstress IC file +!> \author Doug Jacobsen +!> \date 03/07/2014 +!> \details +!> This routine reads the windstress IC file, including latitude and longitude +!> information for windstress data. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_ocean_read_windstress(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (MPAS_Stream_type) :: windstressStream + + integer :: iLat, iLon + + character (len=StrKIND), pointer :: config_global_ocean_windstress_file, config_global_ocean_windstress_lat_varname, & + config_global_ocean_windstress_nlat_dimname, config_global_ocean_windstress_lon_varname, & + config_global_ocean_windstress_nlon_dimname, config_global_ocean_windstress_zonal_varname, & + config_global_ocean_windstress_meridional_varname + + logical, pointer :: config_global_ocean_windstress_latlon_degrees + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_ocean_windstress_file', config_global_ocean_windstress_file) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_windstress_lat_varname', config_global_ocean_windstress_lat_varname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_windstress_nlat_dimname', config_global_ocean_windstress_nlat_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_windstress_lon_varname', config_global_ocean_windstress_lon_varname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_windstress_nlon_dimname', config_global_ocean_windstress_nlon_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_windstress_zonal_varname', config_global_ocean_windstress_zonal_varname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_windstress_meridional_varname', config_global_ocean_windstress_meridional_varname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_windstress_latlon_degrees', config_global_ocean_windstress_latlon_degrees) + + ! Define stream for depth levels + call MPAS_createStream(windstressStream, config_global_ocean_windstress_file, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) + + ! Setup windLat, windLon, and windIC fields for stream to be read in + windLat % fieldName = trim(config_global_ocean_windstress_lat_varname) + windLat % dimSizes(1) = nLatWind + windLat % dimNames(1) = trim(config_global_ocean_windstress_nlat_dimname) + windLat % isVarArray = .false. + windLat % isPersistent = .true. + windLat % isActive = .true. + windLat % hasTimeDimension = .false. + windLat % block => domain % blocklist + allocate(windLat % array(nLatWind)) + + windLon % fieldName = trim(config_global_ocean_windstress_lon_varname) + windLon % dimSizes(1) = nLonWind + windLon % dimNames(1) = trim(config_global_ocean_windstress_nlon_dimname) + windLon % isVarArray = .false. + windLon % isPersistent = .true. + windLon % isActive = .true. + windLon % hasTimeDimension = .false. + windLon % block => domain % blocklist + allocate(windLon % array(nLonWind)) + + zonalWindIC % fieldName = trim(config_global_ocean_windstress_zonal_varname) + zonalWindIC % dimSizes(1) = nLonWind + zonalWindIC % dimSizes(2) = nLatWind + zonalWindIC % dimNames(1) = trim(config_global_ocean_windstress_nlon_dimname) + zonalWindIC % dimNames(2) = trim(config_global_ocean_windstress_nlat_dimname) + zonalWindIC % isVarArray = .false. + zonalWindIC % isPersistent = .true. + zonalWindIC % isActive = .true. + zonalWindIC % hasTimeDimension = .false. + zonalWindIC % block => domain % blocklist + allocate(zonalWindIC % array(nLonWind, nLatWind)) + + meridionalWindIC % fieldName = trim(config_global_ocean_windstress_meridional_varname) + meridionalWindIC % dimSizes(1) = nLonWind + meridionalWindIC % dimSizes(2) = nLatWind + meridionalWindIC % dimNames(1) = trim(config_global_ocean_windstress_nlon_dimname) + meridionalWindIC % dimNames(2) = trim(config_global_ocean_windstress_nlat_dimname) + meridionalWindIC % isVarArray = .false. + meridionalWindIC % isPersistent = .true. + meridionalWindIC % isActive = .true. + meridionalWindIC % hasTimeDimension = .false. + meridionalWindIC % block => domain % blocklist + allocate(meridionalWindIC % array(nLonWind, nLatWind)) + + ! Add windLat, windLon, and windIC fields to stream + call MPAS_streamAddField(windstressStream, windLat, iErr) + call MPAS_streamAddField(windstressStream, windLon, iErr) + call MPAS_streamAddField(windstressStream, zonalWindIC, iErr) + call MPAS_streamAddField(windstressStream, meridionalWindIC, iErr) + + ! Read stream + call MPAS_readStream(windstressStream, 1, iErr) + + ! Close stream + call MPAS_closeStream(windstressStream) + + if (config_global_ocean_windstress_latlon_degrees) then + windLat % array(:) = windLat % array(:) * pii / 180.0_RKIND + windLon % array(:) = windLon % array(:) * pii / 180.0_RKIND + end if + + do iLon = 1, nLonWind + if (windLon % array(iLon) < 0.0_RKIND) then + windLon % array(iLon) = 2.0_RKIND * pii + windLon % array(iLon) + end if + end do + + end subroutine ocn_init_setup_global_ocean_read_windstress!}}} + +!*********************************************************************** +! +! routine ocn_init_setup_global_ocean_interpolate_windstress +! +!> \brief Interpolate the windstress IC to MPAS mesh +!> \author Doug Jacobsen +!> \date 03/07/2014 +!> \details +!> This routine interpolates windstress data to the MPAS mesh. Currently it +!> uses a bilinear interpolation +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_global_ocean_interpolate_windstress(domain, iErr)!{{{ + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool, forcingPool + + real (kind=RKIND) :: currentLat, currentLon + real (kind=RKIND) :: zonalWind, meridionalWind + real (kind=RKIND) :: angle + real (kind=RKIND) :: dist, minDist + real (kind=RKIND) :: x, x1, x2, y, y1, y2, coef, coef11, coef12, coef21, coef22 + + integer :: ilat, iLon + integer :: latSearch, lonSearch + integer :: iEdge + integer :: xInd1, xInd2, yInd1, yInd2 + + real (kind=RKIND), dimension(:), pointer :: latEdge, lonEdge, angleEdge, surfaceWindStress + + integer, pointer :: nEdgesSolve, nEdges + + character (len=StrKIND), pointer :: config_global_ocean_windstress_method + real (kind=RKIND), pointer :: config_global_ocean_windstress_conversion_factor + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_ocean_windstress_method', config_global_ocean_windstress_method) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_windstress_conversion_factor', config_global_ocean_windstress_conversion_factor) + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(meshPool, 'latEdge', latEdge) + call mpas_pool_get_array(meshPool, 'lonEdge', lonEdge) + call mpas_pool_get_array(meshPool, 'angleEdge', angleEdge) + + call mpas_pool_get_array(forcingPool, 'surfaceWindStress', surfaceWindStress) + + if (config_global_ocean_windstress_method .eq. "nearest_neighbor") then + do iEdge = 1, nEdgesSolve + currentLat = latEdge(iEdge) + currentLon = lonEdge(iEdge) + angle = angleEdge(iEdge) + + minDist = 2.0_RKIND * pii + lonSearch = 1 + do iLon = 1, nLonWind + dist = abs(currentLon - windLon % array(iLon)) + if (dist < minDist) then + minDist = dist + lonSearch = iLon + end if + end do + + minDist = 2.0_RKIND * pii + latSearch = 1 + do iLat = 1, nLatWind + dist = abs(currentLat - windLat % array(iLat)) + if (dist < minDist) then + minDist = dist + latSearch = iLat + end if + end do + + zonalWind = zonalWindIC % array(lonSearch, latSearch) * config_global_ocean_windstress_conversion_factor + meridionalWind = meridionalWindIC % array(lonSearch, latSearch) * config_global_ocean_windstress_conversion_factor + + surfaceWindStress(iEdge) = zonalWind * cos(angle) + meridionalWind * sin(angle) + end do + + elseif (config_global_ocean_windstress_method .eq. "bilinear_interpolation") then + + do iEdge = 1, nEdges + x = lonEdge(iEdge) + y = latEdge(iEdge) + angle = angleEdge(iEdge) + + ! Set up bilinear interpolation indices in longitude, watching for periodic boundary at 0 and 2 pi + xInd1 = 0 + if (x .le. windLon % array(1)) then + xInd1 = nLonWind + xInd2 = 1 + x1 = windLon % array(xInd1) - 2.0_RKIND*pii + x2 = windLon % array(xInd2) + elseif (x .ge. windLon % array(nLonWind)) then + xInd1 = nLonWind + xInd2 = 1 + x1 = windLon % array(xInd1) + x2 = windLon % array(xInd2) + 2.0_RKIND*pii + else + do iLon = 1, nLonWind-1 + if (x .le. windLon % array(iLon+1)) then + xInd1 = iLon + xInd2 = iLon+1 + x1 = windLon % array(xInd1) + x2 = windLon % array(xInd2) + exit + end if + end do + endif + + yInd1 = 0 + if (y .le. windLat % array(1)) then + ! if south of the southernmost data point, extrapolate as a constant in latitude + yInd1 = 1 + yInd2 = 1 + coef = 1.0_RKIND/(x2-x1) + coef11 = 1.0_RKIND*(x2-x ) + coef21 = 1.0_RKIND*(x -x1) + coef12 = 0.0_RKIND + coef22 = 0.0_RKIND + elseif (y .ge. windLat % array(nLatWind)) then + ! if north of the northernmost data point, extrapolate as a constant in latitude + yInd1 = nLatWind + yInd2 = nLatWind + coef = 1.0_RKIND/(x2-x1) + coef11 = 1.0_RKIND*(x2-x ) + coef21 = 1.0_RKIND*(x -x1) + coef12 = 0.0_RKIND + coef22 = 0.0_RKIND + else + ! Set up bilinear interpolation coefficients in latitude + do iLat = 1, nLatWind-1 + if (y .le. windLat % array(iLat+1)) then + yInd1 = iLat + yInd2 = iLat+1 + exit + end if + end do + y1 = windLat % array(yInd1) + y2 = windLat % array(yInd2) + coef = 1.0_RKIND/(x2-x1)/(y2-y1) + coef11 = 1.0_RKIND*(x2-x )*(y2-y ) + coef21 = 1.0_RKIND*(x -x1)*(y2-y ) + coef12 = 1.0_RKIND*(x2-x )*(y -y1) + coef22 = 1.0_RKIND*(x -x1)*(y -y1) + endif + + zonalWind = coef*config_global_ocean_windstress_conversion_factor*( & + coef11* zonalWindIC % array(xInd1, yInd1) & + + coef21* zonalWindIC % array(xInd2, yInd1) & + + coef12* zonalWindIC % array(xInd1, yInd2) & + + coef22* zonalWindIC % array(xInd2, yInd2) ) + + meridionalWind = coef*config_global_ocean_windstress_conversion_factor*( & + coef11* meridionalWindIC % array(xInd1, yInd1) & + + coef21* meridionalWindIC % array(xInd2, yInd1) & + + coef12* meridionalWindIC % array(xInd1, yInd2) & + + coef22* meridionalWindIC % array(xInd2, yInd2) ) + + surfaceWindStress(iEdge) = zonalWind * cos(angle) + meridionalWind * sin(angle) + + end do + + else + write(stderrUnit,*) 'ERROR: Invalid choice of config_global_ocean_windstress_method.' + iErr = 1 + call mpas_dmpar_finalize(domain % dminfo) + endif + + block_ptr => block_ptr % next + end do + + end subroutine ocn_init_setup_global_ocean_interpolate_windstress!}}} + +!*********************************************************************** +! +! routine ocn_init_global_ocean_destroy_tracer_fields +! +!> \brief Tracer field cleanup routine +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine destroys the fields that were created to hold tracer +!> initial condition information +! +!----------------------------------------------------------------------- + + subroutine ocn_init_global_ocean_destroy_tracer_fields()!{{{ + deallocate(temperatureIC % array) + deallocate(salinityIC % array) + deallocate(tracerLat % array) + deallocate(tracerLon % array) + end subroutine ocn_init_global_ocean_destroy_tracer_fields!}}} + +!*********************************************************************** +! +! routine ocn_init_global_ocean_destroy_topo_fields +! +!> \brief Topography field cleanup routine +!> \author Doug Jacobsen +!> \date 03/07/2014 +!> \details +!> This routine destroys the fields that were created to hold topography +!> initial condition information +! +!----------------------------------------------------------------------- + + subroutine ocn_init_global_ocean_destroy_topo_fields()!{{{ + deallocate(topoIC % array) + deallocate(topoLat % array) + deallocate(topoLon % array) + end subroutine ocn_init_global_ocean_destroy_topo_fields!}}} + +!*********************************************************************** +! +! routine ocn_init_global_ocean_destroy_windstress_fields +! +!> \brief Windstress field cleanup routine +!> \author Doug Jacobsen +!> \date 03/07/2014 +!> \details +!> This routine destroys the fields that were created to hold windstress +!> initial condition information +! +!----------------------------------------------------------------------- + + subroutine ocn_init_global_ocean_destroy_windstress_fields()!{{{ + deallocate(zonalWindIC % array) + deallocate(meridionalWindIC % array) + deallocate(windLat % array) + deallocate(windLon % array) + end subroutine ocn_init_global_ocean_destroy_windstress_fields!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_global_ocean +! +!> \brief Validation for global ocean test case +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine validates the configuration options for the global ocean test case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_global_ocean(configPool, packagePool, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: configPool, packagePool + integer, intent(out) :: iErr + type (MPAS_IO_Handle_type) :: inputFile + + character (len=StrKIND), pointer :: config_init_configuration, config_global_ocean_depth_file, & + config_global_ocean_depth_dimname, config_global_ocean_temperature_file, & + config_global_ocean_salinity_file, config_global_ocean_tracer_nlat_dimname, & + config_global_ocean_tracer_nlon_dimname, config_global_ocean_topography_file, & + config_global_ocean_topography_nlat_dimname, config_global_ocean_topography_nlon_dimname, & + config_global_ocean_windstress_file, config_global_ocean_windstress_nlat_dimname, & + config_global_ocean_windstress_nlon_dimname + + integer, pointer :: config_vert_levels + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('global_ocean')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_global_ocean_depth_file', config_global_ocean_depth_file) + call mpas_pool_get_config(configPool, 'config_globa_ocean__depth_dimname', config_global_ocean_depth_dimname) + call mpas_pool_get_config(configPool, 'config_global_ocean_temperature_file', config_global_ocean_temperature_file) + call mpas_pool_get_config(configPool, 'config_global_ocean_salinity_file', config_global_ocean_salinity_file) + call mpas_pool_get_config(configPool, 'config_global_ocean_tracer_nlat_dimname', config_global_ocean_tracer_nlat_dimname) + call mpas_pool_get_config(configPool, 'config_global_ocean_tracer_nlon_dimname', config_global_ocean_tracer_nlon_dimname) + call mpas_pool_get_config(configPool, 'config_global_ocean_topography_file', config_global_ocean_topography_file) + call mpas_pool_get_config(configPool, 'config_global_ocean_topography_nlat_dimname', config_global_ocean_topography_nlat_dimname) + call mpas_pool_get_config(configPool, 'config_global_ocean_topography_nlon_dimname', config_global_ocean_topography_nlon_dimname) + call mpas_pool_get_config(configPool, 'config_global_ocean_windstress_file', config_global_ocean_windstress_file) + call mpas_pool_get_config(configPool, 'config_global_ocean_windstress_nlat_dimname', config_global_ocean_windstress_nlat_dimname) + call mpas_pool_get_config(configPool, 'config_global_ocean_windstress_nlon_dimname', config_global_ocean_windstress_nlon_dimname) + + inputFile = MPAS_io_open(config_global_ocean_depth_file, MPAS_IO_READ, MPAS_IO_NETCDF, ierr=iErr) + + call MPAS_io_inq_dim(inputFile, config_global_ocean_depth_dimname, nDepth, iErr) + + call MPAS_io_close(inputFile, iErr) + + inputFile = MPAS_io_open(config_global_ocean_temperature_file, MPAS_IO_READ, MPAS_IO_NETCDF, ierr=iErr) + + call MPAS_io_inq_dim(inputFile, config_global_ocean_tracer_nlat_dimname, nLatTracer, iErr) + call MPAS_io_inq_dim(inputFile, config_global_ocean_tracer_nlon_dimname, nLonTracer, iErr) + + call MPAS_io_close(inputFile, iErr) + + inputFile = MPAS_io_open(config_global_ocean_topography_file, MPAS_IO_READ, MPAS_IO_NETCDF, ierr=iErr) + + call MPAS_io_inq_dim(inputFile, config_global_ocean_topography_nlat_dimname, nLatTopo, iErr) + call MPAS_io_inq_dim(inputFile, config_global_ocean_topography_nlon_dimname, nLonTopo, iErr) + + call MPAS_io_close(inputFile, iErr) + + inputFile = MPAS_io_open(config_global_ocean_windstress_file, MPAS_IO_READ, MPAS_IO_NETCDF, ierr=iErr) + + call MPAS_io_inq_dim(inputFile, config_global_ocean_windstress_nlat_dimname, nLatWind, iErr) + call MPAS_io_inq_dim(inputFile, config_global_ocean_windstress_nlon_dimname, nLonWind, iErr) + + call MPAS_io_close(inputFile, iErr) + + if (config_vert_levels <= 0 .and. nDepth > 0) then + config_vert_levels = nDepth + else if(config_vert_levels <= 0) then + write(stderrUnit,*) 'ERROR: Validation failed for global ocean. Not given a usable value for vertical levels.' + iErr = 1 + end if + + if (trim(config_global_ocean_temperature_file) == 'none') then + write(stderrUnit,*) 'ERROR: Validation failed for global ocean. Invalid filename for config_global_ocean_temperature_file' + iErr = 1 + end if + + if (trim(config_global_ocean_salinity_file) == 'none') then + write(stderrUnit,*) 'ERROR: Validation failed for global ocean. Invalid filename for config_global_ocean_salinity_file' + iErr = 1 + end if + + if (trim(config_global_ocean_depth_file) == 'none') then + write(stderrUnit,*) 'ERROR: Validation failed for global ocean. Invalid filename for config_global_ocean_depth_file' + iErr = 1 + end if + + if (trim(config_global_ocean_topography_file) == 'none') then + write(stderrUnit,*) 'ERROR: Validation failed for global ocean. Invalid filename for config_global_ocean_topography_file' + iErr = 1 + end if + + if (trim(config_global_ocean_windstress_file) == 'none') then + write(stderrUnit,*) 'ERROR: Validation failed for global ocean. Invalid filename for config_global_ocean_windstress_file' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_global_ocean!}}} + +!*********************************************************************** + +end module ocn_init_global_ocean + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker From 32cf37d94f50c8cb9d274fa2eb82d23b9db18ddb Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 27 Aug 2015 14:41:48 -0600 Subject: [PATCH 0198/1724] Fix some missing associated tests This tests fix an issue where a tracer group is deactivated. Previously deactivating a tracer group would cause these portions of code to segfault. --- .../mpas_ocn_time_integration_split.F | 10 ++++--- .../shared/mpas_ocn_init_routines.F | 29 +++++++++++-------- src/core_ocean/shared/mpas_ocn_vmix.F | 4 ++- 3 files changed, 26 insertions(+), 17 deletions(-) diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F index 8c4fd4c46c..a959876c26 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F @@ -306,11 +306,13 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroupCur, 1) call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroupNew, 2) - do iCell = 1, nCells - do k = 1, maxLevelCell(iCell) - tracersGroupNew(:,k,iCell) = tracersGroupCur(:,k,iCell) + if ( associated(tracersGroupCur) .and. associated(tracersGroupNew) ) then + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersGroupNew(:,k,iCell) = tracersGroupCur(:,k,iCell) + end do end do - end do + end if end if end do diff --git a/src/core_ocean/shared/mpas_ocn_init_routines.F b/src/core_ocean/shared/mpas_ocn_init_routines.F index d0078b447f..bdb6bb5072 100644 --- a/src/core_ocean/shared/mpas_ocn_init_routines.F +++ b/src/core_ocean/shared/mpas_ocn_init_routines.F @@ -496,16 +496,19 @@ subroutine ocn_init_routines_vert_coord(domain)!{{{ if ( groupItr % memberType == MPAS_POOL_FIELD ) then call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroup, 1) - do iCell = 1, nCells - ! Linearly interpolate the initial T&S for new location of bottom cell for PBCs - zMidPBC = -0.5_RKIND * (bottomDepth(iCell) + refBottomDepthTopOfCell(k)) - km1 = max(k-1,1) - tracersGroup(:, k, iCell) = tracersGroup(:, k, iCell) & - + (tracersGroup(:, km1, iCell) - tracersGroup(:, k, iCell)) & - /(zMidZLevel(km1) - zMidZLevel(k) + 1.0e-16_RKIND) & - *(zMidPBC - zMidZLevel(k)) + if ( associated(tracersGroup) ) then + do iCell = 1, nCells + ! Linearly interpolate the initial T&S for new location of bottom cell for PBCs + k = maxLevelCell(iCell) + zMidPBC = -0.5_RKIND * (bottomDepth(iCell) + refBottomDepthTopOfCell(k)) + km1 = max(k-1,1) + tracersGroup(:, k, iCell) = tracersGroup(:, k, iCell) & + + (tracersGroup(:, km1, iCell) - tracersGroup(:, k, iCell)) & + /(zMidZLevel(km1) - zMidZLevel(k) + 1.0e-16_RKIND) & + *(zMidPBC - zMidZLevel(k)) - end do + end do + end if end if end do @@ -703,9 +706,11 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) if ( groupItr % memberType == MPAS_POOL_FIELD ) then call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroup, 1) - do iCell=1,nCells - tracersGroup(:, maxLevelCell(iCell)+1:nVertLevels,iCell) = -1.0e34 - end do + if ( associated(tracersGroup) ) then + do iCell=1,nCells + tracersGroup(:, maxLevelCell(iCell)+1:nVertLevels,iCell) = -1.0e34 + end do + end if end if end do diff --git a/src/core_ocean/shared/mpas_ocn_vmix.F b/src/core_ocean/shared/mpas_ocn_vmix.F index 553379b444..2cb3ab05bb 100644 --- a/src/core_ocean/shared/mpas_ocn_vmix.F +++ b/src/core_ocean/shared/mpas_ocn_vmix.F @@ -500,7 +500,9 @@ subroutine ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, err, time if ( groupItr % memberType == MPAS_POOL_FIELD ) then call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroup, timeLevel) - call ocn_tracer_vmix_tend_implicit(meshPool, dt, vertDiffTopOfCell, layerThickness, tracersGroup, err) + if ( associated(tracersGroup) ) then + call ocn_tracer_vmix_tend_implicit(meshPool, dt, vertDiffTopOfCell, layerThickness, tracersGroup, err) + end if end if end do From df9c5c2149159197ced293aa0706a4e4f81f00fe Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Tue, 18 Aug 2015 14:54:19 -0600 Subject: [PATCH 0199/1724] changed vertical interpolation ordering of arrays Changed the vertical interpolation scheme in the eliassen_palm AM so that now it expects monotonically increasing reference array. The reason for this change is that most calls to this routine were sending -potentialDensityMidRef, so the compiler had to make a scratch variable. In order to clean this up, I decided to change the ordering of the arrays expected as arguments, instead of having to assign temporary scratch variables everywhere to be sent to the interpolation routine. The vertical interpolation routine was originally developed with the idea of sending it a reference buoyancy variable, not density. In hindsight, the vertical interpolation should expect a reference density variable to interpolate to. For nonlinear equations of state, this reference density variable can be neutral density. --- .../analysis_members/mpas_ocn_eliassen_palm.F | 40 ++++++++++--------- 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index 15ad9ad61d..5e85151335 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -923,7 +923,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ !------------------------------------------------------------- if(config_eliassen_palm_debug) then do i = 1, nCells - array1_3D(:,i) = zMid(:,nCells/2) + array1_3D(:,i) = -zMid(:,nCells/2) array2_3D(:,i) = potentialDensity(:,nCells/2) end do print *, ' ' @@ -983,7 +983,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ end do call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & maxLevelCell, array1_3D, zMid, potentialDensityMidRef, array1_3Dbuoy) - + do i = 1,nCells do k = 1, nBuoyancyLayers array2_3Dbuoy(k,i) = zMid(1,i) + & @@ -1023,32 +1023,32 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ ! interpolate state variable from z-space into buoyancy-space !------------------------------------------------------------- call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & - maxLevelCell, -potentialDensity, zMid, & - -potentialDensityMidRef, heightMidBuoyCoor) + maxLevelCell, potentialDensity, zMid, & + potentialDensityMidRef, heightMidBuoyCoor) call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & - maxLevelCell, -potentialDensity, zMid, & - -potentialDensityTopRef, heightTopBuoyCoor) + maxLevelCell, potentialDensity, zMid, & + potentialDensityTopRef, heightTopBuoyCoor) call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & - maxLevelCell, -potentialDensity, velocityZonal, & - -potentialDensityMidRef, uMidBuoyCoor) + maxLevelCell, potentialDensity, velocityZonal, & + potentialDensityMidRef, uMidBuoyCoor) call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & - maxLevelCell, -potentialDensity, velocityMeridional, & - -potentialDensityMidRef, vMidBuoyCoor) + maxLevelCell, potentialDensity, velocityMeridional, & + potentialDensityMidRef, vMidBuoyCoor) call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & - maxLevelCell, -potentialDensity, density, & - -potentialDensityMidRef, densityMidBuoyCoor) + maxLevelCell, potentialDensity, density, & + potentialDensityMidRef, densityMidBuoyCoor) call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & - maxLevelCell, -potentialDensity, density, & - -potentialDensityTopRef, densityTopBuoyCoor) + maxLevelCell, potentialDensity, density, & + potentialDensityTopRef, densityTopBuoyCoor) ! Diabatic terms !call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & - ! maxLevelCell, -potentialDensity, wCellCenter, potentialDensityTopRef, wMidBuoyCoor) + ! maxLevelCell, potentialDensity, wCellCenter, potentialDensityTopRef, wMidBuoyCoor) !------------------------------------------------------------- ! fill in data above firstLayerBuoyCoor and below lastLayerBuoyCoor @@ -1294,8 +1294,8 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ ! store relVortMidBuoyCoor in array1_3Dbuoy call linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLayers, & - maxLevelCell, -potentialDensity, relativeVorticityCell, & - -potentialDensityMidRef, array1_3Dbuoy) + maxLevelCell, potentialDensity, relativeVorticityCell, & + potentialDensityMidRef, array1_3Dbuoy) do i = 1,nCells do k=firstLayerBuoyCoor(i), lastLayerBuoyCoor(i) @@ -1720,7 +1720,7 @@ end subroutine check_potentialDensityRef_range!}}} !> Interpolate a field yFieldIn residing on xFieldIn onto xColumnOut and store !> and return in yFieldOut. !> Interpolation is done using one-dimensional interpolation along xColumnOut. -!> Required: xFieldIn monotonically decreases with index value +!> Required: xFieldIn monotonically increases with index value ! !----------------------------------------------------------------------- @@ -1747,6 +1747,10 @@ subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLay integer :: iCell, maxLevel, kB, kBBottom, kBTop, kDataAbove, kDataBelow, kData real (kind=RKIND) :: dx, dy + ! jas issue: the code below works for monotonically decreasing arrays. + ! however above it expects arguments that are monotonically increasing arrays. + xFieldIn = -xFieldIn + xColumnOut = -xColumnOut !----------------------------------------------------------------- ! test for monoticity of xFieldIn From 00d0b76827c2b050ec8a20d4257ffc1fe0996545 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Tue, 18 Aug 2015 16:10:47 -0600 Subject: [PATCH 0200/1724] using scratch vars in vertical interp routine Created scratch variables inside the vertical interpolation routine. --- .../analysis_members/mpas_ocn_eliassen_palm.F | 32 ++++++++++--------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index 5e85151335..4b9d426ef9 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -1746,14 +1746,16 @@ subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLay !----------------------------------------------------------------- integer :: iCell, maxLevel, kB, kBBottom, kBTop, kDataAbove, kDataBelow, kData real (kind=RKIND) :: dx, dy + real (kind=RKIND), dimension(nVertLevels, nCells) :: xSrc ! source data + real (kind=RKIND), dimension(nBuoyancyLayers) :: xDst ! destination data ! jas issue: the code below works for monotonically decreasing arrays. ! however above it expects arguments that are monotonically increasing arrays. - xFieldIn = -xFieldIn - xColumnOut = -xColumnOut + xSrc = -xFieldIn + xDst = -xColumnOut !----------------------------------------------------------------- - ! test for monoticity of xFieldIn + ! test for monoticity of xSrc !----------------------------------------------------------------- ! jas issue : to do @@ -1770,14 +1772,14 @@ subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLay ! find the index of the bottom level of a column maxLevel = maxLevelCell(iCell) - ! Monotonically decreasing xFieldIn required - ! Find index of first element in xColumnOut that is inside xFieldIn(:,iCell) + ! Monotonically decreasing xSrc required + ! Find index of first element in xDst that is inside xSrc(:,iCell) kBTop = 1 do kB = 1, nBuoyancyLayers ! the following line ensures that - ! if all xColumnOut > xFieldIn(1,iCell) then kBTop = nBuoyancyLayers + ! if all xDst > xSrc(1,iCell) then kBTop = nBuoyancyLayers kBTop = kB - if (xColumnOut(kB) <= xFieldIn(1,iCell) ) then + if (xDst(kB) <= xSrc(1,iCell) ) then exit endif enddo @@ -1786,9 +1788,9 @@ subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLay kBBottom = nBuoyancyLayers do kB = nBuoyancyLayers, 1, -1 ! the following line ensures that - ! if all xColumnOut < xFieldIn(1,iCell) then kBBottom = 1 + ! if all xDst < xSrc(1,iCell) then kBBottom = 1 kBBottom = kB - if (xColumnOut(kB) >= xFieldIn(maxLevel,iCell) ) then + if (xDst(kB) >= xSrc(maxLevel,iCell) ) then exit endif enddo @@ -1808,11 +1810,11 @@ subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLay kDataAbove = 1 kDataBelow = kDataAbove + 1 do kB = kBTop, kBBottom - ! for each xColumnOut(kB) value, find the corresponding upper and lower - ! xFieldIn value in the field data, then interpolate y between those values. - if (xColumnOut(kB) < xFieldIn(kDataBelow,iCell)) then + ! for each xDst(kB) value, find the corresponding upper and lower + ! xSrc value in the field data, then interpolate y between those values. + if (xDst(kB) < xSrc(kDataBelow,iCell)) then do kData = kDataBelow, maxLevel - if (xColumnOut(kB) > xFieldIn(kData,iCell) ) then + if (xDst(kB) > xSrc(kData,iCell) ) then kDataBelow=kData kDataAbove=kDataBelow-1 exit @@ -1820,10 +1822,10 @@ subroutine linear_interp_1d_field_along_column(nVertLevels, nCells, nBuoyancyLay enddo endif - dx = xFieldIn(kDataBelow,iCell) - xFieldIn(kDataAbove,iCell) + dx = xSrc(kDataBelow,iCell) - xSrc(kDataAbove,iCell) dy = yFieldIn(kDataBelow,iCell) - yFieldIn(kDataAbove,iCell) yFieldOut(kB,iCell) = yFieldIn(kDataAbove,iCell) + & - (xColumnOut(kB)-xFieldIn(kDataAbove,iCell)) * dy/dx + (xDst(kB)-xSrc(kDataAbove,iCell)) * dy/dx enddo enddo From 7bac90cbfa9e6c6a9b11d862fd85351d296aceb3 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Tue, 18 Aug 2015 16:40:28 -0600 Subject: [PATCH 0201/1724] modified warning message by eliassen_palm AM modified the warning message that the eliassen_palm AM prints out when the potential density of the flow is not contained in the range of values set by the user, rhomin and rhomax. The new message referes to the name of the analysis member, eliassen_palm. --- src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index 4b9d426ef9..c9f9274f5c 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -1698,7 +1698,7 @@ subroutine check_potentialDensityRef_range(nVertLevels, nCells, maxLevelCell, & if (printWarning) then write(stderrUnit,*) - write(stderrUnit,*) 'Warning: in EPFT package, subroutine check_potentialDensityRef_range' + write(stderrUnit,*) 'Warning: in eliassen_palm analysis member, subroutine check_potentialDensityRef_range.' write(stderrUnit,*) 'One or more columns in the ocean domain have densities that are not' write(stderrUnit,*) 'contained in the defined buoyancy space of the EPFT module' if (iCellMinBound.gt.0) write(stderrUnit,*) 'fluid is lighter than min buoyancy at cell: ',iCellMinBound From 41daf9b67d3caf2d37ea6a6092dbf7de538dbf35 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Wed, 19 Aug 2015 11:10:37 -0600 Subject: [PATCH 0202/1724] fixed division by zero in vertical derivative fixed division by zero in vertical derivative routine, used to calculate vertical derivatives of uTWA and vTWA. --- .../analysis_members/mpas_ocn_eliassen_palm.F | 31 ++++++++++--------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index c9f9274f5c..ac0178b247 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -2825,28 +2825,29 @@ subroutine computeVerticalDerivative(nCells, nLayers, & do iCell = 1,nCells - wrkAbove = field(firstLayer(iCell),iCell) - wrkBelow = field(firstLayer(iCell)+1,iCell) - dz = heightMid(firstLayer(iCell),iCell)-heightMid(firstLayer(iCell)+1,iCell) + if ( lastLayer(iCell) > firstLayer(iCell) ) then + wrkAbove = field(firstLayer(iCell),iCell) + wrkBelow = field(firstLayer(iCell)+1,iCell) + dz = heightMid(firstLayer(iCell),iCell)-heightMid(firstLayer(iCell)+1,iCell) - derivativeField(firstLayer(iCell), iCell) = (wrkAbove - wrkBelow) / dz + derivativeField(firstLayer(iCell), iCell) = (wrkAbove - wrkBelow) / dz - do kLayer = firstLayer(iCell)+1, lastLayer(iCell)-1 + do kLayer = firstLayer(iCell)+1, lastLayer(iCell)-1 - wrkAbove = field(kLayer-1,iCell) - wrkBelow = field(kLayer+1,iCell) - dz = heightMid(kLayer-1,iCell)-heightMid(kLayer+1,iCell) + wrkAbove = field(kLayer-1,iCell) + wrkBelow = field(kLayer+1,iCell) + dz = heightMid(kLayer-1,iCell)-heightMid(kLayer+1,iCell) - derivativeField(kLayer, iCell) = (wrkAbove - wrkBelow) / dz + derivativeField(kLayer, iCell) = (wrkAbove - wrkBelow) / dz - end do ! kLayer = firstLayer(iCell)+1, lastLayer(iCell)-1 + end do ! kLayer = firstLayer(iCell)+1, lastLayer(iCell)-1 - wrkAbove = field(lastLayer(iCell)-1,iCell) - wrkBelow = field(lastLayer(iCell),iCell) - dz = heightMid(lastLayer(iCell)-1,iCell)-heightMid(lastLayer(iCell),iCell) - - derivativeField(lastLayer(iCell), iCell) = (wrkAbove - wrkBelow) / dz + wrkAbove = field(lastLayer(iCell)-1,iCell) + wrkBelow = field(lastLayer(iCell),iCell) + dz = heightMid(lastLayer(iCell)-1,iCell)-heightMid(lastLayer(iCell),iCell) + derivativeField(lastLayer(iCell), iCell) = (wrkAbove - wrkBelow) / dz + end if end do ! iCell = 1,nCells end subroutine computeVerticalDerivative!}}} From 4d0e5465ea4df3e940dd12bb61d14aca04a4533e Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Wed, 19 Aug 2015 15:32:31 -0600 Subject: [PATCH 0203/1724] initializing varpisigmaEA to zero for completeness This was not done before, as varpi is always zero. But correlation terms that depended on varpi were being initialized. So decided to initialize varpisigmaEA as well, for completeness and consistency. --- src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index ac0178b247..a398963dc2 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -198,6 +198,7 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ real (kind=RKIND), dimension(:,:), pointer :: heightMGradMeridEA real (kind=RKIND), dimension(:,:), pointer :: usigmaEA real (kind=RKIND), dimension(:,:), pointer :: vsigmaEA + real (kind=RKIND), dimension(:,:), pointer :: varpisigmaEA real (kind=RKIND), dimension(:,:), pointer :: uusigmaEA real (kind=RKIND), dimension(:,:), pointer :: vvsigmaEA real (kind=RKIND), dimension(:,:), pointer :: uvsigmaEA @@ -277,6 +278,7 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ call mpas_pool_get_array(amEPFTPool, 'heightMGradMeridEA', heightMGradMeridEA) call mpas_pool_get_array(amEPFTPool, 'usigmaEA', usigmaEA) call mpas_pool_get_array(amEPFTPool, 'vsigmaEA', vsigmaEA) + call mpas_pool_get_array(amEPFTPool, 'varpisigmaEA', varpisigmaEA) call mpas_pool_get_array(amEPFTPool, 'uusigmaEA', uusigmaEA) call mpas_pool_get_array(amEPFTPool, 'vvsigmaEA', vvsigmaEA) call mpas_pool_get_array(amEPFTPool, 'uvsigmaEA', uvsigmaEA) @@ -295,6 +297,7 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ heightMGradMeridEA = 0.0 usigmaEA = 0.0 vsigmaEA = 0.0 + varpisigmaEA = 0.0 uusigmaEA = 0.0 vvsigmaEA = 0.0 uvsigmaEA = 0.0 From f0b039b609244e02da6837dc499d0677de9ad471 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Thu, 27 Aug 2015 15:05:20 -0600 Subject: [PATCH 0204/1724] warn if compute on startup and restart both true If compute on startup and a restart are both requested, there could be problems if the ensemble averaged loaded in the AM restart were already calculated for the state being loaded in the forward model restart file. This problem could occur if the output interval of the AM restart file is different to the compute interval. --- .../analysis_members/mpas_ocn_eliassen_palm.F | 41 +++++++++++-------- 1 file changed, 24 insertions(+), 17 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index a398963dc2..df403c2222 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -179,10 +179,11 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ real (kind=RKIND), dimension(:), pointer :: buoyancyMidRef real (kind=RKIND), dimension(:), pointer :: buoyancyInterfaceRef - logical, pointer :: amEPFTActive, config_eliassen_palm_do_restart - integer, pointer :: config_eliassen_palm_nBuoyancyLayers - real (kind=RKIND), pointer :: config_eliassen_palm_rhomax_buoycoor - real (kind=RKIND), pointer :: config_eliassen_palm_rhomin_buoycoor + logical, pointer :: amEPFTActive, config_AM_eliassenPalm_do_restart + logical, pointer :: config_AM_eliassenPalm_compute_on_startup + integer, pointer :: config_AM_eliassenPalm_nBuoyancyLayers + real (kind=RKIND), pointer :: config_AM_eliassenPalm_rhomax_buoycoor + real (kind=RKIND), pointer :: config_AM_eliassenPalm_rhomin_buoycoor real (kind=RKIND), pointer :: config_density0 integer, pointer :: nSamplesEA @@ -207,14 +208,16 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ err = 0 - call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_do_restart', & - config_eliassen_palm_do_restart) - call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_nBuoyancyLayers', & - config_eliassen_palm_nBuoyancyLayers) - call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_rhomax_buoycoor', & - config_eliassen_palm_rhomax_buoycoor) - call mpas_pool_get_config(domain % configs, 'config_eliassen_palm_rhomin_buoycoor', & - config_eliassen_palm_rhomin_buoycoor) + call mpas_pool_get_config(domain % configs, 'config_AM_eliassenPalm_do_restart', & + config_AM_eliassenPalm_do_restart) + call mpas_pool_get_config(domain % configs, 'config_AM_eliassenPalm_compute_on_startup', & + config_AM_eliassenPalm_compute_on_startup) + call mpas_pool_get_config(domain % configs, 'config_AM_eliassenPalm_nBuoyancyLayers', & + config_AM_eliassenPalm_nBuoyancyLayers) + call mpas_pool_get_config(domain % configs, 'config_AM_eliassenPalm_rhomax_buoycoor', & + config_AM_eliassenPalm_rhomax_buoycoor) + call mpas_pool_get_config(domain % configs, 'config_AM_eliassenPalm_rhomin_buoycoor', & + config_AM_eliassenPalm_rhomin_buoycoor) call mpas_pool_get_config(domain % configs, 'config_density0', config_density0) @@ -305,6 +308,10 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ vvarpisigmaEA = 0.0 end if + if (config_AM_eliassenPalm_do_restart .and. config_AM_eliassenPalm_compute_on_startup) then + write(stderrUnit,*) ' *** WARNING:: Compute on startup was requested on a restart of AM eliassen_palm.' + end if + block => block % next end do @@ -1701,11 +1708,11 @@ subroutine check_potentialDensityRef_range(nVertLevels, nCells, maxLevelCell, & if (printWarning) then write(stderrUnit,*) - write(stderrUnit,*) 'Warning: in eliassen_palm analysis member, subroutine check_potentialDensityRef_range.' - write(stderrUnit,*) 'One or more columns in the ocean domain have densities that are not' - write(stderrUnit,*) 'contained in the defined buoyancy space of the EPFT module' - if (iCellMinBound.gt.0) write(stderrUnit,*) 'fluid is lighter than min buoyancy at cell: ',iCellMinBound - if (iCellMaxBound.gt.0) write(stderrUnit,*) 'fluid is lighter than max buoyancy at cell: ',iCellMaxBound + write(stderrUnit,*) ' *** WARNING: in eliassen_palm analysis member, subroutine check_potentialDensityRef_range.' + write(stderrUnit,*) ' One or more columns in the ocean domain have densities that are not' + write(stderrUnit,*) ' contained in the defined buoyancy space of the EPFT module' + if (iCellMinBound.gt.0) write(stderrUnit,*) ' fluid is lighter than min buoyancy at cell: ',iCellMinBound + if (iCellMaxBound.gt.0) write(stderrUnit,*) ' fluid is lighter than max buoyancy at cell: ',iCellMaxBound write(stderrUnit,*) end if From 53931cd5c8b121443cecc24914d7719cc01ac7c0 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Thu, 27 Aug 2015 15:08:54 -0600 Subject: [PATCH 0205/1724] Remove timers from EPFT AM --- .../analysis_members/mpas_ocn_eliassen_palm.F | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index df403c2222..e882fe9172 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -20,8 +20,8 @@ module ocn_eliassen_palm - use mpas_grid_types - use mpas_timer + use mpas_derived_types + use mpas_pool_routines use mpas_dmpar use mpas_timekeeping use mpas_stream_manager @@ -59,7 +59,6 @@ module ocn_eliassen_palm ! !-------------------------------------------------------------------- - type (timer_node), pointer :: am_eliassen_palmTimer real (kind=RKIND), parameter :: epsilonEPFT=1.0e-15 !*********************************************************************** @@ -606,11 +605,6 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ dminfo = domain % dminfo - - call mpas_timer_start("compute_eliassen_palm", .false., & - am_eliassen_palmTimer) - - !-------------------------------------------------- ! get config variables !-------------------------------------------------- @@ -1452,10 +1446,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ endif - - call mpas_timer_stop("eliassen_palm", am_eliassen_palmTimer) - - if(config_eliassen_palm_debug) then + if(config_AM_eliassenPalm_debug) then write(stderrUnit, *) ' ' write(stderrUnit, *) 'exiting ocn_compute_epft' write(stderrUnit, *) ' ' From fb359842eff0ff882ab5dec4970df7b4dbd3db6c Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 27 Aug 2015 15:13:56 -0600 Subject: [PATCH 0206/1724] Add associated checks to tracer groups in init files This commit adds checks to see that tracer groups are associated before setting their values in the init mode configuration files. Since all of the tracer groups can be disabled at run-time, disabling one previously would cause a segfault. --- .../mpas_ocn_init_baroclinic_channel.F | 80 +++++++++--------- .../mode_init/mpas_ocn_init_cvmix_WSwSBF.F | 47 ++++++++--- .../mode_init/mpas_ocn_init_global_ocean.F | 82 ++++++++++++------- .../mode_init/mpas_ocn_init_internal_waves.F | 46 ++++++----- .../mode_init/mpas_ocn_init_lock_exchange.F | 28 ++++--- .../mode_init/mpas_ocn_init_overflow.F | 40 +++++---- src/core_ocean/mode_init/mpas_ocn_init_soma.F | 10 ++- 7 files changed, 204 insertions(+), 129 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F b/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F index fb4ff2ddfe..3ded163b11 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F @@ -241,48 +241,52 @@ subroutine ocn_init_setup_baroclinic_channel(domain, iErr)!{{{ yOffset = perturbationWidth * sin (6.0_RKIND * pii * (xCell(iCell) - xMinGlobal) / (xMaxGlobal - xMinGlobal)) ! Set debug tracer - idx = index_tracer1 - do k = 1, nVertLevels - debugTracers(idx, k, iCell) = 1.0_RKIND - enddo - - ! Set stratification based on northern half of domain temperature - idx = index_temperature - do k = nVertLevels, 1, -1 - temperature = config_baroclinic_channel_bottom_temperature & - + (config_baroclinic_channel_surface_temperature - config_baroclinic_channel_bottom_temperature) & - * ( (refZMid(k) + refBottomDepth(nVertLevels)) / refBottomDepth(nVertLevels) ) - activeTracers(idx, k, iCell) = temperature - end do - - if(yCell(iCell) < yMidGlobal - yOffset) then - ! If cell is in the southern half, outside the sin width, subtract temperature difference - activeTracers(idx, :, iCell) = activeTracers(idx, :, iCell) - config_baroclinic_channel_temperature_difference - else if(yCell(iCell) >= yMidGlobal - yOffset .and. & - yCell(iCell) < yMidGlobal - yOffset + perturbationWidth) then - activeTracers(idx, :, iCell) = activeTracers(idx, :, iCell) - config_baroclinic_channel_temperature_difference * ( 1.0_RKIND - ( yCell(iCell) & - - ((yMaxGlobal + yMinGlobal) * 0.5 - yOffset)) / perturbationWidth) + if ( associated(debugTracers) ) then + idx = index_tracer1 + do k = 1, nVertLevels + debugTracers(idx, k, iCell) = 1.0_RKIND + enddo end if - ! Determine yOffset for 3rd crest in sin wave. - yOffset = 0.5_RKIND * perturbationWidth * sin(pii * (xCell(iCell) - xPerturbationMin)/(xPerturbationMax - xPerturbationMin)) - - if ( yCell(iCell) >= yMidGlobal - yOffset - 0.5_RKIND * perturbationWidth .and. & - yCell(iCell) <= yMidGlobal - yOffset + 0.5_RKIND * perturbationWidth .and. & - xCell(iCell) >= xPerturbationMin .and. & - xCell(iCell) <= xPerturbationMax) then - - - do k = 1, nVertLevels - activeTracers(idx, k, iCell) = activeTracers(idx, k, iCell) + & - 0.3_RKIND * ( 1.0_RKIND - ( ( yCell(iCell) - (yMidGlobal - yOffset)) /(0.5_RKIND * perturbationWidth))) - end do + ! Set stratification based on northern half of domain temperature + if ( associated(activeTracers) ) then + idx = index_temperature + do k = nVertLevels, 1, -1 + temperature = config_baroclinic_channel_bottom_temperature & + + (config_baroclinic_channel_surface_temperature - config_baroclinic_channel_bottom_temperature) & + * ( (refZMid(k) + refBottomDepth(nVertLevels)) / refBottomDepth(nVertLevels) ) + activeTracers(idx, k, iCell) = temperature + end do + + if(yCell(iCell) < yMidGlobal - yOffset) then + ! If cell is in the southern half, outside the sin width, subtract temperature difference + activeTracers(idx, :, iCell) = activeTracers(idx, :, iCell) - config_baroclinic_channel_temperature_difference + else if(yCell(iCell) >= yMidGlobal - yOffset .and. & + yCell(iCell) < yMidGlobal - yOffset + perturbationWidth) then + activeTracers(idx, :, iCell) = activeTracers(idx, :, iCell) - config_baroclinic_channel_temperature_difference * ( 1.0_RKIND - ( yCell(iCell) & + - ((yMaxGlobal + yMinGlobal) * 0.5 - yOffset)) / perturbationWidth) + end if + + ! Determine yOffset for 3rd crest in sin wave. + yOffset = 0.5_RKIND * perturbationWidth * sin(pii * (xCell(iCell) - xPerturbationMin)/(xPerturbationMax - xPerturbationMin)) + + if ( yCell(iCell) >= yMidGlobal - yOffset - 0.5_RKIND * perturbationWidth .and. & + yCell(iCell) <= yMidGlobal - yOffset + 0.5_RKIND * perturbationWidth .and. & + xCell(iCell) >= xPerturbationMin .and. & + xCell(iCell) <= xPerturbationMax) then + + + do k = 1, nVertLevels + activeTracers(idx, k, iCell) = activeTracers(idx, k, iCell) + & + 0.3_RKIND * ( 1.0_RKIND - ( ( yCell(iCell) - (yMidGlobal - yOffset)) /(0.5_RKIND * perturbationWidth))) + end do + end if + + ! Set salinity + idx = index_salinity + activeTracers(idx, :, iCell) = config_baroclinic_channel_salinity end if - ! Set salinity - idx = index_salinity - activeTracers(idx, :, iCell) = config_baroclinic_channel_salinity - ! Set layerThickness and restingThickness do k = 1, nVertLevels layerThickness(k, iCell) = config_baroclinic_channel_bottom_depth * ( interfaceLocations(k+1) - interfaceLocations(k) ) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F index 5cd9c516a2..8715718637 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F @@ -231,11 +231,16 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ do iCell = 1, nCellsSolve ! Set temperature and salinity do k = 1, nVertLevels - temperature = config_cvmix_WSwSBF_surface_temperature + refZMid(k) * config_cvmix_WSwSBF_temperature_gradient - activeTracers(index_temperature, k, iCell) = temperature - salinity = config_cvmix_WSwSBF_surface_salinity + refZMid(k) * config_cvmix_WSwSBF_salinity_gradient - activeTracers(index_salinity, k, iCell) = salinity - debugTracers(index_tracer1, k, iCell) = 1.0_RKIND + if ( associated(activeTracers) ) then + temperature = config_cvmix_WSwSBF_surface_temperature + refZMid(k) * config_cvmix_WSwSBF_temperature_gradient + activeTracers(index_temperature, k, iCell) = temperature + salinity = config_cvmix_WSwSBF_surface_salinity + refZMid(k) * config_cvmix_WSwSBF_salinity_gradient + activeTracers(index_salinity, k, iCell) = salinity + end if + + if ( associated(debugTracers) ) then + debugTracers(index_tracer1, k, iCell) = 1.0_RKIND + end if end do ! Set layerThickness @@ -246,13 +251,21 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ ! Set surface temperature restoring value and rate ! Value in units of C, piston velocity in units of m/s - activeTracersSurfaceRestoringValue(index_temperature, iCell) = config_cvmix_WSwSBF_surface_restoring_temperature - activeTracersPistonVelocity(index_temperature, iCell) = config_cvmix_WSwSBF_surface_temperature_piston_velocity + if ( associated(activeTracersSurfaceRestoringValue) ) then + activeTracersSurfaceRestoringValue(index_temperature, iCell) = config_cvmix_WSwSBF_surface_restoring_temperature + end if + if ( associated(activeTracersPistonVelocity) ) then + activeTracersPistonVelocity(index_temperature, iCell) = config_cvmix_WSwSBF_surface_temperature_piston_velocity + end if ! Set surface salinity restoring value and rate ! Value in units of PSU, piston velocity in units of m/s - activeTracersSurfaceRestoringValue(index_salinity, iCell) = config_cvmix_WSwSBF_surface_restoring_salinity - activeTracersPistonVelocity(index_salinity, iCell) = config_cvmix_WSwSBF_surface_salinity_piston_velocity + if ( associated(activeTracersSurfaceRestoringValue) ) then + activeTracersSurfaceRestoringValue(index_salinity, iCell) = config_cvmix_WSwSBF_surface_restoring_salinity + end if + if ( associated(activeTracersPistonVelocity) ) then + activeTracersPistonVelocity(index_salinity, iCell) = config_cvmix_WSwSBF_surface_salinity_piston_velocity + end if ! Set sensible heat flux sensibleHeatFlux(iCell) = config_cvmix_WSwSBF_sensible_heat_flux @@ -269,14 +282,22 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ ! Set interior temperature restoring value and rate do k = 1, nVertLevels - activeTracersInteriorRestoringValue(index_temperature, k, iCell) = activeTracers(index_temperature, k, iCell) - activeTracersInteriorRestoringRate(index_temperature, k, iCell) = config_cvmix_WSwSBF_interior_temperature_restoring_rate + if ( associated(activeTracersInteriorRestoringValue) ) then + activeTracersInteriorRestoringValue(index_temperature, k, iCell) = activeTracers(index_temperature, k, iCell) + end if + if ( associated(activeTracersInteriorRestoringRate) ) then + activeTracersInteriorRestoringRate(index_temperature, k, iCell) = config_cvmix_WSwSBF_interior_temperature_restoring_rate + end if enddo ! Set interior salinity restoring value and rate do k = 1, nVertLevels - activeTracersInteriorRestoringValue(index_salinity, k, iCell) = activeTracers(index_salinity, k, iCell) - activeTracersInteriorRestoringRate(index_salinity, k, iCell) = config_cvmix_WSwSBF_interior_salinity_restoring_rate + if ( associated(activeTracersInteriorRestoringValue) ) then + activeTracersInteriorRestoringValue(index_salinity, k, iCell) = activeTracers(index_salinity, k, iCell) + end if + if ( associated(activeTracersInteriorRestoringRate) ) then + activeTracersInteriorRestoringRate(index_salinity, k, iCell) = config_cvmix_WSwSBF_interior_salinity_restoring_rate + end if enddo ! Set Coriolis parameter diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F index a36627f180..60123ee0c1 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F @@ -1046,8 +1046,10 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ end do do k = 1, maxLevelCell(iCell) - activeTracers(idxTemperature, k, iCell) = temperatureIC % array(lonSearch, latSearch, k) - activeTracers(idxSalinity, k, iCell) = salinityIC % array(lonSearch, latSearch, k) + if ( associated(activeTracers) ) then + activeTracers(idxTemperature, k, iCell) = temperatureIC % array(lonSearch, latSearch, k) + activeTracers(idxSalinity, k, iCell) = salinityIC % array(lonSearch, latSearch, k) + end if end do end do @@ -1122,17 +1124,19 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ ! formulas from http://en.wikipedia.org/wiki/Bilinear_interpolation do k = 1, maxLevelCell(iCell) - activeTracers(idxTemperature, k, iCell) = coef*( & - coef11* temperatureIC % array(xInd1,yInd1, k) & - + coef21* temperatureIC % array(xInd2,yInd1, k) & - + coef12* temperatureIC % array(xInd1,yInd2, k) & - + coef22* temperatureIC % array(xInd2,yInd2, k) ) - - activeTracers(idxSalinity, k, iCell) = coef*( & - coef11* salinityIC % array(xInd1,yInd1, k) & - + coef21* salinityIC % array(xInd2,yInd1, k) & - + coef12* salinityIC % array(xInd1,yInd2, k) & - + coef22* salinityIC % array(xInd2,yInd2, k) ) + if ( associated(activeTracers) ) then + activeTracers(idxTemperature, k, iCell) = coef*( & + coef11* temperatureIC % array(xInd1,yInd1, k) & + + coef21* temperatureIC % array(xInd2,yInd1, k) & + + coef12* temperatureIC % array(xInd1,yInd2, k) & + + coef22* temperatureIC % array(xInd2,yInd2, k) ) + + activeTracers(idxSalinity, k, iCell) = coef*( & + coef11* salinityIC % array(xInd1,yInd1, k) & + + coef21* salinityIC % array(xInd2,yInd1, k) & + + coef12* salinityIC % array(xInd1,yInd2, k) & + + coef22* salinityIC % array(xInd2,yInd2, k) ) + end if end do @@ -1146,19 +1150,29 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ ! set surface restoring values and rate do iCell=1,nCells - activeTracersSurfaceRestoringValue(idxTemperature, iCell) = activeTracers(idxTemperature, 1, iCell) - activeTracersSurfaceRestoringValue(idxSalinity, iCell) = activeTracers(idxSalinity, 1, iCell) - activeTracersPistonVelocity(idxTemperature, iCell) = config_global_ocean_piston_velocity - activeTracersPistonVelocity(idxSalinity, iCell) = config_global_ocean_piston_velocity + if ( associated(activeTracersSurfaceRestoringValue) .and. associated(activeTracers) ) then + activeTracersSurfaceRestoringValue(idxTemperature, iCell) = activeTracers(idxTemperature, 1, iCell) + activeTracersSurfaceRestoringValue(idxSalinity, iCell) = activeTracers(idxSalinity, 1, iCell) + end if + + if ( associated(activeTracersPistonVelocity) ) then + activeTracersPistonVelocity(idxTemperature, iCell) = config_global_ocean_piston_velocity + activeTracersPistonVelocity(idxSalinity, iCell) = config_global_ocean_piston_velocity + end if enddo ! set interior restoring values and rate do iCell=1,nCells do k = 1, maxLevelCell(iCell) - activeTracersInteriorRestoringValue(idxTemperature, k, iCell) = activeTracers(idxTemperature, k, iCell) - activeTracersInteriorRestoringValue(idxSalinity, k, iCell) = activeTracers(idxSalinity, k, iCell) - activeTracersInteriorRestoringRate(idxTemperature, k, iCell) = config_global_ocean_interior_restore_rate - activeTracersInteriorRestoringRate(idxSalinity, k, iCell) = config_global_ocean_interior_restore_rate + if ( associated(activeTracersInteriorRestoringValue) .and. associated(activeTracers) ) then + activeTracersInteriorRestoringValue(idxTemperature, k, iCell) = activeTracers(idxTemperature, k, iCell) + activeTracersInteriorRestoringValue(idxSalinity, k, iCell) = activeTracers(idxSalinity, k, iCell) + end if + + if ( associated(activeTracersInteriorRestoringRate) ) then + activeTracersInteriorRestoringRate(idxTemperature, k, iCell) = config_global_ocean_interior_restore_rate + activeTracersInteriorRestoringRate(idxSalinity, k, iCell) = config_global_ocean_interior_restore_rate + end if enddo enddo @@ -1209,8 +1223,10 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ do iCell = 1, nCells do k = 1, maxLevelCell(iCell) - smoothedtemperature(k, iCell) = activeTracers(idxTemperature, k, iCell) - smoothedsalinity(k, iCell) = activeTracers(idxSalinity, k, iCell) + if ( associated(activeTracers) ) then + smoothedtemperature(k, iCell) = activeTracers(idxTemperature, k, iCell) + smoothedsalinity(k, iCell) = activeTracers(idxSalinity, k, iCell) + end if counter = 1 do j = 1, nEdgesOnCell(iCell) @@ -1218,8 +1234,10 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ ! check if coc not 0 (or nCells+1)? if (k .le. maxLevelCell(coc)) then - smoothedtemperature(k, iCell) = smoothedtemperature(k, iCell) + activeTracers (idxTemperature, k, coc) - smoothedsalinity(k, iCell) = smoothedsalinity(k, iCell) + activeTracers(idxSalinity, k, coc) + if ( associated(activeTracers) ) then + smoothedtemperature(k, iCell) = smoothedtemperature(k, iCell) + activeTracers (idxTemperature, k, coc) + smoothedsalinity(k, iCell) = smoothedsalinity(k, iCell) + activeTracers(idxSalinity, k, coc) + end if counter = counter + 1 end if @@ -1232,11 +1250,17 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ end do ! iCell - activeTracers(idxTemperature, :, :) = smoothedtemperature(:,:) - activeTracers(idxSalinity, :, :) = smoothedsalinity(:,:) + if ( associated(activeTracers) ) then + activeTracers(idxTemperature, :, :) = smoothedtemperature(:,:) + activeTracers(idxSalinity, :, :) = smoothedsalinity(:,:) + end if - activeTracersInteriorRestoringValue(:,:,:) = activeTracers(:,:,:) - activeTracersSurfaceRestoringValue(:,:) = activeTracers(:,1,:) + if ( associated(activeTracersInteriorRestoringValue) .and. associated(activeTracers) ) then + activeTracersInteriorRestoringValue(:,:,:) = activeTracers(:,:,:) + end if + if ( associated(activeTracersSurfaceRestoringValue) .and. associated(activeTracers) ) then + activeTracersSurfaceRestoringValue(:,:) = activeTracers(:,1,:) + end if block_ptr => block_ptr % next end do diff --git a/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F b/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F index 5911ec3320..0378149ee9 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F @@ -239,28 +239,32 @@ subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ do iCell = 1, nCellsSolve ! Set debug tracer - do k = 1, nVertLevels - debugTracers(index_tracer1, k, iCell) = 1.0_RKIND - enddo + if ( associated(debugTracers) ) then + do k = 1, nVertLevels + debugTracers(index_tracer1, k, iCell) = 1.0_RKIND + enddo + end if if ( trim(config_internal_waves_layer_type) == 'z-level' ) then ! Set stratified temperature - do k = nVertLevels, 1, -1 - temperature = config_internal_waves_bottom_temperature & - + (config_internal_waves_surface_temperature - config_internal_waves_bottom_temperature) & - * ( (refZMid(k) - refZMid(nVertLevels)) / (-refZMid(nVertLevels) )) - activeTracers(index_temperature, k, iCell) = temperature - end do - - if ( abs(yCell(iCell) - yMidGlobal) < perturbationWidth ) then - ! If cell is in the southern half, outside the sin width, subtract temperature difference - do k = 2, nVertLevels - temperature = -config_internal_waves_temperature_difference * cos(0.5_RKIND * pii * (yCell(iCell) - yMidGlobal) / perturbationWidth) & - * sin ( pii * refBottomDepth(k-1) / refBottomDepth(nVertLevels-1) ) - - activeTracers(index_temperature, k, iCell) = activeTracers(index_temperature, k, iCell) + temperature + if ( associated(activeTracers) ) then + do k = nVertLevels, 1, -1 + temperature = config_internal_waves_bottom_temperature & + + (config_internal_waves_surface_temperature - config_internal_waves_bottom_temperature) & + * ( (refZMid(k) - refZMid(nVertLevels)) / (-refZMid(nVertLevels) )) + activeTracers(index_temperature, k, iCell) = temperature end do + + if ( abs(yCell(iCell) - yMidGlobal) < perturbationWidth ) then + ! If cell is in the southern half, outside the sin width, subtract temperature difference + do k = 2, nVertLevels + temperature = -config_internal_waves_temperature_difference * cos(0.5_RKIND * pii * (yCell(iCell) - yMidGlobal) / perturbationWidth) & + * sin ( pii * refBottomDepth(k-1) / refBottomDepth(nVertLevels-1) ) + + activeTracers(index_temperature, k, iCell) = activeTracers(index_temperature, k, iCell) + temperature + end do + end if end if ! Set layerThickness @@ -270,7 +274,9 @@ subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ else if ( trim(config_internal_waves_layer_type) == 'isopycnal' ) then ! Set stratified temperature - activeTracers(index_temperature, :, iCell) = refTemperature(:) + if ( associated(activeTracers) ) then + activeTracers(index_temperature, :, iCell) = refTemperature(:) + end if ! Set layerThickness if ( abs(yCell(iCell) - yMidGlobal) < perturbationWidth) then @@ -296,7 +302,9 @@ subroutine ocn_init_setup_internal_waves(domain, iErr)!{{{ endif ! Set salinity - activeTracers(index_salinity, :, iCell) = config_internal_waves_salinity + if ( associated(activeTracers) ) then + activeTracers(index_salinity, :, iCell) = config_internal_waves_salinity + end if ! Set bottomDepth bottomDepth(iCell) = config_internal_waves_bottom_depth diff --git a/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F b/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F index 940aa50c9e..0b7fef655b 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F @@ -203,10 +203,12 @@ subroutine ocn_init_setup_lock_exchange(domain, iErr)!{{{ do iCell = 1, nCellsSolve ! Set temperature, layerThickness, and restingThickness if ( trim(config_lock_exchange_layer_type) == 'z-level' ) then - if(yCell(iCell) < (yMaxGlobal - yMinGlobal) * 0.5_RKIND) then - activeTracers(index_temperature, :, iCell) = config_lock_exchange_south_temp - else - activeTracers(index_temperature, :, iCell) = config_lock_exchange_north_temp + if ( associated(activeTracers) ) then + if(yCell(iCell) < (yMaxGlobal - yMinGlobal) * 0.5_RKIND) then + activeTracers(index_temperature, :, iCell) = config_lock_exchange_south_temp + else + activeTracers(index_temperature, :, iCell) = config_lock_exchange_north_temp + end if end if ! Set layerThickness and restingThickness @@ -215,8 +217,10 @@ subroutine ocn_init_setup_lock_exchange(domain, iErr)!{{{ restingThickness(k, iCell) = layerThickness(k, iCell) end do else if ( trim(config_lock_exchange_layer_type) == 'isopycnal' ) then - activeTracers(index_temperature, 1, iCell) = config_lock_exchange_north_temp - activeTracers(index_temperature, 2:nVertLevels, iCell) = config_lock_exchange_south_temp + if ( associated(activeTracers) ) then + activeTracers(index_temperature, 1, iCell) = config_lock_exchange_north_temp + activeTracers(index_temperature, 2:nVertLevels, iCell) = config_lock_exchange_south_temp + end if if(yCell(iCell) < (yMaxGlobal - yMinGlobal) * 0.5_RKIND) then layerThickness(1, iCell) = config_lock_exchange_isopycnal_min_thickness @@ -230,12 +234,16 @@ subroutine ocn_init_setup_lock_exchange(domain, iErr)!{{{ end if ! Set salinity - activeTracers(index_salinity, :, iCell) = config_lock_exchange_salinity + if ( associated(activeTracers) ) then + activeTracers(index_salinity, :, iCell) = config_lock_exchange_salinity + end if ! Set debugging tracer - do k = 1, nVertLevels - debugTracers(index_tracer1, k, iCell) = 1.0_RKIND - enddo + if ( associated(debugTracers) ) then + do k = 1, nVertLevels + debugTracers(index_tracer1, k, iCell) = 1.0_RKIND + enddo + end if ! Set bottomDepth bottomDepth(iCell) = config_lock_exchange_bottom_depth diff --git a/src/core_ocean/mode_init/mpas_ocn_init_overflow.F b/src/core_ocean/mode_init/mpas_ocn_init_overflow.F index 0e224a1de1..6085c46529 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_overflow.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_overflow.F @@ -192,8 +192,8 @@ subroutine ocn_init_setup_overflow(domain, iErr)!{{{ call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_salinity) call mpas_pool_get_dimension(tracersPool, 'index_tracer1', index_tracer1) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) @@ -240,17 +240,19 @@ subroutine ocn_init_setup_overflow(domain, iErr)!{{{ do iCell = 1, nCellsSolve ! Set temperature - if ( trim(config_overflow_layer_type) == 'sigma' .or. trim(config_overflow_layer_type) == 'z-level' ) then - do k = 1, maxLevelCell(iCell) - if(yCell(iCell) < yMinGlobal + plugWidth) then - activeTracers(index_temperature, k, iCell) = config_overflow_plug_temperature - else - activeTracers(index_temperature, k, iCell) = config_overflow_domain_temperature - end if - end do - else if ( trim(config_overflow_layer_type) == 'isopycnal' ) then - activeTracers(index_temperature, 1, :) = config_overflow_domain_temperature - activeTracers(index_temperature, 2:nVertLevels, :) = config_overflow_plug_temperature + if ( associated(activeTracers) ) then + if ( trim(config_overflow_layer_type) == 'sigma' .or. trim(config_overflow_layer_type) == 'z-level' ) then + do k = 1, maxLevelCell(iCell) + if(yCell(iCell) < yMinGlobal + plugWidth) then + activeTracers(index_temperature, k, iCell) = config_overflow_plug_temperature + else + activeTracers(index_temperature, k, iCell) = config_overflow_domain_temperature + end if + end do + else if ( trim(config_overflow_layer_type) == 'isopycnal' ) then + activeTracers(index_temperature, 1, :) = config_overflow_domain_temperature + activeTracers(index_temperature, 2:nVertLevels, :) = config_overflow_plug_temperature + end if end if ! Set layerThickness and restingThickness @@ -278,12 +280,16 @@ subroutine ocn_init_setup_overflow(domain, iErr)!{{{ end if ! Set salinity - activeTracers(index_salinity, :, iCell) = config_overflow_salinity + if ( associated(activeTracers) ) then + activeTracers(index_salinity, :, iCell) = config_overflow_salinity + end if ! Set debug tracer - do k = 1, nVertLevels - debugTracers(index_tracer1, k, iCell) = 1.0_RKIND - enddo + if ( associated(debugTracers) ) then + do k = 1, nVertLevels + debugTracers(index_tracer1, k, iCell) = 1.0_RKIND + end do + end if end do diff --git a/src/core_ocean/mode_init/mpas_ocn_init_soma.F b/src/core_ocean/mode_init/mpas_ocn_init_soma.F index 994c155a0b..be86eca972 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_soma.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_soma.F @@ -326,13 +326,17 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ factor = - zMid / config_soma_bottom_depth salinity = config_soma_surface_salinity + factor - activeTracers(index_temperature, k, iCell) = temperature - activeTracers(index_salinity, k, iCell) = salinity + if ( associated(activeTracers) ) then + activeTracers(index_temperature, k, iCell) = temperature + activeTracers(index_salinity, k, iCell) = salinity + end if enddo ! Set up debugging tracers - debugTracers(index_tracer1, :, iCell) = 1.0_RKIND + if ( associated(debugTracers) ) then + debugTracers(index_tracer1, :, iCell) = 1.0_RKIND + end if end do ! iCell = 1, nCells From 54b546723b46b77592bdff8b70e8b862e5336f64 Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Fri, 28 Aug 2015 14:31:03 -0600 Subject: [PATCH 0207/1724] Changed left-over macro continuations from \ to &. --- .../mpas_ocn_time_series_stats.F | 120 +++++++++--------- 1 file changed, 60 insertions(+), 60 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index 8ecb99ae0b..dd10aa9d3e 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -1392,8 +1392,8 @@ subroutine operate0r_avg (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ + out_array = (out_array * & + (buffers(b) % total_accum - 1) + in_array) & / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1429,8 +1429,8 @@ subroutine operate1r_avg (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ + out_array = (out_array * & + (buffers(b) % total_accum - 1) + in_array) & / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1466,8 +1466,8 @@ subroutine operate2r_avg (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ + out_array = (out_array * & + (buffers(b) % total_accum - 1) + in_array) & / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1503,8 +1503,8 @@ subroutine operate3r_avg (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ + out_array = (out_array * & + (buffers(b) % total_accum - 1) + in_array) & / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1540,8 +1540,8 @@ subroutine operate4r_avg (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ + out_array = (out_array * & + (buffers(b) % total_accum - 1) + in_array) & / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1577,8 +1577,8 @@ subroutine operate5r_avg (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ + out_array = (out_array * & + (buffers(b) % total_accum - 1) + in_array) & / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1614,8 +1614,8 @@ subroutine operate0i_avg (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ + out_array = (out_array * & + (buffers(b) % total_accum - 1) + in_array) & / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1651,8 +1651,8 @@ subroutine operate1i_avg (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ + out_array = (out_array * & + (buffers(b) % total_accum - 1) + in_array) & / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1688,8 +1688,8 @@ subroutine operate2i_avg (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ + out_array = (out_array * & + (buffers(b) % total_accum - 1) + in_array) & / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1725,8 +1725,8 @@ subroutine operate3i_avg (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else - out_array = (out_array * \ - (buffers(b) % total_accum - 1) + in_array) \ + out_array = (out_array * & + (buffers(b) % total_accum - 1) + in_array) & / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1762,8 +1762,8 @@ subroutine operate0r_min (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1799,8 +1799,8 @@ subroutine operate1r_min (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1836,8 +1836,8 @@ subroutine operate2r_min (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1873,8 +1873,8 @@ subroutine operate3r_min (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1910,8 +1910,8 @@ subroutine operate4r_min (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1947,8 +1947,8 @@ subroutine operate5r_min (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1984,8 +1984,8 @@ subroutine operate0i_min (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -2021,8 +2021,8 @@ subroutine operate1i_min (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -2058,8 +2058,8 @@ subroutine operate2i_min (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -2095,8 +2095,8 @@ subroutine operate3i_min (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -2132,8 +2132,8 @@ subroutine operate0r_max (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2169,8 +2169,8 @@ subroutine operate1r_max (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2206,8 +2206,8 @@ subroutine operate2r_max (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2243,8 +2243,8 @@ subroutine operate3r_max (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2280,8 +2280,8 @@ subroutine operate4r_max (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2317,8 +2317,8 @@ subroutine operate5r_max (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2354,8 +2354,8 @@ subroutine operate0i_max (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2391,8 +2391,8 @@ subroutine operate1i_max (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2428,8 +2428,8 @@ subroutine operate2i_max (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2465,8 +2465,8 @@ subroutine operate3i_max (start_block, tvar) if (buffers(b) % reset_flag) then out_array = in_array else -! out_array = (out_array * \ -! (buffers(b) % total_accum - 1) + in_array) \ +! out_array = (out_array * & +! (buffers(b) % total_accum - 1) + in_array) & ! / buffers(b) % total_accum ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; From 34294562aada70a9d64f38f4b9c1d953bca7d5bc Mon Sep 17 00:00:00 2001 From: toddringler Date: Mon, 31 Aug 2015 08:59:12 -0600 Subject: [PATCH 0208/1724] update water mass census AM to new tracer infrastructure --- .../mpas_ocn_water_mass_census.F | 152 +++++++++--------- 1 file changed, 79 insertions(+), 73 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F b/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F index 423b4b8a8c..bb898728a3 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F +++ b/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F @@ -159,6 +159,7 @@ subroutine ocn_compute_water_mass_census(domain, timeLevel, err)!{{{ type (mpas_pool_type), pointer :: statePool type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: tracersPool real (kind=RKIND), dimension(:,:,:), pointer :: waterMassFractionalDistribution real (kind=RKIND), dimension(:,:,:), pointer :: potentialDensityOfTSDiagram @@ -168,9 +169,9 @@ subroutine ocn_compute_water_mass_census(domain, timeLevel, err)!{{{ ! pointers to data in pools required for T/S water mass census real (kind=RKIND), dimension(:,:), pointer :: layerThickness - real (kind=RKIND), dimension(:,:,:), pointer :: tracers real (kind=RKIND), dimension(:,:), pointer :: potentialDensity real (kind=RKIND), dimension(:,:), pointer :: zMid + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers ! pointers to data in mesh pool ! (note: nOceanRegionsTmpCensus, lonCell, latCell to be removed when region mask is intent(in)) @@ -279,13 +280,16 @@ subroutine ocn_compute_water_mass_census(domain, timeLevel, err)!{{{ call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + + ! get indices for T and S + call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_salinity) ! get pointers to mesh call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) call mpas_pool_get_dimension(block % dimensions, 'nOceanRegionsTmpCensus', nOceanRegionsTmpCensus) - call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) call mpas_pool_get_array(meshPool, 'areaCell', areaCell) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) @@ -293,44 +297,46 @@ subroutine ocn_compute_water_mass_census(domain, timeLevel, err)!{{{ call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) call mpas_pool_get_array(diagnosticsPool, 'potentialDensity', potentialDensity) call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) - call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) ! loop over and bin all data + if ( associated(activeTracers) ) then do iCell=1,nCellsSolve - do iLevel=1,maxLevelCell(iCell) - - ! make copies of data for convienence - temperature = tracers(index_temperature,iLevel,iCell) - salinity = tracers(index_salinity,iLevel,iCell) - density = potentialDensity(iLevel,iCell) - zPosition = zMid(iLevel,iCell) - volume = layerThickness(iLevel,iCell) * areaCell(iCell) - - ! find temperature bin, cycle if bin is out of range - iTemperatureBin = int((temperature-minTemperature)/deltaTemperature) + 1 - if (iTemperatureBin < 1) cycle - if (iTemperatureBin > nTemperatureBins) cycle - - ! find salinity bin, cycle if bin is out of range - iSalinityBin = int((salinity-minSalinity)/deltaSalinity) + 1 - if (iSalinityBin < 1) cycle - if (iSalinityBin > nSalinityBins) cycle - - do iRegion=1,nOceanRegionsTmpCensus - ! add volume into water mass census array for each region - waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion) = & - waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion) & - + volume * regionMask(iRegion,iCell) - potentialDensityOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) = & - potentialDensityOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) & - + density * volume * regionMask(iRegion,iCell) - zPositionOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) = & - zPositionOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) & - + zPosition * volume * regionMask(iRegion,iCell) - enddo - - enddo ! iLevel - enddo ! iCell + do iLevel=1,maxLevelCell(iCell) + + ! make copies of data for convienence + temperature = activeTracers(index_temperature,iLevel,iCell) + salinity = activeTracers(index_salinity,iLevel,iCell) + density = potentialDensity(iLevel,iCell) + zPosition = zMid(iLevel,iCell) + volume = layerThickness(iLevel,iCell) * areaCell(iCell) + + ! find temperature bin, cycle if bin is out of range + iTemperatureBin = int((temperature-minTemperature)/deltaTemperature) + 1 + if (iTemperatureBin < 1) cycle + if (iTemperatureBin > nTemperatureBins) cycle + + ! find salinity bin, cycle if bin is out of range + iSalinityBin = int((salinity-minSalinity)/deltaSalinity) + 1 + if (iSalinityBin < 1) cycle + if (iSalinityBin > nSalinityBins) cycle + + do iRegion=1,nOceanRegionsTmpCensus + ! add volume into water mass census array for each region + waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion) = & + waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion) & + + volume * regionMask(iRegion,iCell) + potentialDensityOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) = & + potentialDensityOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) & + + density * volume * regionMask(iRegion,iCell) + zPositionOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) = & + zPositionOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) & + + zPosition * volume * regionMask(iRegion,iCell) + enddo + + enddo ! iLevel + enddo ! iCell + endif ! associated(activeTracers) block => block % next end do ! block loop @@ -338,16 +344,16 @@ subroutine ocn_compute_water_mass_census(domain, timeLevel, err)!{{{ ! store data in buffer in order to allow only one dmpar calls kBuffer=0 do iTemperatureBin=1,nTemperatureBins - do iSalinityBin=1,nSalinityBins - do iRegion=1,nOceanRegionsTmpCensus - kBuffer = kBuffer+1 - workBufferSum(kBuffer) = waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion) - kBuffer = kBuffer+1 - workBufferSum(kBuffer) = potentialDensityOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) - kBuffer = kBuffer+1 - workBufferSum(kBuffer) = zPositionOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) - enddo - enddo + do iSalinityBin=1,nSalinityBins + do iRegion=1,nOceanRegionsTmpCensus + kBuffer = kBuffer+1 + workBufferSum(kBuffer) = waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion) + kBuffer = kBuffer+1 + workBufferSum(kBuffer) = potentialDensityOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) + kBuffer = kBuffer+1 + workBufferSum(kBuffer) = zPositionOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) + enddo + enddo enddo ! communication @@ -356,40 +362,40 @@ subroutine ocn_compute_water_mass_census(domain, timeLevel, err)!{{{ ! unpack the buffer into intent(out) of this analysis member kBuffer=0 do iTemperatureBin=1,nTemperatureBins - do iSalinityBin=1,nSalinityBins - do iRegion=1,nOceanRegionsTmpCensus - kBuffer = kBuffer+1 - waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion) = workBufferSumReduced(kBuffer) - kBuffer = kBuffer+1 - potentialDensityOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) = workBufferSumReduced(kBuffer) - kBuffer = kBuffer+1 - zPositionOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) = workBufferSumReduced(kBuffer) - enddo - enddo + do iSalinityBin=1,nSalinityBins + do iRegion=1,nOceanRegionsTmpCensus + kBuffer = kBuffer+1 + waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion) = workBufferSumReduced(kBuffer) + kBuffer = kBuffer+1 + potentialDensityOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) = workBufferSumReduced(kBuffer) + kBuffer = kBuffer+1 + zPositionOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) = workBufferSumReduced(kBuffer) + enddo + enddo enddo ! normalize potentialDensityOfTSDiagram by volume in each T,S bin do iTemperatureBin=1,nTemperatureBins - do iSalinityBin=1,nSalinityBins - do iRegion=1,nOceanRegionsTmpCensus - potentialDensityOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) = & - potentialDensityOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) / & - max(waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion), 1.0e-8_RKIND) - zPositionOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) = & - zPositionOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) / & - max(waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion), 1.0e-8_RKIND) - enddo - enddo + do iSalinityBin=1,nSalinityBins + do iRegion=1,nOceanRegionsTmpCensus + potentialDensityOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) = & + potentialDensityOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) / & + max(waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion), 1.0e-8_RKIND) + zPositionOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) = & + zPositionOfTSDiagram(iTemperatureBin,iSalinityBin,iRegion) / & + max(waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion), 1.0e-8_RKIND) + enddo + enddo enddo ! use workBufferSum as workspace to find total volume for each region workBufferSum = 0.0_RKIND do iTemperatureBin=1,nTemperatureBins - do iSalinityBin=1,nSalinityBins - do iRegion=1,nOceanRegionsTmpCensus - workBufferSum(iRegion) = workBufferSum(iRegion) + waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion) - enddo - enddo + do iSalinityBin=1,nSalinityBins + do iRegion=1,nOceanRegionsTmpCensus + workBufferSum(iRegion) = workBufferSum(iRegion) + waterMassFractionalDistribution(iTemperatureBin,iSalinityBin,iRegion) + enddo + enddo enddo ! use this sum to convert waterMassFractionalDistribution from total volume to fractional volume From 948f660c6ee18ada85e5b7f54ef880cf7df62755 Mon Sep 17 00:00:00 2001 From: toddringler Date: Mon, 31 Aug 2015 09:05:40 -0600 Subject: [PATCH 0209/1724] update volume-weighted averages to new tracer infrastructure --- .../mpas_ocn_layer_volume_weighted_averages.F | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_layer_volume_weighted_averages.F b/src/core_ocean/analysis_members/mpas_ocn_layer_volume_weighted_averages.F index 0d77586c53..91df263a5a 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_layer_volume_weighted_averages.F +++ b/src/core_ocean/analysis_members/mpas_ocn_layer_volume_weighted_averages.F @@ -159,6 +159,7 @@ subroutine ocn_compute_layer_volume_weighted_averages(domain, timeLevel, err)!{{ type (mpas_pool_type), pointer :: scratchPool type (mpas_pool_type), pointer :: diagnosticsPool type (mpas_pool_type), pointer :: forcingPool + type (mpas_pool_type), pointer :: tracersPool real (kind=RKIND), dimension(:,:,:), pointer :: minValueWithinOceanLayerRegion real (kind=RKIND), dimension(:,:,:), pointer :: maxValueWithinOceanLayerRegion @@ -175,14 +176,14 @@ subroutine ocn_compute_layer_volume_weighted_averages(domain, timeLevel, err)!{{ real (kind=RKIND), dimension(:,:), pointer :: velocityZonal real (kind=RKIND), dimension(:,:), pointer :: velocityMeridional real (kind=RKIND), dimension(:,:), pointer :: vertVelocityTop - real (kind=RKIND), dimension(:,:,:), pointer :: tracers + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers real (kind=RKIND), dimension(:,:), pointer :: kineticEnergyCell real (kind=RKIND), dimension(:,:), pointer :: relativeVorticityCell real (kind=RKIND), dimension(:,:), pointer :: divergence ! pointers to data in mesh pool integer, pointer :: nVertLevels, nCells, nCellsSolve, nLayerVolWeightedAvgFields, nOceanRegionsTmp - integer, pointer :: indexTemperature, indexSalinity + integer, pointer :: index_temperature, index_salinity integer, dimension(:), pointer :: maxLevelCell real (kind=RKIND), dimension(:), pointer :: areaCell, lonCell, latCell @@ -269,6 +270,7 @@ subroutine ocn_compute_layer_volume_weighted_averages(domain, timeLevel, err)!{{ call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) ! get pointers to mesh call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) @@ -276,8 +278,8 @@ subroutine ocn_compute_layer_volume_weighted_averages(domain, timeLevel, err)!{{ call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(block % dimensions, 'nLayerVolWeightedAvgFields', nLayerVolWeightedAvgFields) call mpas_pool_get_dimension(block % dimensions, 'nOceanRegionsTmp', nOceanRegionsTmp) - call mpas_pool_get_dimension(statePool, 'index_temperature', indexTemperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', indexSalinity) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_salinity) call mpas_pool_get_array(meshPool, 'areaCell', areaCell) call mpas_pool_get_array(meshPool, 'lonCell', lonCell) call mpas_pool_get_array(meshPool, 'latCell', latCell) @@ -300,10 +302,10 @@ subroutine ocn_compute_layer_volume_weighted_averages(domain, timeLevel, err)!{{ call mpas_pool_get_array(diagnosticsPool, 'velocityZonal', velocityZonal) call mpas_pool_get_array(diagnosticsPool, 'velocityMeridional', velocityMeridional) call mpas_pool_get_array(diagnosticsPool, 'vertVelocityTop', vertVelocityTop) - call mpas_pool_get_array(statePool, 'tracers', tracers, 1) call mpas_pool_get_array(diagnosticsPool, 'kineticEnergyCell', kineticEnergyCell) call mpas_pool_get_array(diagnosticsPool, 'relativeVorticityCell', relativeVorticityCell) call mpas_pool_get_array(diagnosticsPool, 'divergence', divergence) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) ! initialize buffers workBufferSum(:) = 0.0_RKIND @@ -330,8 +332,8 @@ subroutine ocn_compute_layer_volume_weighted_averages(domain, timeLevel, err)!{{ workArray( 7,:) = velocityZonal(iLevel,:) workArray( 8,:) = velocityMeridional(iLevel,:) workArray( 9,:) = vertVelocityTop(iLevel,:) - workArray(10,:) = tracers(indexTemperature,iLevel,:) - workArray(11,:) = tracers(indexSalinity,iLevel,:) + if ( associated(activeTracers) ) workArray(10,:) = activeTracers(index_temperature,iLevel,:) + if ( associated(activeTracers) ) workArray(11,:) = activeTracers(index_salinity,iLevel,:) workArray(12,:) = kineticEnergyCell(iLevel,:) workArray(13,:) = relativeVorticityCell(iLevel,:) workArray(14,:) = divergence(iLevel,:) From 9fc9f99cf257184a76297826f45831966278e4e2 Mon Sep 17 00:00:00 2001 From: Mauro Perego Date: Mon, 6 Jul 2015 22:04:50 -0600 Subject: [PATCH 0210/1724] Initialize deltat variable The semi-implicit solver in Albany needs this variable to be initialized. This happens in li_core_init. --- src/core_landice/mode_forward/mpas_li_core.F | 50 ++++++++++++++------ 1 file changed, 35 insertions(+), 15 deletions(-) diff --git a/src/core_landice/mode_forward/mpas_li_core.F b/src/core_landice/mode_forward/mpas_li_core.F index ed708c5e6c..a458b07c0d 100644 --- a/src/core_landice/mode_forward/mpas_li_core.F +++ b/src/core_landice/mode_forward/mpas_li_core.F @@ -93,6 +93,11 @@ function li_core_init(domain, startTimeStamp) result(err) type (MPAS_Time_Type) :: startTime integer :: i, err, err_tmp, globalErr logical, pointer :: config_do_restart + real (kind=RKIND), pointer :: deltat_output + real (kind=RKIND) :: dtSeconds + type (MPAS_Pool_type), pointer :: meshPool + type (MPAS_TimeInterval_type) :: timeStepInterval + character (len=StrKIND), pointer :: xtime err = 0 @@ -107,13 +112,6 @@ function li_core_init(domain, startTimeStamp) result(err) call li_setup_config_options( domain, err_tmp ) err = ior(err, err_tmp) - ! - ! Set startTimeStamp based on the start time of the simulation clock - ! - startTime = mpas_get_clock_time(domain % clock, MPAS_START_TIME, err_tmp) - call mpas_get_time(startTime, dateTimeString=startTimeStamp) - err = ior(err, err_tmp) - if (config_do_restart) then call mpas_stream_mgr_read(domain % streamManager, streamID='restart', ierr=err_tmp) err = ior(err, err_tmp) @@ -128,6 +126,34 @@ function li_core_init(domain, startTimeStamp) result(err) call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) err = ior(err, err_tmp) + ! === + ! Initialize some time stuff on each block + ! === + ! Set startTimeStamp based on the start time of the simulation clock + startTime = mpas_get_clock_time(domain % clock, MPAS_START_TIME, err_tmp) + call mpas_get_time(startTime, dateTimeString=startTimeStamp) ! Get the start time as a time stamp + err = ior(err, err_tmp) + + timeStepInterval = mpas_get_clock_timestep(domain % clock, ierr=err_tmp) ! get timestep interval object + err = ior(err,err_tmp) + call mpas_get_timeInterval(timeStepInterval, StartTimeIn=startTime, dt=dtSeconds, ierr=err_tmp) ! Get config dt in seconds + err = ior(err,err_tmp) + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + + ! Assign initial time stamp + call mpas_pool_get_array(meshPool, 'xtime', xtime) + xtime = startTimeStamp + + ! Initialize dt in seconds + call mpas_pool_get_array(meshPool, 'deltat', deltat_output) + deltat_output = dtSeconds + + block => block % next + end do + ! === ! === Initialize modules === @@ -147,7 +173,7 @@ function li_core_init(domain, startTimeStamp) result(err) ! === block => domain % blocklist do while (associated(block)) - call landice_init_block(block, startTimeStamp, domain % dminfo) + call landice_init_block(block, domain % dminfo) block => block % next end do @@ -516,7 +542,7 @@ end function li_core_finalize !> This routine initializes blocks for the land ice core. ! !----------------------------------------------------------------------- - subroutine landice_init_block(block, startTimeStamp, dminfo) + subroutine landice_init_block(block, dminfo) use mpas_derived_types use mpas_pool_routines @@ -534,7 +560,6 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! !----------------------------------------------------------------- type (dm_info), intent(in) :: dminfo !< Input: Domain info - character(len=*), intent(in) :: startTimeStamp !< Input: time stamp at start !----------------------------------------------------------------- ! @@ -557,7 +582,6 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: geometryPool integer, dimension(:), pointer :: vertexMask - character (len=StrKIND), pointer :: xtime character (len=StrKIND), pointer :: config_velocity_solver logical, pointer :: config_do_velocity_reconstruction_for_external_dycore logical, pointer :: config_adaptive_timestep_include_DCFL @@ -610,10 +634,6 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) call mpas_init_reconstruct(meshPool) endif - ! Assign initial time stamp - call mpas_pool_get_array(meshPool, 'xtime', xtime) - xtime = startTimeStamp - ! Mask init identifies initial ice extent call li_calculate_mask_init(geometryPool, err=err_tmp) err = ior(err, err_tmp) From 2b34eb1f8dfa199ab9730748a79bd0ff8c759239 Mon Sep 17 00:00:00 2001 From: Mauro Perego Date: Mon, 6 Jul 2015 22:07:00 -0600 Subject: [PATCH 0211/1724] Pass to the external velo solver the time step and SMB These are used for the semi-implicit solution of momentum equation and thickness evolution. --- .../Interface_velocity_solver.cpp | 23 ++++++++++++++----- .../Interface_velocity_solver.hpp | 10 ++++---- .../mode_forward/mpas_li_velocity_external.F | 9 +++++--- 3 files changed, 29 insertions(+), 13 deletions(-) diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.cpp b/src/core_landice/mode_forward/Interface_velocity_solver.cpp index f581b1795d..524cecf9e2 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.cpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.cpp @@ -36,15 +36,17 @@ double const *xCell_F, *yCell_F, *zCell_F, *xVertex_F, *yVertex_F, *zVertex_F, std::vector xCellProjected, yCellProjected, zCellProjected; const double unit_length = 1000; const double T0 = 273.15; +const double secondsInAYear = 3.15569e7; const double minThick = 1e-3; //1m const double minBeta = 1e-5; +const double rho_ice = 910.0; //void *phgGrid = 0; std::vector edgesToReceive, fCellsToReceive, indexToTriangleID, verticesOnTria, trianglesOnEdge, trianglesPositionsOnEdge, verticesOnEdge; std::vector indexToVertexID, vertexToFCell, indexToEdgeID, edgeToFEdge, mask, fVertexToTriangleID, fCellToVertex, floatingEdgesIds, dirichletNodesIDs; std::vector temperatureOnTetra, velocityOnVertices, velocityOnCells, - elevationData, thicknessData, betaData, smb_F, thicknessOnCells; + elevationData, thicknessData, betaData, smbData, thicknessOnCells; std::vector isVertexBoundary, isBoundaryEdge; ; int numBoundaryEdges; @@ -284,9 +286,9 @@ void velocity_solver_init_fo(double const *levelsRatio_F) { } void velocity_solver_solve_fo(double const* lowerSurface_F, - double const* thickness_F, double const* beta_F, double const* temperature_F, + double const* thickness_F, double const* beta_F, double const* smb_F, double const* temperature_F, double* const dirichletVelocityXValue, double* const dirichletVelocitYValue, - double* u_normal_F, double* xVelocityOnCell, double* yVelocityOnCell) { + double* u_normal_F, double* xVelocityOnCell, double* yVelocityOnCell, double const* deltat) { std::fill(u_normal_F, u_normal_F + nEdges_F * (nLayers+1), 0.); @@ -328,7 +330,7 @@ void velocity_solver_solve_fo(double const* lowerSurface_F, - import2DFields(lowerSurface_F, thickness_F, beta_F, minThick); + import2DFields(lowerSurface_F, thickness_F, beta_F, smb_F, minThick); std::vector regulThk(thicknessData); for (int index = 0; index < nVertices; index++) @@ -336,10 +338,13 @@ void velocity_solver_solve_fo(double const* lowerSurface_F, importP0Temperature(temperature_F); + std::cout << "\n\nTimeStep: "<< *deltat << "\n\n"<< std::endl; + + double dt = (*deltat)/secondsInAYear; velocity_solver_solve_fo__(nLayers, nGlobalVertices, nGlobalTriangles, Ordering, first_time_step, indexToVertexID, indexToTriangleID, minBeta, regulThk, levelsNormalizedThickness, elevationData, thicknessData, - betaData, temperatureOnTetra, velocityOnVertices); + betaData, smbData, temperatureOnTetra, velocityOnVertices, dt); std::vector mpasIndexToVertexID(nVertices); for (int i = 0; i < nVertices; i++) { @@ -1246,11 +1251,13 @@ void extendMaskByOneLayer(int const* verticesMask_F, } void import2DFields(double const * lowerSurface_F, double const * thickness_F, - double const * beta_F, double eps) { + double const * beta_F, double const * smb_F, double eps) { elevationData.assign(nVertices, 1e10); thicknessData.assign(nVertices, 1e10); if (beta_F != 0) betaData.assign(nVertices, 1e10); + if (smb_F != 0) + smbData.assign(nVertices, 1e10); std::map bdExtensionMap; @@ -1261,6 +1268,8 @@ void import2DFields(double const * lowerSurface_F, double const * thickness_F, elevationData[index] = (lowerSurface_F[iCell] / unit_length) + thicknessData[index]; if (beta_F != 0) betaData[index] = beta_F[iCell] / unit_length; + if (smb_F != 0) + smbData[index] = smb_F[iCell] / unit_length * secondsInAYear/rho_ice; } //extend thickness elevation and basal friction data to the border for floating vertices @@ -1306,6 +1315,8 @@ void import2DFields(double const * lowerSurface_F, double const * thickness_F, elevationData[iv] = thicknessData[iv] + lowerSurface_F[ic] / unit_length; if (beta_F != 0) betaData[iv] = beta_F[ic] / unit_length; + if (smb_F != 0) + smbData[iv] = smb_F[ic] / unit_length * secondsInAYear/rho_ice; } } diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.hpp b/src/core_landice/mode_forward/Interface_velocity_solver.hpp index a1cd122109..37140d2386 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.hpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.hpp @@ -93,10 +93,10 @@ void velocity_solver_solve_l1l2(double const* lowerSurface_F, double* xVelocityOnCell = 0, double* yVelocityOnCell = 0); void velocity_solver_solve_fo(double const* lowerSurface_F, - double const* thickness_F, double const* beta_F, double const* temperature_F, + double const* thickness_F, double const* beta_F, double const* smb_F, double const* temperature_F, double* const dirichletVelocityXValue = 0, double* const dirichletVelocitYValue = 0, double* u_normal_F = 0, - double* xVelocityOnCell = 0, double* yVelocityOnCell = 0); + double* xVelocityOnCell = 0, double* yVelocityOnCell = 0, double const * deltat = 0); void velocity_solver_compute_2d_grid(int const* verticesMask_F, int const* dirichletNodesMask_F, int const* floatingEdgeMask_F); @@ -155,8 +155,10 @@ extern void velocity_solver_solve_fo__(int nLayers, int nGlobalVertices, const std::vector& elevationData, const std::vector& thicknessData, const std::vector& betaData, + const std::vector& smbData, const std::vector& temperatureOnTetra, - std::vector& velocityOnVertices); + std::vector& velocityOnVertices, + const double& deltat = 0.0); #ifdef LIFEV @@ -224,7 +226,7 @@ double signedTriangleArea(const double* x, const double* y, const double* z); void createReducedMPI(int nLocalEntities, MPI_Comm& reduced_comm_id); void import2DFields(double const* lowerSurface_F, double const* thickness_F, - double const* beta_F = 0, double eps = 0); + double const* beta_F = 0, double const* smb_F = 0, double eps = 0); std::vector extendMaskByOneLayer(int const* verticesMask_F); diff --git a/src/core_landice/mode_forward/mpas_li_velocity_external.F b/src/core_landice/mode_forward/mpas_li_velocity_external.F index bfa5a962fe..b15e81a656 100644 --- a/src/core_landice/mode_forward/mpas_li_velocity_external.F +++ b/src/core_landice/mode_forward/mpas_li_velocity_external.F @@ -372,11 +372,12 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc !----------------------------------------------------------------- integer, pointer :: index_temperature real (kind=RKIND), dimension(:), pointer :: & - thickness, lowerSurface, upperSurface, layerThicknessFractions, beta + thickness, lowerSurface, upperSurface, layerThicknessFractions, beta, sfcMassBal real (kind=RKIND), dimension(:,:), pointer :: & normalVelocity, uReconstructX, uReconstructY, uReconstructZ real (kind=RKIND), dimension(:,:,:), pointer :: & tracers + real (kind=RKIND), pointer :: deltat integer, dimension(:), pointer :: vertexMask, edgeMask, floatingEdges integer, dimension(:,:), pointer :: dirichletVelocityMask character (len=StrKIND), pointer :: config_velocity_solver @@ -395,6 +396,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc ! Mesh variables call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(meshPool, 'deltat', deltat) ! Geometry variables call mpas_pool_get_array(geometryPool, 'thickness', thickness) @@ -402,6 +404,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface) call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel = 1) call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(geometryPool, 'sfcMassBal', sfcMassBal) ! Thermal variables call mpas_pool_get_array(thermalPool, 'tracers', tracers) @@ -474,9 +477,9 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc case ('FO') ! =============================================== #ifdef USE_EXTERNAL_FIRSTORDER call mpas_timer_start("velocity_solver_solve_FO") - call velocity_solver_solve_FO(lowerSurface, thickness, beta, tracers(index_temperature,:,:), & + call velocity_solver_solve_FO(lowerSurface, thickness, beta, sfcMassBal, tracers(index_temperature,:,:), & uReconstructX, uReconstructY, & ! Dirichlet boundary values to apply where dirichletVelocityMask=1 - normalVelocity, uReconstructX, uReconstructY) ! return values + normalVelocity, uReconstructX, uReconstructY, deltat) ! return values ! call velocity_solver_estimate_SS_SMB(normalVelocity, mesh % sfcMassBal % array) ! this was used only for some ice2sea experiments, and is not a general routine to use if (config_output_external_velocity_solver_data) then From a03d3474768117dd35165f41ebbac1d6ee8eed86 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 31 Aug 2015 12:26:58 -0600 Subject: [PATCH 0212/1724] On init set MPAS params on C++ side This commit adds a new routine on init called velocity_solver_set_parameters that is used to set the values of parameters needed by the Interface/Albany. This eliminates the need to hard code their values which could lead to errors if the values change. --- .../Interface_velocity_solver.cpp | 32 +++++++++++++++---- .../Interface_velocity_solver.hpp | 2 ++ .../mode_forward/mpas_li_velocity_external.F | 20 +++++++++++- 3 files changed, 47 insertions(+), 7 deletions(-) diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.cpp b/src/core_landice/mode_forward/Interface_velocity_solver.cpp index 524cecf9e2..d086bde09e 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.cpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.cpp @@ -36,10 +36,15 @@ double const *xCell_F, *yCell_F, *zCell_F, *xVertex_F, *yVertex_F, *zVertex_F, std::vector xCellProjected, yCellProjected, zCellProjected; const double unit_length = 1000; const double T0 = 273.15; -const double secondsInAYear = 3.15569e7; +const double secondsInAYear = 31536000.0; // This may vary slightly in MPAS, but this should be close enough for how this is used. const double minThick = 1e-3; //1m const double minBeta = 1e-5; -const double rho_ice = 910.0; +double rho_ice; +//unsigned char dynamic_ice_bit_value; +//unsigned char ice_present_bit_value; +int dynamic_ice_bit_value; +int ice_present_bit_value; + //void *phgGrid = 0; std::vector edgesToReceive, fCellsToReceive, indexToTriangleID, verticesOnTria, trianglesOnEdge, trianglesPositionsOnEdge, verticesOnEdge; @@ -70,6 +75,7 @@ extern "C" { // =================================================== //! Interface functions // =================================================== + int velocity_solver_init_mpi(int* fComm) { // get MPI_Comm from Fortran comm = MPI_Comm_f2c(*fComm); @@ -78,6 +84,20 @@ int velocity_solver_init_mpi(int* fComm) { } +void velocity_solver_set_parameters(double const* rhoi_F, int const* li_mask_ValueDynamicIce, int const* li_mask_ValueIce) { + // This function sets parameter values used by MPAS on the C/C++ side + rho_ice = *rhoi_F; + //std::cout << "rhoi Fortran value:" << *rhoi_F << std::endl; + //std::cout << "rhoi C++ value:" << rho_ice << std::endl; + dynamic_ice_bit_value = *li_mask_ValueDynamicIce; + ice_present_bit_value = *li_mask_ValueIce; + //std::cout << "mask dynamic Fortran value:" << *li_mask_ValueDynamicIce << std::endl; + //std::cout << "mask dynamic C++ value:" << dynamic_ice_bit_value << std::endl; + // Could add seconds in a year, but that can change from time step to time step on the MPAS side, so leaving it out for now. +} + + + void velocity_solver_export_2d_data(double const* lowerSurface_F, double const* thickness_F, double const* beta_F) { if (isDomainEmpty) @@ -488,7 +508,7 @@ void velocity_solver_compute_2d_grid(int const* verticesMask_F, int const* _diri std::vector fVertexToTriangle(nVertices_F, NotAnId); bool changed = false; for (int i(0); i < nVerticesSolve_F; i++) { - if ((verticesMask_F[i] & 0x02) && !isGhostTriangle(i)) { + if ((verticesMask_F[i] & dynamic_ice_bit_value) && !isGhostTriangle(i)) { fVertexToTriangle[i] = triangleToFVertex.size(); triangleToFVertex.push_back(i); } @@ -756,7 +776,7 @@ void velocity_solver_compute_2d_grid(int const* verticesMask_F, int const* _diri bool isBoundary; do { int fVertex = verticesOnCell_F[maxNEdgesOnCell_F * fCell + j++] - 1; - isBoundary = !(verticesMask_F[fVertex] & 0x02); + isBoundary = !(verticesMask_F[fVertex] & dynamic_ice_bit_value); } while ((j < nEdg) && (!isBoundary)); isVertexBoundary[iV] = isBoundary; } @@ -1289,8 +1309,8 @@ void import2DFields(double const * lowerSurface_F, double const * thickness_F, double elevTemp =1e10; for (int j = 0; j < nEdg; j++) { int fEdge = edgesOnCell_F[maxNEdgesOnCell_F * fCell + j] - 1; - bool keep = (mask[verticesOnEdge_F[2 * fEdge] - 1] & 0x02) - && (mask[verticesOnEdge_F[2 * fEdge + 1] - 1] & 0x02); + bool keep = (mask[verticesOnEdge_F[2 * fEdge] - 1] & dynamic_ice_bit_value) + && (mask[verticesOnEdge_F[2 * fEdge + 1] - 1] & dynamic_ice_bit_value); if (!keep) continue; diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.hpp b/src/core_landice/mode_forward/Interface_velocity_solver.hpp index 37140d2386..b3ae404bdd 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.hpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.hpp @@ -82,6 +82,8 @@ int velocity_solver_init_mpi(int* fComm); void velocity_solver_finalize(); +void velocity_solver_set_parameters(double const* rhoi_F, int const* li_mask_ValueDynamicIce, int const* li_mask_ValueIce); + void velocity_solver_init_l1l2(double const* levelsRatio); void velocity_solver_init_fo(double const* levelsRatio); diff --git a/src/core_landice/mode_forward/mpas_li_velocity_external.F b/src/core_landice/mode_forward/mpas_li_velocity_external.F index b15e81a656..3ce7f07360 100644 --- a/src/core_landice/mode_forward/mpas_li_velocity_external.F +++ b/src/core_landice/mode_forward/mpas_li_velocity_external.F @@ -21,7 +21,7 @@ module li_velocity_external use mpas_dmpar use mpas_timer use li_setup - !use, intrinsic :: iso_c_binding + use, intrinsic :: iso_c_binding implicit none private @@ -44,6 +44,17 @@ module li_velocity_external li_velocity_external_solve, & li_velocity_external_finalize + interface + ! Note: Could add all interface routines to this interface... + ! For now, just trying it with this new routine. + subroutine velocity_solver_set_parameters(config_ice_density, li_mask_ValueDynamicIce, li_mask_ValueIce) bind(C, name="velocity_solver_set_parameters") + use iso_c_binding, only: C_INT, C_DOUBLE + INTEGER(C_INT) :: li_mask_ValueDynamicIce, li_mask_ValueIce + REAL(C_DOUBLE) :: config_ice_density + end subroutine velocity_solver_set_parameters + + end interface + !-------------------------------------------------------------------- ! ! Private module variables @@ -188,6 +199,8 @@ end subroutine li_velocity_external_init subroutine li_velocity_external_block_init(block, err) + use li_mask + !----------------------------------------------------------------- ! ! input variables @@ -223,6 +236,7 @@ subroutine li_velocity_external_block_init(block, err) real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xVertex, yVertex, zVertex, areaTriangle real (kind=RKIND), pointer :: radius type (field1DInteger), pointer :: indexToCellIDField, indexToEdgeIDField, indexToVertexIDField + real (kind=RKIND), pointer :: config_ice_density ! halo exchange arrays integer, dimension(:), pointer :: sendCellsArray, & @@ -306,6 +320,10 @@ subroutine li_velocity_external_block_init(block, err) sendEdgesArray, & recvEdgesArray) + ! Set physical parameters needed on the other side + call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) + call velocity_solver_set_parameters(config_ice_density, li_mask_ValueDynamicIce, li_mask_ValueIce) + ! === error check if (err > 0) then write (stderrUnit,*) "An error has occurred in li_velocity_external_block_init." From 99241af971f2f7018335419d3ff8e375c2dd893e Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Thu, 3 Sep 2015 09:20:33 -0600 Subject: [PATCH 0213/1724] Minor modifications to get global_ocean to run. --- src/core_ocean/Makefile | 4 +- src/core_ocean/Registry.xml | 4 +- .../mode_init/Registry_global_ocean.xml | 4 +- .../mode_init/Registry_global_realistic.xml | 177 ------------------ src/core_ocean/mode_init/Registry_soma.xml | 2 +- .../mode_init/mpas_ocn_init_global_ocean.F | 9 +- .../tracer_groups/Registry_debugTracers.xml | 2 +- 7 files changed, 15 insertions(+), 187 deletions(-) delete mode 100644 src/core_ocean/mode_init/Registry_global_realistic.xml diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index 8c0ba0ea12..9f0f2d199f 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -29,7 +29,9 @@ core_input_gen: (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.overflow mode=init configuration=overflow) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.cvmix_convection_unit_test mode=init configuration=cvmix_convection_unit_test) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.cvmix_shear_unit_test mode=init configuration=cvmix_shear_unit_test) - (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.global_realistic mode=init configuration=global_realistic) + (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.soma mode=init configuration=soma) + (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.iso mode=init configuration=iso) + (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.global_ocean mode=init configuration=global_ocean) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean stream_list.ocean. mutable ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.forward stream_list.ocean.forward. mutable mode=forward ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis ) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 1b1babe54c..d1a327fbc9 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -136,10 +136,12 @@ cvmix_convection_unit_test_value="cvmix_convection_unit_test" cvmix_shear_unit_test_value="cvmix_shear_unit_test" cvmx_WSwSBF_value="cvmx_WSwSBF" - global_realistic_value="global_realistic" + global_ocean_value="global_ocean" internal_waves_value="internal_waves" lock_exchange_value="lock_exchange" overflow_value="overflow" + soma_value="soma" + iso_value="iso" /> + /> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/src/core_ocean/mode_init/Registry_soma.xml b/src/core_ocean/mode_init/Registry_soma.xml index a771be4049..851713cdfc 100644 --- a/src/core_ocean/mode_init/Registry_soma.xml +++ b/src/core_ocean/mode_init/Registry_soma.xml @@ -1,4 +1,4 @@ - + - From e94699dcbd661644d984a74acffbb78a52b5531e Mon Sep 17 00:00:00 2001 From: vanroekel Date: Mon, 7 Sep 2015 22:30:56 -0600 Subject: [PATCH 0214/1724] MLD arrays have been changed to be compatible with paraVIEW. This should also allow a model speed up as there is the option to compute one MLD type at a time (density and temperature are separated). However, a range of thresholds is no longer allowed. This is probably okay. It doesn't seem to be an online model requirement --- .../Registry_mixed_layer_depths.xml | 88 ++++--- .../mpas_ocn_mixed_layer_depths.F | 225 ++++++++++-------- 2 files changed, 161 insertions(+), 152 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml index 1f9c6b1019..9a93d86503 100644 --- a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml +++ b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml @@ -1,14 +1,3 @@ - - - - - - - + + - - - - - + + - - - @@ -83,11 +66,18 @@ - + + + - @@ -100,10 +90,12 @@ packages="mixedLayerDepthsAMPKG" clobber_mode="truncate" runtime_format="single_file"> + + - - - - + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F index c7e28fb5c7..fe0a24494c 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F +++ b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F @@ -164,27 +164,26 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ ! Here are some example variables which may be needed for your analysis member integer, pointer :: nVertLevels, nCellsSolve, num_tracers - integer, pointer :: nThresholdBins, nGradientBins integer :: k, iCell, i, refIndex, refLevel(1) integer, pointer :: index_temperature integer, dimension(:), pointer :: maxLevelCell - logical :: found_temp_mld, found_den_mld - logical,pointer :: thresholdFlag, gradientFlag + logical,pointer :: tThresholdFlag, dThresholdFlag + logical,pointer :: tGradientFlag, dGradientFlag ! real (kind=RKIND), dimension(:), pointer :: areaCell - real (kind=RKIND), dimension(:,:,:), pointer :: thresholdMLD, gradientMLD + real (kind=RKIND), dimension(:,:), pointer :: tThresholdMLD, tGradientMLD + real (kind=RKIND), dimension(:,:), pointer :: dThresholdMLD, dGradientMLD real (kind=RKIND), dimension(:,:,:), pointer :: tracers real (kind=RKIND), dimension(:,:), pointer :: zTop, zMid, pressure real (kind=RKIND), dimension(:,:), pointer :: potentialDensity - real (kind=RKIND), pointer :: tempThreshMin, tempThreshMax - real (kind=RKIND), pointer :: tempGradMin, tempGradMax - real (kind=RKIND), pointer :: denThreshMin, denThreshMax - real (kind=RKIND), pointer :: denGradMin, denGradMax + real (kind=RKIND), pointer :: tempThresh + real (kind=RKIND), pointer :: tempGrad + real (kind=RKIND), pointer :: denThresh + real (kind=RKIND), pointer :: denGrad integer, pointer :: interp_type integer :: interp_local real (kind=RKIND), pointer :: refPress - real (kind=RKIND), allocatable, dimension(:,:) :: gradientBins, thresholdBins real (kind=RKIND), allocatable, dimension(:,:) :: densityGradient, temperatureGradient real (kind=RKIND) :: mldTemp,dTempThres, dDenThres, dTempGrad, dDenGrad real (kind=RKIND) :: dz,temp_ref_lev, den_ref_lev, dV, dVm1, dVp1, localVals(6) @@ -197,19 +196,15 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) - call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nThresholdBins', nThresholdBins) - call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nGradientBins', nGradientBins) - - call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_threshold_method', thresholdFlag) - call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_gradient_method', gradientFlag) - call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_crit_temp_minthreshold', tempThreshMin) - call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_crit_temp_maxthreshold', tempThreshMax) - call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_crit_dens_minthreshold', denThreshMin) - call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_crit_dens_maxthreshold', denThreshMax) - call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_temp_gradient_minthreshold', tempGradMin) - call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_temp_gradient_maxthreshold', tempGradMax) - call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_den_gradient_minthreshold', denGradMin) - call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_den_gradient_maxthreshold', denGradMax) + + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_Tthreshold', tThresholdFlag) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_Dthreshold', dThresholdFlag) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_Tgradient', tGradientFlag) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_Dgradient', dGradientFlag) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_crit_temp_threshold', tempThresh) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_crit_dens_threshold', denThresh) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_temp_gradient_threshold', tempGrad) + call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_den_gradient_threshold', denGrad) call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_interp_method', interp_type) call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_reference_pressure', refPress) @@ -231,7 +226,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(statePool, 'tracers', tracers) + call mpas_pool_get_array(statePool, 'tracers', tracers, timeLevel) call mpas_pool_get_array(diagnosticsPool, 'potentialDensity', & potentialDensity) call mpas_pool_get_array(diagnosticsPool, 'pressure', pressure) @@ -240,22 +235,11 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ call mpas_pool_get_array(meshPool, 'latCell', latCell) call mpas_pool_get_array(meshPool, 'lonCell', lonCell) - if(thresholdFlag) then - call mpas_pool_get_array(mixedLayerDepthsAMPool, 'thresholdMLD',thresholdMLD) + if(tThresholdFlag) then + call mpas_pool_get_array(mixedLayerDepthsAMPool, 'tThreshMLD',tThresholdMLD) - dTempThres = (tempThreshMax - tempThreshMin) / float(nThresholdBins) - dDenThres = (denThreshMax - denThreshMin) / float(nThresholdBins) - - allocate(thresholdBins(2,nThresholdBins)) - - do i=1,nThresholdBins - thresholdBins(1,i) = tempThreshMin + dTempThres*(i-1) - thresholdBins(2,i) = denThreshMin + dDenThres*(i-1) - enddo - do iCell = 1,nCellsSolve - found_den_mld = .false. found_temp_mld = .false. do k=1, maxLevelCell(iCell) @@ -266,136 +250,169 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ call interp_bw_levels(localVals(2),localVals(3), & localVals(5),localVals(6),refPress,interp_local, & temp_ref_lev) - - localVals(2:3)=potentialDensity(k:k+1,iCell) - call interp_bw_levels(localVals(2),localVals(3), & - localVals(5),localVals(6),refPress,interp_local, & - den_ref_lev) - - refIndex = k exit endif enddo - do i=1,nThresholdBins - do k=refIndex,maxLevelCell(iCell) + do k=refIndex,maxLevelCell(iCell) - if(.not. found_temp_mld .and. abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) .ge. thresholdBins(1,i)) then + if(.not. found_temp_mld .and. abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) .ge. tempThresh) then dVp1 = abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) dV = abs(tracers(index_temperature,k ,iCell) - temp_ref_lev) dVm1 = abs(tracers(index_temperature,k-1,iCell) - temp_ref_lev) localVals(1:3)=zMid(k-1:k+1,iCell) - call interp_bw_levels(localVals(2),localVals(3), dV, dVp1, thresholdBins(1,i), & + call interp_bw_levels(localVals(2),localVals(3), dV, dVp1, tempThresh, & interp_local, mldTemp)!,dVm1, localVals(1)) mldTemp=max(mldTemp,zMid(k+1,iCell)) !make sure MLD isn't deeper than zMid(k+1) - thresholdMLD(1,i,iCell)=min(mldTemp,zMid(k,iCell)) !MLD should be deeper than zMid(k) + tThresholdMLD(1,iCell)=abs(min(mldTemp,zMid(k,iCell))) !MLD should be deeper than zMid(k) found_temp_mld = .true. + exit endif + enddo + +! if the mixed layer depth is not found, it is set to the depth of the bottom most level + if(.not. found_temp_mld) tThresholdMLD(i,iCell) = abs(zMid(maxLevelCell(iCell),iCell)) + enddo !iCell + + endif !end tThresh MLD search + + if(dThresholdFlag) then + call mpas_pool_get_array(mixedLayerDepthsAMPool, 'tThreshMLD',dThresholdMLD) + + do iCell = 1,nCellsSolve + + found_den_mld = .false. + + do k=1, maxLevelCell(iCell) + if(pressure(k+1,iCell) > refPress) then + localvals(2:3)=potentialDensity(k:k+1,iCell) + localvals(5:6)=pressure(k:k+1,iCell) + + call interp_bw_levels(localVals(2),localVals(3), & + localVals(5),localVals(6),refPress,interp_local, & + den_ref_lev) + exit + endif + enddo - if( .not. found_den_mld .and. abs(potentialDensity(k,iCell) - den_ref_lev) .ge. thresholdBins(2,i)) then + + do k=refIndex,maxLevelCell(iCell) + + if(.not. found_den_mld .and. abs(potentialDensity(k+1,iCell) - den_ref_lev) .ge. denThresh) then dVp1 = abs(potentialDensity(k+1,iCell) - den_ref_lev) dV = abs(potentialDensity(k ,iCell) - den_ref_lev) dVm1 = abs(potentialDensity(k-1,iCell) - den_ref_lev) localVals(1:3)=zMid(k-1:k+1,iCell) - call interp_bw_levels(localVals(2),localVals(3), dV, dVp1, thresholdBins(2,i), & - interp_local, mldTemp)!,dVm1,localVals(1)) - + call interp_bw_levels(localVals(2),localVals(3), dV, dVp1, denThresh, & + interp_local, mldTemp, dVm1, localVals(1)) mldTemp=max(mldTemp,zMid(k+1,iCell)) !make sure MLD isn't deeper than zMid(k+1) - thresholdMLD(2,i,iCell)=min(mldTemp,zMid(k,iCell)) !MLD should be deeper than zMid(k) - + dThresholdMLD(1,iCell)=abs(min(mldTemp,zMid(k,iCell))) !MLD should be deeper than zMid(k) found_den_mld = .true. + exit endif - - if(found_den_mld .and. found_temp_mld) exit - enddo - -! if no MLD found, set to bottom value of zMid - if(.not. found_den_mld) thresholdMLD(2,i,iCell) = zMid(maxLevelCell(iCell),iCell) - if(.not. found_temp_mld) thresholdMLD(1,i,iCell) = zMid(maxLevelCell(iCell),iCell) - enddo !i=1,nThresholdBins - enddo !iCell - - endif !if thresholdflag + enddo + +! if the mixed layer depth is not found, it is set to the depth of the bottom most level + + if(.not. found_den_mld) dthresholdMLD(1,iCell) = abs(zMid(maxLevelCell(iCell),iCell)) + + enddo !iCell + + endif !end dThresh MLD search + ! Compute the mixed layer depth based on a gradient threshold in temperature and density - - if(gradientFlag) then - call mpas_pool_get_array(mixedLayerDepthsAMPool, 'gradientMLD', gradientMLD) - dTempGrad = (tempGradMax - tempGradMin) / float(nGradientBins) - dDenGrad = (denGradMax - denGradMin) / float(nGradientBins) - allocate(gradientBins(2,nGradientBins)) - allocate(densityGradient(2,nVertLevels),temperatureGradient(2,nVertLevels)) - - do i=1,nGradientBins - gradientBins(1,i) = tempGradMin + dTempGrad*(i-1) - gradientBins(2,i) = denGradMin + dDenGrad*(i-1) - enddo - - densityGradient(2,:)=0.0_RKIND + if(tGradientFlag) then + call mpas_pool_get_array(mixedLayerDepthsAMPool, 'tGradientMLD',tGradientMLD) + temperatureGradient(2,:) = 0.0_RKIND - - densityGradient(2,1) = 1 temperatureGradient(2,1) = 1 do iCell = 1,nCellsSolve - found_den_mld=.false. found_temp_mld=.false. do k=2,maxLevelCell(iCell) dz=abs(pressure(k-1,iCell)-pressure(k,iCell)) - densityGradient(k,1) = abs(potentialDensity(k-1,iCell)-potentialDensity(k,iCell)) / dz temperatureGradient(k,1) = abs(tracers(index_temperature,k-1,iCell) - tracers(index_temperature,k,iCell)) / dz - densityGradient(k,2) = k temperatureGradient(k,2) = k enddo ! smooth the gradients to eliminate reduce single point maxima do k=2,maxLevelCell(iCell)-1 - densityGradient(k,1) = (densityGradient(k-1,1) + densityGradient(k,1) + densityGradient(k+1,1)) / float(3) temperatureGradient(k,1) = (temperatureGradient(k-1,1) + temperatureGradient(k,1) + temperatureGradient(k+1,1)) / float(3) enddo - do i=1, nGradientBins do k=2, maxLevelCell(iCell) - if(.not. found_den_mld .and. densityGradient(1,k+1) .ge. gradientBins(2,i)) then - call interp_bw_levels(zTop(k,iCell),zTop(k+1,iCell),densityGradient(k,1),densityGradient(k+1,1), & - gradientBins(2,i), interp_local,mldTemp,densityGradient(k-1,1),zTop(k-1,iCell)) - mldTemp=max(mldTemp,zTop(k+1,iCell)) !make sure MLD isn't deeper than zMid(k+1) - gradientMLD(2,i,iCell)=min(mldTemp,zTop(k,iCell)) !MLD should be deeper than zMid(k) - found_den_mld=.true. - endif - if(.not. found_temp_mld .and. temperatureGradient(k+1,1) .ge. gradientBins(1,i)) then + if(.not. found_temp_mld .and. temperatureGradient(k+1,1) .ge. tempGrad) then call interp_bw_levels(zTop(k,iCell),zTop(k+1,iCell),temperatureGradient(k,1),temperatureGradient(k+1,1), & - gradientBins(1,i), interp_local,mldTemp,temperatureGradient(k-1,1),zTop(k-1,iCell)) + tempGrad, interp_local,mldTemp,temperatureGradient(k-1,1),zTop(k-1,iCell)) mldTemp=max(mldTemp,zTop(k+1,iCell)) !make sure MLD isn't deeper than zMid(k+1) - gradientMLD(1,i,iCell)=min(mldTemp,zTop(k,iCell)) !MLD should be deeper than zMid(k) + tGradientMLD(1,iCell)=min(mldTemp,zTop(k,iCell)) !MLD should be deeper than zMid(k) found_temp_mld=.true. + exit endif - if(found_temp_mld .and. found_den_mld) exit enddo !maxLevelCell if(.not. found_temp_mld) then refLevel=maxloc(temperatureGradient(:,1)) - gradientMLD(1,i,iCell) = zTop(refLevel(1),iCell) + tGradientMLD(1,iCell) = zTop(refLevel(1),iCell) endif + enddo !icell + + endif !if(temperaturegradientflag) + + if(dGradientFlag) then + call mpas_pool_get_array(mixedLayerDepthsAMPool, 'dGradientMLD',dGradientMLD) + + densityGradient(2,:)=0.0_RKIND + densityGradient(2,1) = 1 + + do iCell = 1,nCellsSolve + + found_den_mld=.false. + + do k=2,maxLevelCell(iCell) + dz=abs(pressure(k-1,iCell)-pressure(k,iCell)) + densityGradient(k,1) = abs(potentialDensity(k-1,iCell)-potentialDensity(k,iCell)) / dz + densityGradient(k,2) = k + enddo + +! smooth the gradients to eliminate reduce single point maxima + + do k=2,maxLevelCell(iCell)-1 + densityGradient(k,1) = (densityGradient(k-1,1) + densityGradient(k,1) + densityGradient(k+1,1)) / float(3) + enddo + + + do k=2, maxLevelCell(iCell) + if(.not. found_den_mld .and. densityGradient(1,k+1) .ge. denGrad) then + call interp_bw_levels(zTop(k,iCell),zTop(k+1,iCell),densityGradient(k,1),densityGradient(k+1,1), & + denGrad, interp_local,mldTemp,densityGradient(k-1,1),zTop(k-1,iCell)) + mldTemp=max(mldTemp,zTop(k+1,iCell)) !make sure MLD isn't deeper than zMid(k+1) + dGradientMLD(1,iCell)=abs(min(mldTemp,zTop(k,iCell))) !MLD should be deeper than zMid(k) + found_den_mld=.true. + exit + endif + + enddo !maxLevelCell + + if(.not. found_den_mld) then refLevel=maxloc(densityGradient(:,2)) - gradientMLD(2,i,iCell) = zTop(refLevel(1),iCell) - endif - enddo ! nGradientBins + dGradientMLD(1,iCell) = abs(zTop(refLevel(1),iCell)) + endif enddo !icell - endif !if(gradientflag) - - + endif !if(densitygradientflag) + block => block % next end do From 9a288e2831906b1d5cea0f428549a3add4e32ed2 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Tue, 8 Sep 2015 12:24:57 -0600 Subject: [PATCH 0215/1724] Fix index issue in lock exchange init module This commit fixes an issue trying to access index_temperature and index_salinity in the lock exchange initial condition module. --- src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F b/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F index 0b7fef655b..1a4f7a8e46 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_lock_exchange.F @@ -178,8 +178,8 @@ subroutine ocn_init_setup_lock_exchange(domain, iErr)!{{{ call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(statePool, 'index_temperature', index_temperature) - call mpas_pool_get_dimension(statePool, 'index_salinity', index_salinity) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_salinity) call mpas_pool_get_dimension(tracersPool, 'index_tracer1', index_tracer1) call mpas_pool_get_array(meshPool, 'yCell', yCell) From ad873ed94ce75983491927f6d710730b50eed4a8 Mon Sep 17 00:00:00 2001 From: Luke Van Roekel Date: Tue, 8 Sep 2015 13:35:45 -0600 Subject: [PATCH 0216/1724] fixes some array size declaration errors and logic errors in a v0 version of the switch to paraVIEW compliant arrays --- .../Registry_mixed_layer_depths.xml | 8 +- .../mpas_ocn_mixed_layer_depths.F | 82 ++++++++++--------- 2 files changed, 47 insertions(+), 43 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml index 9a93d86503..e624e8fc4e 100644 --- a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml +++ b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml @@ -66,17 +66,17 @@ - - - - diff --git a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F index fe0a24494c..8556b7407b 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F +++ b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F @@ -172,8 +172,8 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ logical,pointer :: tThresholdFlag, dThresholdFlag logical,pointer :: tGradientFlag, dGradientFlag ! real (kind=RKIND), dimension(:), pointer :: areaCell - real (kind=RKIND), dimension(:,:), pointer :: tThresholdMLD, tGradientMLD - real (kind=RKIND), dimension(:,:), pointer :: dThresholdMLD, dGradientMLD + real (kind=RKIND), dimension(:), pointer :: tThresholdMLD, tGradientMLD + real (kind=RKIND), dimension(:), pointer :: dThresholdMLD, dGradientMLD real (kind=RKIND), dimension(:,:,:), pointer :: tracers real (kind=RKIND), dimension(:,:), pointer :: zTop, zMid, pressure real (kind=RKIND), dimension(:,:), pointer :: potentialDensity @@ -237,7 +237,6 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ if(tThresholdFlag) then call mpas_pool_get_array(mixedLayerDepthsAMPool, 'tThreshMLD',tThresholdMLD) - do iCell = 1,nCellsSolve found_temp_mld = .false. @@ -250,11 +249,11 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ call interp_bw_levels(localVals(2),localVals(3), & localVals(5),localVals(6),refPress,interp_local, & temp_ref_lev) + refIndex=k exit endif enddo - do k=refIndex,maxLevelCell(iCell) if(.not. found_temp_mld .and. abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) .ge. tempThresh) then @@ -265,20 +264,19 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ call interp_bw_levels(localVals(2),localVals(3), dV, dVp1, tempThresh, & interp_local, mldTemp)!,dVm1, localVals(1)) mldTemp=max(mldTemp,zMid(k+1,iCell)) !make sure MLD isn't deeper than zMid(k+1) - tThresholdMLD(1,iCell)=abs(min(mldTemp,zMid(k,iCell))) !MLD should be deeper than zMid(k) + tThresholdMLD(iCell)=abs(min(mldTemp,zMid(k,iCell))) !MLD should be deeper than zMid(k) found_temp_mld = .true. exit endif - enddo - + enddo + ! if the mixed layer depth is not found, it is set to the depth of the bottom most level - if(.not. found_temp_mld) tThresholdMLD(i,iCell) = abs(zMid(maxLevelCell(iCell),iCell)) - enddo !iCell - - endif !end tThresh MLD search - + if(.not. found_temp_mld) tThresholdMLD(iCell) = abs(zMid(maxLevelCell(iCell),iCell)) + enddo !iCell + endif !end tThresh MLD search + if(dThresholdFlag) then - call mpas_pool_get_array(mixedLayerDepthsAMPool, 'tThreshMLD',dThresholdMLD) + call mpas_pool_get_array(mixedLayerDepthsAMPool, 'dThreshMLD',dThresholdMLD) do iCell = 1,nCellsSolve @@ -292,10 +290,10 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ call interp_bw_levels(localVals(2),localVals(3), & localVals(5),localVals(6),refPress,interp_local, & den_ref_lev) - exit + refIndex=k + exit endif enddo - do k=refIndex,maxLevelCell(iCell) @@ -305,29 +303,32 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ dVm1 = abs(potentialDensity(k-1,iCell) - den_ref_lev) localVals(1:3)=zMid(k-1:k+1,iCell) call interp_bw_levels(localVals(2),localVals(3), dV, dVp1, denThresh, & - interp_local, mldTemp, dVm1, localVals(1)) + interp_local, mldTemp)!, dVm1, localVals(1)) mldTemp=max(mldTemp,zMid(k+1,iCell)) !make sure MLD isn't deeper than zMid(k+1) - dThresholdMLD(1,iCell)=abs(min(mldTemp,zMid(k,iCell))) !MLD should be deeper than zMid(k) + dThresholdMLD(iCell)=abs(min(mldTemp,zMid(k,iCell))) !MLD should be deeper than zMid(k) found_den_mld = .true. exit endif - enddo + enddo ! if the mixed layer depth is not found, it is set to the depth of the bottom most level - - if(.not. found_den_mld) dthresholdMLD(1,iCell) = abs(zMid(maxLevelCell(iCell),iCell)) - - enddo !iCell - - endif !end dThresh MLD search + + if(.not. found_den_mld) dThresholdMLD(iCell) = abs(zMid(maxLevelCell(iCell),iCell)) + + enddo !iCell + + endif !end dThresh MLD search ! Compute the mixed layer depth based on a gradient threshold in temperature and density if(tGradientFlag) then - call mpas_pool_get_array(mixedLayerDepthsAMPool, 'tGradientMLD',tGradientMLD) - - temperatureGradient(2,:) = 0.0_RKIND - temperatureGradient(2,1) = 1 + call mpas_pool_get_array(mixedLayerDepthsAMPool, 'tGradMLD',tGradientMLD) + + + allocate(temperatureGradient(nVertLevels,2)) + + temperatureGradient(:,1) = 0.0_RKIND + temperatureGradient(1,2) = 1 do iCell = 1,nCellsSolve @@ -346,12 +347,13 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ enddo - do k=2, maxLevelCell(iCell) + do k=2, maxLevelCell(iCell)-1 if(.not. found_temp_mld .and. temperatureGradient(k+1,1) .ge. tempGrad) then call interp_bw_levels(zTop(k,iCell),zTop(k+1,iCell),temperatureGradient(k,1),temperatureGradient(k+1,1), & tempGrad, interp_local,mldTemp,temperatureGradient(k-1,1),zTop(k-1,iCell)) + mldTemp=max(mldTemp,zTop(k+1,iCell)) !make sure MLD isn't deeper than zMid(k+1) - tGradientMLD(1,iCell)=min(mldTemp,zTop(k,iCell)) !MLD should be deeper than zMid(k) + tGradientMLD(iCell)=abs(min(mldTemp,zTop(k,iCell))) !MLD should be deeper than zMid(k) found_temp_mld=.true. exit @@ -361,18 +363,20 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ if(.not. found_temp_mld) then refLevel=maxloc(temperatureGradient(:,1)) - tGradientMLD(1,iCell) = zTop(refLevel(1),iCell) + tGradientMLD(iCell) = abs(zTop(refLevel(1),iCell)) endif enddo !icell endif !if(temperaturegradientflag) - if(dGradientFlag) then - call mpas_pool_get_array(mixedLayerDepthsAMPool, 'dGradientMLD',dGradientMLD) + if(dGradientFlag) then + call mpas_pool_get_array(mixedLayerDepthsAMPool, 'dGradMLD',dGradientMLD) + + allocate(densityGradient(nVertLevels,2)) - densityGradient(2,:)=0.0_RKIND - densityGradient(2,1) = 1 + densityGradient(:,1)=0.0_RKIND + densityGradient(1,2) = 1 do iCell = 1,nCellsSolve @@ -391,12 +395,12 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ enddo - do k=2, maxLevelCell(iCell) - if(.not. found_den_mld .and. densityGradient(1,k+1) .ge. denGrad) then + do k=2, maxLevelCell(iCell)-1 + if(.not. found_den_mld .and. densityGradient(k+1,1) .ge. denGrad) then call interp_bw_levels(zTop(k,iCell),zTop(k+1,iCell),densityGradient(k,1),densityGradient(k+1,1), & denGrad, interp_local,mldTemp,densityGradient(k-1,1),zTop(k-1,iCell)) mldTemp=max(mldTemp,zTop(k+1,iCell)) !make sure MLD isn't deeper than zMid(k+1) - dGradientMLD(1,iCell)=abs(min(mldTemp,zTop(k,iCell))) !MLD should be deeper than zMid(k) + dGradientMLD(iCell)=abs(min(mldTemp,zTop(k,iCell))) !MLD should be deeper than zMid(k) found_den_mld=.true. exit endif @@ -406,7 +410,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ if(.not. found_den_mld) then refLevel=maxloc(densityGradient(:,2)) - dGradientMLD(1,iCell) = abs(zTop(refLevel(1),iCell)) + dGradientMLD(iCell) = abs(zTop(refLevel(1),iCell)) endif enddo !icell From 6cd0cb9198fb595e6b8827474507b98ecfcb0795 Mon Sep 17 00:00:00 2001 From: vanroekel Date: Tue, 8 Sep 2015 22:04:25 -0600 Subject: [PATCH 0217/1724] time dimension reinstated for the MLD output arrays --- .../analysis_members/Registry_mixed_layer_depths.xml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml index e624e8fc4e..f19448fdd7 100644 --- a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml +++ b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml @@ -66,17 +66,17 @@ - - - - From fde922d12e9fbee049e5018306cc5937866ee0ab Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Wed, 9 Sep 2015 08:29:54 -0600 Subject: [PATCH 0218/1724] Updating timer names for analysis driver This commit updates the analysis driver to fix some issues with nesting of timers. --- src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F index 4adcf08829..10f011d5fb 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -72,6 +72,7 @@ module ocn_analysis_driver character (len=*), parameter :: initTimerPrefix = 'init_' character (len=*), parameter :: computeTimerPrefix = 'compute_' + character (len=*), parameter :: computeStartupTimerPrefix = 'compute_startup_' character (len=*), parameter :: writeTimerPrefix = 'write_' character (len=*), parameter :: alarmTimerPrefix = 'reset_alarm_' character (len=*), parameter :: restartTimerPrefix = 'restart_' @@ -338,7 +339,7 @@ subroutine ocn_analysis_compute_startup(domain, err)!{{{ err = 0 - call mpas_timer_start('analysis_compute', .false.) + call mpas_timer_start('analysis_compute_startup', .false.) timeLevel=1 @@ -355,7 +356,7 @@ subroutine ocn_analysis_compute_startup(domain, err)!{{{ call mpas_pool_get_config(domain % configs, configName, config_AM_write_on_startup) if ( config_AM_compute_on_startup ) then - timerName = trim(computeTimerPrefix) // poolItr % memberName(1:nameLength) + timerName = trim(computeStartupTimerPrefix) // poolItr % memberName(1:nameLength) call mpas_timer_start(timerName, .false.) call ocn_compute_analysis_members(domain, timeLevel, poolItr % memberName, err_tmp) call mpas_timer_stop(timerName) @@ -377,7 +378,7 @@ subroutine ocn_analysis_compute_startup(domain, err)!{{{ end if end do - call mpas_timer_stop('analysis_compute') + call mpas_timer_stop('analysis_compute_startup') end subroutine ocn_analysis_compute_startup!}}} From 4099c0bf0ade2009906c3020718806ced1c38547 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Wed, 9 Sep 2015 09:47:06 -0600 Subject: [PATCH 0219/1724] Correct / Remove write statements Some write statements were unnecessary, while others were writing to incorrect unit numbers. Both are fixed in this commit, where the unnecessary ones are removed and the unit numbers are corrected. --- .../analysis_members/mpas_ocn_water_mass_census.F | 14 +++++++------- .../mode_init/mpas_ocn_init_cvmix_WSwSBF.F | 3 --- .../mode_init/mpas_ocn_init_internal_waves.F | 2 +- .../shared/mpas_ocn_tracer_short_wave_absorption.F | 2 +- .../mpas_ocn_tracer_short_wave_absorption_jerlov.F | 2 +- .../shared/mpas_ocn_tracer_surface_restoring.F | 2 -- src/core_ocean/shared/mpas_ocn_vel_forcing.F | 1 - .../shared/mpas_ocn_vel_forcing_windstress.F | 1 - 8 files changed, 10 insertions(+), 17 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F b/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F index bb898728a3..7c0e6efe60 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F +++ b/src/core_ocean/analysis_members/mpas_ocn_water_mass_census.F @@ -435,20 +435,20 @@ subroutine compute_mask(maxLevelCell, nCells, nCellsSolve, iRegion, lonCell, lat do iCell=1,nCellsSolve if(latCell(iCell).lt. 60.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND enddo - write(6,*) ' Arctic ', sum(workMask) + write(stdoutUnit,*) ' Arctic ', sum(workMask) elseif (iRegion.eq.2) then ! Equatorial do iCell=1,nCellsSolve if(latCell(iCell).gt. 15.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND if(latCell(iCell).lt.-15.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND enddo - write(6,*) ' Equatorial ', sum(workMask) + write(stdoutUnit,*) ' Equatorial ', sum(workMask) elseif (iRegion.eq.3) then ! Southern Ocean do iCell=1,nCellsSolve if(latCell(iCell).gt.-50.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND enddo - write(6,*) ' Southern Ocean ', sum(workMask) + write(stdoutUnit,*) ' Southern Ocean ', sum(workMask) elseif (iRegion.eq.4) then ! Nino 3 do iCell=1,nCellsSolve @@ -457,7 +457,7 @@ subroutine compute_mask(maxLevelCell, nCells, nCellsSolve, iRegion, lonCell, lat if(lonCell(iCell).lt.210.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND if(lonCell(iCell).gt.270.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND enddo - write(6,*) ' Nino 3 ', sum(workMask) + write(stdoutUnit,*) ' Nino 3 ', sum(workMask) elseif (iRegion.eq.5) then ! Nino 4 do iCell=1,nCellsSolve @@ -466,7 +466,7 @@ subroutine compute_mask(maxLevelCell, nCells, nCellsSolve, iRegion, lonCell, lat if(lonCell(iCell).lt.160.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND if(lonCell(iCell).gt.210.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND enddo - write(6,*) ' Nino 4 ', sum(workMask) + write(stdoutUnit,*) ' Nino 4 ', sum(workMask) elseif (iRegion.eq.6) then ! Nino 3.4 do iCell=1,nCellsSolve @@ -475,10 +475,10 @@ subroutine compute_mask(maxLevelCell, nCells, nCellsSolve, iRegion, lonCell, lat if(lonCell(iCell).lt.190.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND if(lonCell(iCell).gt.240.0_RKIND*dtr) workMask(iCell) = 0.0_RKIND enddo - write(6,*) ' Nino 3.4 ', sum(workMask) + write(stdoutUnit,*) ' Nino 3.4 ', sum(workMask) else ! global (do nothing!) - write(6,*) ' Global ', sum(workMask) + write(stdoutUnit,*) ' Global ', sum(workMask) endif end subroutine compute_mask diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F index 8715718637..60db4f35dc 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F @@ -165,9 +165,6 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_max_windstress', config_cvmix_WSwSBF_max_windstress) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_coriolis_parameter', config_cvmix_WSwSBF_coriolis_parameter) - write(6,*) config_cvmix_WSwSBF_surface_temperature, config_cvmix_WSwSBF_surface_salinity, & - config_cvmix_WSwSBF_surface_salinity, config_cvmix_WSwSBF_surface_restoring_salinity - ! load data that required to initialize the ocean simulation block_ptr => domain % blocklist do while(associated(block_ptr)) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F b/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F index 0378149ee9..52a05e8bbf 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_internal_waves.F @@ -362,7 +362,7 @@ subroutine ocn_init_validate_internal_waves(configPool, packagePool, iErr)!{{{ if(config_vert_levels <= 0 .and. config_internal_waves_vert_levels > 0) then config_vert_levels = config_internal_waves_vert_levels else if(config_vert_levels <= 0) then - write(0,*) 'ERROR: Validation failed for internal waves. Not given a usable value for vertical levels.' + write(stderrUnit,*) 'ERROR: Validation failed for internal waves. Not given a usable value for vertical levels.' iErr = 1 end if diff --git a/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption.F b/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption.F index bbb7a1a5cd..5cad45f80c 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption.F @@ -139,7 +139,7 @@ subroutine ocn_tracer_short_wave_absorption_init(err)!{{{ useJerlov = .false. if ( trim( config_sw_absorption_type ) .ne. 'jerlov') then - write(0,*) 'Incorrect option for config_sw_absorption_type. Options are: jerlov' + write(stderrUnit,*) 'Incorrect option for config_sw_absorption_type. Options are: jerlov' err = 1 return else if ( trim( config_sw_absorption_type ) == 'jerlov') then diff --git a/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F b/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F index 4496f78126..0d973cfdef 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F @@ -194,7 +194,7 @@ subroutine ocn_tracer_short_wave_absorption_jerlov_init(err)!{{{ call mpas_pool_get_config(ocnConfigs, 'config_sw_absorption_type', config_sw_absorption_type) if ( trim( config_sw_absorption_type ) .ne. 'jerlov') then - write(0,*) 'Incorrect option for config_sw_absorption_type. Options are: jerlov' + write(stderrUnit,*) 'Incorrect option for config_sw_absorption_type. Options are: jerlov' err = 1 return end if diff --git a/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F b/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F index 56a4be0763..30a78485cc 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F @@ -120,8 +120,6 @@ subroutine ocn_tracer_surface_restoring_compute(nTracers, nCellsSolve, tracers, tracersSurfaceFlux(iTracer, iCell) = tracersSurfaceFlux(iTracer, iCell) - & pistonVelocity(iTracer,iCell) * & (tracers(iTracer, iLevel, iCell) - tracersSurfaceRestoringValue(iTracer,iCell)) - write(6,10) iCell,iTracer,tracersSurfaceFlux(iTracer, iCell), pistonVelocity(iTracer,iCell), tracersSurfaceRestoringValue(iTracer,iCell), tracers(iTracer, iLevel, iCell) - 10 format(5x,2i4,4e12.2) enddo enddo diff --git a/src/core_ocean/shared/mpas_ocn_vel_forcing.F b/src/core_ocean/shared/mpas_ocn_vel_forcing.F index 6b17ca5922..fced50b619 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing.F @@ -128,7 +128,6 @@ subroutine ocn_vel_forcing_tend(meshPool, normalVelocity, surfaceWindStress, lay ! !----------------------------------------------------------------- - write(6,*) ' calling ocn_vel_forcing_windstress_tend' call ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThicknessEdge, tend, err1) call ocn_vel_forcing_rayleigh_tend(meshPool, normalVelocity, tend, err2) diff --git a/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F b/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F index ce5a4f1d69..033bacdc69 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F @@ -129,7 +129,6 @@ subroutine ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThi err = 0 - write(6,*) 'windStressOn',windStressOn if ( .not. windStressOn ) return call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) From f5b08d47ab34a2952eca639298d89f4de30c6414 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Wed, 9 Sep 2015 09:51:59 -0600 Subject: [PATCH 0220/1724] Adding a routine to set the value of sphere_radius This commit adds a recursive subroutine to set the value of sphere_radius correctly in all pools when a spherical mesh is expanded. --- .../mode_init/mpas_ocn_init_spherical_utils.F | 41 +++++++++++++++++++ 1 file changed, 41 insertions(+) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_spherical_utils.F b/src/core_ocean/mode_init/mpas_ocn_init_spherical_utils.F index 6acf1ab44b..4850773a51 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_spherical_utils.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_spherical_utils.F @@ -32,6 +32,7 @@ module ocn_init_spherical_utils public :: ocn_init_expand_sphere, ocn_transform_from_lonlat_to_xyz public :: transform_from_xyz_to_lonlat, ocn_unit_vector_in_3space public :: ocn_vector_on_tangent_plane, ocn_cross_product_in_3space + public :: ocn_init_set_pools_sphere_radius !-------------------------------------------------------------------- ! @@ -143,6 +144,8 @@ subroutine ocn_init_expand_sphere(domain, stream_manager, newRadius, err)!{{{ block_ptr => domain % blocklist do while(associated(block_ptr)) + call ocn_init_set_pools_sphere_radius(block_ptr % structs, newRadius) + ! Expand cell quantities call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) @@ -252,6 +255,44 @@ subroutine ocn_init_expand_sphere(domain, stream_manager, newRadius, err)!{{{ end subroutine ocn_init_expand_sphere!}}} +!*********************************************************************** +! +! recursive routine ocn_init_set_pools_sphere_radius +! +!> \brief MPAS-Ocean Sphere radius update routine +!> \author Doug Jacobsen +!> \date 09/09/2015 +!> \details +!> This routine updates the value of sphere_radius in all pools that contain +!> it. +! +!----------------------------------------------------------------------- + recursive subroutine ocn_init_set_pools_sphere_radius(inPool, newRadius)!{{{ + type (mpas_pool_type), intent(inout) :: inPool + real (kind=RKIND), intent(in) :: newRadius + + type (mpas_pool_type), pointer :: subPool + type (mpas_pool_iterator_type) :: poolItr + real (kind=RKIND), pointer :: sphere_radius + + call mpas_pool_begin_iteration(inPool) + + do while ( mpas_pool_get_next_member(inPool, poolItr) ) + if ( poolItr % memberType == MPAS_POOL_SUBPOOL ) then + call mpas_pool_get_subpool(inPool, poolItr % memberName, subPool) + call ocn_init_set_pools_sphere_radius(subPool, newRadius) + else if ( poolItr % memberType == MPAS_POOL_CONFIG ) then + + if ( poolItr % memberName == 'sphere_radius' ) then + call mpas_pool_get_config(inPool, poolItr % memberName, sphere_radius) + sphere_radius = newRadius + end if + + end if + end do + + end subroutine ocn_init_set_pools_sphere_radius!}}} + !*********************************************************************** ! ! routine ocn_transform_from_lonlat_to_xyz From dceb49929f938c000db2c8b561df5a95eb453bfe Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Tue, 8 Sep 2015 15:28:05 -0600 Subject: [PATCH 0221/1724] Update init templates, standardize piston flag names. --- src/core_ocean/Registry.xml | 8 +- src/core_ocean/driver/mpas_ocn_mpas_core.F | 355 ------------------ .../mode_init/Registry_TEMPLATE.xml | 15 +- .../mode_init/Registry_cvmix_WSwSBF.xml | 4 +- src/core_ocean/mode_init/Registry_iso.xml | 2 +- .../mode_init/mpas_ocn_init_TEMPLATE.F | 253 +++++++++++-- .../mode_init/mpas_ocn_init_cvmix_WSwSBF.F | 12 +- src/core_ocean/mode_init/mpas_ocn_init_iso.F | 6 +- .../tracer_groups/Registry_activeTracers.xml | 2 +- .../tracer_groups/Registry_debugTracers.xml | 2 +- 10 files changed, 252 insertions(+), 407 deletions(-) delete mode 100644 src/core_ocean/driver/mpas_ocn_mpas_core.F diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index d1a327fbc9..688d7aeee9 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -574,11 +574,7 @@ possible_values="Any positive value" /> - - + + @@ -971,7 +968,6 @@ - diff --git a/src/core_ocean/driver/mpas_ocn_mpas_core.F b/src/core_ocean/driver/mpas_ocn_mpas_core.F deleted file mode 100644 index ec5fb9259a..0000000000 --- a/src/core_ocean/driver/mpas_ocn_mpas_core.F +++ /dev/null @@ -1,355 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! mpas_core -! -!> \brief Main driver for MPAS ocean core -!> \author Doug Jacobsen, Mark Petersen, Todd Ringler -!> \date September 2011 -!> \details -!> This module contains initialization and timestep drivers for -!> the MPAS ocean core. -! -!----------------------------------------------------------------------- - -module mpas_core - - use mpas_framework - use mpas_timekeeping - use mpas_dmpar - use mpas_timer - use mpas_io_units - - use ocn_forward_mode - use ocn_analysis_mode - use ocn_init_mode - - contains - -!*********************************************************************** -! -! routine mpas_core_init -! -!> \brief Initialize MPAS-Ocean core -!> \author Doug Jacobsen, Mark Petersen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine calls all initializations required to begin a -!> simulation with MPAS-Ocean -! -!----------------------------------------------------------------------- - - subroutine mpas_core_init(domain, stream_manager, startTimeStamp)!{{{ - - use mpas_grid_types - use mpas_stream_manager - - implicit none - - type (domain_type), intent(inout) :: domain - type (MPAS_streamManager_type), intent(inout) :: stream_manager - character(len=*), intent(out) :: startTimeStamp - - type (dm_info) :: dminfo - - integer :: err - - character (len=StrKIND), pointer :: config_ocean_run_mode - - err = 0 - - dminfo = domain % dminfo - - call mpas_pool_get_config(domain % configs, 'config_ocean_run_mode', config_ocean_run_mode) - - if ( trim(config_ocean_run_mode) == 'forward' ) then - call ocn_forward_mode_init(domain, stream_manager, startTimeStamp) - else if ( trim(config_ocean_run_mode) == 'analysis' ) then - call ocn_analysis_mode_init(domain, stream_manager, startTimeStamp) - else if ( trim(config_ocean_run_mode) == 'init' ) then - call ocn_init_mode_init(domain, stream_manager, startTimeStamp) - end if - - end subroutine mpas_core_init!}}} - -!*********************************************************************** -! -! routine mpas_core_run -! -!> \brief Main driver for MPAS-Ocean time-stepping -!> \author Doug Jacobsen, Mark Petersen, Todd Ringler -!> \date September 2011 -!> \details -!> This routine includes the time-stepping loop, and calls timer -!> routines to write output and restart files. -! -!----------------------------------------------------------------------- - - subroutine mpas_core_run(domain, stream_manager)!{{{ - - use mpas_kind_types - use mpas_grid_types - use mpas_stream_manager - use mpas_timer - - implicit none - - type (domain_type), intent(inout) :: domain - type (MPAS_streamManager_type), intent(inout) :: stream_manager - - character(len=StrKIND), pointer :: config_ocean_run_mode - - call mpas_pool_get_config(domain % configs, 'config_ocean_run_mode', config_ocean_run_mode) - - if ( trim(config_ocean_run_mode) == 'forward' ) then - call ocn_forward_mode_run(domain, stream_manager) - else if ( trim(config_ocean_run_mode) == 'analysis' ) then - call ocn_analysis_mode_run(domain, stream_manager) - else if ( trim(config_ocean_run_mode) == 'init' ) then - call ocn_init_mode_run(domain, stream_manager) - end if - - end subroutine mpas_core_run!}}} - - subroutine mpas_core_finalize(domain, stream_manager)!{{{ - - use mpas_grid_types - use mpas_stream_manager - - implicit none - - type (domain_type), intent(inout) :: domain - type (MPAS_streamManager_type), intent(inout) :: stream_manager - integer :: ierr - - character(len=StrKIND), pointer :: config_ocean_run_mode - - call mpas_pool_get_config(domain % configs, 'config_ocean_run_mode', config_ocean_run_mode) - - if ( trim(config_ocean_run_mode) == 'forward' ) then - call ocn_forward_mode_finalize(domain, stream_manager) - else if (trim(config_ocean_run_mode) == 'analysis' ) then - call ocn_analysis_mode_finalize(domain, stream_manager) - else if (trim(config_ocean_run_mode) == 'init' ) then - call ocn_init_mode_finalize(domain, stream_manager) - end if - - end subroutine mpas_core_finalize!}}} - -!*********************************************************************** -! -! routine mpas_core_setup_packages -! -!> \brief Package setup routine -!> \author Doug Jacobsen -!> \date September 2011 -!> \details -!> This routine is intended to correctly configure the packages for this MPAS -!> core. It can use any Fortran logic to properly configure packages, and it -!> can also make use of any namelist options. All variables in the model are -!> *not* allocated until after this routine is called. -! -!----------------------------------------------------------------------- - subroutine mpas_core_setup_packages(configPool, packagePool, ierr)!{{{ - - use ocn_analysis_driver - - implicit none - - type (mpas_pool_type), intent(in) :: configPool - type (mpas_pool_type), intent(in) :: packagePool - - integer, intent(out) :: ierr - - integer :: err_tmp - - logical, pointer :: forwardModeActive, analysisModeActive, initModeActive - logical, pointer :: thicknessFilterActive - logical, pointer :: splitTimeIntegratorActive - logical, pointer :: bulkForcingActive - logical, pointer :: frazilIceActive - logical, pointer :: inSituEOSActive - - logical, pointer :: config_use_freq_filtered_thickness - logical, pointer :: config_frazil_ice_formation - character (len=StrKIND), pointer :: config_time_integrator, config_forcing_type - character (len=StrKIND), pointer :: config_ocean_run_mode, config_pressure_gradient_type - - ! Get Packages - call mpas_pool_get_package(packagePool, 'forwardModeActive', forwardModeActive) - call mpas_pool_get_package(packagePool, 'analysisModeActive', analysisModeActive) - call mpas_pool_get_package(packagePool, 'initModeActive', initModeActive) - call mpas_pool_get_package(packagePool, 'thicknessFilterActive', thicknessFilterActive) - call mpas_pool_get_package(packagePool, 'splitTimeIntegratorActive', splitTimeIntegratorActive) - call mpas_pool_get_package(packagePool, 'bulkForcingActive', bulkForcingActive) - call mpas_pool_get_package(packagePool, 'frazilIceActive', frazilIceActive) - call mpas_pool_get_package(packagePool, 'inSituEOSActive', inSituEOSActive) - - call mpas_pool_get_config(configPool, 'config_ocean_run_mode', config_ocean_run_mode) - - ierr = 0 - - if ( trim(config_ocean_run_mode) == 'forward' ) then - forwardModeActive = .true. - - call mpas_pool_get_config(configPool, 'config_use_freq_filtered_thickness', config_use_freq_filtered_thickness) - call mpas_pool_get_config(configPool, 'config_time_integrator', config_time_integrator) - call mpas_pool_get_config(configPool, 'config_forcing_type', config_forcing_type) - call mpas_pool_get_config(configPool, 'config_frazil_ice_formation', config_frazil_ice_formation) - call mpas_pool_get_config(configPool, 'config_pressure_gradient_type', config_pressure_gradient_type) - - if (config_use_freq_filtered_thickness) then - thicknessFilterActive = .true. - end if - - if (config_time_integrator == trim('split_explicit') & - .or. config_time_integrator == trim('unsplit_explicit') ) then - - splitTimeIntegratorActive = .true. - end if - - if (config_frazil_ice_formation) then - frazilIceActive = .true. - end if - - if (config_pressure_gradient_type.eq.'Jacobian_from_TS') then - inSituEOSActive = .true. - end if - - call ocn_analysis_setup_packages(configPool, packagePool, err_tmp) - ierr = ior(ierr, err_tmp) - else if (trim(config_ocean_run_mode) == 'analysis' ) then - analysisModeActive = .true. - call ocn_analysis_setup_packages(configPool, packagePool, ierr) - else if (trim(config_ocean_run_mode) == 'init' ) then - initModeActive = .true. - call ocn_init_validate_configuration(configPool, packagePool, ierr) - end if - - end subroutine mpas_core_setup_packages!}}} - -!*********************************************************************** -! -! routine mpas_core_setup_clock -! -!> \brief Pacakge setup routine -!> \author Michael Duda -!> \date 6 August 2014 -!> \details -!> The purpose of this routine is to allow the core to set up a simulation -!> clock that will be used by the I/O subsystem for timing reads and writes -!> of I/O streams. -!> This routine is called from the superstructure after the framework -!> has been initialized but before any fields have been allocated and -!> initial fields have been read from input files. However, all namelist -!> options are available. -! -!----------------------------------------------------------------------- - subroutine mpas_core_setup_clock(core_clock, configs, ierr)!{{{ - - implicit none - - type (MPAS_Clock_type), intent(inout) :: core_clock - type (mpas_pool_type), intent(inout) :: configs - integer, intent(out) :: ierr - - character(len=StrKIND), pointer :: config_ocean_run_mode - - call mpas_pool_get_config(configs, 'config_ocean_run_mode', config_ocean_run_mode) - - if ( trim(config_ocean_run_mode) == 'forward' ) then - call ocn_forward_mode_simulation_clock_init(core_clock, configs, ierr) - else if ( trim(config_ocean_run_mode) == 'analysis' ) then - call ocn_analysis_mode_simulation_clock_init(core_clock, configs, ierr) - else if ( trim(config_ocean_run_mode) == 'init' ) then - call ocn_init_mode_simulation_clock_init(core_clock, configs, ierr) - end if - - end subroutine mpas_core_setup_clock!}}} - -!*********************************************************************** -! -! routine mpas_core_get_mesh_stream -! -!> \brief Returns the name of the stream containing mesh information -!> \author Michael Duda -!> \date 8 August 2014 -!> \details -!> This routine returns the name of the I/O stream containing dimensions, -!> attributes, and mesh fields needed by the framework bootstrapping -!> routine. At the time this routine is called, only namelist options -!> are available. -! -!----------------------------------------------------------------------- - subroutine mpas_core_get_mesh_stream(configs, stream, ierr)!{{{ - - implicit none - - type (mpas_pool_type), intent(in) :: configs - character(len=*), intent(out) :: stream - integer, intent(out) :: ierr - - logical, pointer :: config_do_restart - character(len=StrKIND), pointer :: config_ocean_run_mode - - ierr = 0 - - call mpas_pool_get_config(configs, 'config_ocean_run_mode', config_ocean_run_mode) - - if ( trim(config_ocean_run_mode) == 'forward' .or. trim(config_ocean_run_mode) == 'analysis' ) then - call mpas_pool_get_config(configs, 'config_do_restart', config_do_restart) - - if (.not. associated(config_do_restart)) then - ierr = 1 - else if (config_do_restart) then - write(stream,'(a)') 'restart' - else - write(stream,'(a)') 'input' - end if - else if ( trim(config_ocean_run_mode) == 'init' ) then - write(stream, '(a)') 'input_init' - end if - - end subroutine mpas_core_get_mesh_stream!}}} - - - !*********************************************************************** - ! - ! routine mpas_core_setup_decompositions - ! - !> \brief Decomposition setup routine - !> \author Doug Jacobsen - !> \date September 2011 - !> \details - !> This routine is intended to create the decomposition list within a - !> domain type, and register any decompositons the core wants within it. - ! - !----------------------------------------------------------------------- - subroutine mpas_core_setup_decompositions(ierr)!{{{ - - use mpas_decomp - - implicit none - - integer, intent(out) :: ierr - procedure (mpas_decomp_function), pointer :: decompFunc - - ierr = 0 - - call mpas_decomp_create_decomp_list(decompositions) - - decompFunc => mpas_uniform_decomp - - call mpas_decomp_register_method(decompositions, 'uniform', decompFunc, iErr) - - end subroutine mpas_core_setup_decompositions!}}} - -end module mpas_core - -! vim: foldmethod=marker diff --git a/src/core_ocean/mode_init/Registry_TEMPLATE.xml b/src/core_ocean/mode_init/Registry_TEMPLATE.xml index 99796e5810..d8e52ad626 100644 --- a/src/core_ocean/mode_init/Registry_TEMPLATE.xml +++ b/src/core_ocean/mode_init/Registry_TEMPLATE.xml @@ -1,5 +1,14 @@ - diff --git a/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml b/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml index 0394924aab..911371d6ab 100644 --- a/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml +++ b/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml @@ -19,11 +19,11 @@ description="Salinity to restore towards when surface restoring is turned on." possible_values="Any real number" /> - - diff --git a/src/core_ocean/mode_init/Registry_iso.xml b/src/core_ocean/mode_init/Registry_iso.xml index 07d97485aa..3a29fa9c8e 100644 --- a/src/core_ocean/mode_init/Registry_iso.xml +++ b/src/core_ocean/mode_init/Registry_iso.xml @@ -219,7 +219,7 @@ description="Radius of heat flux localized region 2." possible_values="Any real number." /> - diff --git a/src/core_ocean/mode_init/mpas_ocn_init_TEMPLATE.F b/src/core_ocean/mode_init/mpas_ocn_init_TEMPLATE.F index 72152cb17e..20fc033e95 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_TEMPLATE.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_TEMPLATE.F @@ -10,11 +10,31 @@ ! ocn_init_TEMPLATE ! !> \brief MPAS ocean initialize case -- TEMPLATE -!> \author Doug Jacobsen -!> \date 03/23/2015 +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE !> \details !> This module contains the routines for initializing the -!> the TEMPLATE test case +!> TEMPLATE initial condition +!> +!> In order to add a new analysis member, do the following: +!> 1. In src/core_ocean/mode_init, copy these to your new analysis member name: +!> cp mpas_ocn_init_TEMPLATE.F mpas_ocn_init_your_new_name.F +!> cp Registry_TEMPLATE.xml Registry_ocn_your_new_name.xml +!> +!> 2. In those two new files, replace the following text: +!> TEMPLATE, FILL_IN_AUTHOR, FILL_IN_DATE +!> TEMPLATE uses underscores (subroutine names), like your_new_name. +!> +!> 3. Add a #include line for your registry to +!> src/core_ocean/mode_init/Registry.xml +!> +!> 4. Copy and change TEMPLATE lines in src/core_ocean/mode_init/mpas_ocn_init_mode.F +!> +!> 5. Add these lines for default namelist parsing: +!> in src/core_ocean/Makefile: +!> (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.TEMPLATE mode=init configuration=TEMPLATE) +!> in src/core_ocean/Registry.xml +!> TEMPLATE_value="TEMPLATE" ! !----------------------------------------------------------------------- @@ -63,60 +83,235 @@ module ocn_init_TEMPLATE ! ! routine ocn_init_setup_TEMPLATE ! -!> \brief Setup for baroclinic channel test case -!> \author Doug Jacobsen -!> \date 03/23/2015 +!> \brief Setup for this initial condition +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE !> \details -!> This routine sets up the initial conditions for the baroclinic channel test case. +!> This routine sets up the initial conditions for this case. ! !----------------------------------------------------------------------- - subroutine ocn_init_setup_TEMPLATE(domain, err)!{{{ + subroutine ocn_init_setup_TEMPLATE(domain, iErr)!{{{ - !-------------------------------------------------------------------- + !-------------------------------------------------------------------- - type (domain_type), intent(inout) :: domain - integer, intent(out) :: err + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr - err = 0 + type (block_type), pointer :: block_ptr + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tracersPool + type (mpas_pool_type), pointer :: verticalMeshPool - call mpas_pool_get_config(ocnConfigs, 'config_configuration', config_configuration) + ! local variables + integer :: iCell, k, idx + real (kind=RKIND) :: yMin, yMax, xMin, xMax, dcEdgeMin, dcEdgeMinGlobal + real (kind=RKIND) :: yMinGlobal, yMaxGlobal, yMidGlobal, xMinGlobal, xMaxGlobal + real (kind=RKIND) :: localVar1, localVar2 + real (kind=RKIND), dimension(:), pointer :: interfaceLocations - if(config_configuration .ne. trim('TEMPLATE')) return + ! Define config variable pointers + character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid + logical, pointer :: config_TEMPLATE_example_flag1 + real (kind=RKIND), pointer :: config_TEMPLATE_example_flag2 - ! Setup configuration + ! Define dimension pointers + integer, pointer :: nCellsSolve, nEdgesSolve, nVertLevels, nVertLevelsP1 + integer, pointer :: index_temperature, index_salinity - !-------------------------------------------------------------------- + ! Define variable pointers + logical, pointer :: on_a_sphere + integer, dimension(:), pointer :: maxLevelCell + real (kind=RKIND), dimension(:), pointer :: xCell, yCell,refBottomDepth, refZMid, & + vertCoordMovementWeights, bottomDepth, & + fCell, fEdge, fVertex, dcEdge + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers + + iErr = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('TEMPLATE')) return + + ! Get config flag settings + + call mpas_pool_get_config(ocnConfigs, 'config_vertical_grid', config_vertical_grid) + + call mpas_pool_get_config(ocnConfigs, 'config_TEMPLATE_example_flag1', config_TEMPLATE_example_flag1) + call mpas_pool_get_config(ocnConfigs, 'config_TEMPLATE_example_flag2', config_TEMPLATE_example_flag2) + + ! Determine vertical grid for configuration + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nVertLevelsP1', nVertLevelsP1) + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + + ! you may restrict your case geometry as follows: + ! if ( on_a_sphere ) call mpas_dmpar_global_abort('IERROR: The TEMPLATE configuration can only be applied to a planar mesh. Exiting...') + + allocate(interfaceLocations(nVertLevelsP1)) + call ocn_generate_vertical_grid( config_vertical_grid, interfaceLocations ) + + !-------------------------------------------------------------------- + ! Use this section to make boundaries non-periodic + !-------------------------------------------------------------------- + + ! Initalize min/max values to large positive and negative values + yMin = 1.0E10_RKIND + yMax = -1.0E10_RKIND + xMin = 1.0E10_RKIND + xMax = -1.0E10_RKIND + dcEdgeMin = 1.0E10_RKIND + + ! Determine local min and max values. + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + + yMin = min( yMin, minval(yCell(1:nCellsSolve))) + yMax = max( yMax, maxval(yCell(1:nCellsSolve))) + xMin = min( xMin, minval(xCell(1:nCellsSolve))) + xMax = max( xMax, maxval(xCell(1:nCellsSolve))) + dcEdgeMin = min( dcEdgeMin, minval(dcEdge(1:nEdgesSolve))) + + block_ptr => block_ptr % next + end do + + ! Determine global min and max values. + call mpas_dmpar_min_real(domain % dminfo, yMin, yMinGlobal) + call mpas_dmpar_max_real(domain % dminfo, yMax, yMaxGlobal) + call mpas_dmpar_min_real(domain % dminfo, xMin, xMinGlobal) + call mpas_dmpar_max_real(domain % dminfo, xMax, xMaxGlobal) + call mpas_dmpar_min_real(domain % dminfo, dcEdgeMin, dcEdgeMinGlobal) + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call ocn_mark_north_boundary(meshPool, yMaxGlobal, dcEdgeMinGlobal, iErr) + call ocn_mark_south_boundary(meshPool, yMinGlobal, dcEdgeMinGlobal, iErr) + + block_ptr => block_ptr % next + end do + + !-------------------------------------------------------------------- + ! Use this section to set initial values + !-------------------------------------------------------------------- + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_salinity) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'fCell', fCell) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + call mpas_pool_get_array(meshPool, 'fVertex', fVertex) + + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + call mpas_pool_get_array(tracersPool, 'layerThickness', layerThickness, 1) + + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + + ! ! Set refBottomDepth and refZMid + do k = 1, nVertLevels + refBottomDepth(k) = config_TEMPLATE_bottom_depth * interfaceLocations(k+1) + refZMid(k) = - 0.5_RKIND * (interfaceLocations(k+1) + interfaceLocations(k)) * config_TEMPLATE_bottom_depth + end do + + ! Set vertCoordMovementWeights + vertCoordMovementWeights(:) = 1.0_RKIND + + do iCell = 1, nCellsSolve + + ! Set temperature + idx = index_temperature + do k = 1, nVertLevels + ! activeTracers(idx, k, iCell) = + end do + + ! Set salinity + idx = index_salinity + do k = 1, nVertLevels + ! activeTracers(idx, k, iCell) = + end do + + ! Set layerThickness and restingThickness + do k = 1, nVertLevels + ! layerThickness(k, iCell) = + ! restingThickness(k, iCell) = + end do + + ! Set bottomDepth + ! bottomDepth(iCell) = + + ! Set maxLevelCell + ! maxLevelCell(iCell) = + + ! Set Coriolis parameters, if other than zero + fCell(iCell) = config_TEMPLATE_coriolis_parameter + fEdge(iCell) = config_TEMPLATE_coriolis_parameter + fVertex(iCell) = config_TEMPLATE_coriolis_parameter + + end do + + block_ptr => block_ptr % next + end do + + !-------------------------------------------------------------------- - end subroutine ocn_init_setup_TEMPLATE!}}} + end subroutine ocn_init_setup_TEMPLATE!}}} !*********************************************************************** ! ! routine ocn_init_validate_TEMPLATE ! -!> \brief Validation for baroclinic channel test case -!> \author Doug Jacobsen -!> \date 03/23/2015 +!> \brief Validation for this initial condition +!> \author FILL_IN_AUTHOR +!> \date FILL_IN_DATE !> \details -!> This routine validates the configuration options for the baroclinic channel test case. +!> This routine validates the configuration options for this case. ! !----------------------------------------------------------------------- - subroutine ocn_init_validate_TEMPLATE(configPool, packagePool, err)!{{{ + subroutine ocn_init_validate_TEMPLATE(configPool, packagePool, iErr)!{{{ !-------------------------------------------------------------------- type (mpas_pool_type), intent(in) :: configPool, packagePool - integer, intent(out) :: err + integer, intent(out) :: iErr - character (len=StrKIND), pointer :: config_configuration + character (len=StrKIND), pointer :: config_init_configuration integer, pointer :: config_vert_levels, config_TEMPLATE_vert_levels - err = 0 + iErr = 0 - call mpas_pool_get_config(configPool, 'config_configuration', config_configuration) + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) - if(config_configuration .ne. trim('TEMPLATE')) return + if(config_init_configuration .ne. trim('TEMPLATE')) return call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) call mpas_pool_get_config(configPool, 'config_TEMPLATE_vert_levels', config_TEMPLATE_vert_levels) @@ -124,8 +319,8 @@ subroutine ocn_init_validate_TEMPLATE(configPool, packagePool, err)!{{{ if(config_vert_levels <= 0 .and. config_TEMPLATE_vert_levels > 0) then config_vert_levels = config_TEMPLATE_vert_levels else if (config_vert_levels <= 0) then - write(stderrUnit,*) 'ERROR: Validation failed for TEMPLATE. Not given a usable value for vertical levels.' - err = 1 + write(stderrUnit,*) 'IERROR: Validation failed for TEMPLATE. Not given a usable value for vertical levels.' + iErr = 1 end if !-------------------------------------------------------------------- diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F index 60db4f35dc..5f6029de47 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F @@ -117,8 +117,8 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ config_cvmix_WSwSBF_surface_salinity, & config_cvmix_WSwSBF_surface_restoring_temperature, & config_cvmix_WSwSBF_surface_restoring_salinity, & - config_cvmix_WSwSBF_surface_temperature_piston_velocity, & - config_cvmix_WSwSBF_surface_salinity_piston_velocity, & + config_cvmix_WSwSBF_temperature_piston_velocity, & + config_cvmix_WSwSBF_salinity_piston_velocity, & config_cvmix_WSwSBF_sensible_heat_flux, & config_cvmix_WSwSBF_latent_heat_flux, & config_cvmix_WSwSBF_shortwave_heat_flux, & @@ -150,8 +150,8 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_salinity', config_cvmix_WSwSBF_surface_salinity) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_restoring_temperature', config_cvmix_WSwSBF_surface_restoring_temperature) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_restoring_salinity', config_cvmix_WSwSBF_surface_restoring_salinity) - call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_temperature_piston_velocity', config_cvmix_WSwSBF_surface_temperature_piston_velocity) - call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_surface_salinity_piston_velocity', config_cvmix_WSwSBF_surface_salinity_piston_velocity) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_temperature_piston_velocity', config_cvmix_WSwSBF_temperature_piston_velocity) + call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_salinity_piston_velocity', config_cvmix_WSwSBF_salinity_piston_velocity) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_sensible_heat_flux', config_cvmix_WSwSBF_sensible_heat_flux) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_latent_heat_flux', config_cvmix_WSwSBF_latent_heat_flux) call mpas_pool_get_config(domain % configs, 'config_cvmix_WSwSBF_shortwave_heat_flux', config_cvmix_WSwSBF_shortwave_heat_flux) @@ -252,7 +252,7 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ activeTracersSurfaceRestoringValue(index_temperature, iCell) = config_cvmix_WSwSBF_surface_restoring_temperature end if if ( associated(activeTracersPistonVelocity) ) then - activeTracersPistonVelocity(index_temperature, iCell) = config_cvmix_WSwSBF_surface_temperature_piston_velocity + activeTracersPistonVelocity(index_temperature, iCell) = config_cvmix_WSwSBF_temperature_piston_velocity end if ! Set surface salinity restoring value and rate @@ -261,7 +261,7 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ activeTracersSurfaceRestoringValue(index_salinity, iCell) = config_cvmix_WSwSBF_surface_restoring_salinity end if if ( associated(activeTracersPistonVelocity) ) then - activeTracersPistonVelocity(index_salinity, iCell) = config_cvmix_WSwSBF_surface_salinity_piston_velocity + activeTracersPistonVelocity(index_salinity, iCell) = config_cvmix_WSwSBF_salinity_piston_velocity end if ! Set sensible heat flux diff --git a/src/core_ocean/mode_init/mpas_ocn_init_iso.F b/src/core_ocean/mode_init/mpas_ocn_init_iso.F index 0e3ae31d78..56333fa5d8 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_iso.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_iso.F @@ -143,7 +143,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ real (kind=RKIND), pointer :: config_iso_heat_flux_lat_ss real (kind=RKIND), pointer :: config_iso_heat_flux_lat_sm real (kind=RKIND), pointer :: config_iso_heat_flux_lat_mn - real (kind=RKIND), pointer :: config_iso_surface_temp_piston_vel + real (kind=RKIND), pointer :: config_iso_surface_temperature_piston_velocity real (kind=RKIND), pointer :: config_iso_initial_temp_t1 real (kind=RKIND), pointer :: config_iso_initial_temp_t2 real (kind=RKIND), pointer :: config_iso_initial_temp_h0 @@ -288,7 +288,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_lat_ss', config_iso_heat_flux_lat_ss) call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_lat_sm', config_iso_heat_flux_lat_sm) call mpas_pool_get_config(domain % configs, 'config_iso_heat_flux_lat_mn', config_iso_heat_flux_lat_mn) - call mpas_pool_get_config(domain % configs, 'config_iso_surface_temp_piston_vel', config_iso_surface_temp_piston_vel) + call mpas_pool_get_config(domain % configs, 'config_iso_surface_temperature_piston_velocity', config_iso_surface_temperature_piston_velocity) call mpas_pool_get_config(domain % configs, 'config_iso_initial_temp_t1', config_iso_initial_temp_t1) call mpas_pool_get_config(domain % configs, 'config_iso_initial_temp_t2', config_iso_initial_temp_t2) call mpas_pool_get_config(domain % configs, 'config_iso_initial_temp_h0', config_iso_initial_temp_h0) @@ -394,7 +394,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ transSS = config_iso_heat_flux_lat_ss * pii/180.0 transSM = config_iso_heat_flux_lat_sm * pii/180.0 transMN = config_iso_heat_flux_lat_mn * pii/180.0 - tempPistonVel = config_iso_surface_temp_piston_vel + tempPistonVel = config_iso_surface_temperature_piston_velocity tempT1 = config_iso_initial_temp_t1 tempT2 = config_iso_initial_temp_t2 temph0 = config_iso_initial_temp_h0 diff --git a/src/core_ocean/tracer_groups/Registry_activeTracers.xml b/src/core_ocean/tracer_groups/Registry_activeTracers.xml index 4cec42428b..e09559cac4 100644 --- a/src/core_ocean/tracer_groups/Registry_activeTracers.xml +++ b/src/core_ocean/tracer_groups/Registry_activeTracers.xml @@ -1,4 +1,4 @@ - + + Date: Fri, 28 Aug 2015 16:54:42 -0600 Subject: [PATCH 0222/1724] initial work on add a global stats analysis member to LI core --- src/core_landice/analysis_members/Makefile | 2 +- .../Registry_analysis_members.xml | 2 +- .../Registry_global_stats.xml | 64 +++ .../analysis_members/mpas_li_global_stats.F | 395 ++++++++++++++++++ 4 files changed, 461 insertions(+), 2 deletions(-) create mode 100644 src/core_landice/analysis_members/Registry_global_stats.xml create mode 100644 src/core_landice/analysis_members/mpas_li_global_stats.F diff --git a/src/core_landice/analysis_members/Makefile b/src/core_landice/analysis_members/Makefile index 4f76b4638f..2c84ec3f99 100644 --- a/src/core_landice/analysis_members/Makefile +++ b/src/core_landice/analysis_members/Makefile @@ -2,7 +2,7 @@ OBJS = mpas_li_analysis_driver.o -MEMBERS = +MEMBERS = mpas_li_global_stats.o all: $(OBJS) diff --git a/src/core_landice/analysis_members/Registry_analysis_members.xml b/src/core_landice/analysis_members/Registry_analysis_members.xml index ff45f26355..49f051d7ac 100644 --- a/src/core_landice/analysis_members/Registry_analysis_members.xml +++ b/src/core_landice/analysis_members/Registry_analysis_members.xml @@ -1 +1 @@ -//#include "Registry_TEMPLATE.xml" +//#include "Registry_global_stats.xml" diff --git a/src/core_landice/analysis_members/Registry_global_stats.xml b/src/core_landice/analysis_members/Registry_global_stats.xml new file mode 100644 index 0000000000..c8acbe19fd --- /dev/null +++ b/src/core_landice/analysis_members/Registry_global_stats.xml @@ -0,0 +1,64 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_landice/analysis_members/mpas_li_global_stats.F b/src/core_landice/analysis_members/mpas_li_global_stats.F new file mode 100644 index 0000000000..3814471924 --- /dev/null +++ b/src/core_landice/analysis_members/mpas_li_global_stats.F @@ -0,0 +1,395 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! mpas_li_global_stats +! +!> \brief MPAS land ice analysis mode member: mpas_li_global_stats +!> \author Stephen Price +!> \date 8-30-2015 +!> \details +!> +!> +!----------------------------------------------------------------------- +module li_global_stats + + use mpas_derived_types + use mpas_pool_routines + use mpas_dmpar + use mpas_timekeeping + use mpas_stream_manager + + use li_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: li_init_global_stats, & + li_compute_global_stats, & + li_restart_global_stats, & + li_finalize_global_stats + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine li_init_global_stats +! +!> \brief Initialize MPAS-Land Ice analysis member +!> \author S. Price +!> \date 9/9/2015 +!> \details +!> This routine conducts all initializations required for the +!> MPAS-Land Ice analysis member. +! +!----------------------------------------------------------------------- + + subroutine li_init_global_stats(domain, memberName, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + character (len=*), intent(in) :: memberName + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine li_init_global_stats!}}} + +!*********************************************************************** +! +! routine li_compute_global_stats +! +!> \brief Compute MPAS-Land Ice analysis member +!> \author S. Price +!> \date 9/9/2015 +!> \details +!> This routine conducts all computation required for this +!> MPAS-Land Ice analysis member. +! +!----------------------------------------------------------------------- + + subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + integer, intent(in) :: timeLevel + character (len=*), intent(in) :: memberName + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: globalStatsAMPool + type (dm_info) :: dminfo + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: scratchPool + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: globalStatsAM + + type (mpas_pool_type), pointer :: geometryPool + + ! Here are some example variables which may be needed for your analysis member +! integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, num_tracers + integer, pointer :: nCellsSolve +! integer :: iTracer, k, iCell + integer :: k, iCell +! integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop, maxLevelVertexBot + +! real (kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge + real (kind=RKIND), dimension(:), pointer :: areaCell + + real (kind=RKIND), dimension(:), pointer :: thickness + integer, dimension(:), pointer :: cellMask + + ! simple 1 or 0 masks to be used here for calc. global sums over floating or grounded ice + integer, dimension(:), pointer :: iceMask + integer, dimension(:), pointer :: groundedMask + integer, dimension(:), pointer :: floatingMask + + ! scalars to be calculated here from global sums + real (kind=RKIND), pointer :: totalIceArea + real (kind=RKIND), pointer :: totalIceVolume + real (kind=RKIND), pointer :: groundedIceArea + real (kind=RKIND), pointer :: groundedIceVolume + real (kind=RKIND), pointer :: floatingIceArea + real (kind=RKIND), pointer :: floatingIceVolume + + err = 0 + + dminfo = domain % dminfo + + ! initialize scalar global sums and work masks to zero + totalIceArea = 0.0_RKIND + totalIceVolume = 0.0_RKIND + groundedIceArea = 0.0_RKIND + groundedIceVolume = 0.0_RKIND + floatingIceArea = 0.0_RKIND + floatingIceVolume = 0.0_RKIND + iceMask = 0 + groundedMask = 0 + floatingMask = 0 + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'globalStatsAM', globalStatsAMPool) + + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + + ! Here are some example variables which may be needed for your analysis member +! call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) + +! call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) +! call mpas_pool_get_dimension(block % dimensions, 'nEdgesSolve', nEdgesSolve) +! call mpas_pool_get_dimension(block % dimensions, 'nVerticesSolve', nVerticesSolve) + + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) +! call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) +! call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) +! call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) +! call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) +! call mpas_pool_get_array(meshPool, 'maxLevelVertexBot', maxLevelVertexBot) + + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + + call mpas_pool_get_array(globalStatsAMPool, 'totalIceArea', totalIceArea) + call mpas_pool_get_array(globalStatsAMPool, 'totalIceVolume', totalIceVolume) + call mpas_pool_get_array(globalStatsAMPool, 'floatingIceArea', floatingIceArea) + call mpas_pool_get_array(globalStatsAMPool, 'floatingIceVolume', floatingIceVolume) + call mpas_pool_get_array(globalStatsAMPool, 'groundedIceArea', groundedIceArea) + call mpas_pool_get_array(globalStatsAMPool, 'groundedIceVolume', groundedIceVolume) + + ! populate work masks (1 and 0 based for multiplication of area and thickness fields) + where( cellMask == 32 ); iceMask = 1; endwhere + where( cellMask == 4 ); floatingMask = 1; endwhere + groundedMask = iceMask - floatingMask + + ! Computations which are functions of nCells, nEdges, or nVertices + ! must be placed within this block loop + ! Here are some example loops + do iCell = 1,nCellsSolve + +! do k = 1, maxLevelCell(iCell) +! do iTracer = 1, num_tracers + ! computations on tracers(iTracer,k, iCell) +! end do +! end do + + ! calculate total ice area and volume + totalIceArea = totalIceArea + real( iceMask(iCell), RKIND) * areaCell(iCell) + totalIceVolume = totalIceVolume + real( iceMask(iCell), RKIND) * areaCell(iCell) * thickness(iCell) + + ! calculate grounded ice area and volume + groundedIceArea = groundedIceArea + real( groundedMask(iCell), RKIND) * areaCell(iCell) + groundedIceVolume = groundedIceVolume + real( groundedMask(iCell), RKIND) * areaCell(iCell) * thickness(iCell) + + ! calculate floating ice area and volume + floatingIceArea = floatingIceArea + real( floatingMask(iCell), RKIND) * areaCell(iCell) + floatingIceVolume = floatingIceVolume + real( floatingMask(iCell), RKIND) * areaCell(iCell) * thickness(iCell) + + end do + + block => block % next + end do + + ! mpi gather/scatter calls may be placed here. + ! Here are some examples. See mpas_oac_global_stats.F for further details. +! call mpas_dmpar_sum_real_array(dminfo, nVariables, sumSquares(1:nVariables), reductions(1:nVariables)) +! call mpas_dmpar_min_real_array(dminfo, nMins, mins(1:nMins), reductions(1:nMins)) +! call mpas_dmpar_max_real_array(dminfo, nMaxes, maxes(1:nMaxes), reductions(1:nMaxes)) + + ! Even though some variables do not include an index that is decomposed amongst + ! domain partitions, we assign them within a block loop so that all blocks have the + ! correct values for writing output. + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'globalStatsAM', globalStatsAMPool) + + ! assignment of final globalStatsAM variables could occur here. + + block => block % next + end do + + end subroutine li_compute_global_stats!}}} + +!*********************************************************************** +! +! routine li_restart_global_stats +! +!> \brief Save restart for MPAS-Land Ice analysis member +!> \author S. Price +!> \date 9/9/2015 +!> \details +!> This routine conducts computation required to save a restart state +!> for the MPAS-Land Ice analysis member. +! +!----------------------------------------------------------------------- + + subroutine li_restart_global_stats(domain, memberName, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + character (len=*), intent(in) :: memberName + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine li_restart_global_stats!}}} + +!*********************************************************************** +! +! routine li_finalize_global_stats +! +!> \brief Finalize MPAS-Land Ice analysis member +!> \author S. Price +!> \date 9/9/2015 +!> \details +!> This routine conducts all finalizations required for this +!> MPAS-Land Ice analysis member. +! +!----------------------------------------------------------------------- + + subroutine li_finalize_global_stats(domain, memberName, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + character (len=*), intent(in) :: memberName + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + end subroutine li_finalize_global_stats!}}} + +end module li_global_stats + +! vim: foldmethod=marker From a8d7af0c8301bf0238a7d983bd9db122dd68963f Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Thu, 10 Sep 2015 08:24:24 -0600 Subject: [PATCH 0223/1724] Update forcing_data streams Add a forcing_data stream for init mode. Add surface restoring variables to forcing_data for forward mode. --- src/core_ocean/Registry.xml | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 688d7aeee9..6424740e43 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -958,7 +958,6 @@ - @@ -972,6 +971,7 @@ + - + + + + + + + + + Date: Thu, 10 Sep 2015 11:55:45 -0600 Subject: [PATCH 0224/1724] revert to init. version of analysis driver and update it to call (in devel.) global stats. member --- .../mpas_li_analysis_driver.F | 54 +++++++++---------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/src/core_landice/analysis_members/mpas_li_analysis_driver.F b/src/core_landice/analysis_members/mpas_li_analysis_driver.F index 67ece45fc2..3615bdf81b 100644 --- a/src/core_landice/analysis_members/mpas_li_analysis_driver.F +++ b/src/core_landice/analysis_members/mpas_li_analysis_driver.F @@ -10,8 +10,8 @@ ! li_analysis_driver ! !> \brief Driver for MPAS Land Ice analysis members -!> \author MPAS-LI Team -!> \date November 2013 +!> \author S. Price +!> \date 9/10/2015 !> \details !> This is the driver for the MPAS Land Ice members. ! @@ -26,7 +26,7 @@ module li_analysis_driver use mpas_stream_manager use li_constants -! use li_TEM_PLATE + use li_global_stats implicit none private @@ -77,8 +77,8 @@ module li_analysis_driver ! routine li_analysis_setup_packages ! !> \brief Setup packages for MPAS-Land Ice analysis driver -!> \author MPAS-LI Team -!> \date November 2013 +!> \author S. Price +!> \date 9/10/2015 !> \details !> This routine is intended to configure the packages for all !> Land Ice analysis members. @@ -127,7 +127,7 @@ subroutine li_analysis_setup_packages(configPool, packagePool, err)!{{{ err = 0 call mpas_pool_create_pool(analysisMemberList) -! call mpas_pool_add_config(analysisMemberList, 'temPlate', 1) + call mpas_pool_add_config(analysisMemberList, 'globalStats', 1) ! DON'T EDIT BELOW HERE @@ -152,8 +152,8 @@ end subroutine li_analysis_setup_packages!}}} ! routine li_analysis_init ! !> \brief Initialize MPAS-Land Ice analysis driver -!> \author MPAS-LI Team -!> \date November 2013 +!> \author S. Price +!> \date 9/10/2015 !> \details !> This routine calls all initializations required for the !> MPAS-Land Ice analysis driver. @@ -268,8 +268,8 @@ end subroutine li_analysis_init!}}} ! routine li_analysis_compute_startup ! !> \brief Driver for MPAS-Land Ice analysis computations -!> \author MPAS-LI Team -!> \date November 2013 +!> \author S. Price +!> \date 9/10/2015 !> \details !> This routine calls all computation subroutines required for the !> MPAS-Land Ice analysis driver. @@ -364,8 +364,8 @@ end subroutine li_analysis_compute_startup!}}} ! routine li_analysis_compute ! !> \brief Driver for MPAS-Land Ice analysis computations -!> \author MPAS-LI Team -!> \date November 2013 +!> \author S. Price +!> \date 9/10/2015 !> \details !> This routine calls all computation subroutines required for the !> MPAS-Land Ice analysis driver. @@ -457,8 +457,8 @@ end subroutine li_analysis_compute!}}} ! routine li_analysis_restart ! !> \brief Save restart for MPAS-Land Ice analysis driver -!> \author MPAS-LI Team -!> \date November 2013 +!> \author S. Price +!> \date 9/10/2015 !> \details !> This routine calls all subroutines required to prepare to save !> the restart state for the MPAS-Land Ice analysis driver. @@ -530,8 +530,8 @@ end subroutine li_analysis_restart!}}} ! routine li_analysis_write ! !> \brief Driver for MPAS-Land Ice analysis output -!> \author MPAS-LI Team -!> \date November 2013 +!> \author S. Price +!> \date 9/10/2015 !> \details !> This routine calls all output writing subroutines required for the !> MPAS-Land Ice analysis driver. @@ -548,7 +548,7 @@ subroutine li_analysis_write(domain, err)!{{{ ! !----------------------------------------------------------------- - type (domain_type), intent(in) :: domain + type (domain_type), intent(inout) :: domain !----------------------------------------------------------------- ! @@ -613,8 +613,8 @@ end subroutine li_analysis_write!}}} ! routine li_analysis_finalize ! !> \brief Finalize MPAS-Land Ice analysis driver -!> \author MPAS-LI Team -!> \date November 2013 +!> \author S. Price +!> \date 9/10/2015 !> \details !> This routine calls all finalize routines required for the !> MPAS-Land Ice analysis driver. @@ -704,8 +704,8 @@ subroutine li_init_analysis_members(domain, analysisMemberName, iErr)!{{{ nameLength = len_trim(analysisMemberName) -! if ( analysisMemberName(1:nameLength) == 'temPlate' ) then -! call li_init_TEM_PLATE(domain, analysisMemberName, err_tmp) + if ( analysisMemberName(1:nameLength) == 'globalStats' ) then + call li_init_TEM_PLATE(domain, analysisMemberName, err_tmp) end if iErr = ior(iErr, err_tmp) @@ -735,8 +735,8 @@ subroutine li_compute_analysis_members(domain, timeLevel, analysisMemberName, iE nameLength = len_trim(analysisMemberName) -! if ( analysisMemberName(1:nameLength) == 'temPlate' ) then -! call li_compute_TEM_PLATE(domain, analysisMemberName, timeLevel, err_tmp) + if ( analysisMemberName(1:nameLength) == 'globalStats' ) then + call li_compute_TEM_PLATE(domain, analysisMemberName, timeLevel, err_tmp) end if iErr = ior(iErr, err_tmp) @@ -765,8 +765,8 @@ subroutine li_restart_analysis_members(domain, analysisMemberName, iErr)!{{{ nameLength = len_trim(analysisMemberName) -! if ( analysisMemberName(1:nameLength) == 'temPlate' ) then -! call li_restart_TEM_PLATE(domain, analysisMemberName, err_tmp) + if ( analysisMemberName(1:nameLength) == 'globalStats' ) then + call li_restart_TEM_PLATE(domain, analysisMemberName, err_tmp) end if iErr = ior(iErr, err_tmp) @@ -795,8 +795,8 @@ subroutine li_finalize_analysis_members(domain, analysisMemberName, iErr)!{{{ nameLength = len_trim(analysisMemberName) -! if ( analysisMemberName(1:nameLength) == 'temPlate' ) then -! call li_finalize_TEM_PLATE(domain, analysisMemberName, err_tmp) + if ( analysisMemberName(1:nameLength) == 'globalStats' ) then + call li_finalize_TEM_PLATE(domain, analysisMemberName, err_tmp) end if iErr = ior(iErr, err_tmp) From bf67684832307560f8fe219e3d5760f511b2c092 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 10 Sep 2015 13:29:32 -0600 Subject: [PATCH 0225/1724] Fix loop order in surface restoring computation This commit fixes an incorrect ordering of loops in the surface restoring flux computation. --- .../shared/mpas_ocn_tracer_surface_restoring.F | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F b/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F index 30a78485cc..09e9e1441c 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F @@ -115,12 +115,12 @@ subroutine ocn_tracer_surface_restoring_compute(nTracers, nCellsSolve, tracers, err = 0 iLevel = 1 ! base surface flux restoring on tracer fields in the top layer - do iTracer=1,nTracers do iCell=1,nCellsSolve - tracersSurfaceFlux(iTracer, iCell) = tracersSurfaceFlux(iTracer, iCell) - & - pistonVelocity(iTracer,iCell) * & - (tracers(iTracer, iLevel, iCell) - tracersSurfaceRestoringValue(iTracer,iCell)) - enddo + do iTracer=1,nTracers + tracersSurfaceFlux(iTracer, iCell) = tracersSurfaceFlux(iTracer, iCell) - & + pistonVelocity(iTracer,iCell) * & + (tracers(iTracer, iLevel, iCell) - tracersSurfaceRestoringValue(iTracer,iCell)) + enddo enddo !-------------------------------------------------------------------- From 7477d45c91e849a20d6f4afa5bb6c1af882ea002 Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Thu, 10 Sep 2015 23:06:24 -0600 Subject: [PATCH 0226/1724] fix makefile to clean all subdirs; add (non-working) driver calls to fwd code; TEM_PLATE replacements --- src/core_landice/Makefile | 1 + src/core_landice/Registry.xml | 1 - .../analysis_members/mpas_li_analysis_driver.F | 8 ++++---- .../analysis_members/mpas_li_global_stats.F | 4 ++++ src/core_landice/mode_forward/mpas_li_core.F | 10 ++++++++++ 5 files changed, 19 insertions(+), 5 deletions(-) diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index 8f814d70a9..d2d188809a 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -46,3 +46,4 @@ clean: $(RM) -r default_inputs (cd shared; $(MAKE) clean) (cd mode_forward; $(MAKE) clean) + (cd analysis_members; $(MAKE) clean) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index ee9621e335..b273b2a387 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -320,7 +320,6 @@ - Date: Fri, 11 Sep 2015 12:29:49 -0600 Subject: [PATCH 0228/1724] Large refactor that moved the state into MPAS framework. --- .../Registry_time_series_stats.xml | 16 +- .../mpas_ocn_time_series_stats.F | 1849 ++++++++++------- 2 files changed, 1158 insertions(+), 707 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_time_series_stats.xml b/src/core_ocean/analysis_members/Registry_time_series_stats.xml index 82d86f71aa..ef9f79eaef 100644 --- a/src/core_ocean/analysis_members/Registry_time_series_stats.xml +++ b/src/core_ocean/analysis_members/Registry_time_series_stats.xml @@ -88,11 +88,23 @@ - + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index dd10aa9d3e..cf299a91fb 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -42,51 +42,41 @@ module ocn_time_series_stats ! Private module variables !-------------------------------------------------------------------- - ! startup, interval, and restart is done in the outer analysis driver - - ! time buffer type - ! this keeps track of timers and if and when they need to accumulate - type time_buffer_type - ! internal state - logical :: started_flag, accumulate_flag, reset_flag - real (kind=RKIND) :: total_accum - - type (MPAS_Time_type) :: start_time - type (MPAS_TimeInterval_type) :: duration_interval - type (MPAS_TimeInterval_type) :: repeat_interval - type (MPAS_TimeInterval_type) :: reset_interval - - ! alarm IDs - character (len=StrKIND) :: start_alarm_ID - character (len=StrKIND) :: repeat_alarm_ID - character (len=StrKIND) :: duration_alarm_ID - character (len=StrKIND) :: reset_alarm_ID - - ! name of counter - character (len=StrKIND) :: output_counter - end type time_buffer_type - - ! time variable type - ! this keeps track of arrays, array types, and names - type time_variable_type - type (mpas_pool_field_info_type) :: info - character (len=StrKIND) :: input_name - ! either you have to put a number of buffers per variable - ! or put the output variables in the buffers (I decided to put it here) + type time_series_alarms_type + type (mpas_time_type) :: start_time + type (mpas_timeinterval_type) :: duration_interval + type (mpas_timeinterval_type) :: repeat_interval + type (mpas_timeinterval_type) :: reset_interval + end type time_series_alarms_type + + type time_series_variable_type + ! state per variable, stored in framework + character (len=StrKIND), pointer :: input_name character (len=StrKIND), dimension(:), allocatable :: output_names - end type time_variable_type + end type time_series_variable_type - ! operation - integer :: operation - - ! stream name - character (len=StrKIND), pointer :: stream_name + type time_series_buffer_type + ! state per buffer, stored in framework + integer, pointer :: started_flag, accumulate_flag, reset_flag + + ! strings for looking up alarms and buffers per buffer + character (len=StrKIND), pointer :: start_alarm_ID, repeat_alarm_ID, & + duration_alarm_ID, reset_alarm_ID + + ! counter for accumulation + real, pointer :: counter + end type time_series_buffer_type - ! information per variable - type (time_variable_type), dimension(:), allocatable :: variables + type time_series_type + ! state per instance, stored in framework + integer, pointer :: operation + integer, pointer :: number_of_variables + integer, pointer :: number_of_buffers - ! information per buffer - type (time_buffer_type), dimension(:), allocatable :: buffers + ! allocated on every instance call + type (time_series_variable_type), dimension(:), allocatable :: variables + type (time_series_buffer_type), dimension(:), allocatable :: buffers + end type time_series_type ! enum of ops and types integer, parameter :: AVG_OP = 1 @@ -98,6 +88,72 @@ module ocn_time_series_stats integer, parameter :: REPEAT_INTERVALS = 7 integer, parameter :: RESET_INTERVALS = 8 + character (len=3), parameter :: AVG_TOKEN = 'avg' + character (len=3), parameter :: MIN_TOKEN = 'min' + character (len=3), parameter :: MAX_TOKEN = 'max' + + character (len=4), parameter :: MESH_STREAM = 'mesh' + character (len=5), parameter :: TIME_STREAM = 'xtime' + + character (len=StrKIND), parameter :: ONE_STRING_MEMORY = & + 'timeSeriesStatsOneString' + character (len=StrKIND), parameter :: ONE_INTEGER_MEMORY = & + 'timeSeriesStatsOneInteger' + character (len=StrKIND), parameter :: ONE_REAL_MEMORY = & + 'timeSeriesStatsOneReal' + + character (len=StrKIND), parameter :: CONFIG_PREFIX = & + 'config_AM_timeSeriesStats' + character (len=StrKIND), parameter :: FRAMEWORK_PREFIX = 'timeSeriesStats' + + character (len=StrKIND), parameter :: STREAM_NAME_SUFFIX = '_stream_name' + character (len=StrKIND), parameter :: OPERATION_SUFFIX = '_operation' + character (len=StrKIND), parameter :: ADD_MESH_SUFFIX = '_add_mesh' + + character (len=StrKIND), parameter :: NUMBER_OF_BUFFERS_SUFFIX = & + '_number_of_buffers' + character (len=StrKIND), parameter :: NUMBER_OF_VARIABLES_SUFFIX = & + '_number_of_variables' + + character (len=StrKIND), parameter :: INPUT_NAME_SUFFIX = '_input_name' + + character (len=StrKIND), parameter :: REFERENCE_TIMES_SUFFIX = & + '_reference_times' + character (len=StrKIND), parameter :: DURATION_INTERVALS_SUFFIX = & + '_duration_intervals' + character (len=StrKIND), parameter :: REPEAT_INTERVALS_SUFFIX = & + '_repeat_intervals' + character (len=StrKIND), parameter :: RESET_INTERVALS_SUFFIX = & + '_reset_intervals' + + character (len=StrKIND), parameter :: STARTED_FLAG_SUFFIX = & + '_started_flag' + character (len=StrKIND), parameter :: ACCUMULATE_FLAG_SUFFIX = & + '_accumulate_flag' + character (len=StrKIND), parameter :: RESET_FLAG_SUFFIX = & + '_reset_flag' + character (len=StrKIND), parameter :: START_ALARM_ID_SUFFIX = & + '_start_alarm_ID' + character (len=StrKIND), parameter :: REPEAT_ALARM_ID_SUFFIX = & + '_repeat_alarm_ID' + character (len=StrKIND), parameter :: DURATION_ALARM_ID_SUFFIX = & + '_duration_alarm_ID' + character (len=StrKIND), parameter :: RESET_ALARM_ID_SUFFIX = & + '_reset_alarm_ID' + character (len=StrKIND), parameter :: COUNTER_SUFFIX = & + '_counter_' + + character (len=StrKIND), parameter :: START_ALARM_PREFIX = '_startAlarm_' + character (len=StrKIND), parameter :: REPEAT_ALARM_PREFIX = '_repeatAlarm_' + character (len=StrKIND), parameter :: DURATION_ALARM_PREFIX = & + '_durationAlarm_' + character (len=StrKIND), parameter :: RESET_ALARM_PREFIX = '_resetAlarm_' + + character (len=StrKIND), parameter :: INITIAL_TIME_TOKEN = 'initial_time' + character (len=StrKIND), parameter :: REPEAT_INTERVAL_TOKEN = & + 'repeat_interval' + character (len=StrKIND), parameter :: RESET_INTERVAL_TOKEN = 'reset_interval' + !*********************************************************************** contains @@ -123,34 +179,40 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ integer, intent(out) :: err !< Output: error flag ! local variables - integer :: b - integer :: number_of_variables, number_of_buffers + integer :: v character (len=StrKIND) :: instance ! TODO intent(in) - character (len=StrKIND) :: prefix, op - character (len=StrKIND), pointer :: stream_name + type (time_series_type) :: series + type (time_series_alarms_type) :: alarms ! start procedure err = 0 - ! string representation ! TODO placeholder for some unique ID if this code is replicated - ! per multiple AMs for multiple streams - instance = '' - prefix = 'config_AM_timeSeriesStats' // trim(instance) + instance = '' ! TODO to be passed in + + ! TODO skip all of this if do_restart is true and a restart stream exists ! get the basic configuration of this stream - call start_init(domain, prefix, number_of_variables, number_of_buffers, & - stream_name, op, err) + call start_init(domain, instance, series, err) ! modify the stream to remove existing vars and add accumulated versions - call modify_stream(domain, stream_name, number_of_variables, & - number_of_buffers, instance, prefix, op, err) + call modify_stream(domain, instance, series, err) ! get all of the timing and configuration - call get_alarms(domain, prefix, number_of_buffers, err) + call get_alarms(domain, instance, series, alarms, err) ! set all of the alarms based on timers - call set_alarms(domain % clock, instance, number_of_buffers, err) + call set_alarms(domain, instance, series, alarms, err) + + ! TODO have a subroutine to put all state and data into restart stream + ! TODO add a restart stream config option + + ! clean up the memory + do v = 1, series % number_of_variables + deallocate(series % variables(v) % output_names) + end do + deallocate(series % variables) + deallocate(series % buffers) end subroutine ocn_init_time_series_stats!}}} @@ -176,36 +238,47 @@ subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ integer, intent(out) :: err !< Output: error flag ! local variables - integer :: i, v, b - real (kind=RKIND), pointer :: counter + character (len=StrKIND) :: instance ! TODO intent(in) + integer :: v, b + type (time_series_type) :: series ! start procedure err = 0 + ! TODO placeholder for some unique ID if this code is replicated + instance = '' ! TODO to be passed in + + ! get all of the state + call get_state(domain, instance, series) + ! update the counter - do b = 1, size(buffers) - if (buffers(b) % accumulate_flag) then - if (buffers(b) % reset_flag) then - buffers(b) % total_accum = 1 + do b = 1, series % number_of_buffers + if (series % buffers(b) % accumulate_flag) then + if (series % buffers(b) % reset_flag) then + series % buffers(b) % counter = 1 else - buffers(b) % total_accum = buffers(b) % total_accum + 1 + series % buffers(b) % counter = series % buffers(b) % counter + 1 end if - - ! update the stream - call mpas_pool_get_array(domain % blocklist % allFields, & - buffers(b) % output_counter, counter, 1) - counter = buffers(b) % total_accum end if end do ! do all of the operations - do v = 1, size(variables) - call typed_operate(domain % blocklist, v, operation) + do v = 1, series % number_of_variables + call typed_operate(domain % blocklist, & + series % variables(v), & + series % buffers, & + series % operation) end do ! do all of the time checking and flag setting - call timer_checking(domain % clock, err) + call timer_checking(series, domain % clock, err) + ! clean up the memory + do v = 1, series % number_of_variables + deallocate(series % variables(v) % output_names) + end do + deallocate(series % variables) + deallocate(series % buffers) end subroutine ocn_compute_time_series_stats!}}} @@ -259,31 +332,155 @@ subroutine ocn_finalize_time_series_stats(domain, err)!{{{ integer, intent(out) :: err !< Output: error flag ! local variables - integer :: i, v ! start procedure err = 0 - ! clean up memory - if (allocated(buffers)) then - deallocate(buffers) - end if - if (allocated(variables)) then - do v = 1, size(variables) - if (allocated(variables(v) % output_names)) & - then - deallocate(variables(v) % output_names) - end if - end do - deallocate(variables) - end if - end subroutine ocn_finalize_time_series_stats!}}} ! ! local subroutines ! +!*********************************************************************** +! routine get_state +! +!> \brief Get all of the state for this instance. +!> \author Jon Woodring +!> \date September 1, 2015 +!> \details +!> This will allocate and fetch all of the state necessary for this +!> instance that is being run. +!----------------------------------------------------------------------- +subroutine get_state(domain, instance, series) + ! input variables + character (len=StrKIND), intent(in) :: instance + + ! input/output variables + type (domain_type), intent(inout) :: domain + + ! output variables + type (time_series_type), intent(out) :: series + + ! local variables + integer :: v, b + character (len=StrKIND) :: storage_prefix, var_identifier, & + buf_identifier, var_prefix, buf_prefix, field_name, op_name + + ! start procedure + storage_prefix = trim(FRAMEWORK_PREFIX) // trim(instance) + + ! + ! get the base + ! + + ! number_of_variables + field_name = trim(storage_prefix) // trim(NUMBER_OF_VARIABLES_SUFFIX) + call mpas_pool_get_array(domain % blocklist % allFields, & + field_name, series % number_of_variables, 1) + + ! number_of_buffers + field_name = trim(storage_prefix) // trim(NUMBER_OF_BUFFERS_SUFFIX) + call mpas_pool_get_array(domain % blocklist % allFields, & + field_name, series % number_of_buffers, 1) + + ! operation + field_name = trim(storage_prefix) // trim(OPERATION_SUFFIX) + call mpas_pool_get_array(domain % blocklist % allFields, & + field_name, series % operation, 1) + + ! operator + if (series % operation == AVG_OP) then + op_name = AVG_TOKEN + else if (series % operation == MIN_OP) then + op_name = MIN_TOKEN + else + op_name = MAX_TOKEN + end if + + ! create the memory + allocate(series % variables(series % number_of_variables)) + allocate(series % buffers(series % number_of_buffers)) + do v = 1, series % number_of_variables + allocate(series % variables(v) % output_names(series % number_of_buffers)) + end do + + ! + ! get the instance values for variables + ! + + do v = 1, series % number_of_variables + ! identifier + write(var_identifier, '(I0)') v + var_prefix = trim(storage_prefix) // '_' // trim(var_identifier) + + ! input_name + field_name = trim(var_prefix) // trim(INPUT_NAME_SUFFIX) + call mpas_pool_get_array(domain % blocklist % allFields, & + field_name, series % variables(v) % input_name, 1) + + do b = 1, series % number_of_buffers + write(buf_identifier, '(I0)') b + + ! create output names + series % variables(v) % output_names(b) = output_naming & + (storage_prefix, op_name, series % variables(v) % input_name, & + buf_identifier) + end do + end do + + ! + ! get the instance values for buffers + ! + + do b = 1, series % number_of_buffers + ! identifier + write(buf_identifier, '(I0)') b + buf_prefix = trim(storage_prefix) // '_' // trim(buf_identifier) + + ! started_flag + field_name = trim(buf_prefix) // trim(STARTED_FLAG_SUFFIX) + call mpas_pool_get_array(domain % blocklist % allFields, & + field_name, series % buffers(b) % started_flag, 1) + + ! accumulate_flag + field_name = trim(buf_prefix) // trim(ACCUMULATE_FLAG_SUFFIX) + call mpas_pool_get_array(domain % blocklist % allFields, & + field_name, series % buffers(b) % accumulate_flag, 1) + + ! reset_flag + field_name = trim(buf_prefix) // trim(RESET_FLAG_SUFFIX) + call mpas_pool_get_array(domain % blocklist % allFields, & + field_name, series % buffers(b) % reset_flag, 1) + + ! start_alarm_ID + field_name = trim(buf_prefix) // trim(START_ALARM_ID_SUFFIX) + call mpas_pool_get_array(domain % blocklist % allFields, & + field_name, series % buffers(b) % start_alarm_ID, 1) + + ! repeat_alarm_ID + field_name = trim(buf_prefix) // trim(REPEAT_ALARM_ID_SUFFIX) + call mpas_pool_get_array(domain % blocklist % allFields, & + field_name, series % buffers(b) % repeat_alarm_ID, 1) + + ! duration_alarm_ID + field_name = trim(buf_prefix) // trim(DURATION_ALARM_ID_SUFFIX) + call mpas_pool_get_array(domain % blocklist % allFields, & + field_name, series % buffers(b) % duration_alarm_ID, 1) + + ! reset_alarm_ID + field_name = trim(buf_prefix) // trim(RESET_ALARM_ID_SUFFIX) + call mpas_pool_get_array(domain % blocklist % allFields, & + field_name, series % buffers(b) % reset_alarm_ID, 1) + + ! counter + field_name = counter_naming(storage_prefix, buf_identifier) + call mpas_pool_get_array(domain % blocklist % allFields, & + field_name, series % buffers(b) % counter, 1) + end do + +end subroutine get_state + !*********************************************************************** ! routine start_init ! @@ -294,30 +491,75 @@ end subroutine ocn_finalize_time_series_stats!}}} !> This will count the number of variables, number of buffers, and !> also get the stream name and operation strings. !----------------------------------------------------------------------- -subroutine start_init(domain, prefix, number_of_variables, & - number_of_buffers, stream_name, op, err) +subroutine start_init(domain, instance, series, err) ! input variables - character (len=StrKIND), intent(in) :: prefix + character (len=StrKIND), intent(in) :: instance ! input/output variables type (domain_type), intent(inout) :: domain ! output variables - character (len=StrKIND), pointer, intent(out) :: stream_name - character (len=StrKIND), intent(out) :: op - integer, intent(out) :: number_of_variables, number_of_buffers + type (time_series_type), intent(out) :: series integer, intent(out) :: err !< Output: error flag ! local variables - character (len=StrKIND), pointer :: config_results - character (len=StrKIND) :: copy, config - integer :: b + character (len=StrKIND), pointer :: config_results, stream_name + character (len=StrKIND) :: config, namelist_prefix, storage_prefix, & + var_identifier, buf_identifier, var_prefix, buf_prefix + integer :: b, v + type (field0DChar), pointer :: srcString, dstString + type (field0DInteger), pointer :: srcInteger, dstInteger + type (field0DReal), pointer :: srcReal, dstReal ! start procedure err = 0 + namelist_prefix = trim(CONFIG_PREFIX) // trim(instance) + storage_prefix = trim(FRAMEWORK_PREFIX) // trim(instance) + + ! + ! allocate some framework memory + ! + + ! number_of_variables + call mpas_pool_get_field(domain % blocklist % allFields, & + ONE_INTEGER_MEMORY, srcInteger, 1) + call mpas_duplicate_field(srcInteger, dstInteger) + dstInteger % fieldName = & + trim(storage_prefix) // trim(NUMBER_OF_VARIABLES_SUFFIX) + call mpas_pool_add_field(domain % blocklist % allFields, & + dstInteger % fieldName, dstInteger) + call mpas_pool_get_array(domain % blocklist % allFields, & + dstInteger % fieldName, series % number_of_variables, 1) + + ! number_of_buffers + call mpas_pool_get_field(domain % blocklist % allFields, & + ONE_INTEGER_MEMORY, srcInteger, 1) + call mpas_duplicate_field(srcInteger, dstInteger) + dstInteger % fieldName = & + trim(storage_prefix) // trim(NUMBER_OF_BUFFERS_SUFFIX) + call mpas_pool_add_field(domain % blocklist % allFields, & + dstInteger % fieldName, dstInteger) + call mpas_pool_get_array(domain % blocklist % allFields, & + dstInteger % fieldName, series % number_of_buffers, 1) + + ! operation + call mpas_pool_get_field(domain % blocklist % allFields, & + ONE_INTEGER_MEMORY, srcInteger, 1) + call mpas_duplicate_field(srcInteger, dstInteger) + dstInteger % fieldName = & + trim(storage_prefix) // trim(OPERATION_SUFFIX) + call mpas_pool_add_field(domain % blocklist % allFields, & + dstInteger % fieldName, dstInteger) + call mpas_pool_get_array(domain % blocklist % allFields, & + dstInteger % fieldName, series % operation, 1) + + ! + ! assign some instance values + ! + ! get the stream name - config = trim(prefix) // '_stream_name' + config = trim(namelist_prefix) // trim(STREAM_NAME_SUFFIX) call mpas_pool_get_config(domain % configs, config, stream_name) if (stream_name == 'none') then @@ -328,46 +570,330 @@ subroutine start_init(domain, prefix, number_of_variables, & ! count the number of variables call mpas_stream_mgr_begin_iteration(domain % streamManager, & stream_name, err) - number_of_variables = 0 + series % number_of_variables = 0 do while (mpas_stream_mgr_get_next_field(domain % streamManager, & - stream_name, copy)) - number_of_variables = number_of_variables + 1 + stream_name, config)) + series % number_of_variables = series % number_of_variables + 1 end do ! count the number of buffers - config = trim(prefix) // '_reference_times' + config = trim(namelist_prefix) // trim(REFERENCE_TIMES_SUFFIX) call mpas_pool_get_config(domain % configs, config, config_results) - copy = config_results - number_of_buffers = 1 - b = scan(copy, ';') + config = config_results + series % number_of_buffers = 1 + b = scan(config, ';') do while (b > 0) - number_of_buffers = number_of_buffers + 1 - copy = copy(b+1:) - b = scan(copy, ';') + series % number_of_buffers = series % number_of_buffers + 1 + config = config(b+1:) + b = scan(config, ';') end do ! get our operation - config = trim(prefix) // '_operation' + config = trim(namelist_prefix) // trim(OPERATION_SUFFIX) call mpas_pool_get_config(domain % configs, config, config_results) - if (config_results == 'avg') then - operation = AVG_OP - op = 'avg' - else if (config_results == 'min') then - operation = MIN_OP - op = 'min' - else if (config_results == 'max') then - operation = MAX_OP - op = 'max' + if (config_results == AVG_TOKEN) then + series % operation = AVG_OP + else if (config_results == MIN_TOKEN) then + series % operation = MIN_OP + else if (config_results == MAX_TOKEN) then + series % operation = MAX_OP else ! error if unknown operation call mpas_dmpar_global_abort('Error: unknown operation in time ' // & 'averaging analysis member configuration.') end if + ! create the memory + allocate(series % variables(series % number_of_variables)) + allocate(series % buffers(series % number_of_buffers)) + do v = 1, series % number_of_variables + allocate(series % variables(v) % output_names(series % number_of_buffers)) + end do + + ! + ! duplicate memory for storing data in the framework + ! + + ! create variable space + do v = 1, series % number_of_variables + ! identifier + write(var_identifier, '(I0)') v + var_prefix = trim(storage_prefix) // '_' // trim(var_identifier) + + ! input_name + call mpas_pool_get_field(domain % blocklist % allFields, & + ONE_STRING_MEMORY, srcString, 1) + call mpas_duplicate_field(srcString, dstString) + dstString % fieldName = trim(var_prefix) // trim(INPUT_NAME_SUFFIX) + call mpas_pool_add_field(domain % blocklist % allFields, & + dstString % fieldName, dstString) + call mpas_pool_get_array(domain % blocklist % allFields, & + dstString % fieldName, series % variables(v) % input_name, 1) + end do + + ! create buffer space + do b = 1, series % number_of_buffers + ! identifier + write(buf_identifier, '(I0)') b + buf_prefix = trim(storage_prefix) // '_' // trim(buf_identifier) + + ! started_flag + call mpas_pool_get_field(domain % blocklist % allFields, & + ONE_INTEGER_MEMORY, srcInteger, 1) + call mpas_duplicate_field(srcInteger, dstInteger) + dstInteger % fieldName = trim(buf_prefix) // trim(STARTED_FLAG_SUFFIX) + call mpas_pool_add_field(domain % blocklist % allFields, & + dstInteger % fieldName, dstInteger) + call mpas_pool_get_array(domain % blocklist % allFields, & + dstInteger % fieldName, series % buffers(b) % started_flag, 1) + + ! accumulate_flag + call mpas_pool_get_field(domain % blocklist % allFields, & + ONE_INTEGER_MEMORY, srcInteger, 1) + call mpas_duplicate_field(srcInteger, dstInteger) + dstInteger % fieldName = trim(buf_prefix) // trim(ACCUMULATE_FLAG_SUFFIX) + call mpas_pool_add_field(domain % blocklist % allFields, & + dstInteger % fieldName, dstInteger) + call mpas_pool_get_array(domain % blocklist % allFields, & + dstInteger % fieldName, series % buffers(b) % accumulate_flag, 1) + + ! reset_flag + call mpas_pool_get_field(domain % blocklist % allFields, & + ONE_INTEGER_MEMORY, srcInteger, 1) + call mpas_duplicate_field(srcInteger, dstInteger) + dstInteger % fieldName = trim(buf_prefix) // trim(RESET_FLAG_SUFFIX) + call mpas_pool_add_field(domain % blocklist % allFields, & + dstInteger % fieldName, dstInteger) + call mpas_pool_get_array(domain % blocklist % allFields, & + dstInteger % fieldName, series % buffers(b) % reset_flag, 1) + + ! start_alarm_ID + call mpas_pool_get_field(domain % blocklist % allFields, & + ONE_STRING_MEMORY, srcString, 1) + call mpas_duplicate_field(srcString, dstString) + dstString % fieldName = trim(buf_prefix) // trim(START_ALARM_ID_SUFFIX) + call mpas_pool_add_field(domain % blocklist % allFields, & + dstString % fieldName, dstString) + call mpas_pool_get_array(domain % blocklist % allFields, & + dstString % fieldName, series % buffers(b) % start_alarm_ID, 1) + + ! repeat_alarm_ID + call mpas_pool_get_field(domain % blocklist % allFields, & + ONE_STRING_MEMORY, srcString, 1) + call mpas_duplicate_field(srcString, dstString) + dstString % fieldName = trim(buf_prefix) // trim(REPEAT_ALARM_ID_SUFFIX) + call mpas_pool_add_field(domain % blocklist % allFields, & + dstString % fieldName, dstString) + call mpas_pool_get_array(domain % blocklist % allFields, & + dstString % fieldName, series % buffers(b) % repeat_alarm_ID, 1) + + ! duration_alarm_ID + call mpas_pool_get_field(domain % blocklist % allFields, & + ONE_STRING_MEMORY, srcString, 1) + call mpas_duplicate_field(srcString, dstString) + dstString % fieldName = trim(buf_prefix) // trim(DURATION_ALARM_ID_SUFFIX) + call mpas_pool_add_field(domain % blocklist % allFields, & + dstString % fieldName, dstString) + call mpas_pool_get_array(domain % blocklist % allFields, & + dstString % fieldName, series % buffers(b) % duration_alarm_ID, 1) + + ! reset_alarm_ID + call mpas_pool_get_field(domain % blocklist % allFields, & + ONE_STRING_MEMORY, srcString, 1) + call mpas_duplicate_field(srcString, dstString) + dstString % fieldName = trim(buf_prefix) // trim(RESET_ALARM_ID_SUFFIX) + call mpas_pool_add_field(domain % blocklist % allFields, & + dstString % fieldName, dstString) + call mpas_pool_get_array(domain % blocklist % allFields, & + dstString % fieldName, series % buffers(b) % reset_alarm_ID, 1) + + ! counter + call mpas_pool_get_field(domain % blocklist % allFields, & + ONE_REAL_MEMORY, srcReal, 1) + call mpas_duplicate_field(srcReal, dstReal) + dstReal % fieldName = counter_naming(storage_prefix, buf_identifier) + call mpas_pool_add_field(domain % blocklist % allFields, & + dstReal % fieldName, dstReal) + call mpas_pool_get_array(domain % blocklist % allFields, & + dstReal % fieldName, series % buffers(b) % counter, 1) + end do + end subroutine start_init +!*********************************************************************** +! routine modify_stream +! +!> \brief Remove existing variables and replace them with new ones +!> \author Jon Woodring +!> \date September 1, 2015 +!> \details +!> Given a stream name, this will remove the existing variables +!> in a stream and replace them with similiarly named ones for +!> their accumulation. It will also add xtime and optionally the mesh. +!----------------------------------------------------------------------- +subroutine modify_stream(domain, instance, series, err)!{{{ + ! input variables + character (len=StrKIND), intent(in) :: instance + + ! input/output variables + type (domain_type), intent(inout) :: domain + type (time_series_type), intent(inout) :: series + + ! output variables + integer, intent(out) :: err !< Output: error flag + + ! local variables + integer :: v, b + character (len=StrKIND), pointer :: stream_name + logical, pointer :: copy_mesh + character (len=StrKIND) :: field_name, config, op_name + character (len=StrKIND) :: namelist_prefix, storage_prefix, buf_identifier, & + buf_prefix + type (mpas_pool_field_info_type) :: info + + ! start procedure + err = 0 + + namelist_prefix = trim(CONFIG_PREFIX) // trim(instance) + storage_prefix = trim(FRAMEWORK_PREFIX) // trim(instance) + + ! get the stream name + config = trim(namelist_prefix) // trim(STREAM_NAME_SUFFIX) + call mpas_pool_get_config(domain % configs, config, stream_name) + + ! + ! assign values to series and modify the stream + ! + + ! get the old field names + call mpas_stream_mgr_begin_iteration(domain % streamManager, & + stream_name, err) + v = 1 + do while (mpas_stream_mgr_get_next_field(domain % streamManager, & + stream_name, field_name)) + series % variables(v) % input_name = field_name + v = v + 1 + end do + + ! remove the old ones from the stream + do v = 1, series % number_of_variables + call mpas_stream_mgr_remove_field(domain % streamManager, & + stream_name, series % variables(v) % input_name) + end do + + ! add xtime to the stream + call mpas_stream_mgr_add_field(domain % streamManager, & + stream_name, TIME_STREAM, ierr=err) + + ! optionally add mesh to stream + config = trim(namelist_prefix) // trim(ADD_MESH_SUFFIX) + call mpas_pool_get_config(domain % configs, config, copy_mesh) + if (copy_mesh) then + call mpas_stream_mgr_begin_iteration(domain % streamManager, & + MESH_STREAM, err) + do while (mpas_stream_mgr_get_next_field(domain % streamManager, & + MESH_STREAM, field_name)) + call mpas_stream_mgr_add_field(domain % streamManager, & + stream_name, field_name, ierr=err) + end do + end if + + ! put the counters in the output stream + do b = 1, series % number_of_buffers + write(buf_identifier, '(I0)') b + + field_name = counter_naming(storage_prefix, buf_identifier) + call mpas_stream_mgr_add_field(domain % streamManager, & + stream_name, field_name, ierr=err) + end do + + ! operator + if (series % operation == AVG_OP) then + op_name = AVG_TOKEN + else if (series % operation == MIN_OP) then + op_name = MIN_TOKEN + else + op_name = MAX_TOKEN + end if + + ! set up the variables + call mpas_stream_mgr_begin_iteration(domain % streamManager, & + stream_name, err) + do v = 1, series % number_of_variables + ! get the info of the field + call mpas_pool_get_field_info(domain % blocklist % allFields, & + series % variables(v) % input_name, info) + + ! check if we can handle it + if(.not. ((info % fieldType == MPAS_POOL_REAL) & + .or. (info % fieldType == MPAS_POOL_INTEGER))) then + call mpas_dmpar_global_abort('Error: field "' // & + trim(series % variables(v) % input_name) // '" listed in the ' // & + 'output stream, for time series stats analysis member ' // & + 'stream, is not real or integer.') + end if + + ! allocate a number of fields and add field + do b = 1, series % number_of_buffers + write(buf_identifier, '(I0)') b + + ! create the name of the output var + series % variables(v) % output_names(b) = output_naming(storage_prefix, & + op_name, series % variables(v) % input_name, buf_identifier) + + ! create the field and add to pool + call add_new_field(info, & + series % variables(v) % input_name, & + series % variables(v) % output_names(b), & + domain % blocklist % allFields) + + ! add the field to the stream + call mpas_stream_mgr_add_field(domain % streamManager, & + stream_name, series % variables(v) % output_names(b), ierr=err) + end do + end do ! number_of_variables + +end subroutine modify_stream!}}} + + +!*********************************************************************** +! function output_naming +! +!> \brief Given an input name, create a cooresponding output name +!> \author Jon Woodring +!> \date September 1, 2015 +!> \details +!> Code to create consistent output names from input names. +!----------------------------------------------------------------------- +character (len=StrKIND) function output_naming & +(storage_prefix, op_name, input_name, buf_identifier) + character (len=StrKIND), intent(in) :: storage_prefix, op_name, & + input_name, buf_identifier + + output_naming = trim(storage_prefix) // '_' // trim(op_name) // '_' // & + trim(input_name) // '_' // trim(buf_identifier) +end function output_naming + + +!*********************************************************************** +! function counter_naming +! +!> \brief Given an buffer number, create a cooresponding counter name +!> \author Jon Woodring +!> \date September 1, 2015 +!> \details +!> Code to create consistent counter names from buffer numbers. +!----------------------------------------------------------------------- +character (len=StrKIND) function counter_naming & +(storage_prefix, buf_identifier) + character (len=StrKIND), intent(in) :: storage_prefix, buf_identifier + + counter_naming = trim(storage_prefix) // trim(COUNTER_SUFFIX) // & + trim(buf_identifier) +end function counter_naming + !*********************************************************************** ! routine get_alarms ! @@ -378,40 +904,44 @@ end subroutine start_init !> This will read the namelist and get the strings and set the clocks !> for the different timers to be used. The actual alarms are not set. !----------------------------------------------------------------------- -subroutine get_alarms(domain, prefix, number_of_buffers, err) +subroutine get_alarms(domain, instance, series, alarms, err) ! input variables - integer, intent(in) :: number_of_buffers - character (len=StrKIND) :: prefix + character (len=StrKIND), intent(in) :: instance ! input/output variables type (domain_type), intent(inout) :: domain + type (time_series_type), intent(inout) :: series ! output variables integer, intent(out) :: err !< Output: error flag + type (time_series_alarms_type), intent(out) :: alarms ! local variables - integer :: b, n character (len=StrKIND), pointer :: config_results - character (len=StrKIND) :: config + character (len=StrKIND) :: config, namelist_prefix + integer :: b, n logical :: ok type (mpas_timeinterval_type) :: rem, zero + ! create prefix + namelist_prefix = trim(CONFIG_PREFIX) // trim(instance) + ! configure start times - we don't have to check ok ! because the timer count is based on reference_times tokens - config = trim(prefix) // '_reference_times' + config = trim(namelist_prefix) // trim(REFERENCE_TIMES_SUFFIX) call mpas_pool_get_config(domain % configs, config, config_results) - call set_times(buffers, number_of_buffers, domain % clock, & - START_TIMES, config_results, ok, err) + call set_times(series, alarms, domain % clock, START_TIMES, & + config_results, ok, err) ! order matters, don't reorder these following ones! ! it matters because times/intervals can be configured to be equal ! to other ones ! configure reset intervals - config = trim(prefix) // '_reset_intervals' + config = trim(namelist_prefix) // trim(RESET_INTERVALS_SUFFIX) call mpas_pool_get_config(domain % configs, config, config_results) - call set_times(buffers, number_of_buffers, domain % clock, & - RESET_INTERVALS, config_results, ok, err) + call set_times(series, alarms, domain % clock, RESET_INTERVALS, & + config_results, ok, err) if (.not. ok) then call mpas_dmpar_global_abort('Error: number of times in ' // & 'reset_intervals is not consistent with number of times ' // & @@ -420,10 +950,10 @@ subroutine get_alarms(domain, prefix, number_of_buffers, err) end if ! configure repeat intervals - config = trim(prefix) // '_repeat_intervals' + config = trim(namelist_prefix) // trim(REPEAT_INTERVALS_SUFFIX) call mpas_pool_get_config(domain % configs, config, config_results) - call set_times(buffers, number_of_buffers, domain % clock, & - REPEAT_INTERVALS, config_results, ok, err) + call set_times(series, alarms, domain % clock, REPEAT_INTERVALS, & + config_results, ok, err) if (.not. ok) then call mpas_dmpar_global_abort('Error: number of times in ' // & 'repeat_intervals is not consistent with number of times ' // & @@ -432,10 +962,10 @@ subroutine get_alarms(domain, prefix, number_of_buffers, err) end if ! configure duration intervals - config = trim(prefix) // '_duration_intervals' + config = trim(namelist_prefix) // trim(DURATION_INTERVALS_SUFFIX) call mpas_pool_get_config(domain % configs, config, config_results) - call set_times(buffers, number_of_buffers, domain % clock, & - DURATION_INTERVALS, config_results, ok, err) + call set_times(series, alarms, domain % clock, DURATION_INTERVALS, & + config_results, ok, err) if (.not. ok) then call mpas_dmpar_global_abort('Error: number of times in ' // & 'duration_intervals is not consistent with number of times ' // & @@ -446,25 +976,27 @@ subroutine get_alarms(domain, prefix, number_of_buffers, err) ! check if some of the time configuration is sensible call mpas_set_timeInterval(zero, s=0) - do b = 1, number_of_buffers - call mpas_interval_division(buffers(b) % start_time, & - buffers(b) % repeat_interval, buffers(b) % reset_interval, n, rem) + do b = 1, series % number_of_buffers + call mpas_interval_division(alarms % start_time, & + alarms % repeat_interval, & + alarms % reset_interval, n, rem) if (n > 1 .or. (n == 1 .and. rem /= zero)) then write(stderrUnit,*) 'Warning: repeat_interval > ' // & 'reset_interval in time averaging analysis member ' // & 'configuration. Truncating repeat_interval.' - buffers(b) % repeat_interval = buffers(b) % reset_interval + alarms % repeat_interval = alarms % reset_interval end if - call mpas_interval_division(buffers(b) % start_time, & - buffers(b) % duration_interval, buffers(b) % repeat_interval, n, rem) + call mpas_interval_division(alarms % start_time, & + alarms % duration_interval, & + alarms % repeat_interval, n, rem) if (n > 1 .or. (n == 1 .and. rem /= zero)) then write(stderrUnit,*) 'Warning: duration_interval > ' // & 'repeat_interval in time averaging analysis member ' // & 'configuration. Truncating duration_interval.' - buffers(b) % repeat_interval = buffers(b) % reset_interval + alarms % repeat_interval = alarms % reset_interval end if end do end subroutine get_alarms @@ -481,50 +1013,53 @@ end subroutine get_alarms !> Alarms for the different timers are set, such that temporal !> window alarms are configured. !----------------------------------------------------------------------- -subroutine set_alarms(clock, instance, number_of_buffers, err) +subroutine set_alarms(domain, instance, series, alarms, err) ! input variables - integer, intent(in) :: number_of_buffers - character (len=StrKIND) :: instance + character (len=StrKIND), intent(in) :: instance ! input/output variables - type (mpas_clock_type), intent(inout) :: clock + type (domain_type), intent(inout) :: domain + type (time_series_type), intent(inout) :: series + type (time_series_alarms_type), intent(in) :: alarms ! output variables integer, intent(out) :: err !< Output: error flag ! local variables integer :: b, repeat_n, duration_n, reset_n - character (len=StrKIND) :: buffer + character (len=StrKIND) :: buf_identifier, alarm_prefix type (mpas_time_type) :: current_time, when, & duration_time, repeat_time, reset_time type (mpas_timeinterval_type) :: elapsed, zero, & repeat_rem, duration_rem, reset_rem + ! start procedure + alarm_prefix = trim(FRAMEWORK_PREFIX) // trim(instance) + ! get current time - current_time = mpas_get_clock_time(clock, MPAS_NOW, err) + current_time = mpas_get_clock_time(domain % clock, MPAS_NOW, err) ! configure alarms - do b = 1, number_of_buffers - write(buffer, '(I0)') b + do b = 1, series % number_of_buffers + write(buf_identifier, '(I0)') b ! see if we start in the future or we have already started - if (current_time >= buffers(b) % start_time) then - buffers(b) % started_flag = .true. - ! TODO this needs to be false if do_restart - buffers(b) % reset_flag = .true. + if (current_time >= alarms % start_time) then + series % buffers(b) % started_flag = 1 + series % buffers(b) % reset_flag = 1 ! no start alarm - buffers(b) % start_alarm_ID = '' + series % buffers(b) % start_alarm_ID = '' else - buffers(b) % started_flag = .false. - buffers(b) % reset_flag = .false. + series % buffers(b) % started_flag = 0 + series % buffers(b) % reset_flag = 0 ! set the start alarm - buffers(b) % start_alarm_ID = & - 'tavg_start' // trim(instance) // '_' // buffer - call mpas_add_clock_alarm(clock, & - buffers(b) % start_alarm_ID, & - buffers(b) % start_time, ierr=err) + series % buffers(b) % start_alarm_ID = trim(alarm_prefix) // & + trim(START_ALARM_PREFIX) // trim(buf_identifier) + call mpas_add_clock_alarm(domain % clock, & + series % buffers(b) % start_alarm_ID, & + alarms % start_time, ierr=err) end if ! @@ -532,212 +1067,80 @@ subroutine set_alarms(clock, instance, number_of_buffers, err) ! ! set next duration time - when = buffers(b) % start_time + & - buffers(b) % duration_interval ! duration is offset + when = alarms % start_time + alarms % duration_interval ! duration is offset if (current_time > when) then elapsed = current_time - when call mpas_interval_division(when, elapsed, & - buffers(b) % repeat_interval, & ! repeat is correct + alarms % repeat_interval, & ! repeat is correct duration_n, duration_rem) - duration_rem = buffers(b) % repeat_interval - duration_rem + duration_rem = alarms % repeat_interval - duration_rem duration_time = current_time + duration_rem ! remainder of repeat else - duration_time = buffers(b) % start_time + buffers(b) % duration_interval + duration_time = alarms % start_time + alarms % duration_interval duration_n = 0 end if ! set next repeat time - when = buffers(b) % start_time + buffers(b) % repeat_interval + when = alarms % start_time + alarms % repeat_interval if (current_time > when) then elapsed = current_time - when call mpas_interval_division(when, elapsed, & - buffers(b) % repeat_interval, repeat_n, repeat_rem) - repeat_rem = buffers(b) % repeat_interval - repeat_rem + alarms % repeat_interval, repeat_n, repeat_rem) + repeat_rem = alarms % repeat_interval - repeat_rem repeat_time = current_time + repeat_rem else - repeat_time = buffers(b) % start_time + buffers(b) % repeat_interval + repeat_time = alarms % start_time + alarms % repeat_interval repeat_n = 0 end if ! set next reset time - when = buffers(b) % start_time + buffers(b) % reset_interval + when = alarms % start_time + alarms % reset_interval if (current_time > when) then elapsed = current_time - when call mpas_interval_division(when, elapsed, & - buffers(b) % reset_interval, reset_n, reset_rem) - reset_rem = buffers(b) % reset_interval - reset_rem + alarms % reset_interval, reset_n, reset_rem) + reset_rem = alarms % reset_interval - reset_rem reset_time = current_time + reset_rem else - reset_time = buffers(b) % start_time + buffers(b) % reset_interval + reset_time = alarms % start_time + alarms % reset_interval reset_n = 0 end if ! we're accumulating if we are in a window between duration and repeat - buffers(b) % accumulate_flag = duration_n == repeat_n + if (duration_n == repeat_n) then + series % buffers(b) % accumulate_flag = 1 + else + series % buffers(b) % accumulate_flag = 0 + end if ! ! set the reoccurring timers ! - buffers(b) % duration_alarm_ID = & - 'tavg_duration' // trim(instance) // '_' // buffer - call mpas_add_clock_alarm(clock, & - buffers(b) % duration_alarm_ID, & + series % buffers(b) % duration_alarm_ID = trim(alarm_prefix) // & + trim(DURATION_ALARM_PREFIX) // trim(buf_identifier) + call mpas_add_clock_alarm(domain % clock, & + series % buffers(b) % duration_alarm_ID, & duration_time, & ! duration sets the offset - buffers(b) % repeat_interval, ierr=err) ! but repeat sets the interval + alarms % repeat_interval, ierr=err) ! but repeat is interval - buffers(b) % repeat_alarm_ID = & - 'tavg_repeat' // trim(instance) // '_' // buffer - call mpas_add_clock_alarm(clock, & - buffers(b) % repeat_alarm_ID, & + series % buffers(b) % repeat_alarm_ID = trim(alarm_prefix) // & + trim(REPEAT_ALARM_PREFIX) // trim(buf_identifier) + call mpas_add_clock_alarm(domain % clock, & + series % buffers(b) % repeat_alarm_ID, & repeat_time, & - buffers(b) % repeat_interval, ierr=err) + alarms % repeat_interval, ierr=err) - buffers(b) % reset_alarm_ID = & - 'tavg_reset' // trim(instance) // '_' // buffer - call mpas_add_clock_alarm(clock, & - buffers(b) % reset_alarm_ID, & + series % buffers(b) % reset_alarm_ID = trim(alarm_prefix) // & + trim(RESET_ALARM_PREFIX) // trim(buf_identifier) + call mpas_add_clock_alarm(domain % clock, & + series % buffers(b) % reset_alarm_ID, & reset_time, & - buffers(b) % reset_interval, ierr=err) + alarms % reset_interval, ierr=err) end do end subroutine set_alarms -!*********************************************************************** -! routine modify_stream -! -!> \brief Remove existing variables and replace them with new ones -!> \author Jon Woodring -!> \date September 1, 2015 -!> \details -!> Given a stream name, this will remove the existing variables -!> in a stream and replace them with similiarly named ones for -!> their accumulation. It will also add xtime and optionally the mesh. -!----------------------------------------------------------------------- -subroutine modify_stream(domain, stream_name, number_of_variables, & - number_of_buffers, instance, prefix, op, err)!{{{ - ! input variables - integer, intent(in) :: number_of_variables, number_of_buffers - character (len=StrKIND) :: stream_name, instance, prefix, op - - ! input/output variables - type (domain_type), intent(inout) :: domain - - ! output variables - integer, intent(out) :: err !< Output: error flag - - ! local variables - integer :: v, b - character (len=StrKIND) :: field, buffer, config, var - logical, pointer :: copy_mesh - type (Field0DReal), pointer :: src, dst - - ! allocate the variable information - allocate(variables(number_of_variables)) - - ! allocate the state for the buffers - allocate(buffers(number_of_buffers)) - - ! get the old field names - call mpas_stream_mgr_begin_iteration(domain % streamManager, & - stream_name, err) - v = 1 - do while (mpas_stream_mgr_get_next_field(domain % streamManager, & - stream_name, field)) - variables(v) % input_name = field - v = v + 1 - end do - - ! remove the old ones from the stream - do v = 1, number_of_variables - call mpas_stream_mgr_remove_field(domain % streamManager, & - stream_name, variables(v) % input_name) - end do - - ! add xtime to the stream - call mpas_stream_mgr_add_field(domain % streamManager, & - stream_name, 'xtime', ierr=err) - - ! optionally add mesh to stream - config = trim(prefix) // '_add_mesh' - call mpas_pool_get_config(domain % configs, config, copy_mesh) - if (copy_mesh) then - call mpas_stream_mgr_begin_iteration(domain % streamManager, & - 'mesh', err) - do while (mpas_stream_mgr_get_next_field(domain % streamManager, & - 'mesh', field)) - call mpas_stream_mgr_add_field(domain % streamManager, & - stream_name, field, ierr=err) - end do - end if - - ! set up the variables - call mpas_stream_mgr_begin_iteration(domain % streamManager, & - stream_name, err) - do v = 1, number_of_variables - ! allocate space for the names of the outputs - allocate(variables(v) % output_names(number_of_buffers)) - write(var, '(I0)') v - - ! get the info of the field - call mpas_pool_get_field_info(domain % blocklist % allFields, & - variables(v) % input_name, variables(v) % info) - - ! check if we can handle it - if(.not. & - ((variables(v) % info % fieldType == MPAS_POOL_REAL) & - .or. & - (variables(v) % info % fieldType == MPAS_POOL_INTEGER))) & - then - call mpas_dmpar_global_abort('Error: field "' // & - trim(variables(v) % input_name) // '" listed in the ' // & - 'output stream, for time series stats analysis member ' // & - 'stream, is not real or integer.') - end if - - ! allocate a number of fields and add field - do b = 1, number_of_buffers - ! create the name of the new field - write(buffer, '(I0)') b - field = 'time' // trim(instance) // '_' // & - trim(op) // '_' // trim(buffer) // '_' - variables(v) % output_names(b) = trim(field) // & - variables(v) % input_name - - ! create the field and add to pool - call add_new_field(variables(v) % info, & - variables(v) % input_name, field, domain % blocklist % allFields) - - ! add the field to the stream - call mpas_stream_mgr_add_field(domain % streamManager, & - stream_name, variables(v) % output_names(b), ierr=err) - end do - end do ! number_of_variables - - ! add counters to stream - do b = 1, size(buffers) - ! create the name of the counter - write(buffer, '(I0)') b - field = 'time' // trim(instance) // '_' // trim(buffer) // '_counter' - - ! create counter and add to pool - call mpas_pool_get_field(domain % blocklist % allFields, & - 'timeSeriesStatsCounter', src, 1) - call mpas_duplicate_field(src, dst) - dst % fieldName = field - call mpas_pool_add_field(domain % blocklist % allFields, & - field, dst) - - ! add counter to the stream - buffers(b) % output_counter = field - call mpas_stream_mgr_add_field(domain % streamManager, & - stream_name, buffers(b) % output_counter, ierr=err) - end do - -end subroutine modify_stream!}}} - - - !*********************************************************************** ! routine walk_string ! @@ -799,17 +1202,17 @@ end subroutine walk_string!}}} !> Walk a list of times delimited by spaces and set the time info !> for the buffer structure so that alarms can be set. !----------------------------------------------------------------------- -subroutine set_times(buffers, number_of_buffers, clock, & - which, config, ok, err) +subroutine set_times(series, alarms, clock, which, config, ok, err) ! input variables - integer, intent(in) :: number_of_buffers, which + integer, intent(in) :: which character (len=StrKIND), pointer, intent(in) :: config ! input/output variables - type (time_buffer_type), dimension(:), intent(inout) :: buffers + type (time_series_type), intent(inout) :: series type (MPAS_Clock_type), intent(inout) :: clock ! output variables + type (time_series_alarms_type) :: alarms logical, intent(out) :: ok integer, intent(out) :: err @@ -826,35 +1229,34 @@ subroutine set_times(buffers, number_of_buffers, clock, & do while (ok) ! exit if we went over b = b + 1 - if (b > number_of_buffers) then + if (b > series % number_of_buffers) then exit end if ! set the time if (which == START_TIMES) then - if (time == 'initial_time') then - buffers(b) % start_time = mpas_get_clock_time(clock, & - MPAS_START_TIME, err) + if (time == INITIAL_TIME_TOKEN) then + alarms % start_time = mpas_get_clock_time(clock, MPAS_START_TIME, err) else - call mpas_set_time(buffers(b) % start_time, & - dateTimeString=time, ierr=err) + call mpas_set_time(alarms % start_time, dateTimeString=time, ierr=err) end if else if (which == DURATION_INTERVALS) then - if (time == 'repeat_interval') then - buffers(b) % duration_interval = buffers(b) % repeat_interval + if (time == REPEAT_INTERVAL_TOKEN) then + alarms % duration_interval = alarms % repeat_interval else - call mpas_set_timeInterval(buffers(b) % duration_interval, & + call mpas_set_timeInterval(alarms % duration_interval, & timeString=time, ierr=err) end if else if (which == REPEAT_INTERVALS) then - if (time == 'reset_interval') then - buffers(b) % repeat_interval = buffers(b) % reset_interval + if (time == RESET_INTERVAL_TOKEN) then + alarms % repeat_interval = & + alarms % reset_interval else - call mpas_set_timeInterval(buffers(b) % repeat_interval, & + call mpas_set_timeInterval(alarms % repeat_interval, & timeString=time, ierr=err) end if else - call mpas_set_timeInterval(buffers(b) % reset_interval, & + call mpas_set_timeInterval(alarms % reset_interval, & timeString=time, ierr=err) end if @@ -863,7 +1265,7 @@ subroutine set_times(buffers, number_of_buffers, clock, & end do ! only ok if we parsed out as many as there are number of buffers - ok = number_of_buffers == b + ok = series % number_of_buffers == b end subroutine set_times @@ -878,10 +1280,10 @@ end subroutine set_times !> This routine conducts all initializations required for !> duplicating a field and adding it to the allFields pool. !----------------------------------------------------------------------- -subroutine add_new_field(info, inname, prefix, pool)!{{{ +subroutine add_new_field(info, inname, outname, pool)!{{{ ! input variables type (mpas_pool_field_info_type), intent(in) :: info - character (len=StrKIND), intent(in) :: inname, prefix + character (len=StrKIND), intent(in) :: inname, outname ! input/output variables type (mpas_pool_type), intent(inout) :: pool @@ -893,27 +1295,27 @@ subroutine add_new_field(info, inname, prefix, pool)!{{{ ! duplicate field and add new field to pool if (info % fieldType == MPAS_POOL_REAL) then if (info % nDims == 0) then - call copy_field_0r(inname, pool, prefix) + call copy_field_0r(inname, pool, outname) else if (info % nDims == 1) then - call copy_field_1r(inname, pool, prefix) + call copy_field_1r(inname, pool, outname) else if (info % nDims == 2) then - call copy_field_2r(inname, pool, prefix) + call copy_field_2r(inname, pool, outname) else if (info % nDims == 3) then - call copy_field_3r(inname, pool, prefix) + call copy_field_3r(inname, pool, outname) else if (info % nDims == 4) then - call copy_field_4r(inname, pool, prefix) + call copy_field_4r(inname, pool, outname) else - call copy_field_5r(inname, pool, prefix) + call copy_field_5r(inname, pool, outname) end if else if (info % nDims == 0) then - call copy_field_0i(inname, pool, prefix) + call copy_field_0i(inname, pool, outname) else if (info % nDims == 1) then - call copy_field_1i(inname, pool, prefix) + call copy_field_1i(inname, pool, outname) else if (info % nDims == 2) then - call copy_field_2i(inname, pool, prefix) + call copy_field_2i(inname, pool, outname) else - call copy_field_3i(inname, pool, prefix) + call copy_field_3i(inname, pool, outname) end if end if @@ -931,10 +1333,11 @@ end subroutine add_new_field!}}} !> This routine conducts timer checking to determine if it !> needs to run at this particular time. !----------------------------------------------------------------------- -subroutine timer_checking(clock, err)!{{{ +subroutine timer_checking(series, clock, err)!{{{ ! input variables ! input/output variables + type (time_series_type), intent(inout) :: series type (mpas_clock_type), intent(inout) :: clock ! output variables @@ -946,38 +1349,38 @@ subroutine timer_checking(clock, err)!{{{ ! start procedure err = 0 - do b = 1, size(buffers) + do b = 1, series % number_of_buffers ! clear any resets - if (buffers(b) % reset_flag) then - if (buffers(b) % accumulate_flag) then - buffers(b) % reset_flag = .false. + if (series % buffers(b) % reset_flag == 1) then + if (series % buffers(b) % accumulate_flag == 1) then + series % buffers(b) % reset_flag = 0 end if end if ! see if the started alarm is ringing - if (trim(buffers(b) % start_alarm_ID) /= '') then + if (trim(series % buffers(b) % start_alarm_ID) /= '') then if (mpas_is_alarm_ringing(clock, & - buffers(b) % start_alarm_ID, ierr=err)) then + series % buffers(b) % start_alarm_ID, ierr=err)) then call mpas_reset_clock_alarm(clock, & - buffers(b) % start_alarm_ID, ierr=err) - buffers(b) % started_flag = .true. - buffers(b) % reset_flag = .true. - buffers(b) % accumulate_flag = .true. + series % buffers(b) % start_alarm_ID, ierr=err) + series % buffers(b) % started_flag = 1 + series % buffers(b) % reset_flag = 1 + series % buffers(b) % accumulate_flag = 1 end if end if ! if we aren't started, cycle to next buffer - if (.not. buffers(b) % started_flag) then + if (series % buffers(b) % started_flag == 0) then cycle end if ! check various other alarms ! see if we need to reset if(mpas_is_alarm_ringing(clock, & - buffers(b) % reset_alarm_ID, ierr=err)) then + series % buffers(b) % reset_alarm_ID, ierr=err)) then call mpas_reset_clock_alarm(clock, & - buffers(b) % reset_alarm_ID, ierr=err) - buffers(b) % reset_flag = .true. + series % buffers(b) % reset_alarm_ID, ierr=err) + series % buffers(b) % reset_flag = 1 end if ! turn off accumulation @@ -985,20 +1388,20 @@ subroutine timer_checking(clock, err)!{{{ ! duration needs to be >= 2 * compute_interval ! (a series can only be 2 or more) if (mpas_is_alarm_ringing(clock, & - buffers(b) % duration_alarm_ID, ierr=err)) then + series % buffers(b) % duration_alarm_ID, ierr=err)) then call mpas_reset_clock_alarm(clock, & - buffers(b) % duration_alarm_ID, ierr=err) - buffers(b) % accumulate_flag = .false. + series % buffers(b) % duration_alarm_ID, ierr=err) + series % buffers(b) % accumulate_flag = 0 end if ! turn on accumulation ! (this is second, in case the duration and repeat ! overlaps on the same timer) if (mpas_is_alarm_ringing(clock, & - buffers(b) % repeat_alarm_ID, ierr=err)) then + series % buffers(b) % repeat_alarm_ID, ierr=err)) then call mpas_reset_clock_alarm(clock, & - buffers(b) % repeat_alarm_ID, ierr=err) - buffers(b) % accumulate_flag = .true. + series % buffers(b) % repeat_alarm_ID, ierr=err) + series % buffers(b) % accumulate_flag = 1 end if end do @@ -1016,100 +1419,106 @@ end subroutine timer_checking!}}} !> Since we don't know the type of the array, we need to do some !> run-time type switching based on the type of the array. !----------------------------------------------------------------------- -subroutine typed_operate(block, v, operation)!{{{ +subroutine typed_operate(block, variable, buffers, operation)!{{{ ! input variables type (block_type), pointer, intent(in) :: block - integer, intent(in) :: v, operation + integer, intent(in) :: operation + type (time_series_variable_type), intent(in) :: variable + type (time_series_buffer_type), dimension(:), intent(in) :: buffers ! input/output variables ! output variables ! local variables + type (mpas_pool_field_info_type) :: info + + ! get the info + call mpas_pool_get_field_info(block % allFields, variable % input_name, info) ! switch based on the type, dimensionality, and operation - if (variables(v) % info % fieldType == MPAS_POOL_REAL) then - if (variables(v) % info % nDims == 0) then + if (info % fieldType == MPAS_POOL_REAL) then + if (info % nDims == 0) then if (operation == AVG_OP) then - call operate0r_avg(block, variables(v)) + call operate0r_avg(block, variable, buffers) else if (operation == MIN_OP) then - call operate0r_min(block, variables(v)) + call operate0r_min(block, variable, buffers) else - call operate0r_max(block, variables(v)) + call operate0r_max(block, variable, buffers) end if - else if (variables(v) % info % nDims == 1) then + else if (info % nDims == 1) then if (operation == AVG_OP) then - call operate1r_avg(block, variables(v)) + call operate1r_avg(block, variable, buffers) else if (operation == MIN_OP) then - call operate1r_min(block, variables(v)) + call operate1r_min(block, variable, buffers) else - call operate1r_max(block, variables(v)) + call operate1r_max(block, variable, buffers) end if - else if (variables(v) % info % nDims == 2) then + else if (info % nDims == 2) then if (operation == AVG_OP) then - call operate2r_avg(block, variables(v)) + call operate2r_avg(block, variable, buffers) else if (operation == MIN_OP) then - call operate2r_min(block, variables(v)) + call operate2r_min(block, variable, buffers) else - call operate2r_max(block, variables(v)) + call operate2r_max(block, variable, buffers) end if - else if (variables(v) % info % nDims == 3) then + else if (info % nDims == 3) then if (operation == AVG_OP) then - call operate3r_avg(block, variables(v)) + call operate3r_avg(block, variable, buffers) else if (operation == MIN_OP) then - call operate3r_min(block, variables(v)) + call operate3r_min(block, variable, buffers) else - call operate3r_max(block, variables(v)) + call operate3r_max(block, variable, buffers) end if - else if (variables(v) % info % nDims == 4) then + else if (info % nDims == 4) then if (operation == AVG_OP) then - call operate4r_avg(block, variables(v)) + call operate4r_avg(block, variable, buffers) else if (operation == MIN_OP) then - call operate4r_min(block, variables(v)) + call operate4r_min(block, variable, buffers) else - call operate4r_max(block, variables(v)) + call operate4r_max(block, variable, buffers) end if else if (operation == AVG_OP) then - call operate5r_avg(block, variables(v)) + call operate5r_avg(block, variable, buffers) else if (operation == MIN_OP) then - call operate5r_min(block, variables(v)) + call operate5r_min(block, variable, buffers) else - call operate5r_max(block, variables(v)) + call operate5r_max(block, variable, buffers) end if end if else - if (variables(v) % info % nDims == 0) then + if (info % nDims == 0) then if (operation == AVG_OP) then - call operate0i_avg(block, variables(v)) + call operate0i_avg(block, variable, buffers) else if (operation == MIN_OP) then - call operate0i_min(block, variables(v)) + call operate0i_min(block, variable, buffers) else - call operate0i_max(block, variables(v)) + call operate0i_max(block, variable, buffers) end if - else if (variables(v) % info % nDims == 1) then + else if (info % nDims == 1) then if (operation == AVG_OP) then - call operate1i_avg(block, variables(v)) + call operate1i_avg(block, variable, buffers) else if (operation == MIN_OP) then - call operate1i_min(block, variables(v)) + call operate1i_min(block, variable, buffers) else - call operate1i_max(block, variables(v)) + call operate1i_max(block, variable, buffers) end if - else if (variables(v) % info % nDims == 2) then + else if (info % nDims == 2) then if (operation == AVG_OP) then - call operate2i_avg(block, variables(v)) + call operate2i_avg(block, variable, buffers) else if (operation == MIN_OP) then - call operate2i_min(block, variables(v)) + call operate2i_min(block, variable, buffers) else - call operate2i_max(block, variables(v)) + call operate2i_max(block, variable, buffers) end if else if (operation == AVG_OP) then - call operate3i_avg(block, variables(v)) + call operate3i_avg(block, variable, buffers) else if (operation == MIN_OP) then - call operate3i_min(block, variables(v)) + call operate3i_min(block, variable, buffers) else - call operate3i_max(block, variables(v)) + call operate3i_max(block, variable, buffers) end if end if end if @@ -1128,8 +1537,8 @@ end subroutine typed_operate!}}} !> duplicating a field and adding it to the allFields pool based on type. !----------------------------------------------------------------------- -subroutine copy_field_0r(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix +subroutine copy_field_0r(inname, pool, outname)!{{{ + character (len=StrKIND), intent(in) :: inname, outname type (mpas_pool_type), intent(inout) :: pool type (field0DReal), pointer :: src, dst @@ -1138,20 +1547,20 @@ subroutine copy_field_0r(inname, pool, prefix)!{{{ call mpas_pool_get_field(pool, inname, src, 1) call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = outname if (dst % isVarArray) then do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) + dst % constituentNames(i) = trim(outname) // '_' // & + trim(dst % constituentNames(i)) end do end if call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_0r!}}} -subroutine copy_field_1r(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix +subroutine copy_field_1r(inname, pool, outname)!{{{ + character (len=StrKIND), intent(in) :: inname, outname type (mpas_pool_type), intent(inout) :: pool type (field1DReal), pointer :: src, dst @@ -1160,20 +1569,20 @@ subroutine copy_field_1r(inname, pool, prefix)!{{{ call mpas_pool_get_field(pool, inname, src, 1) call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = outname if (dst % isVarArray) then do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) + dst % constituentNames(i) = trim(outname) // '_' // & + trim(dst % constituentNames(i)) end do end if call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_1r!}}} -subroutine copy_field_2r(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix +subroutine copy_field_2r(inname, pool, outname)!{{{ + character (len=StrKIND), intent(in) :: inname, outname type (mpas_pool_type), intent(inout) :: pool type (field2DReal), pointer :: src, dst @@ -1182,20 +1591,20 @@ subroutine copy_field_2r(inname, pool, prefix)!{{{ call mpas_pool_get_field(pool, inname, src, 1) call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = outname if (dst % isVarArray) then do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) + dst % constituentNames(i) = trim(outname) // '_' // & + trim(dst % constituentNames(i)) end do end if call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_2r!}}} -subroutine copy_field_3r(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix +subroutine copy_field_3r(inname, pool, outname)!{{{ + character (len=StrKIND), intent(in) :: inname, outname type (mpas_pool_type), intent(inout) :: pool type (field3DReal), pointer :: src, dst @@ -1204,20 +1613,20 @@ subroutine copy_field_3r(inname, pool, prefix)!{{{ call mpas_pool_get_field(pool, inname, src, 1) call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = outname if (dst % isVarArray) then do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) + dst % constituentNames(i) = trim(outname) // '_' // & + trim(dst % constituentNames(i)) end do end if call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_3r!}}} -subroutine copy_field_4r(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix +subroutine copy_field_4r(inname, pool, outname)!{{{ + character (len=StrKIND), intent(in) :: inname, outname type (mpas_pool_type), intent(inout) :: pool type (field4DReal), pointer :: src, dst @@ -1226,20 +1635,20 @@ subroutine copy_field_4r(inname, pool, prefix)!{{{ call mpas_pool_get_field(pool, inname, src, 1) call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = outname if (dst % isVarArray) then do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) + dst % constituentNames(i) = trim(outname) // '_' // & + trim(dst % constituentNames(i)) end do end if call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_4r!}}} -subroutine copy_field_5r(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix +subroutine copy_field_5r(inname, pool, outname)!{{{ + character (len=StrKIND), intent(in) :: inname, outname type (mpas_pool_type), intent(inout) :: pool type (field5DReal), pointer :: src, dst @@ -1248,20 +1657,20 @@ subroutine copy_field_5r(inname, pool, prefix)!{{{ call mpas_pool_get_field(pool, inname, src, 1) call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = outname if (dst % isVarArray) then do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) + dst % constituentNames(i) = trim(outname) // '_' // & + trim(dst % constituentNames(i)) end do end if call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_5r!}}} -subroutine copy_field_0i(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix +subroutine copy_field_0i(inname, pool, outname)!{{{ + character (len=StrKIND), intent(in) :: inname, outname type (mpas_pool_type), intent(inout) :: pool type (field0DInteger), pointer :: src, dst @@ -1270,20 +1679,20 @@ subroutine copy_field_0i(inname, pool, prefix)!{{{ call mpas_pool_get_field(pool, inname, src, 1) call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = outname if (dst % isVarArray) then do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) + dst % constituentNames(i) = trim(outname) // '_' // & + trim(dst % constituentNames(i)) end do end if call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_0i!}}} -subroutine copy_field_1i(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix +subroutine copy_field_1i(inname, pool, outname)!{{{ + character (len=StrKIND), intent(in) :: inname, outname type (mpas_pool_type), intent(inout) :: pool type (field1DInteger), pointer :: src, dst @@ -1292,20 +1701,20 @@ subroutine copy_field_1i(inname, pool, prefix)!{{{ call mpas_pool_get_field(pool, inname, src, 1) call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = outname if (dst % isVarArray) then do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) + dst % constituentNames(i) = trim(outname) // '_' // & + trim(dst % constituentNames(i)) end do end if call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_1i!}}} -subroutine copy_field_2i(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix +subroutine copy_field_2i(inname, pool, outname)!{{{ + character (len=StrKIND), intent(in) :: inname, outname type (mpas_pool_type), intent(inout) :: pool type (field2DInteger), pointer :: src, dst @@ -1314,20 +1723,20 @@ subroutine copy_field_2i(inname, pool, prefix)!{{{ call mpas_pool_get_field(pool, inname, src, 1) call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = outname if (dst % isVarArray) then do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) + dst % constituentNames(i) = trim(outname) // '_' // & + trim(dst % constituentNames(i)) end do end if call mpas_pool_add_field(pool, dst % fieldName, dst) end subroutine copy_field_2i!}}} -subroutine copy_field_3i(inname, pool, prefix)!{{{ - character (len=StrKIND), intent(in) :: inname, prefix +subroutine copy_field_3i(inname, pool, outname)!{{{ + character (len=StrKIND), intent(in) :: inname, outname type (mpas_pool_type), intent(inout) :: pool type (field3DInteger), pointer :: src, dst @@ -1336,12 +1745,12 @@ subroutine copy_field_3i(inname, pool, prefix)!{{{ call mpas_pool_get_field(pool, inname, src, 1) call mpas_duplicate_field(src, dst) - dst % fieldName = trim(prefix) // dst % fieldName + dst % fieldName = outname if (dst % isVarArray) then do i = 1, size(dst % constituentNames) - dst % constituentNames(i) = trim(prefix) // & - dst % constituentNames(i) + dst % constituentNames(i) = trim(outname) // '_' // & + trim(dst % constituentNames(i)) end do end if @@ -1368,9 +1777,10 @@ end subroutine copy_field_3i!}}} !> have a special case of normalizing the data before writing it !> to disk). !----------------------------------------------------------------------- -subroutine operate0r_avg (start_block, tvar) +subroutine operate0r_avg (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), pointer :: in_array, out_array integer :: b @@ -1379,22 +1789,22 @@ subroutine operate0r_avg (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else out_array = (out_array * & - (buffers(b) % total_accum - 1) + in_array) & - / buffers(b) % total_accum ; + (buffers(b) % counter - 1) + in_array) & + / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1405,9 +1815,10 @@ subroutine operate0r_avg (start_block, tvar) end do end subroutine operate0r_avg -subroutine operate1r_avg (start_block, tvar) +subroutine operate1r_avg (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:), pointer :: in_array, out_array integer :: b @@ -1416,22 +1827,22 @@ subroutine operate1r_avg (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else out_array = (out_array * & - (buffers(b) % total_accum - 1) + in_array) & - / buffers(b) % total_accum ; + (buffers(b) % counter - 1) + in_array) & + / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1442,9 +1853,10 @@ subroutine operate1r_avg (start_block, tvar) end do end subroutine operate1r_avg -subroutine operate2r_avg (start_block, tvar) +subroutine operate2r_avg (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array integer :: b @@ -1453,22 +1865,22 @@ subroutine operate2r_avg (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else out_array = (out_array * & - (buffers(b) % total_accum - 1) + in_array) & - / buffers(b) % total_accum ; + (buffers(b) % counter - 1) + in_array) & + / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1479,9 +1891,10 @@ subroutine operate2r_avg (start_block, tvar) end do end subroutine operate2r_avg -subroutine operate3r_avg (start_block, tvar) +subroutine operate3r_avg (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array integer :: b @@ -1490,22 +1903,22 @@ subroutine operate3r_avg (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else out_array = (out_array * & - (buffers(b) % total_accum - 1) + in_array) & - / buffers(b) % total_accum ; + (buffers(b) % counter - 1) + in_array) & + / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1516,9 +1929,10 @@ subroutine operate3r_avg (start_block, tvar) end do end subroutine operate3r_avg -subroutine operate4r_avg (start_block, tvar) +subroutine operate4r_avg (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array integer :: b @@ -1527,22 +1941,22 @@ subroutine operate4r_avg (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else out_array = (out_array * & - (buffers(b) % total_accum - 1) + in_array) & - / buffers(b) % total_accum ; + (buffers(b) % counter - 1) + in_array) & + / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1553,9 +1967,10 @@ subroutine operate4r_avg (start_block, tvar) end do end subroutine operate4r_avg -subroutine operate5r_avg (start_block, tvar) +subroutine operate5r_avg (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array integer :: b @@ -1564,22 +1979,22 @@ subroutine operate5r_avg (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else out_array = (out_array * & - (buffers(b) % total_accum - 1) + in_array) & - / buffers(b) % total_accum ; + (buffers(b) % counter - 1) + in_array) & + / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1590,9 +2005,10 @@ subroutine operate5r_avg (start_block, tvar) end do end subroutine operate5r_avg -subroutine operate0i_avg (start_block, tvar) +subroutine operate0i_avg (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable integer, pointer :: in_array, out_array integer :: b @@ -1601,22 +2017,22 @@ subroutine operate0i_avg (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else out_array = (out_array * & - (buffers(b) % total_accum - 1) + in_array) & - / buffers(b) % total_accum ; + (buffers(b) % counter - 1) + in_array) & + / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1627,9 +2043,10 @@ subroutine operate0i_avg (start_block, tvar) end do end subroutine operate0i_avg -subroutine operate1i_avg (start_block, tvar) +subroutine operate1i_avg (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable integer, dimension(:), pointer :: in_array, out_array integer :: b @@ -1638,22 +2055,22 @@ subroutine operate1i_avg (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else out_array = (out_array * & - (buffers(b) % total_accum - 1) + in_array) & - / buffers(b) % total_accum ; + (buffers(b) % counter - 1) + in_array) & + / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1664,9 +2081,10 @@ subroutine operate1i_avg (start_block, tvar) end do end subroutine operate1i_avg -subroutine operate2i_avg (start_block, tvar) +subroutine operate2i_avg (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable integer, dimension(:,:), pointer :: in_array, out_array integer :: b @@ -1675,22 +2093,22 @@ subroutine operate2i_avg (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else out_array = (out_array * & - (buffers(b) % total_accum - 1) + in_array) & - / buffers(b) % total_accum ; + (buffers(b) % counter - 1) + in_array) & + / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1701,9 +2119,10 @@ subroutine operate2i_avg (start_block, tvar) end do end subroutine operate2i_avg -subroutine operate3i_avg (start_block, tvar) +subroutine operate3i_avg (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable integer, dimension(:,:,:), pointer :: in_array, out_array integer :: b @@ -1712,22 +2131,22 @@ subroutine operate3i_avg (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else out_array = (out_array * & - (buffers(b) % total_accum - 1) + in_array) & - / buffers(b) % total_accum ; + (buffers(b) % counter - 1) + in_array) & + / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1738,9 +2157,10 @@ subroutine operate3i_avg (start_block, tvar) end do end subroutine operate3i_avg -subroutine operate0r_min (start_block, tvar) +subroutine operate0r_min (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), pointer :: in_array, out_array integer :: b @@ -1749,22 +2169,22 @@ subroutine operate0r_min (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1775,9 +2195,10 @@ subroutine operate0r_min (start_block, tvar) end do end subroutine operate0r_min -subroutine operate1r_min (start_block, tvar) +subroutine operate1r_min (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:), pointer :: in_array, out_array integer :: b @@ -1786,22 +2207,22 @@ subroutine operate1r_min (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1812,9 +2233,10 @@ subroutine operate1r_min (start_block, tvar) end do end subroutine operate1r_min -subroutine operate2r_min (start_block, tvar) +subroutine operate2r_min (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array integer :: b @@ -1823,22 +2245,22 @@ subroutine operate2r_min (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1849,9 +2271,10 @@ subroutine operate2r_min (start_block, tvar) end do end subroutine operate2r_min -subroutine operate3r_min (start_block, tvar) +subroutine operate3r_min (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array integer :: b @@ -1860,22 +2283,22 @@ subroutine operate3r_min (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1886,9 +2309,10 @@ subroutine operate3r_min (start_block, tvar) end do end subroutine operate3r_min -subroutine operate4r_min (start_block, tvar) +subroutine operate4r_min (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array integer :: b @@ -1897,22 +2321,22 @@ subroutine operate4r_min (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1923,9 +2347,10 @@ subroutine operate4r_min (start_block, tvar) end do end subroutine operate4r_min -subroutine operate5r_min (start_block, tvar) +subroutine operate5r_min (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array integer :: b @@ -1934,22 +2359,22 @@ subroutine operate5r_min (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1960,9 +2385,10 @@ subroutine operate5r_min (start_block, tvar) end do end subroutine operate5r_min -subroutine operate0i_min (start_block, tvar) +subroutine operate0i_min (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable integer, pointer :: in_array, out_array integer :: b @@ -1971,22 +2397,22 @@ subroutine operate0i_min (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -1997,9 +2423,10 @@ subroutine operate0i_min (start_block, tvar) end do end subroutine operate0i_min -subroutine operate1i_min (start_block, tvar) +subroutine operate1i_min (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable integer, dimension(:), pointer :: in_array, out_array integer :: b @@ -2008,22 +2435,22 @@ subroutine operate1i_min (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -2034,9 +2461,10 @@ subroutine operate1i_min (start_block, tvar) end do end subroutine operate1i_min -subroutine operate2i_min (start_block, tvar) +subroutine operate2i_min (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable integer, dimension(:,:), pointer :: in_array, out_array integer :: b @@ -2045,22 +2473,22 @@ subroutine operate2i_min (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -2071,9 +2499,10 @@ subroutine operate2i_min (start_block, tvar) end do end subroutine operate2i_min -subroutine operate3i_min (start_block, tvar) +subroutine operate3i_min (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable integer, dimension(:,:,:), pointer :: in_array, out_array integer :: b @@ -2082,22 +2511,22 @@ subroutine operate3i_min (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; @@ -2108,9 +2537,10 @@ subroutine operate3i_min (start_block, tvar) end do end subroutine operate3i_min -subroutine operate0r_max (start_block, tvar) +subroutine operate0r_max (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), pointer :: in_array, out_array integer :: b @@ -2119,22 +2549,22 @@ subroutine operate0r_max (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2145,9 +2575,10 @@ subroutine operate0r_max (start_block, tvar) end do end subroutine operate0r_max -subroutine operate1r_max (start_block, tvar) +subroutine operate1r_max (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:), pointer :: in_array, out_array integer :: b @@ -2156,22 +2587,22 @@ subroutine operate1r_max (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2182,9 +2613,10 @@ subroutine operate1r_max (start_block, tvar) end do end subroutine operate1r_max -subroutine operate2r_max (start_block, tvar) +subroutine operate2r_max (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array integer :: b @@ -2193,22 +2625,22 @@ subroutine operate2r_max (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2219,9 +2651,10 @@ subroutine operate2r_max (start_block, tvar) end do end subroutine operate2r_max -subroutine operate3r_max (start_block, tvar) +subroutine operate3r_max (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array integer :: b @@ -2230,22 +2663,22 @@ subroutine operate3r_max (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2256,9 +2689,10 @@ subroutine operate3r_max (start_block, tvar) end do end subroutine operate3r_max -subroutine operate4r_max (start_block, tvar) +subroutine operate4r_max (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array integer :: b @@ -2267,22 +2701,22 @@ subroutine operate4r_max (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2293,9 +2727,10 @@ subroutine operate4r_max (start_block, tvar) end do end subroutine operate4r_max -subroutine operate5r_max (start_block, tvar) +subroutine operate5r_max (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array integer :: b @@ -2304,22 +2739,22 @@ subroutine operate5r_max (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2330,9 +2765,10 @@ subroutine operate5r_max (start_block, tvar) end do end subroutine operate5r_max -subroutine operate0i_max (start_block, tvar) +subroutine operate0i_max (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable integer, pointer :: in_array, out_array integer :: b @@ -2341,22 +2777,22 @@ subroutine operate0i_max (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2367,9 +2803,10 @@ subroutine operate0i_max (start_block, tvar) end do end subroutine operate0i_max -subroutine operate1i_max (start_block, tvar) +subroutine operate1i_max (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable integer, dimension(:), pointer :: in_array, out_array integer :: b @@ -2378,22 +2815,22 @@ subroutine operate1i_max (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2404,9 +2841,10 @@ subroutine operate1i_max (start_block, tvar) end do end subroutine operate1i_max -subroutine operate2i_max (start_block, tvar) +subroutine operate2i_max (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable integer, dimension(:,:), pointer :: in_array, out_array integer :: b @@ -2415,22 +2853,22 @@ subroutine operate2i_max (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; @@ -2441,9 +2879,10 @@ subroutine operate2i_max (start_block, tvar) end do end subroutine operate2i_max -subroutine operate3i_max (start_block, tvar) +subroutine operate3i_max (start_block, variable, buffers) type (block_type), pointer, intent(in) :: start_block - type (time_variable_type), intent(inout) :: tvar + type (time_series_buffer_type), dimension(:), intent(in) :: buffers + type (time_series_variable_type), intent(in) :: variable integer, dimension(:,:,:), pointer :: in_array, out_array integer :: b @@ -2452,22 +2891,22 @@ subroutine operate3i_max (start_block, tvar) block => start_block do while (associated(block)) call mpas_pool_get_array(block % allFields, & - tvar % input_name, in_array, 1) + variable % input_name, in_array, 1) do b = 1, size(buffers) - if (.not. buffers(b) % accumulate_flag) then + if (buffers(b) % accumulate_flag == 0) then cycle end if call mpas_pool_get_array(block % allFields, & - tvar % output_names(b), out_array, 1) + variable % output_names(b), out_array, 1) - if (buffers(b) % reset_flag) then + if (buffers(b) % reset_flag == 1) then out_array = in_array else ! out_array = (out_array * & -! (buffers(b) % total_accum - 1) + in_array) & -! / buffers(b) % total_accum ; +! (buffers(b) % counter - 1) + in_array) & +! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; From afafbb8b099cd22bea6cc0b540edbefb671c4ebe Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Fri, 11 Sep 2015 12:41:20 -0600 Subject: [PATCH 0229/1724] Forgot to make a numerical comparison for integer flags. --- src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index cf299a91fb..5a5fe3d666 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -253,8 +253,8 @@ subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ ! update the counter do b = 1, series % number_of_buffers - if (series % buffers(b) % accumulate_flag) then - if (series % buffers(b) % reset_flag) then + if (series % buffers(b) % accumulate_flag == 1) then + if (series % buffers(b) % reset_flag == 1) then series % buffers(b) % counter = 1 else series % buffers(b) % counter = series % buffers(b) % counter + 1 From 5240a1b85ec3b0aa8ef50b0bb79b2555350a445b Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Fri, 11 Sep 2015 15:22:30 -0600 Subject: [PATCH 0230/1724] getting .nc output from analysis driver now but compute portion of analysis member not being called for some reason --- .../analysis_members/Registry_analysis_members.xml | 2 +- .../analysis_members/mpas_li_analysis_driver.F | 1 + .../analysis_members/mpas_li_global_stats.F | 12 ++++++++++-- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/src/core_landice/analysis_members/Registry_analysis_members.xml b/src/core_landice/analysis_members/Registry_analysis_members.xml index 49f051d7ac..0a4e51c4f4 100644 --- a/src/core_landice/analysis_members/Registry_analysis_members.xml +++ b/src/core_landice/analysis_members/Registry_analysis_members.xml @@ -1 +1 @@ -//#include "Registry_global_stats.xml" +#include "Registry_global_stats.xml" diff --git a/src/core_landice/analysis_members/mpas_li_analysis_driver.F b/src/core_landice/analysis_members/mpas_li_analysis_driver.F index 89477fa1d1..d31c2f7bd9 100644 --- a/src/core_landice/analysis_members/mpas_li_analysis_driver.F +++ b/src/core_landice/analysis_members/mpas_li_analysis_driver.F @@ -503,6 +503,7 @@ subroutine li_analysis_restart(domain, err)!{{{ integer :: nameLength err = 0 + timeLevel=1 call mpas_timer_start('analysis_restart', .false.) diff --git a/src/core_landice/analysis_members/mpas_li_global_stats.F b/src/core_landice/analysis_members/mpas_li_global_stats.F index ef610e999d..7990579d5f 100644 --- a/src/core_landice/analysis_members/mpas_li_global_stats.F +++ b/src/core_landice/analysis_members/mpas_li_global_stats.F @@ -104,6 +104,8 @@ subroutine li_init_global_stats(domain, memberName, err)!{{{ err = 0 + print *, 'in li_init_global_stats' + end subroutine li_init_global_stats!}}} !*********************************************************************** @@ -260,8 +262,8 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ totalIceVolume = totalIceVolume + real( iceMask(iCell), RKIND) * areaCell(iCell) * thickness(iCell) ! debugging - print *, 'totalIceArea=', totalIceArea - print *, 'totalIceVolume=', totalIceVolume +! print *, 'totalIceArea=', totalIceArea +! print *, 'totalIceVolume=', totalIceVolume ! calculate grounded ice area and volume groundedIceArea = groundedIceArea + real( groundedMask(iCell), RKIND) * areaCell(iCell) @@ -294,6 +296,8 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ block => block % next end do + print *, 'in li_compute_global_stats' + end subroutine li_compute_global_stats!}}} !*********************************************************************** @@ -343,6 +347,8 @@ subroutine li_restart_global_stats(domain, memberName, err)!{{{ err = 0 + print *, 'in li_restart_global_stats' + end subroutine li_restart_global_stats!}}} !*********************************************************************** @@ -392,6 +398,8 @@ subroutine li_finalize_global_stats(domain, memberName, err)!{{{ err = 0 + print *, 'in li_finalize_global_stats' + end subroutine li_finalize_global_stats!}}} end module li_global_stats From fa59e9d0d68b7d8622f969be6e2cdc689ea0e1ae Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Sat, 12 Sep 2015 23:55:58 -0600 Subject: [PATCH 0231/1724] add call to compute on startup for analysis member; comment out non-working (gives seg fault) AM code --- .../mpas_li_analysis_driver.F | 1 - .../analysis_members/mpas_li_global_stats.F | 204 +++++++++--------- src/core_landice/mode_forward/mpas_li_core.F | 14 +- 3 files changed, 114 insertions(+), 105 deletions(-) diff --git a/src/core_landice/analysis_members/mpas_li_analysis_driver.F b/src/core_landice/analysis_members/mpas_li_analysis_driver.F index d31c2f7bd9..89477fa1d1 100644 --- a/src/core_landice/analysis_members/mpas_li_analysis_driver.F +++ b/src/core_landice/analysis_members/mpas_li_analysis_driver.F @@ -503,7 +503,6 @@ subroutine li_analysis_restart(domain, err)!{{{ integer :: nameLength err = 0 - timeLevel=1 call mpas_timer_start('analysis_restart', .false.) diff --git a/src/core_landice/analysis_members/mpas_li_global_stats.F b/src/core_landice/analysis_members/mpas_li_global_stats.F index 7990579d5f..54b39f68cc 100644 --- a/src/core_landice/analysis_members/mpas_li_global_stats.F +++ b/src/core_landice/analysis_members/mpas_li_global_stats.F @@ -191,112 +191,114 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ real (kind=RKIND), pointer :: floatingIceArea real (kind=RKIND), pointer :: floatingIceVolume + print *, 'in li_compute_global_stats (start)' + err = 0 dminfo = domain % dminfo ! initialize scalar global sums and work masks to zero - totalIceArea = 0.0_RKIND - totalIceVolume = 0.0_RKIND - groundedIceArea = 0.0_RKIND - groundedIceVolume = 0.0_RKIND - floatingIceArea = 0.0_RKIND - floatingIceVolume = 0.0_RKIND - iceMask = 0 - groundedMask = 0 - floatingMask = 0 - - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', statePool) - call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) - call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) - call mpas_pool_get_subpool(block % structs, 'globalStatsAM', globalStatsAMPool) - - call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) - - ! Here are some example variables which may be needed for your analysis member -! call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) - -! call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) -! call mpas_pool_get_dimension(block % dimensions, 'nEdgesSolve', nEdgesSolve) -! call mpas_pool_get_dimension(block % dimensions, 'nVerticesSolve', nVerticesSolve) - - call mpas_pool_get_array(meshPool, 'areaCell', areaCell) -! call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) -! call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) -! call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) -! call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) -! call mpas_pool_get_array(meshPool, 'maxLevelVertexBot', maxLevelVertexBot) - - call mpas_pool_get_array(geometryPool, 'thickness', thickness) - call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) - - call mpas_pool_get_array(globalStatsAMPool, 'totalIceArea', totalIceArea) - call mpas_pool_get_array(globalStatsAMPool, 'totalIceVolume', totalIceVolume) - call mpas_pool_get_array(globalStatsAMPool, 'floatingIceArea', floatingIceArea) - call mpas_pool_get_array(globalStatsAMPool, 'floatingIceVolume', floatingIceVolume) - call mpas_pool_get_array(globalStatsAMPool, 'groundedIceArea', groundedIceArea) - call mpas_pool_get_array(globalStatsAMPool, 'groundedIceVolume', groundedIceVolume) - - ! populate work masks (1 and 0 based for multiplication of area and thickness fields) - where( cellMask == 32 ); iceMask = 1; endwhere - where( cellMask == 4 ); floatingMask = 1; endwhere - groundedMask = iceMask - floatingMask - - ! Computations which are functions of nCells, nEdges, or nVertices - ! must be placed within this block loop - ! Here are some example loops - do iCell = 1,nCellsSolve - -! do k = 1, maxLevelCell(iCell) -! do iTracer = 1, num_tracers - ! computations on tracers(iTracer,k, iCell) -! end do -! end do - - ! calculate total ice area and volume - totalIceArea = totalIceArea + real( iceMask(iCell), RKIND) * areaCell(iCell) - totalIceVolume = totalIceVolume + real( iceMask(iCell), RKIND) * areaCell(iCell) * thickness(iCell) - - ! debugging -! print *, 'totalIceArea=', totalIceArea -! print *, 'totalIceVolume=', totalIceVolume - - ! calculate grounded ice area and volume - groundedIceArea = groundedIceArea + real( groundedMask(iCell), RKIND) * areaCell(iCell) - groundedIceVolume = groundedIceVolume + real( groundedMask(iCell), RKIND) * areaCell(iCell) * thickness(iCell) - - ! calculate floating ice area and volume - floatingIceArea = floatingIceArea + real( floatingMask(iCell), RKIND) * areaCell(iCell) - floatingIceVolume = floatingIceVolume + real( floatingMask(iCell), RKIND) * areaCell(iCell) * thickness(iCell) - - end do - - block => block % next - end do - - ! mpi gather/scatter calls may be placed here. - ! Here are some examples. See mpas_oac_global_stats.F for further details. -! call mpas_dmpar_sum_real_array(dminfo, nVariables, sumSquares(1:nVariables), reductions(1:nVariables)) -! call mpas_dmpar_min_real_array(dminfo, nMins, mins(1:nMins), reductions(1:nMins)) -! call mpas_dmpar_max_real_array(dminfo, nMaxes, maxes(1:nMaxes), reductions(1:nMaxes)) - - ! Even though some variables do not include an index that is decomposed amongst - ! domain partitions, we assign them within a block loop so that all blocks have the - ! correct values for writing output. - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'globalStatsAM', globalStatsAMPool) - - ! assignment of final globalStatsAM variables could occur here. - - block => block % next - end do - - print *, 'in li_compute_global_stats' +! totalIceArea = 0.0_RKIND +! totalIceVolume = 0.0_RKIND +! groundedIceArea = 0.0_RKIND +! groundedIceVolume = 0.0_RKIND +! floatingIceArea = 0.0_RKIND +! floatingIceVolume = 0.0_RKIND +! iceMask = 0 +! groundedMask = 0 +! floatingMask = 0 + +! block => domain % blocklist +! do while (associated(block)) +! call mpas_pool_get_subpool(block % structs, 'state', statePool) +! call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) +! call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) +! call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) +! call mpas_pool_get_subpool(block % structs, 'globalStatsAM', globalStatsAMPool) +! +! call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) +! +! ! Here are some example variables which may be needed for your analysis member +!! call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) +! +!! call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) +! call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) +!! call mpas_pool_get_dimension(block % dimensions, 'nEdgesSolve', nEdgesSolve) +!! call mpas_pool_get_dimension(block % dimensions, 'nVerticesSolve', nVerticesSolve) +! +! call mpas_pool_get_array(meshPool, 'areaCell', areaCell) +!! call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) +!! call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) +!! call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) +!! call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) +!! call mpas_pool_get_array(meshPool, 'maxLevelVertexBot', maxLevelVertexBot) +! +! call mpas_pool_get_array(geometryPool, 'thickness', thickness) +! call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) +! +! call mpas_pool_get_array(globalStatsAMPool, 'totalIceArea', totalIceArea) +! call mpas_pool_get_array(globalStatsAMPool, 'totalIceVolume', totalIceVolume) +! call mpas_pool_get_array(globalStatsAMPool, 'floatingIceArea', floatingIceArea) +! call mpas_pool_get_array(globalStatsAMPool, 'floatingIceVolume', floatingIceVolume) +! call mpas_pool_get_array(globalStatsAMPool, 'groundedIceArea', groundedIceArea) +! call mpas_pool_get_array(globalStatsAMPool, 'groundedIceVolume', groundedIceVolume) +! +! ! populate work masks (1 and 0 based for multiplication of area and thickness fields) +! where( cellMask == 32 ); iceMask = 1; endwhere +! where( cellMask == 4 ); floatingMask = 1; endwhere +! groundedMask = iceMask - floatingMask +! +! ! Computations which are functions of nCells, nEdges, or nVertices +! ! must be placed within this block loop +! ! Here are some example loops +!! do iCell = 1,nCellsSolve +! +!! do k = 1, maxLevelCell(iCell) +!! do iTracer = 1, num_tracers +! ! computations on tracers(iTracer,k, iCell) +!! end do +!! end do +! +! ! calculate total ice area and volume +! totalIceArea = totalIceArea + real( iceMask(iCell), RKIND) * areaCell(iCell) +! totalIceVolume = totalIceVolume + real( iceMask(iCell), RKIND) * areaCell(iCell) * thickness(iCell) +! +! ! debugging +!! print *, 'totalIceArea=', totalIceArea +!! print *, 'totalIceVolume=', totalIceVolume +! +! ! calculate grounded ice area and volume +! groundedIceArea = groundedIceArea + real( groundedMask(iCell), RKIND) * areaCell(iCell) +! groundedIceVolume = groundedIceVolume + real( groundedMask(iCell), RKIND) * areaCell(iCell) * thickness(iCell) +! +! ! calculate floating ice area and volume +! floatingIceArea = floatingIceArea + real( floatingMask(iCell), RKIND) * areaCell(iCell) +! floatingIceVolume = floatingIceVolume + real( floatingMask(iCell), RKIND) * areaCell(iCell) * thickness(iCell) +! +!! end do +! +! block => block % next +! end do +! +! ! mpi gather/scatter calls may be placed here. +! ! Here are some examples. See mpas_oac_global_stats.F for further details. +!! call mpas_dmpar_sum_real_array(dminfo, nVariables, sumSquares(1:nVariables), reductions(1:nVariables)) +!! call mpas_dmpar_min_real_array(dminfo, nMins, mins(1:nMins), reductions(1:nMins)) +!! call mpas_dmpar_max_real_array(dminfo, nMaxes, maxes(1:nMaxes), reductions(1:nMaxes)) +! +! ! Even though some variables do not include an index that is decomposed amongst +! ! domain partitions, we assign them within a block loop so that all blocks have the +! ! correct values for writing output. +! block => domain % blocklist +! do while (associated(block)) +! call mpas_pool_get_subpool(block % structs, 'globalStatsAM', globalStatsAMPool) +! +! ! assignment of final globalStatsAM variables could occur here. +! +! block => block % next +! end do + + print *, 'in li_compute_global_stats (end)' end subroutine li_compute_global_stats!}}} diff --git a/src/core_landice/mode_forward/mpas_li_core.F b/src/core_landice/mode_forward/mpas_li_core.F index 37a5c64e04..9429afaa0d 100644 --- a/src/core_landice/mode_forward/mpas_li_core.F +++ b/src/core_landice/mode_forward/mpas_li_core.F @@ -289,6 +289,10 @@ function li_core_run(domain) result(err) call mpas_timer_stop("compute_statistics") endif + !SFP added: compute analysis members on startup if option activiated + call li_analysis_compute_startup(domain, err_tmp) + err = ior(err, err_tmp) + ! === ! === Write Initial Output ! === @@ -421,9 +425,13 @@ function li_core_run(domain) result(err) err = ior(err, err_tmp) !SFP added: call analysis driver compute, etc. - call li_analysis_compute(domain, err) - call li_analysis_restart(domain, err) - call li_analysis_write(domain, err) + call li_analysis_compute(domain, err_tmp) + err = ior(err, err_tmp) + +! call li_analysis_restart(domain, err) + + call li_analysis_write(domain, err_tmp) + err = ior(err, err_tmp) ! === error check and exit call mpas_dmpar_max_int(domain % dminfo, err, globalErr) ! Find out if any blocks got an error From 7d730126a48fe759c66addd4a33a0080ff21f0c0 Mon Sep 17 00:00:00 2001 From: Mauro Perego Date: Thu, 3 Sep 2015 09:50:11 -0600 Subject: [PATCH 0232/1724] add function procsSharingVertex to dycore interface This function computes the ranks of processes that share a vertex. This is called by Albany-Felix starting with Albany hash: 39ed4d5f0c4fb790622cfeaa7943806afd0ef9e1 (Sept. 3, 2015) to optimize the construction of the FE grid. (Albany builds newer than that commit will require this change to MPAS. --- .../Interface_velocity_solver.cpp | 33 ++++++++++++++++--- .../Interface_velocity_solver.hpp | 1 + 2 files changed, 30 insertions(+), 4 deletions(-) diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.cpp b/src/core_landice/mode_forward/Interface_velocity_solver.cpp index d086bde09e..ef1dff7b55 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.cpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.cpp @@ -29,7 +29,7 @@ int nVertices, nEdges, nTriangles, nGlobalVertices, nGlobalEdges, int maxNEdgesOnCell_F; int const *cellsOnEdge_F, *cellsOnVertex_F, *verticesOnCell_F, *verticesOnEdge_F, *edgesOnCell_F, *indexToCellID_F, *nEdgesOnCells_F, - *dirichletCellsMask_F, *floatingEdgesMask_F; + *dirichletCellsMask_F, *floatingEdgesMask_F, *verticesMask_F; std::vector layersRatio, levelsNormalizedThickness; int nLayers; double const *xCell_F, *yCell_F, *zCell_F, *xVertex_F, *yVertex_F, *zVertex_F, *areaTriangle_F; @@ -47,7 +47,8 @@ int ice_present_bit_value; //void *phgGrid = 0; std::vector edgesToReceive, fCellsToReceive, indexToTriangleID, - verticesOnTria, trianglesOnEdge, trianglesPositionsOnEdge, verticesOnEdge; + verticesOnTria, trianglesOnEdge, trianglesPositionsOnEdge, verticesOnEdge, + trianglesProcIds, reduced_ranks; std::vector indexToVertexID, vertexToFCell, indexToEdgeID, edgeToFEdge, mask, fVertexToTriangleID, fCellToVertex, floatingEdgesIds, dirichletNodesIDs; std::vector temperatureOnTetra, velocityOnVertices, velocityOnCells, @@ -160,6 +161,9 @@ void velocity_solver_set_grid_data(int const* _nCells_F, int const* _nEdges_F, recvVerticesList_F = new exchangeList_Type( unpackMpiArray(recvVerticesArray_F)); + trianglesProcIds.resize(nVertices_F); + getProcIds(trianglesProcIds, recvVerticesList_F); + if (radius > 10) { xCellProjected.resize(nCells_F); yCellProjected.resize(nCells_F); @@ -491,9 +495,10 @@ void velocity_solver_finalize() { * */ -void velocity_solver_compute_2d_grid(int const* verticesMask_F, int const* _dirichletCellsMask_F, int const* _floatingEdgesMask_F) { +void velocity_solver_compute_2d_grid(int const* _verticesMask_F, int const* _dirichletCellsMask_F, int const* _floatingEdgesMask_F) { int numProcs, me; + verticesMask_F = _verticesMask_F; dirichletCellsMask_F = _dirichletCellsMask_F; floatingEdgesMask_F = _floatingEdgesMask_F; @@ -1379,9 +1384,12 @@ void createReducedMPI(int nLocalEntities, MPI_Comm& reduced_comm_id) { int nonEmpty = int(nLocalEntities > 0); MPI_Allgather(&nonEmpty, 1, MPI_INT, &haveElements[0], 1, MPI_INT, comm); std::vector ranks; + reduced_ranks.resize(numProcs,0); for (int i = 0; i < numProcs; i++) { - if (haveElements[i]) + if (haveElements[i]) { + reduced_ranks[i] = ranks.size(); ranks.push_back(i); + } } MPI_Comm_group(comm, &world_group_id); @@ -1783,3 +1791,20 @@ int prismType(long long int const* prismVertexMpasIds, int& minIndex) } } + void procsSharingVertex(const int vertex, std::vector& procIds) { + int fCell = vertexToFCell[vertex]; + procIds.clear(); + int nEdg = nEdgesOnCells_F[fCell]; + int me; + MPI_Comm_rank(comm, &me); + procIds.reserve(nEdg); + for(int i=0; i > >& prismStruct, const std::vector& prismFaceIds, std::vector& tetraPos, std::vector& facePos); void tetrasFromPrismStructured (int const* prismVertexMpasIds, int const* prismVertexGIds, int tetrasIdsOnPrism[][4]); +void procsSharingVertex(const int vertex, std::vector& procIds); bool belongToTria(double const* x, double const* t, double bcoords[3], double eps = 1e-3); From d19d29dab3a9f10ec2d8ba4c21bbe9f275ac4907 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Thu, 10 Sep 2015 16:07:05 -0600 Subject: [PATCH 0233/1724] added a 1d CVT generator option to vertical grid --- src/core_ocean/Registry.xml | 14 ++++ .../mode_init/mpas_ocn_init_vertical_grids.F | 69 ++++++++++++++++++- 2 files changed, 82 insertions(+), 1 deletion(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 6424740e43..5dd75bd87a 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -160,6 +160,20 @@ possible_values="'uniform', ..." /> + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F index ed4cb87146..2440cf6222 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F @@ -69,11 +69,12 @@ module ocn_init_vertical_grids !> 0 being the top of top layer and 1 being the bottom of bottom layer ! !----------------------------------------------------------------------- - subroutine ocn_generate_vertical_grid(gridType, interfaceLocations)!{{{ + subroutine ocn_generate_vertical_grid(gridType, interfaceLocations, configPool)!{{{ implicit none character (len=*), intent(in) :: gridType real (kind=RKIND), dimension(:), intent(out) :: interfaceLocations + type (mpas_pool_type), optional, intent(in) :: configPool !< Input: Pool with namelist options if ( trim(gridType) == 'uniform' ) then call ocn_generate_uniform_vertical_grid(interfaceLocations) @@ -83,6 +84,12 @@ subroutine ocn_generate_vertical_grid(gridType, interfaceLocations)!{{{ call ocn_generate_42layerWOCE_vertical_grid(interfaceLocations) else if ( trim(gridType) == '100layerACMEv1' ) then call ocn_generate_100layerACMEv1_vertical_grid(interfaceLocations) + else if ( trim(gridType) == '1dCVTgenerator' ) then + if (.not. present(configPool)) then + call mpas_dmpar_global_abort("ERROR: requesting a 1d CVT vertical grid generation without passing the corresponding parameters. Exiting...") + else + call ocn_generate_1dCVT_vertical_grid(configPool, interfaceLocations) + end if else write(stderrUnit, *) ' WARNING: '//trim(gridType)//' is an invalid vertical grid choice. No vertical grid will be generated.' end if @@ -423,6 +430,66 @@ subroutine ocn_generate_100layerACMEv1_vertical_grid(interfaceLocations)!{{{ end subroutine ocn_generate_100layerACMEv1_vertical_grid!}}} + +!*********************************************************************** +! +! routine ocn_generate_1dCVT_vertical_grid +! +!> \brief 1D CVT vertical grid generator +!> \author Juan A. Saenz +!> \date 09/10/2015 +!> \details +!> This routine generates a vertical grid with total depth = 1. +!> This code is adapted from Todd's cvt_1d code. +! +!----------------------------------------------------------------------- + + subroutine ocn_generate_1dCVT_vertical_grid(configPool, interfaceLocations)!{{{ + + type (mpas_pool_type), intent(in) :: configPool + real (kind=RKIND), dimension(:), intent(out) :: interfaceLocations + + integer :: k + integer :: nInterfaces, nVertLevels + real (kind=RKIND) :: stretch1 + real (kind=RKIND) :: stretch2 + real (kind=RKIND) :: dzSeed + + real (kind=RKIND) :: stretch + real (kind=RKIND) :: dz + real (kind=RKIND) :: maxInterfaceLocation + + real (kind=RKIND), pointer :: config_1dCVTgenerator_stretch1 + real (kind=RKIND), pointer :: config_1dCVTgenerator_stretch2 + real (kind=RKIND), pointer :: config_1dCVTgenerator_dzSeed + + call mpas_pool_get_config(configPool, 'config_1dCVTgenerator_stretch1', config_1dCVTgenerator_stretch1) + call mpas_pool_get_config(configPool, 'config_1dCVTgenerator_stretch2', config_1dCVTgenerator_stretch2) + call mpas_pool_get_config(configPool, 'config_1dCVTgenerator_dzSeed', config_1dCVTgenerator_dzSeed) + + stretch1 = config_1dCVTgenerator_stretch1 + stretch2 = config_1dCVTgenerator_stretch2 + dzSeed = config_1dCVTgenerator_dzSeed + + nInterfaces = size(interfaceLocations, dim=1) + nVertLevels = nInterfaces - 1 + + ! compute profile starting at top and stretch dz as we move down + dz = dzSeed + interfaceLocations(1) = 0.0_RKIND + interfaceLocations(2) = dz + do k=2,nVertLevels + stretch = stretch1 + (stretch2-stretch1)*k/nVertLevels + dz = stretch*dz + interfaceLocations(k+1) = interfaceLocations(k) + dz + enddo + + ! normalize so that positions span 0 to 1 + maxInterfaceLocation = maxval(interfaceLocations) + interfaceLocations(:) = interfaceLocations(:) / maxInterfaceLocation + + end subroutine ocn_generate_1dCVT_vertical_grid!}}} + !*********************************************************************** end module ocn_init_vertical_grids From 80fb26d62b07784ba33310617686c88870446154 Mon Sep 17 00:00:00 2001 From: "Juan A. Saenz" Date: Thu, 10 Sep 2015 15:13:30 -0600 Subject: [PATCH 0234/1724] Fixing issues with the iso configuration This commit updates the piston velocity for the ISO configuration. And adds a check to see if the debugTracers are present before assigning them values. --- src/core_ocean/mode_init/Registry_iso.xml | 2 +- src/core_ocean/mode_init/mpas_ocn_init_iso.F | 6 ++++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/mode_init/Registry_iso.xml b/src/core_ocean/mode_init/Registry_iso.xml index 3a29fa9c8e..91d0d182c6 100644 --- a/src/core_ocean/mode_init/Registry_iso.xml +++ b/src/core_ocean/mode_init/Registry_iso.xml @@ -219,7 +219,7 @@ description="Radius of heat flux localized region 2." possible_values="Any real number." /> - diff --git a/src/core_ocean/mode_init/mpas_ocn_init_iso.F b/src/core_ocean/mode_init/mpas_ocn_init_iso.F index 56333fa5d8..0cf461d0da 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_iso.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_iso.F @@ -350,7 +350,7 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ ! Define interface locations allocate( interfaceLocations( nVertLevelsP1 ) ) - call ocn_generate_vertical_grid( config_vertical_grid, interfaceLocations ) + call ocn_generate_vertical_grid( config_vertical_grid, interfaceLocations, domain % configs ) ! assign config variables nVertLevels = config_iso_vert_levels @@ -676,7 +676,9 @@ subroutine ocn_init_setup_iso(domain, iErr)!{{{ ! Set up debugging tracers idx = index_tracer1 - debugTracers(idx, :, iCell) = 1.0_RKIND + if ( associated(debugTracers) ) then + debugTracers(idx, :, iCell) = 1.0_RKIND + end if ! Heat fluxes heatFluxZonal = 0.0_RKIND From ad09f38d3499035e016d0f8de154ece33f8e11ab Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Mon, 14 Sep 2015 15:44:37 -0600 Subject: [PATCH 0235/1724] Remove duplicated code to initialize restoring This commit removes some duplicated code to initialize restoring fields for the global ocean configuration. Previously, these fields were initialized two times in the global ocean model. --- .../mode_init/mpas_ocn_init_global_ocean.F | 85 +++++++++---------- 1 file changed, 39 insertions(+), 46 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F index cf31b02303..20e917ca67 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F @@ -1013,13 +1013,6 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) call mpas_pool_get_array(tracersPool, 'debugTracers', debugTracers, 1) - call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) - call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) - call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersPistonVelocity', activeTracersPistonVelocity, 1) - call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersSurfaceRestoringValue', activeTracersSurfaceRestoringValue, 1) - call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringRate', activeTracersInteriorRestoringRate, 1) - call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringValue', activeTracersInteriorRestoringValue, 1) - if (config_global_ocean_tracer_method .eq. "nearest_neighbor") then do iCell = 1, nCells currentLat = latCell(iCell) @@ -1148,33 +1141,6 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ call mpas_dmpar_finalize(domain % dminfo) endif - ! set surface restoring values and rate - do iCell=1,nCells - if ( associated(activeTracersSurfaceRestoringValue) .and. associated(activeTracers) ) then - activeTracersSurfaceRestoringValue(idxTemperature, iCell) = activeTracers(idxTemperature, 1, iCell) - activeTracersSurfaceRestoringValue(idxSalinity, iCell) = activeTracers(idxSalinity, 1, iCell) - end if - - if ( associated(activeTracersPistonVelocity) ) then - activeTracersPistonVelocity(idxTemperature, iCell) = config_global_ocean_piston_velocity - activeTracersPistonVelocity(idxSalinity, iCell) = config_global_ocean_piston_velocity - end if - enddo - - ! set interior restoring values and rate - do iCell=1,nCells - do k = 1, maxLevelCell(iCell) - if ( associated(activeTracersInteriorRestoringValue) .and. associated(activeTracers) ) then - activeTracersInteriorRestoringValue(idxTemperature, k, iCell) = activeTracers(idxTemperature, k, iCell) - activeTracersInteriorRestoringValue(idxSalinity, k, iCell) = activeTracers(idxSalinity, k, iCell) - end if - - if ( associated(activeTracersInteriorRestoringRate) ) then - activeTracersInteriorRestoringRate(idxTemperature, k, iCell) = config_global_ocean_interior_restore_rate - activeTracersInteriorRestoringRate(idxSalinity, k, iCell) = config_global_ocean_interior_restore_rate - end if - enddo - enddo block_ptr => block_ptr % next end do @@ -1211,11 +1177,6 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) - call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) - call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) - call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersSurfaceRestoringValue', activeTracersSurfaceRestoringValue, 1) - call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringValue', activeTracersInteriorRestoringValue, 1) - call mpas_pool_get_array(scratchPool, 'smoothedTemperature', smoothedTemperature) call mpas_pool_get_array(scratchPool, 'smoothedSalinity', smoothedSalinity) @@ -1255,13 +1216,6 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ activeTracers(idxSalinity, :, :) = smoothedsalinity(:,:) end if - if ( associated(activeTracersInteriorRestoringValue) .and. associated(activeTracers) ) then - activeTracersInteriorRestoringValue(:,:,:) = activeTracers(:,:,:) - end if - if ( associated(activeTracersSurfaceRestoringValue) .and. associated(activeTracers) ) then - activeTracersSurfaceRestoringValue(:,:) = activeTracers(:,1,:) - end if - block_ptr => block_ptr % next end do @@ -1280,6 +1234,45 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ call mpas_deallocate_scratch_field(smoothedSalinityField, .false.) endif + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) + call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersSurfaceRestoringValue', activeTracersSurfaceRestoringValue, 1) + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersPistonVelocity', activeTracersPistonVelocity, 1) + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringValue', activeTracersInteriorRestoringValue, 1) + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, 'activeTracersInteriorRestoringRate', activeTracersInteriorRestoringRate, 1) + + ! set interior restoring values and rate + if ( associated(activeTracersInteriorRestoringValue) .and. associated(activeTracers) ) then + activeTracersInteriorRestoringValue(:, :, :) = activeTracers(:, :, :) + end if + + if ( associated(activeTracersInteriorRestoringRate) ) then + activeTracersInteriorRestoringRate(:, :, :) = config_global_ocean_interior_restore_rate + end if + + ! set surface restoring values and rate + if ( associated(activeTracersSurfaceRestoringValue) .and. associated(activeTracers) ) then + activeTracersSurfaceRestoringValue(:, :) = activeTracers(:, 1, :) + end if + + if ( associated(activeTracersPistonVelocity) ) then + activeTracersPistonVelocity(:, :) = config_global_ocean_piston_velocity + end if + + block_ptr => block_ptr % next + end do + + end subroutine ocn_init_setup_global_ocean_interpolate_tracers!}}} !*********************************************************************** From de2416086094f7da4ccd203375e902ac28632170 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Mon, 14 Sep 2015 15:51:04 -0600 Subject: [PATCH 0236/1724] Changing references to tracer group fields to var_structs This commit changes references in streams for tracer group fields (such as those for interior or surface restoring) to use var_structs instead of var_arrays. The motivation is that var_structs will include every tracer group's fields, while var_arrays need to have each tracerGroup explicitly listed, which could be cumbersome to update. Additionally, these can easily be changed at run-time to only read / write the groups of interest. --- src/core_ocean/Registry.xml | 56 ++++++++++++++++++++----------------- 1 file changed, 31 insertions(+), 25 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 5dd75bd87a..a9cc16af91 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -971,7 +971,7 @@ - + @@ -1046,7 +1046,7 @@ mode="forward;analysis"> - + @@ -1065,7 +1065,7 @@ mode="forward;analysis"> - + @@ -1091,7 +1091,7 @@ mode="forward"> - + @@ -1206,32 +1206,38 @@ - + - - - - - + + + + + + + + - - - - - - + + + + + + + + - + From 1fe8bcd8437f6b07a35dd7723ca6c264238bd31b Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Mon, 14 Sep 2015 15:58:11 -0600 Subject: [PATCH 0237/1724] General registry cleanup This commit cleans up registry, including making sure streams are defined, and contain the correct members. --- src/core_ocean/Registry.xml | 134 +++++++----------- .../tracer_groups/Registry_activeTracers.xml | 132 ++++++++--------- .../tracer_groups/Registry_debugTracers.xml | 92 ++++++------ 3 files changed, 166 insertions(+), 192 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index a9cc16af91..7d97bb658e 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -147,10 +147,10 @@ description="Logical flag that controls if a spherical mesh is expanded to an earth sized sphere or not." possible_values=".true. or .false." /> - + + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + @@ -986,6 +950,24 @@ + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + - - - - - - - - - - - - - - - - - - - - - - + + - + diff --git a/src/core_ocean/tracer_groups/Registry_activeTracers.xml b/src/core_ocean/tracer_groups/Registry_activeTracers.xml index e09559cac4..b6d2857894 100644 --- a/src/core_ocean/tracer_groups/Registry_activeTracers.xml +++ b/src/core_ocean/tracer_groups/Registry_activeTracers.xml @@ -76,70 +76,70 @@ /> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/tracer_groups/Registry_debugTracers.xml b/src/core_ocean/tracer_groups/Registry_debugTracers.xml index a6502fea50..05f8424897 100644 --- a/src/core_ocean/tracer_groups/Registry_debugTracers.xml +++ b/src/core_ocean/tracer_groups/Registry_debugTracers.xml @@ -45,7 +45,7 @@ - + @@ -67,49 +67,49 @@ /> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + From 5965c89cab9f6c6d7b06b107cf20fd4283dd383b Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Mon, 14 Sep 2015 23:01:25 -0600 Subject: [PATCH 0238/1724] global sums now being calculated correctly per block; compute subroutine still not being called other than on startup --- .../analysis_members/mpas_li_global_stats.F | 215 ++++++++---------- 1 file changed, 99 insertions(+), 116 deletions(-) diff --git a/src/core_landice/analysis_members/mpas_li_global_stats.F b/src/core_landice/analysis_members/mpas_li_global_stats.F index 54b39f68cc..26854fe321 100644 --- a/src/core_landice/analysis_members/mpas_li_global_stats.F +++ b/src/core_landice/analysis_members/mpas_li_global_stats.F @@ -25,6 +25,7 @@ module li_global_stats use mpas_stream_manager use li_constants + use li_mask implicit none private @@ -162,26 +163,14 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ type (mpas_pool_type), pointer :: scratchPool type (mpas_pool_type), pointer :: diagnosticsPool type (mpas_pool_type), pointer :: globalStatsAM - type (mpas_pool_type), pointer :: geometryPool - ! Here are some example variables which may be needed for your analysis member -! integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, num_tracers - integer, pointer :: nCellsSolve -! integer :: iTracer, k, iCell - integer :: k, iCell -! integer, dimension(:), pointer :: maxLevelCell, maxLevelEdgeTop, maxLevelVertexBot - -! real (kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge real (kind=RKIND), dimension(:), pointer :: areaCell - real (kind=RKIND), dimension(:), pointer :: thickness - integer, dimension(:), pointer :: cellMask - ! simple 1 or 0 masks to be used here for calc. global sums over floating or grounded ice - integer, dimension(:), pointer :: iceMask - integer, dimension(:), pointer :: groundedMask - integer, dimension(:), pointer :: floatingMask + integer, dimension(:), pointer :: cellMask + integer, pointer :: nCellsSolve + integer :: k, iCell ! scalars to be calculated here from global sums real (kind=RKIND), pointer :: totalIceArea @@ -191,112 +180,106 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ real (kind=RKIND), pointer :: floatingIceArea real (kind=RKIND), pointer :: floatingIceVolume - print *, 'in li_compute_global_stats (start)' + ! scalar sums over blocks + real (kind=RKIND) :: blockSumIceArea + real (kind=RKIND) :: blockSumIceVolume + real (kind=RKIND) :: blockSumGroundedIceArea + real (kind=RKIND) :: blockSumGroundedIceVolume + real (kind=RKIND) :: blockSumFloatingIceArea + real (kind=RKIND) :: blockSumFloatingIceVolume + + print *, 'in li_compute_global_stats (start)' ! debug err = 0 + ! initialize sums over blocks to 0 + blockSumIceArea = 0.0_RKIND + blockSumIceVolume = 0.0_RKIND + blockSumGroundedIceArea = 0.0_RKIND + blockSumGroundedIceVolume = 0.0_RKIND + blockSumFloatingIceArea = 0.0_RKIND + blockSumFloatingIceVolume = 0.0_RKIND + dminfo = domain % dminfo - ! initialize scalar global sums and work masks to zero -! totalIceArea = 0.0_RKIND -! totalIceVolume = 0.0_RKIND -! groundedIceArea = 0.0_RKIND -! groundedIceVolume = 0.0_RKIND -! floatingIceArea = 0.0_RKIND -! floatingIceVolume = 0.0_RKIND -! iceMask = 0 -! groundedMask = 0 -! floatingMask = 0 - -! block => domain % blocklist -! do while (associated(block)) -! call mpas_pool_get_subpool(block % structs, 'state', statePool) -! call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) -! call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) -! call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) -! call mpas_pool_get_subpool(block % structs, 'globalStatsAM', globalStatsAMPool) -! -! call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) -! -! ! Here are some example variables which may be needed for your analysis member -!! call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) -! -!! call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) -! call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) -!! call mpas_pool_get_dimension(block % dimensions, 'nEdgesSolve', nEdgesSolve) -!! call mpas_pool_get_dimension(block % dimensions, 'nVerticesSolve', nVerticesSolve) -! -! call mpas_pool_get_array(meshPool, 'areaCell', areaCell) -!! call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) -!! call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) -!! call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) -!! call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) -!! call mpas_pool_get_array(meshPool, 'maxLevelVertexBot', maxLevelVertexBot) -! -! call mpas_pool_get_array(geometryPool, 'thickness', thickness) -! call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) -! -! call mpas_pool_get_array(globalStatsAMPool, 'totalIceArea', totalIceArea) -! call mpas_pool_get_array(globalStatsAMPool, 'totalIceVolume', totalIceVolume) -! call mpas_pool_get_array(globalStatsAMPool, 'floatingIceArea', floatingIceArea) -! call mpas_pool_get_array(globalStatsAMPool, 'floatingIceVolume', floatingIceVolume) -! call mpas_pool_get_array(globalStatsAMPool, 'groundedIceArea', groundedIceArea) -! call mpas_pool_get_array(globalStatsAMPool, 'groundedIceVolume', groundedIceVolume) -! -! ! populate work masks (1 and 0 based for multiplication of area and thickness fields) -! where( cellMask == 32 ); iceMask = 1; endwhere -! where( cellMask == 4 ); floatingMask = 1; endwhere -! groundedMask = iceMask - floatingMask -! -! ! Computations which are functions of nCells, nEdges, or nVertices -! ! must be placed within this block loop -! ! Here are some example loops -!! do iCell = 1,nCellsSolve -! -!! do k = 1, maxLevelCell(iCell) -!! do iTracer = 1, num_tracers -! ! computations on tracers(iTracer,k, iCell) -!! end do -!! end do -! -! ! calculate total ice area and volume -! totalIceArea = totalIceArea + real( iceMask(iCell), RKIND) * areaCell(iCell) -! totalIceVolume = totalIceVolume + real( iceMask(iCell), RKIND) * areaCell(iCell) * thickness(iCell) -! -! ! debugging -!! print *, 'totalIceArea=', totalIceArea -!! print *, 'totalIceVolume=', totalIceVolume -! -! ! calculate grounded ice area and volume -! groundedIceArea = groundedIceArea + real( groundedMask(iCell), RKIND) * areaCell(iCell) -! groundedIceVolume = groundedIceVolume + real( groundedMask(iCell), RKIND) * areaCell(iCell) * thickness(iCell) -! -! ! calculate floating ice area and volume -! floatingIceArea = floatingIceArea + real( floatingMask(iCell), RKIND) * areaCell(iCell) -! floatingIceVolume = floatingIceVolume + real( floatingMask(iCell), RKIND) * areaCell(iCell) * thickness(iCell) -! -!! end do -! -! block => block % next -! end do -! -! ! mpi gather/scatter calls may be placed here. -! ! Here are some examples. See mpas_oac_global_stats.F for further details. -!! call mpas_dmpar_sum_real_array(dminfo, nVariables, sumSquares(1:nVariables), reductions(1:nVariables)) -!! call mpas_dmpar_min_real_array(dminfo, nMins, mins(1:nMins), reductions(1:nMins)) -!! call mpas_dmpar_max_real_array(dminfo, nMaxes, maxes(1:nMaxes), reductions(1:nMaxes)) -! -! ! Even though some variables do not include an index that is decomposed amongst -! ! domain partitions, we assign them within a block loop so that all blocks have the -! ! correct values for writing output. -! block => domain % blocklist -! do while (associated(block)) -! call mpas_pool_get_subpool(block % structs, 'globalStatsAM', globalStatsAMPool) -! -! ! assignment of final globalStatsAM variables could occur here. -! -! block => block % next -! end do + block => domain % blocklist + do while (associated(block)) + + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'globalStatsAM', globalStatsAMPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + + call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + + call mpas_pool_get_array(globalStatsAMPool, 'totalIceArea', totalIceArea) + call mpas_pool_get_array(globalStatsAMPool, 'totalIceVolume', totalIceVolume) + call mpas_pool_get_array(globalStatsAMPool, 'floatingIceArea', floatingIceArea) + call mpas_pool_get_array(globalStatsAMPool, 'floatingIceVolume', floatingIceVolume) + call mpas_pool_get_array(globalStatsAMPool, 'groundedIceArea', groundedIceArea) + call mpas_pool_get_array(globalStatsAMPool, 'groundedIceVolume', groundedIceVolume) + + do iCell = 1,nCellsSolve + + ! sums of ice area and volume over cells + blockSumIceArea = blockSumIceArea + li_mask_is_ice_int(cellMask(iCell)) * areaCell(iCell) + blockSumIceVolume = blockSumIceVolume + li_mask_is_ice_int(cellMask(iCell)) * areaCell(iCell) * thickness(iCell) + +! blockSumGroundedIceArea = blockSumGroundedIceArea + (1-li_mask_is_floating_ice_int(cellMask(iCell))) * areaCell(iCell) +! blockSumGroundedIceVolume = blockSumGroundedIceVolume + (1-li_mask_is_floating_ice_int(cellMask(iCell))) * areaCell(iCell) * thickness(iCell) + +! blockSumFloatingIceArea = blockSumFloatingIceArea + li_mask_is_floating_ice_int(cellMask(iCell)) * areaCell(iCell) +! blockSumFloatingIceVolume = blockSumFloatingIceVolume + li_mask_is_floating_ice_int(cellMask(iCell)) * areaCell(iCell) * thickness(iCell) + + ! debugging +! print *, 'CellMask = ', CellMask(iCell) +! print *, 'iceMask = ', li_mask_is_ice_int(cellMask(iCell)) +! print *, 'groundedMask = ', (1 - li_mask_is_floating_ice_int(cellMask(iCell)) ) +! print *, 'floatingMask = ', li_mask_is_floating_ice_int(cellMask(iCell)) +! print *, 'areaCell = ', areaCell(iCell) +! print *, 'thickness = ', thickness(iCell) +! print *, 'blockSumIceArea=', blockSumIceArea +! print *, 'blockSumIceVolume=', blockSumIceVolume + + end do + + block => block % next + end do + + totalIceArea = blockSumIceArea + totalIceVolume = blockSumIceVolume +! groundedIceArea = blockSumGroundedIceArea +! groundedIceVolume = blockSumGroundedIceVolume +! floatingIceArea = blockSumFloatingIceArea +! floatingIceVolume = blockSumFloatingIceVolume + + ! debugging + print *, 'totalIceArea=', totalIceArea + print *, 'totalIceVolume=', totalIceVolume +! print *, 'groundedIceArea=', groundedIceArea +! print *, 'groundedIceVolume=', groundedIceVolume +! print *, 'floatingIceArea=', floatingIceArea +! print *, 'floatingIceVolume=', floatingIceVolume + + ! mpi gather/scatter calls may be placed here. + ! Here are some examples. See mpas_oac_global_stats.F for further details. +! call mpas_dmpar_sum_real_array(dminfo, nVariables, sumSquares(1:nVariables), reductions(1:nVariables)) +! call mpas_dmpar_min_real_array(dminfo, nMins, mins(1:nMins), reductions(1:nMins)) +! call mpas_dmpar_max_real_array(dminfo, nMaxes, maxes(1:nMaxes), reductions(1:nMaxes)) + + ! Even though some variables do not include an index that is decomposed amongst + ! domain partitions, we assign them within a block loop so that all blocks have the + ! correct values for writing output. + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'globalStatsAM', globalStatsAMPool) + + ! assignment of final globalStatsAM variables could occur here. + + block => block % next + end do print *, 'in li_compute_global_stats (end)' From c0e21b0b8b366232319df6ff746c8a1794c8cea0 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Fri, 11 Sep 2015 15:40:52 -0700 Subject: [PATCH 0239/1724] Renaming surfaceWindStress --> surfaceStress This makes more sense for adding top drag (and potentially other surface stresses) to this field Requres renaming ocn_vel_forcing_windstress --> ocn_vel_forcing_surface_stress --- src/core_ocean/Registry.xml | 16 +++---- .../mpas_ocn_surface_area_weighted_averages.F | 6 +-- .../mode_forward/mpas_ocn_forward_mode.F | 4 +- .../mode_init/mpas_ocn_init_global_ocean.F | 8 ++-- src/core_ocean/shared/Makefile | 6 +-- src/core_ocean/shared/mpas_ocn_diagnostics.F | 14 +++--- .../shared/mpas_ocn_surface_bulk_forcing.F | 12 ++--- src/core_ocean/shared/mpas_ocn_tendency.F | 17 ++++--- src/core_ocean/shared/mpas_ocn_vel_forcing.F | 10 ++-- ... => mpas_ocn_vel_forcing_surface_stress.F} | 46 +++++++++---------- 10 files changed, 71 insertions(+), 68 deletions(-) rename src/core_ocean/shared/{mpas_ocn_vel_forcing_windstress.F => mpas_ocn_vel_forcing_surface_stress.F} (83%) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 7d97bb658e..b93009cdc6 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -590,7 +590,7 @@ - + @@ -1227,8 +1227,8 @@ - - + + @@ -2135,11 +2135,11 @@ constituent fields, depending on the forcing options selected. ********************************************************************* --> - - \brief MPAS ocean wind stress +!> \brief MPAS ocean surface stress !> \author Doug Jacobsen, Mark Petersen, Todd Ringler !> \date September 2011 !> \details !> This module contains the routine for computing -!> tendencies from wind stress. +!> tendencies from surface stress. ! !----------------------------------------------------------------------- -module ocn_vel_forcing_windstress +module ocn_vel_forcing_surface_stress use mpas_derived_types use mpas_pool_routines @@ -42,8 +42,8 @@ module ocn_vel_forcing_windstress ! !-------------------------------------------------------------------- - public :: ocn_vel_forcing_windstress_tend, & - ocn_vel_forcing_windstress_init + public :: ocn_vel_forcing_surface_stress_tend, & + ocn_vel_forcing_surface_stress_init !-------------------------------------------------------------------- ! @@ -59,18 +59,18 @@ module ocn_vel_forcing_windstress !*********************************************************************** ! -! routine ocn_vel_forcing_windstress_tend +! routine ocn_vel_forcing_surface_stress_tend ! -!> \brief Computes tendency term from wind stress +!> \brief Computes tendency term from surface stress !> \author Doug Jacobsen, Mark Petersen, Todd Ringler !> \date 15 September 2011 !> \details -!> This routine computes the wind stress tendency for momentum +!> This routine computes the surface stress tendency for momentum !> based on current state. ! !----------------------------------------------------------------------- - subroutine ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThicknessEdge, tend, err)!{{{ + subroutine ocn_vel_forcing_surface_stress_tend(meshPool, surfaceStress, layerThicknessEdge, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -79,7 +79,7 @@ subroutine ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThi !----------------------------------------------------------------- real (kind=RKIND), dimension(:), intent(in) :: & - surfaceWindStress !< Input: Wind stress at surface + surfaceStress !< Input: Wind stress at surface real (kind=RKIND), dimension(:,:), intent(in) :: & layerThicknessEdge !< Input: thickness at edge @@ -149,7 +149,7 @@ subroutine ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThi remainingStress = remainingStress - (transmissionCoeffTop - transmissionCoeffBot) - tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * surfaceWindStress(iEdge) & + tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * surfaceStress(iEdge) & * (transmissionCoeffTop - transmissionCoeffBot) / config_density0 / layerThicknessEdge(k,iEdge) zTop = zBot @@ -158,7 +158,7 @@ subroutine ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThi if ( maxLevelEdgeTop(iEdge) > 0 .and. remainingStress > 0.0_RKIND) then tend(maxLevelEdgeTop(iEdge), iEdge) = tend(maxLevelEdgeTop(iEdge), iEdge) & - + edgeMask(maxLevelEdgeTop(iEdge), iEdge) * surfaceWindStress(iEdge) * remainingStress & + + edgeMask(maxLevelEdgeTop(iEdge), iEdge) * surfaceStress(iEdge) * remainingStress & / config_density0 / layerThicknessEdge(maxLevelEdgeTop(iEdge), iEdge) end if enddo @@ -166,22 +166,22 @@ subroutine ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThi !-------------------------------------------------------------------- - end subroutine ocn_vel_forcing_windstress_tend!}}} + end subroutine ocn_vel_forcing_surface_stress_tend!}}} !*********************************************************************** ! -! routine ocn_vel_forcing_windstress_init +! routine ocn_vel_forcing_surface_stress_init ! -!> \brief Initializes ocean wind stress forcing +!> \brief Initializes ocean surface stress forcing !> \author Doug Jacobsen, Mark Petersen, Todd Ringler !> \date September 2011 !> \details -!> This routine initializes quantities related to wind stress +!> This routine initializes quantities related to surface stress !> in the ocean. ! !----------------------------------------------------------------------- - subroutine ocn_vel_forcing_windstress_init(err)!{{{ + subroutine ocn_vel_forcing_surface_stress_init(err)!{{{ !-------------------------------------------------------------------- @@ -193,23 +193,23 @@ subroutine ocn_vel_forcing_windstress_init(err)!{{{ integer, intent(out) :: err !< Output: error flag - logical, pointer :: config_disable_vel_windstress + logical, pointer :: config_disable_vel_surface_stress - call mpas_pool_get_config(ocnConfigs, 'config_disable_vel_windstress', config_disable_vel_windstress) + call mpas_pool_get_config(ocnConfigs, 'config_disable_vel_surface_stress', config_disable_vel_surface_stress) windStressOn = .true. - if(config_disable_vel_windstress) windStressOn = .false. + if(config_disable_vel_surface_stress) windStressOn = .false. err = 0 !-------------------------------------------------------------------- - end subroutine ocn_vel_forcing_windstress_init!}}} + end subroutine ocn_vel_forcing_surface_stress_init!}}} !*********************************************************************** -end module ocn_vel_forcing_windstress +end module ocn_vel_forcing_surface_stress !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! vim: foldmethod=marker From 79fa1d83e2114ccd3c594e3de519a15dd565d2c1 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Mon, 14 Sep 2015 08:32:35 -0700 Subject: [PATCH 0240/1724] Adding land-ice surface fluxes A new module, ocn_surface_land_ice_fluxes, has been added which: * computes thickness and active tracer fluxes and top drag together * adds thickness and active tracer fluxes to surface fluxes * adds top drag to surface stress Description of surfaceStress has been changed at Doug Jacobsen's request --- src/core_ocean/Registry.xml | 176 ++- .../driver/mpas_ocn_core_interface.F | 11 + .../mode_forward/mpas_ocn_forward_mode.F | 12 +- src/core_ocean/shared/Makefile | 5 +- .../shared/mpas_ocn_surface_land_ice_fluxes.F | 1054 +++++++++++++++++ src/core_ocean/shared/mpas_ocn_tendency.F | 23 +- .../mpas_ocn_vel_forcing_surface_stress.F | 8 +- 7 files changed, 1274 insertions(+), 15 deletions(-) create mode 100644 src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index b93009cdc6..d006972fdb 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -618,6 +618,68 @@ possible_values=".true. or .false." /> + + + + + + + + + + + + + + + + + - + @@ -965,6 +1028,9 @@ + + + @@ -1112,6 +1178,9 @@ + + + @@ -2136,7 +2205,7 @@ ********************************************************************* --> + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/driver/mpas_ocn_core_interface.F b/src/core_ocean/driver/mpas_ocn_core_interface.F index 43fdf07bfd..0255d417b9 100644 --- a/src/core_ocean/driver/mpas_ocn_core_interface.F +++ b/src/core_ocean/driver/mpas_ocn_core_interface.F @@ -109,6 +109,7 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ logical, pointer :: thicknessFilterActive logical, pointer :: splitTimeIntegratorActive logical, pointer :: windStressBulkPKGActive + logical, pointer :: landIceFluxesPKGActive logical, pointer :: thicknessBulkPKGActive logical, pointer :: frazilIceActive logical, pointer :: inSituEOSActive @@ -136,6 +137,7 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ character (len=StrKIND), pointer :: config_pressure_gradient_type logical, pointer :: config_use_bulk_wind_stress logical, pointer :: config_use_bulk_thickness_flux + logical, pointer :: config_use_land_ice_fluxes type (mpas_pool_iterator_type) :: groupItr character (len=StrKIND) :: tracerGroupName, configName, packageName @@ -202,6 +204,15 @@ function ocn_setup_packages(configPool, packagePool) result(ierr)!{{{ windStressBulkPKGActive = .true. end if + ! + ! test for land ice fluxes, landIceFluxesPKG + ! + call mpas_pool_get_package(packagePool, 'landIceFluxesPKGActive', landIceFluxesPKGActive) + call mpas_pool_get_config(configPool, 'config_use_land_ice_fluxes', config_use_land_ice_fluxes) + if ( config_use_land_ice_fluxes ) then + landIceFluxesPKGActive = .true. + end if + ! ! test for use of frazil ice formation, frazilIceActive ! diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index 843f7e59b0..ed25c02325 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -51,6 +51,7 @@ module ocn_forward_mode use ocn_vel_coriolis use ocn_vel_forcing_surface_stress use ocn_surface_bulk_forcing + use ocn_surface_land_ice_fluxes use ocn_tracer_hmix use ocn_tracer_surface_flux_to_tend @@ -181,6 +182,8 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ ierr = ior(ierr, err_tmp) call ocn_surface_bulk_forcing_init(err_tmp) ierr = ior(ierr, err_tmp) + call ocn_surface_land_ice_fluxes_init(err_tmp) + ierr = ior(ierr, err_tmp) call ocn_tracer_hmix_init(err_tmp) ierr = ior(ierr, err_tmp) @@ -388,6 +391,9 @@ function ocn_forward_mode_run(domain) result(ierr)!{{{ type (mpas_pool_type), pointer :: meshPool type (mpas_pool_type), pointer :: statePool type (mpas_pool_type), pointer :: forcingPool + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: scratchPool + type (MPAS_timeInterval_type) :: timeStep character(len=StrKIND), pointer :: config_restart_timestamp_name @@ -444,7 +450,11 @@ function ocn_forward_mode_run(domain) result(ierr)!{{{ call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) - call ocn_forcing_build_fraction_absorbed_array(meshPool, statePool, forcingpool, ierr, 1) + call mpas_pool_get_subpool(block_ptr % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + call ocn_forcing_build_fraction_absorbed_array(meshPool, statePool, forcingPool, ierr, 1) + call ocn_surface_land_ice_fluxes_build_arrays(meshPool, statePool, diagnosticsPool, & + forcingPool, scratchPool, 1, err) block_ptr => block_ptr % next end do diff --git a/src/core_ocean/shared/Makefile b/src/core_ocean/shared/Makefile index c6c5ed1912..a8943c4c4e 100644 --- a/src/core_ocean/shared/Makefile +++ b/src/core_ocean/shared/Makefile @@ -45,6 +45,7 @@ OBJS = mpas_ocn_init_routines.o \ mpas_ocn_constants.o \ mpas_ocn_forcing.o \ mpas_ocn_surface_bulk_forcing.o \ + mpas_ocn_surface_land_ice_fluxes.o \ mpas_ocn_forcing_restoring.o \ mpas_ocn_time_average.o \ mpas_ocn_time_average_coupled.o \ @@ -54,7 +55,7 @@ all: $(OBJS) mpas_ocn_init_routines.o: mpas_ocn_constants.o mpas_ocn_time_average.o mpas_ocn_diagnostics.o mpas_ocn_gm.o -mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_restoring.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_surface_bulk_forcing.o mpas_ocn_tracer_surface_flux_to_tend.o mpas_ocn_tracer_interior_restoring.o mpas_ocn_tracer_exponential_decay.o mpas_ocn_tracer_ideal_age.o mpas_ocn_tracer_TTD.o mpas_ocn_vmix.o mpas_ocn_constants.o +mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_restoring.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_surface_bulk_forcing.o mpas_ocn_surface_land_ice_fluxes.o mpas_ocn_tracer_surface_flux_to_tend.o mpas_ocn_tracer_interior_restoring.o mpas_ocn_tracer_exponential_decay.o mpas_ocn_tracer_ideal_age.o mpas_ocn_tracer_TTD.o mpas_ocn_vmix.o mpas_ocn_constants.o mpas_ocn_diagnostics_routines.o: mpas_ocn_constants.o @@ -138,6 +139,8 @@ mpas_ocn_forcing.o: mpas_ocn_constants.o mpas_ocn_forcing_restoring.o mpas_ocn_surface_bulk_forcing.o: +mpas_ocn_surface_land_ice_fluxes.o: mpas_ocn_constants.o + mpas_ocn_forcing_restoring.o: mpas_ocn_constants.o mpas_ocn_sea_ice.o: mpas_ocn_constants.o diff --git a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F new file mode 100644 index 0000000000..584899f755 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F @@ -0,0 +1,1054 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_surface_land_ice_fluxes +! +!> \brief MPAS ocean surface land-ice fluxes +!> \author Xylar Asay-Davis +!> \date 10/02/2014 +!> \details +!> This module contains routines for computing surface flux related +!> melting under land-ice. +! +!----------------------------------------------------------------------- + +module ocn_surface_land_ice_fluxes + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_surface_land_ice_fluxes_tracers, & + ocn_surface_land_ice_fluxes_vel, & + ocn_surface_land_ice_fluxes_thick, & + ocn_surface_land_ice_fluxes_build_arrays, & + ocn_surface_land_ice_fluxes_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + logical :: landIceFluxesOn, isomipOn, jenkinsOn, hollandJenkinsOn + + real (kind=RKIND) :: Tf0, dTf_dp, dTf_dS, cp_land_ice, rho_land_ice, refDensity + + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_surface_land_ice_fluxes_tracers +! +!> \brief Determines the tracers melt fluxes under land ice +!> \author Xylar Asay-Davis +!> \date 9 September 2015 +!> \details +!> This routine adds land-ice tracer fluxes to the surface flux array +!> used to compute tracer tendencies later in MPAS. +! +!----------------------------------------------------------------------- + + subroutine ocn_surface_land_ice_fluxes_tracers(meshPool, groupName, forcingPool, tracersSurfaceFlux, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + character (len=*) :: groupName !< Input: Name of tracer group + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information + real (kind=RKIND), dimension(:,:), intent(inout) :: tracersSurfaceFlux !< Input/Output: Surface flux for tracer group + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + if ( trim(groupName) == 'activeTracers' ) then + call ocn_surface_land_ice_fluxes_active_tracers(meshPool, forcingPool, tracersSurfaceFlux, err) + end if + + end subroutine ocn_surface_land_ice_fluxes_tracers!}}} + +!*********************************************************************** +! +! routine ocn_surface_land_ice_fluxes_vel +! +!> \brief Computes tendency term for top drag +!> \author Xylar Asay-Davis +!> \date 9 September 2015 +!> \details +!> This routine computes the top-drag tendency for momentum +!> based on current state. +! +!----------------------------------------------------------------------- + + subroutine ocn_surface_land_ice_fluxes_vel(meshPool, forcingPool, surfaceStress, surfaceStressMagnitude, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:), intent(inout) :: surfaceStress, & !< Input/Output: Array for total surface stress + surfaceStressMagnitude !< Input/Output: Array for magnitude of surface stress + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + integer :: iEdge, iCell + integer, pointer :: nCells, nEdges + + real (kind=RKIND), dimension(:), pointer :: topDrag, topDragMagnitude + + err = 0 + + if ( .not. landIceFluxesOn ) return + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + + call mpas_pool_get_array(forcingPool, 'topDrag', topDrag) + call mpas_pool_get_array(forcingPool, 'topDragMagnitude', topDragMagnitude) + + do iEdge = 1, nEdges + surfaceStress(iEdge) = surfaceStress(iEdge) + topDrag(iEdge) + end do + + ! Build surface stress magnitude at cell centers + do iCell = 1, nCells + surfaceStressMagnitude(iCell) = surfaceStressMagnitude(iCell) + topDragMagnitude(iCell) + end do + + !-------------------------------------------------------------------- + + end subroutine ocn_surface_land_ice_fluxes_vel!}}} + +!*********************************************************************** +! +! routine ocn_surface_land_ice_fluxes_thick +! +!> \brief Add land-ice fluxes to surfaceThicknessFlux. +!> \author Xylar Asay-Davis +!> \date 11 September 2015 +!> \details +!> This routine adds land-ice freshwater fluxes to the surface thickness flux +!> to be converted into a thickness tendency later. +! +!----------------------------------------------------------------------- + + subroutine ocn_surface_land_ice_fluxes_thick(meshPool, forcingPool, surfaceThicknessFlux, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information + real (kind=RKIND), dimension(:), intent(inout) :: surfaceThicknessFlux !< Input/Output: Array for surface thickness flux + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell + integer, pointer :: nCells + + real (kind=RKIND), dimension(:), pointer :: landIceFreshwaterFlux + + err = 0 + + if ( .not. landIceFluxesOn ) return + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_array(forcingPool, 'landIceFreshwaterFlux', landIceFreshwaterFlux) + + ! Build surface fluxes at cell centers + do iCell = 1, nCells + surfaceThicknessFlux(iCell) = surfaceThicknessFlux(iCell) + landIceFreshwaterFlux(iCell) / refDensity + end do + + end subroutine ocn_surface_land_ice_fluxes_thick!}}} + +!*********************************************************************** +! +! routine ocn_surface_land_ice_fluxes_active_tracers +! +!> \brief Adds the active tracers fluxes from land-ice melting. +!> \author Xylar Asay-Davis +!> \date 11 September 2015 +!> \details +!> This routine adds the active tracers fluxes to surface fluxes +!> from which tracer tendencies are computed later. +! +!----------------------------------------------------------------------- + + subroutine ocn_surface_land_ice_fluxes_active_tracers(meshPool, forcingPool, tracersSurfaceFlux, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information + real (kind=RKIND), dimension(:,:), intent(inout) :: tracersSurfaceFlux + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell + integer, pointer :: nCells + + real (kind=RKIND), dimension(:), pointer :: landIceHeatFlux + + err = 0 + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_array(forcingPool, 'landIceHeatFlux', landIceHeatFlux) + + ! add to surface fluxes at cell centers + do iCell = 1, nCells + tracersSurfaceFlux(1, iCell) = tracersSurfaceFlux(1, iCell) + landIceHeatFlux(iCell)/(refDensity*cp_sw) + end do + + end subroutine ocn_surface_land_ice_fluxes_active_tracers!}}} + + +!*********************************************************************** +! +! routine ocn_surface_land_ice_fluxes_build_arrays +! +!> \brief Builds the forcing array for land-ice forcing +!> \author Xylar Asay-Davis +!> \date 10/02/2014 +!> \details +!> This routine builds surface flux arrays related to land-ice forcing. +! +!----------------------------------------------------------------------- + + subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, statePool, diagnosticsPool, & + forcingPool, scratchPool, timeLevel, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: & + statePool, & !< Input: State information + meshPool, & !< Input: mesh information + diagnosticsPool !< Input: diagnostics information + + integer, intent(in) :: timeLevel + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: & + forcingPool, & !< Input: Forcing information + scratchPool !< Input: scratch field information + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: tracersPool + + integer :: iCell, iEdge, cell1, cell2, iLevel, i + integer, pointer :: nCellsSolve, nEdgesSolve + + integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnCell + + integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell + + integer, pointer :: indexT, indexS + + real (kind=RKIND), pointer :: config_land_ice_flux_topDragCoeff, config_land_ice_flux_ISOMIP_gammaT, & + config_land_ice_flux_boundaryLayerThickness, & + config_land_ice_flux_boundaryLayerNeighborWeight, & + config_land_ice_flux_rms_tidal_velocity, & + config_land_ice_flux_jenkins_heat_transfer_coefficient, & + config_land_ice_flux_jenkins_salt_transfer_coefficient + + logical, pointer :: config_land_ice_flux_useHollandJenkinsAdvDiff + + + real (kind=RKIND) :: velocityMagnitude, freshwaterFlux, heatFlux, & + landIceEdgeFraction, blThickness, dz, blWeightSum, h_nu, Gamma_turb + + real (kind=RKIND), dimension(:), pointer :: seaSurfacePressure, landIceFraction, & + landIceInterfaceTemperature, & + landIceInterfaceSalinity, landIceFrictionVelocity, & + landIceBoundaryLayerTemperature, & + landIceBoundaryLayerSalinity, & + landIceFreshwaterFlux, topDrag, topDragMagnitude, & + landIceHeatFlux, heatFluxToLandIce, & + blTempScratch, blSaltScratch, heatTransferVelocity, & + saltTransferVelocity, landIceTemperature, & + landIceHeatTransferVelocity, fCell, & + freezeInterfaceSalinity, freezeInterfaceTemperature, & + freezeFreshwaterFlux, freezeHeatFlux, & + freezeIceHeatFlux + + real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, kineticEnergyCell, layerThickness + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers + type (field1DReal), pointer :: boundaryLayerTemperatureField, boundaryLayerSalinityField, & + heatTransferVelocityField, saltTransferVelocityField, & + freezeInterfaceSalinityField, freezeInterfaceTemperatureField, & + freezeFreshwaterFluxField, freezeHeatFluxField, & + freezeIceHeatFluxField + + ! constants for Holland and Jenkins 1999 parameterization of the boundary layer + real (kind=RKIND), parameter :: & + Pr = 13.8_RKIND, & ! the Prandtl number + Sc = 2432.0_RKIND, & ! the Schmidt number + nuSaltWater = 1.95e-6_RKIND, & ! molecular viscosity of sea water (m^2/s) + kVonKarman = 0.4_RKIND, & ! the von Karman constant + xiN = 0.052_RKIND ! dimensionless planetary boundary layer constant + + + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_topDragCoeff', config_land_ice_flux_topDragCoeff) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_ISOMIP_gammaT', config_land_ice_flux_ISOMIP_gammaT) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_boundaryLayerThickness', config_land_ice_flux_boundaryLayerThickness) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_boundaryLayerNeighborWeight', config_land_ice_flux_boundaryLayerNeighborWeight) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_rms_tidal_velocity', config_land_ice_flux_rms_tidal_velocity) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_useHollandJenkinsAdvDiff', config_land_ice_flux_useHollandJenkinsAdvDiff) + + if(jenkinsOn) then + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_jenkins_heat_transfer_coefficient', config_land_ice_flux_jenkins_heat_transfer_coefficient) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_jenkins_salt_transfer_coefficient', config_land_ice_flux_jenkins_salt_transfer_coefficient) + end if + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexT) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexS) + + + call mpas_pool_get_array(diagnosticsPool, 'kineticEnergyCell', kineticEnergyCell) + + call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) + call mpas_pool_get_array(forcingPool, 'landIceFraction', landIceFraction) + + call mpas_pool_get_array(forcingPool, 'topDrag', topDrag) + call mpas_pool_get_array(forcingPool, 'topDragMagnitude', topDragMagnitude) + call mpas_pool_get_array(forcingPool, 'landIceFreshwaterFlux', landIceFreshwaterFlux) + call mpas_pool_get_array(forcingPool, 'landIceHeatFlux', landIceHeatFlux) + call mpas_pool_get_array(forcingPool, 'heatFluxToLandIce', heatFluxToLandIce) + call mpas_pool_get_array(forcingPool, 'landIceInterfaceTemperature', landIceInterfaceTemperature) + call mpas_pool_get_array(forcingPool, 'landIceInterfaceSalinity', landIceInterfaceSalinity) + call mpas_pool_get_array(forcingPool, 'landIceFrictionVelocity', landIceFrictionVelocity) + call mpas_pool_get_array(forcingPool, 'landIceBoundaryLayerTemperature', landIceBoundaryLayerTemperature) + call mpas_pool_get_array(forcingPool, 'landIceBoundaryLayerSalinity', landIceBoundaryLayerSalinity) + + call mpas_pool_get_field(scratchPool, 'boundaryLayerTemperatureScratch', boundaryLayerTemperatureField) + call mpas_pool_get_field(scratchPool, 'boundaryLayerSalinityScratch', boundaryLayerSalinityField) + call mpas_allocate_scratch_field(boundaryLayerTemperatureField, .true.) + call mpas_allocate_scratch_field(boundaryLayerSalinityField, .true.) + blTempScratch => boundaryLayerTemperatureField % array + blSaltScratch => boundaryLayerSalinityField % array + if(jenkinsOn .or. hollandJenkinsOn) then + call mpas_pool_get_array(forcingPool, 'landIceTemperature', landIceTemperature) + call mpas_pool_get_array(forcingPool, 'landIceHeatTransferVelocity', landIceHeatTransferVelocity) + + call mpas_pool_get_field(scratchPool, 'heatTransferVelocityScratch', heatTransferVelocityField) + call mpas_pool_get_field(scratchPool, 'saltTransferVelocityScratch', saltTransferVelocityField) + call mpas_allocate_scratch_field(heatTransferVelocityField, .true.) + call mpas_allocate_scratch_field(saltTransferVelocityField, .true.) + heatTransferVelocity => heatTransferVelocityField % array + saltTransferVelocity => saltTransferVelocityField % array + end if + if(hollandJenkinsOn) then + call mpas_pool_get_array(meshPool, 'fCell', fCell) + end if + if(config_land_ice_flux_useHollandJenkinsAdvDiff) then + call mpas_pool_get_field(scratchPool, 'freezeInterfaceSalinityScratch', freezeInterfaceSalinityField) + call mpas_pool_get_field(scratchPool, 'freezeInterfaceTemperatureScratch', freezeInterfaceTemperatureField) + call mpas_pool_get_field(scratchPool, 'freezeFreshwaterFluxScratch', freezeFreshwaterFluxField) + call mpas_pool_get_field(scratchPool, 'freezeHeatFluxScratch', freezeHeatFluxField) + call mpas_pool_get_field(scratchPool, 'freezeIceHeatFluxScratch', freezeIceHeatFluxField) + call mpas_allocate_scratch_field(freezeInterfaceSalinityField, .true.) + call mpas_allocate_scratch_field(freezeInterfaceTemperatureField, .true.) + call mpas_allocate_scratch_field(freezeFreshwaterFluxField, .true.) + call mpas_allocate_scratch_field(freezeHeatFluxField, .true.) + call mpas_allocate_scratch_field(freezeIceHeatFluxField, .true.) + freezeInterfaceSalinity => freezeInterfaceSalinityField % array + freezeInterfaceTemperature => freezeInterfaceTemperatureField % array + freezeFreshwaterFlux => freezeFreshwaterFluxField % array + freezeHeatFlux => freezeHeatFluxField % array + freezeIceHeatFlux => freezeIceHeatFluxField % array + end if + + + ! Compute top drag + do iEdge = 1, nEdgesSolve + cell1 = cellsOnEdge(1, iEdge) + cell2 = cellsOnEdge(2, iEdge) + + ! top drag tau = - CD*|u|*u, where |u| = sqrt(2*KE) = sqrt(KE1 + KE2) from the neighboring cells + velocityMagnitude = sqrt(kineticEnergyCell(1,cell1) + kineticEnergyCell(1,cell2)) + landIceEdgeFraction = 0.5_RKIND*(landIceFraction(cell1)+landIceFraction(cell2)) + + topDrag(iEdge) = - landIceEdgeFraction * config_land_ice_flux_topDragCoeff & + * velocityMagnitude * normalVelocity(1,iEdge) + + end do + + ! compute top drag and friction velocity at cell centers + do iCell = 1, nCellsSolve + ! the magnitude of the top drag is CD*u**2 = CD*(2*KE) + topDragMagnitude(iCell) = landIceFraction(iCell) & + * 2.0_RKIND * config_land_ice_flux_topDragCoeff * kineticEnergyCell(1,iCell) + ! the friction velocity is the square root of the top drag + variance of tidal velocity (computed regardless of land-ice coverage) + landIceFrictionVelocity(iCell) = sqrt(config_land_ice_flux_topDragCoeff* (2.0_RKIND * kineticEnergyCell(1,iCell) & + + config_land_ice_flux_rms_tidal_velocity)) + end do + + ! average temperature and salinity over horizontal neighbors and the sub-ice-shelf boundary layer + do iCell = 1, nCellsSolve + blThickness = 0.0_RKIND + blTempScratch(iCell) = 0.0_RKIND + blSaltScratch(iCell) = 0.0_RKIND + do iLevel = 1, maxLevelCell(iCell) + dz = min(layerThickness(iLevel,iCell),config_land_ice_flux_boundaryLayerThickness-blThickness) + if(dz <= 0.0_RKIND) exit + blTempScratch(iCell) = blTempScratch(iCell) + activeTracers(indexT, iLevel, iCell)*dz + blSaltScratch(iCell) = blSaltScratch(iCell) + activeTracers(indexS, iLevel, iCell)*dz + blThickness = blThickness + dz + end do + if(blThickness > 0.0_RKIND) then + blTempScratch(iCell) = blTempScratch(iCell)/blThickness + blSaltScratch(iCell) = blSaltScratch(iCell)/blThickness + end if + end do + do iCell = 1, nCellsSolve + blWeightSum = 1.0_RKIND + landIceBoundaryLayerTemperature(iCell) = blTempScratch(iCell) + landIceBoundaryLayerSalinity(iCell) = blSaltScratch(iCell) + do i = 1, nEdgesOnCell(iCell) + cell2 = cellsOnCell(i,iCell) + if(cell2 <= 0 .or. cell2 > nCellsSolve) cycle + + landIceBoundaryLayerTemperature(iCell) = landIceBoundaryLayerTemperature(iCell) & + + config_land_ice_flux_boundaryLayerNeighborWeight*blTempScratch(cell2) + landIceBoundaryLayerSalinity(iCell) = landIceBoundaryLayerSalinity(iCell) & + + config_land_ice_flux_boundaryLayerNeighborWeight*blSaltScratch(cell2) + blWeightSum = blWeightSum + config_land_ice_flux_boundaryLayerNeighborWeight + end do + if(blWeightSum > 0.0_RKIND) then + landIceBoundaryLayerTemperature(iCell) = landIceBoundaryLayerTemperature(iCell)/blWeightSum + landIceBoundaryLayerSalinity(iCell) = landIceBoundaryLayerSalinity(iCell)/blWeightSum + end if + end do + + if(isomipOn) then + do iCell = 1, nCellsSolve + ! linearized equaiton for the S and p dependent potential freezing temperature + landIceInterfaceTemperature(iCell) = Tf0 & + + dTf_dS*landIceBoundaryLayerSalinity(iCell) & + + dTf_dp*seaSurfacePressure(iCell) + + ! using (3) and (4) from Hunter (2006) + ! or (7) from Jenkins et al. (2001) if gamma constant + ! and no heat flux into ice + ! freshwater flux = density * melt rate is in kg/m^2/s + freshwaterFlux = -refDensity * config_land_ice_flux_ISOMIP_gammaT * (cp_sw/latent_heat_fusion_mks) & + * (landIceInterfaceTemperature(iCell)-landIceBoundaryLayerTemperature(iCell)) + + landIceFreshwaterFlux(iCell) = landIceFraction(iCell)*freshwaterFlux + + ! Using (13) from Jenkins et al. (2001) + ! heat flux is in W/s + heatFlux = cp_sw*(freshwaterFlux*landIceInterfaceTemperature(iCell) & + + refDensity*config_land_ice_flux_ISOMIP_gammaT & + * (landIceInterfaceTemperature(iCell)-landIceBoundaryLayerTemperature(iCell))) + landIceHeatFlux(iCell) = landIceFraction(iCell)*heatFlux + + heatFluxToLandIce(iCell) = 0.0_RKIND + + end do + end if + + if(jenkinsOn .or. hollandJenkinsOn) then + do iCell = 1, nCellsSolve + if(jenkinsOn) then + ! transfer coefficients from namelist + heatTransferVelocity(iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_heat_transfer_coefficient + saltTransferVelocity(iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_salt_transfer_coefficient + else + ! friction-velocity dependent non-dimensional transfer coefficients from + ! Holland and Jenkins 1999, (14)-(16) with eta_* = 1 + h_nu = 5.0_RKIND*nuSaltWater/landIceFrictionVelocity(iCell) ! uStar should never be zero because of tidal term + + Gamma_turb = 1.0_RKIND/(2.0_RKIND*xiN) - 1.0_RKIND/kVonKarman + if(abs(fCell(iCell)) > 0.0_RKIND) then + Gamma_turb = Gamma_turb + 1.0_RKIND/kVonKarman*log(landIceFrictionVelocity(iCell) & + *xiN/(abs(fCell(iCell))*h_nu)) + end if + + heatTransferVelocity(iCell) = 1.0_RKIND/(Gamma_turb + 12.5_RKIND*Pr**(2.0_RKIND/3.0_RKIND) - 6.0_RKIND) + saltTransferVelocity(iCell) = 1.0_RKIND/(Gamma_turb + 12.5_RKIND*Sc**(2.0_RKIND/3.0_RKIND) - 6.0_RKIND) + + end if + end do + if(config_land_ice_flux_useHollandJenkinsAdvDiff) then + ! melting solution + call compute_HJ99_melt_fluxes( & + landIceBoundaryLayerTemperature, & + landIceBoundaryLayerSalinity, & + heatTransferVelocity, & + saltTransferVelocity, & + landIceTemperature, & + seaSurfacePressure, & + landIceInterfaceSalinity, & + landIceInterfaceTemperature, & + landIceFreshwaterFlux, & + landIceHeatFlux, & + heatFluxToLandIce, & + nCellsSolve, & + err) + if(err .ne. 0) then + call mpas_dmpar_global_abort("ERROR: compute_HJ99_melt_fluxes failed.") + end if + + ! freezing solution + landIceHeatTransferVelocity(:) = 0.0_RKIND + call compute_melt_fluxes( & + landIceBoundaryLayerTemperature, & + landIceBoundaryLayerSalinity, & + heatTransferVelocity, & + saltTransferVelocity, & + landIceTemperature, & + landIceHeatTransferVelocity, & + seaSurfacePressure, & + freezeInterfaceSalinity, & + freezeInterfaceTemperature, & + freezeFreshwaterFlux, & + freezeHeatFlux, & + freezeIceHeatFlux, & + nCellsSolve, & + err) + if(err .ne. 0) then + call mpas_dmpar_global_abort("ERROR: compute_melt_fluxes failed.") + end if + + where(landIceFreshwaterFlux < 0.0_RKIND) + landIceInterfaceSalinity = freezeInterfaceSalinity + landIceInterfaceTemperature = freezeInterfaceTemperature + landIceFreshwaterFlux = freezeFreshwaterFlux + landIceHeatFlux = freezeHeatFlux + heatFluxToLandIce = freezeIceHeatFlux + end where + else + call compute_melt_fluxes( & + landIceBoundaryLayerTemperature, & + landIceBoundaryLayerSalinity, & + heatTransferVelocity, & + saltTransferVelocity, & + landIceTemperature, & + landIceHeatTransferVelocity, & + seaSurfacePressure, & + landIceInterfaceSalinity, & + landIceInterfaceTemperature, & + landIceFreshwaterFlux, & + landIceHeatFlux, & + heatFluxToLandIce, & + nCellsSolve, & + err) + if(err .ne. 0) then + call mpas_dmpar_global_abort("ERROR: compute_melt_fluxes failed.") + end if + end if + landIceFreshwaterFlux(:) = landIceFraction(:)*landIceFreshwaterFlux(:) + landIceHeatFlux(:) = landIceFraction(:)*landIceHeatFlux(:) + heatFluxToLandIce(:) = landIceFraction(:)*heatFluxToLandIce(:) + + end if + + call mpas_deallocate_scratch_field(boundaryLayerTemperatureField, .true.) + call mpas_deallocate_scratch_field(boundaryLayerSalinityField, .true.) + if(jenkinsOn .or. hollandJenkinsOn) then + call mpas_deallocate_scratch_field(heatTransferVelocityField, .true.) + call mpas_deallocate_scratch_field(saltTransferVelocityField, .true.) + end if + if(config_land_ice_flux_useHollandJenkinsAdvDiff) then + call mpas_deallocate_scratch_field(freezeInterfaceSalinityField, .true.) + call mpas_deallocate_scratch_field(freezeInterfaceTemperatureField, .true.) + call mpas_deallocate_scratch_field(freezeFreshwaterFluxField, .true.) + call mpas_deallocate_scratch_field(freezeHeatFluxField, .true.) + call mpas_deallocate_scratch_field(freezeIceHeatFluxField, .true.) + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_surface_land_ice_fluxes_build_arrays!}}} + +!*********************************************************************** +! +! routine ocn_surface_land_ice_fluxes_init +! +!> \brief Initializes land-ice forcing +!> \author Xylar Asay-Davis +!> \date 10/02/2014 +!> \details +!> This routine initializes a variety of quantities related to +!> land-ice forcing. +! +!----------------------------------------------------------------------- + + subroutine ocn_surface_land_ice_fluxes_init(err)!{{{ + + integer, intent(out) :: err !< Output: error flag + + character (len=StrKIND), pointer :: config_land_ice_flux_formulation + logical, pointer :: config_use_land_ice_fluxes + + real (kind=RKIND), pointer :: config_land_ice_flux_Tf0, & + config_land_ice_flux_dTf_dp, & + config_land_ice_flux_dTf_dS, & + config_land_ice_flux_cp_ice, & + config_land_ice_flux_rho_ice, & + config_density0 + + + err = 0 + isomipOn = .false. + jenkinsOn = .false. + hollandJenkinsOn = .false. + + call mpas_pool_get_config(ocnConfigs, 'config_use_land_ice_fluxes', config_use_land_ice_fluxes) + landIceFluxesOn = config_use_land_ice_fluxes + if(.not. landIceFluxesOn) return + + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_formulation', config_land_ice_flux_formulation) + + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_Tf0', config_land_ice_flux_Tf0) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_dTf_dp', config_land_ice_flux_dTf_dp) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_dTf_dS', config_land_ice_flux_dTf_dS) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_cp_ice', config_land_ice_flux_cp_ice) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_rho_ice', config_land_ice_flux_rho_ice) + call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) + + if ( trim(config_land_ice_flux_formulation) == 'ISOMIP' ) then + isomipOn = .true. + else if ( trim(config_land_ice_flux_formulation) == 'Jenkins' ) then + jenkinsOn = .true. + else if ( trim(config_land_ice_flux_formulation) == 'HollandJenkins' ) then + hollandJenkinsOn = .true. + else + write(stderrUnit, *) "ERROR: config_land_ice_flux_formulation not one of 'ISOMIP', 'Jenkins', or 'HollandJenkins'." + err = 1 + call mpas_dmpar_global_abort("ERROR: config_land_ice_flux_formulation not one of 'ISOMIP', 'Jenkins', or 'HollandJenkins'.") + end if + + Tf0 = config_land_ice_flux_Tf0 + dTf_dp = config_land_ice_flux_dTf_dp + dTf_dS = config_land_ice_flux_dTf_dS + cp_land_ice = config_land_ice_flux_cp_ice + rho_land_ice = config_land_ice_flux_rho_ice + refDensity = config_density0 + + !-------------------------------------------------------------------- + + end subroutine ocn_surface_land_ice_fluxes_init!}}} + +!*********************************************************************** +! +! routine ocn_forcing_compute_melt_fluxes +! +!> \brief Computes ocean and ice melt fluxes, etc. +!> \author Xylar Asay-Davis +!> \date 3/27/2015 +!> This routine computes melt fluxes (melt rate, temperature fluxes +!> into the ice and the ocean, and salt flux) as well as the interface +!> temperature and salinity. This routine expects an ice temperature +!> in the bottom layer of ice and ocean temperature and salinity in +!> the top ocean layer as well as the pressure at the ice/ocean interface. +!> +!> The ocean heat and salt transfer velocities are determined based on +!> observations of turbulent mixing rates in the under-ice boundary layer. +!> They should be the product of the friction velocity and a (possibly +!> spatially variable) non-dimenional transfer coefficient. +!> +!> The ice heat transfer velocity is either zero if heat conduction into the +!> ice is to be neglected or is computed as: +!> iceHeatTransferVelocity = kappa_ice/(0.5*dz_ice), +!> where kappa_ice is the molecular diffusivity of heat +!> in ice and dz_ice is the thickness of the bottom layer of ice, where +!> iceTemperature is supplied. +!> +! +!----------------------------------------------------------------------- + + + subroutine compute_melt_fluxes( & + oceanTemperature, & + oceanSalinity, & + oceanHeatTransferVelocity, & + oceanSaltTransferVelocity, & + iceTemperature, & + iceHeatTransferVelocity, & + interfacePressure, & + outInterfaceSalinity, & + outInterfaceTemperature, & + outFreshwaterFlux, & + outOceanHeatFlux, & + outIceHeatFlux, & + nCells, & + err) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(in) :: & + oceanTemperature, & !< Input: ocean temperature in top layer + oceanSalinity, & !< Input: ocean salinity in top layer + oceanHeatTransferVelocity, & !< Input: ocean heat transfer velocity + oceanSaltTransferVelocity, & !< Input: ocean salt transfer velocity + iceTemperature, & !< Input: ice temperature in bottom layer + iceHeatTransferVelocity, & !< Input: ice heat transfer velocity + interfacePressure !< Input: pressure at the ice-ocean interface + + integer, intent(in) :: nCells !< Input: number of cells in each array + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(out) :: & + outInterfaceSalinity, & !< Output: ocean salinity at the interface + outInterfaceTemperature, & !< Output: ice/ocean temperature at the interface + outFreshwaterFlux, & !< Output: ocean thickness flux (melt rate) + outOceanHeatFlux, & !< Output: the temperature flux into the ocean + outIceHeatFlux !< Output: the temperature flux into the ice + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND) :: T0, transferVelocityRatio, Tlatent, nu, a, b, c, eta + integer :: iCell + + err = 0 + Tlatent = latent_heat_fusion_mks/cp_sw + do iCell = 1, nCells + T0 = Tf0 + dTf_dp*interfacePressure(iCell) + transferVelocityRatio = oceanSaltTransferVelocity(iCell)/oceanHeatTransferVelocity(iCell) + + nu = (rho_land_ice*cp_land_ice*iceHeatTransferVelocity(iCell))/(refDensity*cp_sw*oceanHeatTransferVelocity(iCell)) + a = -dTf_dS*(1.0_RKIND + nu) + b = transferVelocityRatio*Tlatent - nu*(T0 - iceTemperature(iCell)) + oceanTemperature(iCell) - T0 + c = -transferVelocityRatio*Tlatent + + ! a is strictly positive; c is strictly negative so we never get imaginary roots + ! The positive root is the one we want (salinity is strictly positive) + outInterfaceSalinity(iCell) = (-b + sqrt(b**2 - 4.0_RKIND*a*c*oceanSalinity(iCell)))/(2.0_RKIND*a) + if (outInterfaceSalinity(iCell) .le. 0.0_RKIND) then + err = 1 + return + end if + outInterfaceTemperature(iCell) = dTf_dS*outInterfaceSalinity(iCell)+T0 + + outFreshwaterFlux(iCell) = refDensity*oceanSaltTransferVelocity(iCell) & + * (oceanSalinity(iCell)/outInterfaceSalinity(iCell) - 1.0_RKIND) + + ! According to Jenkins et al. (2001), the temperature fluxes into the ocean are: + ! 1. the advection of meltwater into the top layer (or removal for freezing) + ! 2. the turbulent transfer of heat across the boundary layer, based on the termal driving + outOceanHeatFlux(iCell) = cp_sw*(outFreshwaterFlux(iCell)*outInterfaceTemperature(iCell) & + - refDensity*oceanHeatTransferVelocity(iCell)*(oceanTemperature(iCell)-outInterfaceTemperature(iCell))) + + ! the temperature fluxes into the ice are: + ! 1. the advection of ice at the interface temperature out of the domain due to melting + ! (or in due to freezing) + ! 2. the diffusion (if any) of heat into the ice, based on temperature difference between + ! the reference point in the ice (either the surface or the middle of the bottom layer) + ! and the interface + outIceHeatFlux(iCell) = cp_land_ice * & + (- outFreshwaterFlux(iCell)*outInterfaceTemperature(iCell) & + - rho_land_ice*iceHeatTransferVelocity(iCell)*(iceTemperature(iCell) - outInterfaceTemperature(iCell))) + end do + + !-------------------------------------------------------------------- + + end subroutine compute_melt_fluxes + + + +!*********************************************************************** +! +! routine compute_HJ99_melt_fluxes +! +!> \brief Computes melt fluxes, etc. according to HJ99 +!> \author Xylar Asay-Davis +!> \date 3/28/2015 +!> \details +!> This routine computes melt fluxes (melt rate, temperature fluxes +!> into the ice and the ocean, and salt flux) as well as the interface +!> temperature and salinity. Following Holland and Jenkins (1999), +!> temperature is assumed to be vertically advected and diffused in +!> the ice at a rate determined by the melt rate, so that no +!> heat transfer velocity for the ice need be supplied. Except for +!> very small melt rates, the Holland and Jenkins advection/diffusion +!> solution produces an ice temperature profile that is approximately +!> constant with depth except near the ice-ocean interface. The ice +!> temperature supplied to this routine should be the far-field value, +!> equal to the time-averaged surface temperature. +!> +!> The solution is only appropriate for melting (positive ocean +!> thickness flux). For freezing, the fluxes should be computed using +!> ocn_forcing_compute_melt_fluxes with ``insulating'' ice where +!> the iceHeatTransferVelocity is set to zero. +! +!----------------------------------------------------------------------- + + subroutine compute_HJ99_melt_fluxes( & + oceanTemperature, & + oceanSalinity, & + oceanHeatTransferVelocity, & + oceanSaltTransferVelocity, & + iceTemperature, & + interfacePressure, & + outInterfaceSalinity, & + outInterfaceTemperature, & + outFreshwaterFlux, & + outOceanHeatFlux, & + outIceHeatFlux, & + nCells, & + err) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(in) :: & + oceanTemperature, & !< Input: ocean temperature in top layer + oceanSalinity, & !< Input: ocean salinity in top layer + oceanHeatTransferVelocity, & !< Input: ocean heat transfer velocity + oceanSaltTransferVelocity, & !< Input: ocean salt transfer velocity + iceTemperature, & !< Input: ice temperature in bottom layer + interfacePressure !< Input: pressure at the ice-ocean interface + + integer, intent(in) :: nCells !< Input: number of cells in each array + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(out) :: & + outInterfaceSalinity, & !< Output: ocean salinity at the interface + outInterfaceTemperature, & !< Output: ice/ocean temperature at the interface + outFreshwaterFlux, & !< Output: ocean thickness flux (melt rate) + outOceanHeatFlux, & !< Output: the temperature flux into the ocean + outIceHeatFlux !< Output: the temperature flux into the ice + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND) :: T0, cpRatio, transferVelocityRatio, Tlatent, a, b, c, eta, TlatentStar + + integer :: iCell + + err = 0 + cpRatio = cp_land_ice/cp_sw + do iCell = 1, nCells + T0 = Tf0 + dTf_dp*interfacePressure(iCell) + transferVelocityRatio = (rho_fw/refDensity)*oceanSaltTransferVelocity(iCell)/oceanHeatTransferVelocity(iCell) + Tlatent = latent_heat_fusion_mks/cp_sw + + eta = cpRatio * transferVelocityRatio + TlatentStar = Tlatent + cpRatio*(T0-iceTemperature(iCell)) + a = -dTf_dS*(1.0_RKIND - eta) + b = (transferVelocityRatio*TlatentStar - eta*dTf_dS*oceanSalinity(iCell) & + + oceanTemperature(iCell) - T0) + c = -transferVelocityRatio*TlatentStar + + ! a is strictly positive; c is strictly negative so we never get imaginary roots + ! The positive root is the one we want (salinity is strictly positive) + outInterfaceSalinity(iCell) = (-b + sqrt(b**2 - 4.0_RKIND*a*c*oceanSalinity(iCell)))/(2.0_RKIND*a) + if (outInterfaceSalinity(iCell) .le. 0.0_RKIND) then + err = 1 + return + end if + outInterfaceTemperature(iCell) = dTf_dS*outInterfaceSalinity(iCell)+T0 + + outFreshwaterFlux(iCell) = refDensity*oceanSaltTransferVelocity(iCell) & + * (oceanSalinity(iCell)/outInterfaceSalinity(iCell) - 1.0_RKIND) + + ! According to Jenkins et al. (2001), the temperature fluxes into the ocean are: + ! 1. the advection of meltwater into the top layer (or removal for freezing) + ! 2. the turbulent transfer of heat across the boundary layer, based on the termal driving + outOceanHeatFlux(iCell) = cp_sw*(outFreshwaterFlux(iCell)*outInterfaceTemperature(iCell) & + - refDensity*oceanHeatTransferVelocity(iCell)*(oceanTemperature(iCell)-outInterfaceTemperature(iCell))) + + ! Since we're considering only melting and ignoring diffusion, + ! the ice loses heat simply by the loss of ice mass at the prescribed + ! (surface?) ice temperature + outIceHeatFlux(iCell) = -cp_land_ice*outFreshwaterFlux(iCell)*iceTemperature(iCell) + end do + + !-------------------------------------------------------------------- + + end subroutine compute_HJ99_melt_fluxes + + +!*********************************************************************** + +end module ocn_surface_land_ice_fluxes diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index b2798e0ee1..f0a1c0b45a 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -28,6 +28,7 @@ module ocn_tendency use ocn_constants use ocn_surface_bulk_forcing + use ocn_surface_land_ice_fluxes use ocn_tracer_hmix use ocn_high_freq_thickness_hmix_del2 @@ -139,11 +140,16 @@ subroutine ocn_tend_thick(tendPool, forcingPool, diagnosticsPool, meshPool)!{{{ if(config_disable_thick_all_tend) return - ! Build suface stress array from bulk + ! Build suface mass flux array from bulk call mpas_timer_start("bulk_thick", .false.) call ocn_surface_bulk_forcing_thick(meshPool, forcingPool, surfaceThicknessFlux, err) call mpas_timer_stop("bulk_thick") + ! Build suface thickness flux array from land ice + call mpas_timer_start("land_ice_thick", .false.) + call ocn_surface_land_ice_fluxes_thick(meshPool, forcingPool, surfaceThicknessFlux, err) + call mpas_timer_stop("land_ice_thick") + ! ! height tendency: horizontal advection term -\nabla\cdot ( hu) ! @@ -269,6 +275,11 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP call ocn_surface_bulk_forcing_vel(meshPool, forcingPool, surfaceStress, surfaceStressMagnitude, err) call mpas_timer_stop("bulk_ws") + ! Add top drag to suface stress + call mpas_timer_start("top_drag", .false.) + call ocn_surface_land_ice_fluxes_vel(meshPool, forcingPool, surfaceStress, surfaceStressMagnitude, err) + call mpas_timer_stop("top_drag") + ! ! velocity tendency: nonlinear Coriolis term and grad of kinetic energy ! @@ -550,11 +561,11 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me call mpas_timer_stop("surface_restoring_" // trim(groupItr % memberName)) endif - ! land-ice / ocean interface flux - ! this is a flux at the top ocean surface -- so these fluxes should be added into tracerGroupSurfaceFlux - ! if (put correct logic here, only 'active' when coupling is turned on) - ! call ocn_tracer_landIce_ocean_coupling(tracerGroup, tracerGroupSurfaceFlux) - ! endif + ! tracer fluxes at the land-ice / ocean interface + ! this is a flux at the top ocean surface -- so these fluxes are added into tracerGroupSurfaceFlux + call mpas_timer_start("land_ice_" // trim(groupItr % memberName), .false.) + call ocn_surface_land_ice_fluxes_tracers(meshPool, groupItr % memberName, forcingPool, tracerGroupSurfaceFlux, err) + call mpas_timer_stop("land_ice_" // trim(groupItr % memberName)) ! ! other additions to tracerGroupSurfaceFlux should be added here diff --git a/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F b/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F index 4e524dd0b9..2e41b052ac 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F @@ -51,7 +51,7 @@ module ocn_vel_forcing_surface_stress ! !-------------------------------------------------------------------- - logical :: windStressOn + logical :: surfaceStressOn !*********************************************************************** @@ -129,7 +129,7 @@ subroutine ocn_vel_forcing_surface_stress_tend(meshPool, surfaceStress, layerThi err = 0 - if ( .not. windStressOn ) return + if ( .not. surfaceStressOn ) return call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) @@ -197,9 +197,9 @@ subroutine ocn_vel_forcing_surface_stress_init(err)!{{{ call mpas_pool_get_config(ocnConfigs, 'config_disable_vel_surface_stress', config_disable_vel_surface_stress) - windStressOn = .true. + surfaceStressOn = .true. - if(config_disable_vel_surface_stress) windStressOn = .false. + if(config_disable_vel_surface_stress) surfaceStressOn = .false. err = 0 From 2d54a666627c6215db2a8e467cfda544518336a2 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Mon, 14 Sep 2015 13:05:13 -0700 Subject: [PATCH 0241/1724] bulk fluxes add to rather than overwriting surface fluxes Both surfaceThicknessFlux and surfaceStress now have other sources outside of bulk (from land ice) so bulk fluxes are now added to each rather than assigned to each --- src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F index 1430e37d42..14b799ae61 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F @@ -188,13 +188,13 @@ subroutine ocn_surface_bulk_forcing_vel(meshPool, forcingPool, surfaceStress, su zonalAverage = 0.5 * (windStressZonal(cell1) + windStressZonal(cell2)) meridionalAverage = 0.5 * (windStressMeridional(cell1) + windStressMeridional(cell2)) - surfaceStress(iEdge) = cos(angleEdge(iEdge)) * zonalAverage + sin(angleEdge(iEdge)) * meridionalAverage + surfaceStress(iEdge) = surfaceStress(iEdge) + cos(angleEdge(iEdge)) * zonalAverage + sin(angleEdge(iEdge)) * meridionalAverage end do ! Build surface fluxes at cell centers do iCell = 1, nCells - surfaceStressMagnitude(iCell) = sqrt(windStressZonal(iCell)**2 + windStressMeridional(iCell)**2) + surfaceStressMagnitude(iCell) = surfaceStressMagnitude(iCell) + sqrt(windStressZonal(iCell)**2 + windStressMeridional(iCell)**2) end do end subroutine ocn_surface_bulk_forcing_vel!}}} @@ -267,7 +267,7 @@ subroutine ocn_surface_bulk_forcing_thick(meshPool, forcingPool, surfaceThicknes ! Build surface fluxes at cell centers do iCell = 1, nCells - surfaceThicknessFlux(iCell) = ( snowFlux(iCell) + rainFlux(iCell) + evaporationFlux(iCell) + seaIceFreshWaterFlux(iCell) + iceRunoffFlux(iCell) + riverRunoffFlux(iCell) ) / refDensity + surfaceThicknessFlux(iCell) = surfaceThicknessFlux(iCell) + ( snowFlux(iCell) + rainFlux(iCell) + evaporationFlux(iCell) + seaIceFreshWaterFlux(iCell) + iceRunoffFlux(iCell) + riverRunoffFlux(iCell) ) / refDensity end do end subroutine ocn_surface_bulk_forcing_thick!}}} From 9f733b6103b23da8ec3e43831382e27c8b627217 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Mon, 14 Sep 2015 22:57:14 -0700 Subject: [PATCH 0242/1724] Moved several land-ice related fields to diagnostics The boundary-layer T and S, the heat and salt transfer velocitities, the top drag and the friction velocity are now computed as part of diagnostics. This ensures that they are at the right time level when they are used to compute fluxes and better separates fields that will always be computed in MPAS-O from those that will sometiems be computed in the coupler. --- src/core_ocean/Registry.xml | 71 ++-- .../mode_forward/mpas_ocn_forward_mode.F | 4 +- src/core_ocean/shared/mpas_ocn_diagnostics.F | 238 ++++++++++++++ .../shared/mpas_ocn_surface_land_ice_fluxes.F | 302 +++++------------- src/core_ocean/shared/mpas_ocn_tendency.F | 2 +- 5 files changed, 352 insertions(+), 265 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index d006972fdb..5ae6fe6f3a 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -598,8 +598,8 @@ possible_values=".true. or .false." /> + + - - + @@ -1179,8 +1186,7 @@ - - + @@ -2121,6 +2127,29 @@ description="GM stream function" packages="forwardMode;analysisMode" /> + + + + + + - - @@ -2386,18 +2411,6 @@ description="The salinity at the land ice-ocean interface" packages="landIceFluxesPKG" /> - - - - - block_ptr % next end do diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index d3e38da37e..3069bf0f72 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -662,6 +662,12 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic call computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, timeLevel) endif + + ! + ! compute fields needed to compute land-ice fluxes, either in the ocean model or in the coupler + call computeLandIceFluxInputFields(meshPool, statePool, forcingPool, scratchPool, & + diagnosticsPool, timeLevel) + do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1, iEdge) cell2 = cellsOnEdge(2, iEdge) @@ -1281,6 +1287,238 @@ subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPo end subroutine computeKPPInputFields!}}} + +!*********************************************************************** +! +! routine computeLandIceFluxInputFields +! +!> \brief Builds the forcing array for land-ice forcing +!> \author Xylar Asay-Davis +!> \date 09/14/2015 +!> \details +!> This routine builds surface flux arrays related to land-ice forcing. +! +!----------------------------------------------------------------------- + + subroutine computeLandIceFluxInputFields(meshPool, statePool, & + forcingPool, scratchPool, diagnosticsPool, timeLevel)!{{{ + + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), intent(in) :: statePool !< Input: State information + type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information + type (mpas_pool_type), intent(in) :: scratchPool !< Input/Output: scratch variables + type (mpas_pool_type), intent(inout) :: diagnosticsPool !< Input/Output: Diagnostics information + + integer, intent(in) :: timeLevel + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: tracersPool + + integer :: iCell, iEdge, cell1, cell2, iLevel, i + integer, pointer :: nCellsSolve, nEdgesSolve + + integer, dimension(:,:), pointer :: cellsOnCell, cellsOnEdge + + integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell + + integer, pointer :: indexT, indexS + + character (len=StrKIND), pointer :: config_land_ice_flux_formulation + logical, pointer :: config_use_land_ice_fluxes + + real (kind=RKIND), pointer :: config_land_ice_flux_boundaryLayerThickness, & + config_land_ice_flux_boundaryLayerNeighborWeight, & + config_land_ice_flux_topDragCoeff, & + config_land_ice_flux_rms_tidal_velocity, & + config_land_ice_flux_jenkins_heat_transfer_coefficient, & + config_land_ice_flux_jenkins_salt_transfer_coefficient + + real (kind=RKIND) :: blThickness, dz, blWeightSum, h_nu, Gamma_turb, landIceEdgeFraction, velocityMagnitude + + real (kind=RKIND), dimension(:), pointer :: landIceFraction, & + landIceFrictionVelocity, & + landIceBoundaryLayerTemperature, & + landIceBoundaryLayerSalinity, & + landIceHeatTransferVelocity, & + landIceSaltTransferVelocity, & + topDrag, & + topDragMagnitude, & + fCell, & + blTempScratch, blSaltScratch + + real (kind=RKIND), dimension(:,:), pointer :: kineticEnergyCell, layerThickness, normalVelocity + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers + type (field1DReal), pointer :: boundaryLayerTemperatureField, boundaryLayerSalinityField + + logical :: jenkinsOn, hollandJenkinsOn + + ! constants for Holland and Jenkins 1999 parameterization of the boundary layer + real (kind=RKIND), parameter :: & + Pr = 13.8_RKIND, & ! the Prandtl number + Sc = 2432.0_RKIND, & ! the Schmidt number + nuSaltWater = 1.95e-6_RKIND, & ! molecular viscosity of sea water (m^2/s) + kVonKarman = 0.4_RKIND, & ! the von Karman constant + xiN = 0.052_RKIND ! dimensionless planetary boundary layer constant + + + call mpas_pool_get_config(ocnConfigs, 'config_use_land_ice_fluxes', config_use_land_ice_fluxes) + if(.not. config_use_land_ice_fluxes) return + + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_formulation', config_land_ice_flux_formulation) + if ( trim(config_land_ice_flux_formulation) == 'Jenkins' ) then + jenkinsOn = .true. + else if ( trim(config_land_ice_flux_formulation) == 'HollandJenkins' ) then + hollandJenkinsOn = .true. + end if + + + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_topDragCoeff', config_land_ice_flux_topDragCoeff) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_boundaryLayerThickness', config_land_ice_flux_boundaryLayerThickness) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_boundaryLayerNeighborWeight', config_land_ice_flux_boundaryLayerNeighborWeight) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_rms_tidal_velocity', config_land_ice_flux_rms_tidal_velocity) + + if(jenkinsOn) then + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_jenkins_heat_transfer_coefficient', config_land_ice_flux_jenkins_heat_transfer_coefficient) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_jenkins_salt_transfer_coefficient', config_land_ice_flux_jenkins_salt_transfer_coefficient) + end if + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexT) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexS) + + call mpas_pool_get_array(forcingPool, 'landIceFraction', landIceFraction) + + call mpas_pool_get_array(diagnosticsPool, 'landIceFrictionVelocity', landIceFrictionVelocity) + call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerTemperature', landIceBoundaryLayerTemperature) + call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerSalinity', landIceBoundaryLayerSalinity) + call mpas_pool_get_array(diagnosticsPool, 'topDrag', topDrag) + call mpas_pool_get_array(diagnosticsPool, 'topDragMagnitude', topDragMagnitude) + if(jenkinsOn .or. hollandJenkinsOn) then + call mpas_pool_get_array(diagnosticsPool, 'landIceHeatTransferVelocity', landIceHeatTransferVelocity) + call mpas_pool_get_array(diagnosticsPool, 'landIceSaltTransferVelocity', landIceSaltTransferVelocity) + end if + + call mpas_pool_get_field(scratchPool, 'boundaryLayerTemperatureScratch', boundaryLayerTemperatureField) + call mpas_pool_get_field(scratchPool, 'boundaryLayerSalinityScratch', boundaryLayerSalinityField) + call mpas_allocate_scratch_field(boundaryLayerTemperatureField, .true.) + call mpas_allocate_scratch_field(boundaryLayerSalinityField, .true.) + blTempScratch => boundaryLayerTemperatureField % array + blSaltScratch => boundaryLayerSalinityField % array + if(hollandJenkinsOn) then + call mpas_pool_get_array(meshPool, 'fCell', fCell) + end if + + ! Compute top drag + do iEdge = 1, nEdgesSolve + cell1 = cellsOnEdge(1, iEdge) + cell2 = cellsOnEdge(2, iEdge) + + ! top drag tau = - CD*|u|*u, where |u| = sqrt(2*KE) = sqrt(KE1 + KE2) from the neighboring cells + velocityMagnitude = sqrt(kineticEnergyCell(1,cell1) + kineticEnergyCell(1,cell2)) + landIceEdgeFraction = 0.5_RKIND*(landIceFraction(cell1)+landIceFraction(cell2)) + + topDrag(iEdge) = - landIceEdgeFraction * config_land_ice_flux_topDragCoeff & + * velocityMagnitude * normalVelocity(1,iEdge) + + end do + + ! compute top drag magnitude and friction velocity at cell centers + do iCell = 1, nCellsSolve + ! the magnitude of the top drag is CD*u**2 = CD*(2*KE) + topDragMagnitude(iCell) = landIceFraction(iCell) & + * 2.0_RKIND * config_land_ice_flux_topDragCoeff * kineticEnergyCell(1,iCell) + + ! the friction velocity is the square root of the top drag + variance of tidal velocity (computed regardless of land-ice coverage) + landIceFrictionVelocity(iCell) = sqrt(config_land_ice_flux_topDragCoeff* (2.0_RKIND * kineticEnergyCell(1,iCell) & + + config_land_ice_flux_rms_tidal_velocity)) + end do + + + + ! average temperature and salinity over horizontal neighbors and the sub-ice-shelf boundary layer + do iCell = 1, nCellsSolve + blThickness = 0.0_RKIND + blTempScratch(iCell) = 0.0_RKIND + blSaltScratch(iCell) = 0.0_RKIND + do iLevel = 1, maxLevelCell(iCell) + dz = min(layerThickness(iLevel,iCell),config_land_ice_flux_boundaryLayerThickness-blThickness) + if(dz <= 0.0_RKIND) exit + blTempScratch(iCell) = blTempScratch(iCell) + activeTracers(indexT, iLevel, iCell)*dz + blSaltScratch(iCell) = blSaltScratch(iCell) + activeTracers(indexS, iLevel, iCell)*dz + blThickness = blThickness + dz + end do + if(blThickness > 0.0_RKIND) then + blTempScratch(iCell) = blTempScratch(iCell)/blThickness + blSaltScratch(iCell) = blSaltScratch(iCell)/blThickness + end if + end do + do iCell = 1, nCellsSolve + blWeightSum = 1.0_RKIND + landIceBoundaryLayerTemperature(iCell) = blTempScratch(iCell) + landIceBoundaryLayerSalinity(iCell) = blSaltScratch(iCell) + do i = 1, nEdgesOnCell(iCell) + cell2 = cellsOnCell(i,iCell) + if(cell2 <= 0 .or. cell2 > nCellsSolve) cycle + + landIceBoundaryLayerTemperature(iCell) = landIceBoundaryLayerTemperature(iCell) & + + config_land_ice_flux_boundaryLayerNeighborWeight*blTempScratch(cell2) + landIceBoundaryLayerSalinity(iCell) = landIceBoundaryLayerSalinity(iCell) & + + config_land_ice_flux_boundaryLayerNeighborWeight*blSaltScratch(cell2) + blWeightSum = blWeightSum + config_land_ice_flux_boundaryLayerNeighborWeight + end do + if(blWeightSum > 0.0_RKIND) then + landIceBoundaryLayerTemperature(iCell) = landIceBoundaryLayerTemperature(iCell)/blWeightSum + landIceBoundaryLayerSalinity(iCell) = landIceBoundaryLayerSalinity(iCell)/blWeightSum + end if + end do + + if(jenkinsOn) then + do iCell = 1, nCellsSolve + ! transfer coefficients from namelist + landIceHeatTransferVelocity(iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_heat_transfer_coefficient + landIceSaltTransferVelocity(iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_salt_transfer_coefficient + end do + else if(hollandJenkinsOn) then + do iCell = 1, nCellsSolve + ! friction-velocity dependent non-dimensional transfer coefficients from + ! Holland and Jenkins 1999, (14)-(16) with eta_* = 1 + h_nu = 5.0_RKIND*nuSaltWater/landIceFrictionVelocity(iCell) ! uStar should never be zero because of tidal term + + Gamma_turb = 1.0_RKIND/(2.0_RKIND*xiN) - 1.0_RKIND/kVonKarman + if(abs(fCell(iCell)) > 0.0_RKIND) then + Gamma_turb = Gamma_turb + 1.0_RKIND/kVonKarman*log(landIceFrictionVelocity(iCell) & + *xiN/(abs(fCell(iCell))*h_nu)) + end if + + landIceHeatTransferVelocity(iCell) = 1.0_RKIND/(Gamma_turb + 12.5_RKIND*Pr**(2.0_RKIND/3.0_RKIND) - 6.0_RKIND) + landIceSaltTransferVelocity(iCell) = 1.0_RKIND/(Gamma_turb + 12.5_RKIND*Sc**(2.0_RKIND/3.0_RKIND) - 6.0_RKIND) + end do + end if + + call mpas_deallocate_scratch_field(boundaryLayerTemperatureField, .true.) + call mpas_deallocate_scratch_field(boundaryLayerSalinityField, .true.) + + !-------------------------------------------------------------------- + + end subroutine computeLandIceFluxInputFields!}}} + + !*********************************************************************** ! ! routine ocn_reconstruct_gm_vectors diff --git a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F index 584899f755..ef3b9ce72e 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F +++ b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F @@ -56,7 +56,7 @@ module ocn_surface_land_ice_fluxes logical :: landIceFluxesOn, isomipOn, jenkinsOn, hollandJenkinsOn - real (kind=RKIND) :: Tf0, dTf_dp, dTf_dS, cp_land_ice, rho_land_ice, refDensity + real (kind=RKIND) :: Tf0, dTf_dp, dTf_dS, cp_land_ice, rho_land_ice !*********************************************************************** @@ -129,7 +129,7 @@ end subroutine ocn_surface_land_ice_fluxes_tracers!}}} ! !----------------------------------------------------------------------- - subroutine ocn_surface_land_ice_fluxes_vel(meshPool, forcingPool, surfaceStress, surfaceStressMagnitude, err)!{{{ + subroutine ocn_surface_land_ice_fluxes_vel(meshPool, diagnosticsPool, surfaceStress, surfaceStressMagnitude, err)!{{{ !----------------------------------------------------------------- ! @@ -137,7 +137,7 @@ subroutine ocn_surface_land_ice_fluxes_vel(meshPool, forcingPool, surfaceStress, ! !----------------------------------------------------------------- type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information - type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information + type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostics information !----------------------------------------------------------------- ! @@ -172,8 +172,8 @@ subroutine ocn_surface_land_ice_fluxes_vel(meshPool, forcingPool, surfaceStress, call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - call mpas_pool_get_array(forcingPool, 'topDrag', topDrag) - call mpas_pool_get_array(forcingPool, 'topDragMagnitude', topDragMagnitude) + call mpas_pool_get_array(diagnosticsPool, 'topDrag', topDrag) + call mpas_pool_get_array(diagnosticsPool, 'topDragMagnitude', topDragMagnitude) do iEdge = 1, nEdges surfaceStress(iEdge) = surfaceStress(iEdge) + topDrag(iEdge) @@ -247,7 +247,7 @@ subroutine ocn_surface_land_ice_fluxes_thick(meshPool, forcingPool, surfaceThick ! Build surface fluxes at cell centers do iCell = 1, nCells - surfaceThicknessFlux(iCell) = surfaceThicknessFlux(iCell) + landIceFreshwaterFlux(iCell) / refDensity + surfaceThicknessFlux(iCell) = surfaceThicknessFlux(iCell) + landIceFreshwaterFlux(iCell) / rho_sw end do end subroutine ocn_surface_land_ice_fluxes_thick!}}} @@ -309,7 +309,7 @@ subroutine ocn_surface_land_ice_fluxes_active_tracers(meshPool, forcingPool, tra ! add to surface fluxes at cell centers do iCell = 1, nCells - tracersSurfaceFlux(1, iCell) = tracersSurfaceFlux(1, iCell) + landIceHeatFlux(iCell)/(refDensity*cp_sw) + tracersSurfaceFlux(1, iCell) = tracersSurfaceFlux(1, iCell) + landIceHeatFlux(iCell)/(rho_sw*cp_sw) end do end subroutine ocn_surface_land_ice_fluxes_active_tracers!}}} @@ -323,12 +323,13 @@ end subroutine ocn_surface_land_ice_fluxes_active_tracers!}}} !> \author Xylar Asay-Davis !> \date 10/02/2014 !> \details -!> This routine builds surface flux arrays related to land-ice forcing. +!> This routine computes surface fluxes related to land-ice forcing based +!> on diagnostics from the previous time step. ! !----------------------------------------------------------------------- - subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, statePool, diagnosticsPool, & - forcingPool, scratchPool, timeLevel, err)!{{{ + subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & + forcingPool, scratchPool, err)!{{{ !----------------------------------------------------------------- ! @@ -337,12 +338,9 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, statePool, diagnos !----------------------------------------------------------------- type (mpas_pool_type), intent(in) :: & - statePool, & !< Input: State information meshPool, & !< Input: mesh information diagnosticsPool !< Input: diagnostics information - integer, intent(in) :: timeLevel - !----------------------------------------------------------------- ! ! input/output variables @@ -368,126 +366,59 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, statePool, diagnos type (mpas_pool_type), pointer :: tracersPool - integer :: iCell, iEdge, cell1, cell2, iLevel, i - integer, pointer :: nCellsSolve, nEdgesSolve - - integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnCell - - integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell - - integer, pointer :: indexT, indexS + integer :: iCell + integer, pointer :: nCellsSolve - real (kind=RKIND), pointer :: config_land_ice_flux_topDragCoeff, config_land_ice_flux_ISOMIP_gammaT, & - config_land_ice_flux_boundaryLayerThickness, & - config_land_ice_flux_boundaryLayerNeighborWeight, & - config_land_ice_flux_rms_tidal_velocity, & - config_land_ice_flux_jenkins_heat_transfer_coefficient, & - config_land_ice_flux_jenkins_salt_transfer_coefficient + real (kind=RKIND), pointer :: config_land_ice_flux_ISOMIP_gammaT logical, pointer :: config_land_ice_flux_useHollandJenkinsAdvDiff - real (kind=RKIND) :: velocityMagnitude, freshwaterFlux, heatFlux, & - landIceEdgeFraction, blThickness, dz, blWeightSum, h_nu, Gamma_turb + real (kind=RKIND) :: freshwaterFlux, heatFlux real (kind=RKIND), dimension(:), pointer :: seaSurfacePressure, landIceFraction, & + landIceSurfaceTemperature, & landIceInterfaceTemperature, & landIceInterfaceSalinity, landIceFrictionVelocity, & landIceBoundaryLayerTemperature, & landIceBoundaryLayerSalinity, & - landIceFreshwaterFlux, topDrag, topDragMagnitude, & + landIceFreshwaterFlux, & landIceHeatFlux, heatFluxToLandIce, & - blTempScratch, blSaltScratch, heatTransferVelocity, & - saltTransferVelocity, landIceTemperature, & - landIceHeatTransferVelocity, fCell, & + landIceHeatTransferVelocity, & + landIceSaltTransferVelocity, & freezeInterfaceSalinity, freezeInterfaceTemperature, & freezeFreshwaterFlux, freezeHeatFlux, & freezeIceHeatFlux - real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, kineticEnergyCell, layerThickness real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers type (field1DReal), pointer :: boundaryLayerTemperatureField, boundaryLayerSalinityField, & - heatTransferVelocityField, saltTransferVelocityField, & freezeInterfaceSalinityField, freezeInterfaceTemperatureField, & freezeFreshwaterFluxField, freezeHeatFluxField, & freezeIceHeatFluxField - ! constants for Holland and Jenkins 1999 parameterization of the boundary layer - real (kind=RKIND), parameter :: & - Pr = 13.8_RKIND, & ! the Prandtl number - Sc = 2432.0_RKIND, & ! the Schmidt number - nuSaltWater = 1.95e-6_RKIND, & ! molecular viscosity of sea water (m^2/s) - kVonKarman = 0.4_RKIND, & ! the von Karman constant - xiN = 0.052_RKIND ! dimensionless planetary boundary layer constant - - - err = 0 - call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_topDragCoeff', config_land_ice_flux_topDragCoeff) call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_ISOMIP_gammaT', config_land_ice_flux_ISOMIP_gammaT) - call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_boundaryLayerThickness', config_land_ice_flux_boundaryLayerThickness) - call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_boundaryLayerNeighborWeight', config_land_ice_flux_boundaryLayerNeighborWeight) - call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_rms_tidal_velocity', config_land_ice_flux_rms_tidal_velocity) call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_useHollandJenkinsAdvDiff', config_land_ice_flux_useHollandJenkinsAdvDiff) - if(jenkinsOn) then - call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_jenkins_heat_transfer_coefficient', config_land_ice_flux_jenkins_heat_transfer_coefficient) - call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_jenkins_salt_transfer_coefficient', config_land_ice_flux_jenkins_salt_transfer_coefficient) - end if - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) - - call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) - - call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) - call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) - call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) - call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) - call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexT) - call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexS) - - call mpas_pool_get_array(diagnosticsPool, 'kineticEnergyCell', kineticEnergyCell) + call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerTemperature', landIceBoundaryLayerTemperature) + call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerSalinity', landIceBoundaryLayerSalinity) + call mpas_pool_get_array(diagnosticsPool, 'landIceHeatTransferVelocity', landIceHeatTransferVelocity) + call mpas_pool_get_array(diagnosticsPool, 'landIceSaltTransferVelocity', landIceSaltTransferVelocity) call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) call mpas_pool_get_array(forcingPool, 'landIceFraction', landIceFraction) + call mpas_pool_get_array(forcingPool, 'landIceSurfaceTemperature', landIceSurfaceTemperature) - call mpas_pool_get_array(forcingPool, 'topDrag', topDrag) - call mpas_pool_get_array(forcingPool, 'topDragMagnitude', topDragMagnitude) call mpas_pool_get_array(forcingPool, 'landIceFreshwaterFlux', landIceFreshwaterFlux) call mpas_pool_get_array(forcingPool, 'landIceHeatFlux', landIceHeatFlux) call mpas_pool_get_array(forcingPool, 'heatFluxToLandIce', heatFluxToLandIce) call mpas_pool_get_array(forcingPool, 'landIceInterfaceTemperature', landIceInterfaceTemperature) call mpas_pool_get_array(forcingPool, 'landIceInterfaceSalinity', landIceInterfaceSalinity) call mpas_pool_get_array(forcingPool, 'landIceFrictionVelocity', landIceFrictionVelocity) - call mpas_pool_get_array(forcingPool, 'landIceBoundaryLayerTemperature', landIceBoundaryLayerTemperature) - call mpas_pool_get_array(forcingPool, 'landIceBoundaryLayerSalinity', landIceBoundaryLayerSalinity) - - call mpas_pool_get_field(scratchPool, 'boundaryLayerTemperatureScratch', boundaryLayerTemperatureField) - call mpas_pool_get_field(scratchPool, 'boundaryLayerSalinityScratch', boundaryLayerSalinityField) - call mpas_allocate_scratch_field(boundaryLayerTemperatureField, .true.) - call mpas_allocate_scratch_field(boundaryLayerSalinityField, .true.) - blTempScratch => boundaryLayerTemperatureField % array - blSaltScratch => boundaryLayerSalinityField % array - if(jenkinsOn .or. hollandJenkinsOn) then - call mpas_pool_get_array(forcingPool, 'landIceTemperature', landIceTemperature) - call mpas_pool_get_array(forcingPool, 'landIceHeatTransferVelocity', landIceHeatTransferVelocity) - - call mpas_pool_get_field(scratchPool, 'heatTransferVelocityScratch', heatTransferVelocityField) - call mpas_pool_get_field(scratchPool, 'saltTransferVelocityScratch', saltTransferVelocityField) - call mpas_allocate_scratch_field(heatTransferVelocityField, .true.) - call mpas_allocate_scratch_field(saltTransferVelocityField, .true.) - heatTransferVelocity => heatTransferVelocityField % array - saltTransferVelocity => saltTransferVelocityField % array - end if - if(hollandJenkinsOn) then - call mpas_pool_get_array(meshPool, 'fCell', fCell) - end if + if(config_land_ice_flux_useHollandJenkinsAdvDiff) then call mpas_pool_get_field(scratchPool, 'freezeInterfaceSalinityScratch', freezeInterfaceSalinityField) call mpas_pool_get_field(scratchPool, 'freezeInterfaceTemperatureScratch', freezeInterfaceTemperatureField) @@ -506,68 +437,6 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, statePool, diagnos freezeIceHeatFlux => freezeIceHeatFluxField % array end if - - ! Compute top drag - do iEdge = 1, nEdgesSolve - cell1 = cellsOnEdge(1, iEdge) - cell2 = cellsOnEdge(2, iEdge) - - ! top drag tau = - CD*|u|*u, where |u| = sqrt(2*KE) = sqrt(KE1 + KE2) from the neighboring cells - velocityMagnitude = sqrt(kineticEnergyCell(1,cell1) + kineticEnergyCell(1,cell2)) - landIceEdgeFraction = 0.5_RKIND*(landIceFraction(cell1)+landIceFraction(cell2)) - - topDrag(iEdge) = - landIceEdgeFraction * config_land_ice_flux_topDragCoeff & - * velocityMagnitude * normalVelocity(1,iEdge) - - end do - - ! compute top drag and friction velocity at cell centers - do iCell = 1, nCellsSolve - ! the magnitude of the top drag is CD*u**2 = CD*(2*KE) - topDragMagnitude(iCell) = landIceFraction(iCell) & - * 2.0_RKIND * config_land_ice_flux_topDragCoeff * kineticEnergyCell(1,iCell) - ! the friction velocity is the square root of the top drag + variance of tidal velocity (computed regardless of land-ice coverage) - landIceFrictionVelocity(iCell) = sqrt(config_land_ice_flux_topDragCoeff* (2.0_RKIND * kineticEnergyCell(1,iCell) & - + config_land_ice_flux_rms_tidal_velocity)) - end do - - ! average temperature and salinity over horizontal neighbors and the sub-ice-shelf boundary layer - do iCell = 1, nCellsSolve - blThickness = 0.0_RKIND - blTempScratch(iCell) = 0.0_RKIND - blSaltScratch(iCell) = 0.0_RKIND - do iLevel = 1, maxLevelCell(iCell) - dz = min(layerThickness(iLevel,iCell),config_land_ice_flux_boundaryLayerThickness-blThickness) - if(dz <= 0.0_RKIND) exit - blTempScratch(iCell) = blTempScratch(iCell) + activeTracers(indexT, iLevel, iCell)*dz - blSaltScratch(iCell) = blSaltScratch(iCell) + activeTracers(indexS, iLevel, iCell)*dz - blThickness = blThickness + dz - end do - if(blThickness > 0.0_RKIND) then - blTempScratch(iCell) = blTempScratch(iCell)/blThickness - blSaltScratch(iCell) = blSaltScratch(iCell)/blThickness - end if - end do - do iCell = 1, nCellsSolve - blWeightSum = 1.0_RKIND - landIceBoundaryLayerTemperature(iCell) = blTempScratch(iCell) - landIceBoundaryLayerSalinity(iCell) = blSaltScratch(iCell) - do i = 1, nEdgesOnCell(iCell) - cell2 = cellsOnCell(i,iCell) - if(cell2 <= 0 .or. cell2 > nCellsSolve) cycle - - landIceBoundaryLayerTemperature(iCell) = landIceBoundaryLayerTemperature(iCell) & - + config_land_ice_flux_boundaryLayerNeighborWeight*blTempScratch(cell2) - landIceBoundaryLayerSalinity(iCell) = landIceBoundaryLayerSalinity(iCell) & - + config_land_ice_flux_boundaryLayerNeighborWeight*blSaltScratch(cell2) - blWeightSum = blWeightSum + config_land_ice_flux_boundaryLayerNeighborWeight - end do - if(blWeightSum > 0.0_RKIND) then - landIceBoundaryLayerTemperature(iCell) = landIceBoundaryLayerTemperature(iCell)/blWeightSum - landIceBoundaryLayerSalinity(iCell) = landIceBoundaryLayerSalinity(iCell)/blWeightSum - end if - end do - if(isomipOn) then do iCell = 1, nCellsSolve ! linearized equaiton for the S and p dependent potential freezing temperature @@ -579,7 +448,7 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, statePool, diagnos ! or (7) from Jenkins et al. (2001) if gamma constant ! and no heat flux into ice ! freshwater flux = density * melt rate is in kg/m^2/s - freshwaterFlux = -refDensity * config_land_ice_flux_ISOMIP_gammaT * (cp_sw/latent_heat_fusion_mks) & + freshwaterFlux = -rho_sw * config_land_ice_flux_ISOMIP_gammaT * (cp_sw/latent_heat_fusion_mks) & * (landIceInterfaceTemperature(iCell)-landIceBoundaryLayerTemperature(iCell)) landIceFreshwaterFlux(iCell) = landIceFraction(iCell)*freshwaterFlux @@ -587,7 +456,7 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, statePool, diagnos ! Using (13) from Jenkins et al. (2001) ! heat flux is in W/s heatFlux = cp_sw*(freshwaterFlux*landIceInterfaceTemperature(iCell) & - + refDensity*config_land_ice_flux_ISOMIP_gammaT & + + rho_sw*config_land_ice_flux_ISOMIP_gammaT & * (landIceInterfaceTemperature(iCell)-landIceBoundaryLayerTemperature(iCell))) landIceHeatFlux(iCell) = landIceFraction(iCell)*heatFlux @@ -597,35 +466,14 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, statePool, diagnos end if if(jenkinsOn .or. hollandJenkinsOn) then - do iCell = 1, nCellsSolve - if(jenkinsOn) then - ! transfer coefficients from namelist - heatTransferVelocity(iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_heat_transfer_coefficient - saltTransferVelocity(iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_salt_transfer_coefficient - else - ! friction-velocity dependent non-dimensional transfer coefficients from - ! Holland and Jenkins 1999, (14)-(16) with eta_* = 1 - h_nu = 5.0_RKIND*nuSaltWater/landIceFrictionVelocity(iCell) ! uStar should never be zero because of tidal term - - Gamma_turb = 1.0_RKIND/(2.0_RKIND*xiN) - 1.0_RKIND/kVonKarman - if(abs(fCell(iCell)) > 0.0_RKIND) then - Gamma_turb = Gamma_turb + 1.0_RKIND/kVonKarman*log(landIceFrictionVelocity(iCell) & - *xiN/(abs(fCell(iCell))*h_nu)) - end if - - heatTransferVelocity(iCell) = 1.0_RKIND/(Gamma_turb + 12.5_RKIND*Pr**(2.0_RKIND/3.0_RKIND) - 6.0_RKIND) - saltTransferVelocity(iCell) = 1.0_RKIND/(Gamma_turb + 12.5_RKIND*Sc**(2.0_RKIND/3.0_RKIND) - 6.0_RKIND) - - end if - end do if(config_land_ice_flux_useHollandJenkinsAdvDiff) then ! melting solution call compute_HJ99_melt_fluxes( & landIceBoundaryLayerTemperature, & landIceBoundaryLayerSalinity, & - heatTransferVelocity, & - saltTransferVelocity, & - landIceTemperature, & + landIceHeatTransferVelocity, & + landIceSaltTransferVelocity, & + landIceSurfaceTemperature, & seaSurfacePressure, & landIceInterfaceSalinity, & landIceInterfaceTemperature, & @@ -639,14 +487,11 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, statePool, diagnos end if ! freezing solution - landIceHeatTransferVelocity(:) = 0.0_RKIND call compute_melt_fluxes( & landIceBoundaryLayerTemperature, & landIceBoundaryLayerSalinity, & - heatTransferVelocity, & - saltTransferVelocity, & - landIceTemperature, & landIceHeatTransferVelocity, & + landIceSaltTransferVelocity, & seaSurfacePressure, & freezeInterfaceSalinity, & freezeInterfaceTemperature, & @@ -666,14 +511,12 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, statePool, diagnos landIceHeatFlux = freezeHeatFlux heatFluxToLandIce = freezeIceHeatFlux end where - else + else ! not using Holland and Jenkins advection/diffusion call compute_melt_fluxes( & landIceBoundaryLayerTemperature, & landIceBoundaryLayerSalinity, & - heatTransferVelocity, & - saltTransferVelocity, & - landIceTemperature, & landIceHeatTransferVelocity, & + landIceSaltTransferVelocity, & seaSurfacePressure, & landIceInterfaceSalinity, & landIceInterfaceTemperature, & @@ -692,12 +535,6 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, statePool, diagnos end if - call mpas_deallocate_scratch_field(boundaryLayerTemperatureField, .true.) - call mpas_deallocate_scratch_field(boundaryLayerSalinityField, .true.) - if(jenkinsOn .or. hollandJenkinsOn) then - call mpas_deallocate_scratch_field(heatTransferVelocityField, .true.) - call mpas_deallocate_scratch_field(saltTransferVelocityField, .true.) - end if if(config_land_ice_flux_useHollandJenkinsAdvDiff) then call mpas_deallocate_scratch_field(freezeInterfaceSalinityField, .true.) call mpas_deallocate_scratch_field(freezeInterfaceTemperatureField, .true.) @@ -734,8 +571,7 @@ subroutine ocn_surface_land_ice_fluxes_init(err)!{{{ config_land_ice_flux_dTf_dp, & config_land_ice_flux_dTf_dS, & config_land_ice_flux_cp_ice, & - config_land_ice_flux_rho_ice, & - config_density0 + config_land_ice_flux_rho_ice err = 0 @@ -754,7 +590,6 @@ subroutine ocn_surface_land_ice_fluxes_init(err)!{{{ call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_dTf_dS', config_land_ice_flux_dTf_dS) call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_cp_ice', config_land_ice_flux_cp_ice) call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_rho_ice', config_land_ice_flux_rho_ice) - call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) if ( trim(config_land_ice_flux_formulation) == 'ISOMIP' ) then isomipOn = .true. @@ -773,7 +608,6 @@ subroutine ocn_surface_land_ice_fluxes_init(err)!{{{ dTf_dS = config_land_ice_flux_dTf_dS cp_land_ice = config_land_ice_flux_cp_ice rho_land_ice = config_land_ice_flux_rho_ice - refDensity = config_density0 !-------------------------------------------------------------------- @@ -797,13 +631,11 @@ end subroutine ocn_surface_land_ice_fluxes_init!}}} !> They should be the product of the friction velocity and a (possibly !> spatially variable) non-dimenional transfer coefficient. !> -!> The ice heat transfer velocity is either zero if heat conduction into the -!> ice is to be neglected or is computed as: -!> iceHeatTransferVelocity = kappa_ice/(0.5*dz_ice), -!> where kappa_ice is the molecular diffusivity of heat -!> in ice and dz_ice is the thickness of the bottom layer of ice, where -!> iceTemperature is supplied. -!> +!> The iceTemperatureDistance is the distance between the location +!> where the iceTemperature is supplied and the ice-ocean interface, +!> used to compute a temperature gradient. The ice thermal conductivity, +!> kappa_land_ice, is zero for the freezing solution from Holland and Jenkins +!> (1999) in which the ice is purely insulating. ! !----------------------------------------------------------------------- @@ -813,8 +645,6 @@ subroutine compute_melt_fluxes( & oceanSalinity, & oceanHeatTransferVelocity, & oceanSaltTransferVelocity, & - iceTemperature, & - iceHeatTransferVelocity, & interfacePressure, & outInterfaceSalinity, & outInterfaceTemperature, & @@ -822,7 +652,10 @@ subroutine compute_melt_fluxes( & outOceanHeatFlux, & outIceHeatFlux, & nCells, & - err) + err, & + iceTemperature, & + iceTemperatureDistance, & + kappa_land_ice) !----------------------------------------------------------------- ! @@ -835,17 +668,16 @@ subroutine compute_melt_fluxes( & oceanSalinity, & !< Input: ocean salinity in top layer oceanHeatTransferVelocity, & !< Input: ocean heat transfer velocity oceanSaltTransferVelocity, & !< Input: ocean salt transfer velocity - iceTemperature, & !< Input: ice temperature in bottom layer - iceHeatTransferVelocity, & !< Input: ice heat transfer velocity interfacePressure !< Input: pressure at the ice-ocean interface integer, intent(in) :: nCells !< Input: number of cells in each array - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- + real (kind=RKIND), dimension(:), intent(in), optional:: & + iceTemperature, & !< Input: ice temperature in bottom layer + iceTemperatureDistance !< Input: distance to ice temperature from ice-ocean interface + + real (kind=RKIND), intent(in), optional:: & + kappa_land_ice !< Input: the diffusivity of heat in land ice !----------------------------------------------------------------- ! @@ -868,18 +700,30 @@ subroutine compute_melt_fluxes( & ! !----------------------------------------------------------------- - real (kind=RKIND) :: T0, transferVelocityRatio, Tlatent, nu, a, b, c, eta + real (kind=RKIND) :: T0, transferVelocityRatio, Tlatent, nu, a, b, c, eta, & + iceHeatFluxCoeff, iceDeltaT integer :: iCell + logical :: coupled + err = 0 + coupled = present(iceTemperature) .and. present(iceTemperatureDistance) & + .and. present(kappa_land_ice) Tlatent = latent_heat_fusion_mks/cp_sw do iCell = 1, nCells + if(coupled) then + iceHeatFluxCoeff = rho_land_ice*cp_land_ice*kappa_land_ice/iceTemperatureDistance(iCell) + nu = iceHeatFluxCoeff/(rho_sw*cp_sw*oceanHeatTransferVelocity(iCell)) + iceDeltaT = T0 - iceTemperature(iCell) + else + nu = 0.0_RKIND + iceDeltaT = 0.0_RKIND + end if T0 = Tf0 + dTf_dp*interfacePressure(iCell) transferVelocityRatio = oceanSaltTransferVelocity(iCell)/oceanHeatTransferVelocity(iCell) - nu = (rho_land_ice*cp_land_ice*iceHeatTransferVelocity(iCell))/(refDensity*cp_sw*oceanHeatTransferVelocity(iCell)) a = -dTf_dS*(1.0_RKIND + nu) - b = transferVelocityRatio*Tlatent - nu*(T0 - iceTemperature(iCell)) + oceanTemperature(iCell) - T0 + b = transferVelocityRatio*Tlatent - nu*iceDeltaT + oceanTemperature(iCell) - T0 c = -transferVelocityRatio*Tlatent ! a is strictly positive; c is strictly negative so we never get imaginary roots @@ -891,14 +735,14 @@ subroutine compute_melt_fluxes( & end if outInterfaceTemperature(iCell) = dTf_dS*outInterfaceSalinity(iCell)+T0 - outFreshwaterFlux(iCell) = refDensity*oceanSaltTransferVelocity(iCell) & + outFreshwaterFlux(iCell) = rho_sw*oceanSaltTransferVelocity(iCell) & * (oceanSalinity(iCell)/outInterfaceSalinity(iCell) - 1.0_RKIND) ! According to Jenkins et al. (2001), the temperature fluxes into the ocean are: ! 1. the advection of meltwater into the top layer (or removal for freezing) ! 2. the turbulent transfer of heat across the boundary layer, based on the termal driving outOceanHeatFlux(iCell) = cp_sw*(outFreshwaterFlux(iCell)*outInterfaceTemperature(iCell) & - - refDensity*oceanHeatTransferVelocity(iCell)*(oceanTemperature(iCell)-outInterfaceTemperature(iCell))) + - rho_sw*oceanHeatTransferVelocity(iCell)*(oceanTemperature(iCell)-outInterfaceTemperature(iCell))) ! the temperature fluxes into the ice are: ! 1. the advection of ice at the interface temperature out of the domain due to melting @@ -906,9 +750,11 @@ subroutine compute_melt_fluxes( & ! 2. the diffusion (if any) of heat into the ice, based on temperature difference between ! the reference point in the ice (either the surface or the middle of the bottom layer) ! and the interface - outIceHeatFlux(iCell) = cp_land_ice * & - (- outFreshwaterFlux(iCell)*outInterfaceTemperature(iCell) & - - rho_land_ice*iceHeatTransferVelocity(iCell)*(iceTemperature(iCell) - outInterfaceTemperature(iCell))) + outIceHeatFlux(iCell) = -cp_land_ice*outFreshwaterFlux(iCell)*outInterfaceTemperature(iCell) + if(coupled) then + outIceHeatFlux(iCell) = outIceHeatFlux(iCell) & + - iceHeatFluxCoeff*(iceTemperature(iCell) - outInterfaceTemperature(iCell)) + end if end do !-------------------------------------------------------------------- @@ -1010,7 +856,7 @@ subroutine compute_HJ99_melt_fluxes( & cpRatio = cp_land_ice/cp_sw do iCell = 1, nCells T0 = Tf0 + dTf_dp*interfacePressure(iCell) - transferVelocityRatio = (rho_fw/refDensity)*oceanSaltTransferVelocity(iCell)/oceanHeatTransferVelocity(iCell) + transferVelocityRatio = (rho_fw/rho_sw)*oceanSaltTransferVelocity(iCell)/oceanHeatTransferVelocity(iCell) Tlatent = latent_heat_fusion_mks/cp_sw eta = cpRatio * transferVelocityRatio @@ -1029,14 +875,14 @@ subroutine compute_HJ99_melt_fluxes( & end if outInterfaceTemperature(iCell) = dTf_dS*outInterfaceSalinity(iCell)+T0 - outFreshwaterFlux(iCell) = refDensity*oceanSaltTransferVelocity(iCell) & + outFreshwaterFlux(iCell) = rho_sw*oceanSaltTransferVelocity(iCell) & * (oceanSalinity(iCell)/outInterfaceSalinity(iCell) - 1.0_RKIND) ! According to Jenkins et al. (2001), the temperature fluxes into the ocean are: ! 1. the advection of meltwater into the top layer (or removal for freezing) ! 2. the turbulent transfer of heat across the boundary layer, based on the termal driving outOceanHeatFlux(iCell) = cp_sw*(outFreshwaterFlux(iCell)*outInterfaceTemperature(iCell) & - - refDensity*oceanHeatTransferVelocity(iCell)*(oceanTemperature(iCell)-outInterfaceTemperature(iCell))) + - rho_sw*oceanHeatTransferVelocity(iCell)*(oceanTemperature(iCell)-outInterfaceTemperature(iCell))) ! Since we're considering only melting and ignoring diffusion, ! the ice loses heat simply by the loss of ice mass at the prescribed diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index f0a1c0b45a..c853d33605 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -277,7 +277,7 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP ! Add top drag to suface stress call mpas_timer_start("top_drag", .false.) - call ocn_surface_land_ice_fluxes_vel(meshPool, forcingPool, surfaceStress, surfaceStressMagnitude, err) + call ocn_surface_land_ice_fluxes_vel(meshPool, diagnosticsPool, surfaceStress, surfaceStressMagnitude, err) call mpas_timer_stop("top_drag") ! From a70859dc3a4ccf8585c1fa46b76c1501d4f64ead Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Tue, 15 Sep 2015 10:34:27 -0600 Subject: [PATCH 0243/1724] move some mods needed for analsys to shared & update makefile --- src/core_landice/shared/Makefile | 10 +- src/core_landice/shared/mpas_li_mask.F | 650 ++++++++++++++++++++++++ src/core_landice/shared/mpas_li_setup.F | 312 ++++++++++++ 3 files changed, 971 insertions(+), 1 deletion(-) create mode 100644 src/core_landice/shared/mpas_li_mask.F create mode 100644 src/core_landice/shared/mpas_li_setup.F diff --git a/src/core_landice/shared/Makefile b/src/core_landice/shared/Makefile index 231262b2ff..b9e1f68208 100644 --- a/src/core_landice/shared/Makefile +++ b/src/core_landice/shared/Makefile @@ -1,12 +1,20 @@ .SUFFIXES: .F .o .cpp -OBJS = mpas_li_constants.o +OBJS = mpas_li_constants.o \ + mpas_li_mask.o \ + mpas_li_setup.o all: $(OBJS) mpas_li_constants.o: +mpas_li_setup.o: + +mpas_li_mask.o: mpas_li_setup.o + + + clean: $(RM) *.o *.mod *.f90 @# Certain systems with intel compilers generate *.i files diff --git a/src/core_landice/shared/mpas_li_mask.F b/src/core_landice/shared/mpas_li_mask.F new file mode 100644 index 0000000000..b75674536d --- /dev/null +++ b/src/core_landice/shared/mpas_li_mask.F @@ -0,0 +1,650 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! li_mask +! +!> \MPAS land-ice mask calculations +!> \author Matt Hoffman +!> \date 10 May 2012 +!> \details +!> This module contains the routines for calculating masks for land ice +!> +! +!----------------------------------------------------------------------- + +module li_mask + + use mpas_derived_types + use mpas_pool_routines + use mpas_dmpar + use li_setup + + implicit none + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + integer, parameter :: li_mask_ValueIce = 32 ! Giving this the highest current value so it is obvious during visualization + integer, parameter :: li_mask_ValueDynamicIce = 2 + integer, parameter :: li_mask_ValueFloating = 4 + integer, parameter :: li_mask_ValueMargin = 8 ! This is the last cell with ice. + integer, parameter :: li_mask_ValueDynamicMargin = 16 ! This is the last dynamically active cell with ice + integer, parameter :: li_mask_ValueInitialIceExtent = 1 + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + ! all subroutines and functions in this module are public! + + + ! interfaces without a suffix return logicals + ! interfaces with names that end with '_int' return 0/1 + ! TODO Eventually we may decide to only keep and maintain one of these return types. + + interface li_mask_is_ice + module procedure li_mask_is_ice_logout_1d + module procedure li_mask_is_ice_logout_0d + end interface + + + interface li_mask_is_ice_int + module procedure li_mask_is_ice_intout_1d + module procedure li_mask_is_ice_intout_0d + end interface + + + interface li_mask_is_dynamic_ice + module procedure li_mask_is_dynamic_ice_logout_1d + module procedure li_mask_is_dynamic_ice_logout_0d + end interface + + + interface li_mask_is_dynamic_ice_int + module procedure li_mask_is_dynamic_ice_intout_1d + module procedure li_mask_is_dynamic_ice_intout_0d + end interface + + + interface li_mask_is_dynamic_margin + module procedure li_mask_is_dynamic_margin_logout_1d + module procedure li_mask_is_dynamic_margin_logout_0d + end interface + + + interface li_mask_is_dynamic_margin_int + module procedure li_mask_is_dynamic_margin_logout_1d + module procedure li_mask_is_dynamic_margin_logout_0d + end interface + + + interface li_mask_is_floating_ice + module procedure li_mask_is_floating_ice_logout_1d + module procedure li_mask_is_floating_ice_logout_0d + end interface + + + interface li_mask_is_floating_ice_int + module procedure li_mask_is_floating_ice_intout_1d + module procedure li_mask_is_floating_ice_intout_0d + end interface + + + interface li_mask_is_grounded_ice + module procedure li_mask_is_grounded_ice_logout_1d + module procedure li_mask_is_grounded_ice_logout_0d + end interface + + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + + +!*********************************************************************** + +contains + + + +!*********************************************************************** +! +! routine li_calculate_mask_init +! +!> \brief Calculates masks for land ice for info needed from initial condition only +!> \author Matt Hoffman +!> \date 25 June 2012 +!> \details +!> This routine Calculates masks for land ice for info needed from initial condition only. +! +!----------------------------------------------------------------------- + + subroutine li_calculate_mask_init(geometryPool, err) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: & + geometryPool !< Input/Output: geometry information + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + integer, dimension(:), pointer :: cellMask + real(KIND=RKIND), dimension(:), pointer :: thickness + logical, pointer :: config_do_restart + + err = 0 + + ! Assign pointers and variables + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + + call mpas_pool_get_config(liConfigs, 'config_do_restart', config_do_restart) + + if (config_do_restart .eqv. .false.) then ! We only want to set this bit of the mask when a new simulation starts, but not during a restart. + ! Initialize cell mask to 0 everywhere before we assign anything to it. + cellMask = 0 + where (thickness > 0.0) + cellMask = ior(cellMask, li_mask_ValueInitialIceExtent) + end where + endif + + !-------------------------------------------------------------------- + + end subroutine li_calculate_mask_init + + + +!*********************************************************************** +! +! routine land_ice_calculate_mask +! +!> \brief Calculates masks for land ice +!> \author Matt Hoffman +!> \date 10 May 2012 +!> \details +!> This routine Calculates masks for land ice. +! +!----------------------------------------------------------------------- + + subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + + type (mpas_pool_type), intent(inout) :: & + velocityPool !< Input: velocity information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: & + geometryPool !< Input/Output: geometry information + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + integer, pointer :: nCells, nVertices, nEdges, vertexDegree + real(KIND=RKIND), dimension(:), pointer :: thickness, bedTopography + integer, dimension(:), pointer :: nEdgesOnCell, cellMask, vertexMask, edgeMask + integer, dimension(:,:), pointer :: cellsOnCell, cellsOnVertex, cellsOnEdge, dirichletVelocityMask + real (kind=RKIND), pointer :: config_ice_density, config_ocean_density, & + config_sea_level, config_dynamic_thickness + character (len=StrKIND), pointer :: config_velocity_solver + + integer :: i, j, iCell + logical :: isMargin + logical :: aCellOnVertexHasIce, aCellOnVertexHasNoIce, aCellOnVertexHasDynamicIce, aCellOnVertexHasNoDynamicIce, aCellOnVertexIsFloating + logical :: aCellOnEdgeHasIce, aCellOnEdgeHasNoIce, aCellOnEdgeHasDynamicIce, aCellOnEdgeHasNoDynamicIce, aCellOnEdgeIsFloating + + + err = 0 + + ! Assign pointers and variables + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) + + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + + call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel=1) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + + call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) + call mpas_pool_get_config(liConfigs, 'config_ocean_density', config_ocean_density) + call mpas_pool_get_config(liConfigs, 'config_sea_level', config_sea_level) + call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + + ! ==== + ! Calculate cellMask values=========================== + ! ==== + + ! Set mask to 0 everywhere, but need to preserve bits the initial ice extent bit + do i=1, nCells + cellMask(i) = iand(cellMask(i), li_mask_ValueInitialIceExtent) + enddo + + ! Identify cells with ice + where (thickness > 0) + cellMask = ior(cellMask, li_mask_ValueIce) + end where + + ! Identify cells where the ice is above the ice dynamics thickness limit + if (config_velocity_solver == 'sia') then + where ( thickness > config_dynamic_thickness ) + cellMask = ior(cellMask, li_mask_ValueDynamicIce) + end where + else ! HO external FEM dycore + call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel = 1) + ! Identify cells where the ice is above the ice dynamics thickness limit but not with a dirichletVelocity condition set + where ( (thickness > config_dynamic_thickness) .and. & ! same as for SIA case + (dirichletVelocityMask(1,:) == 0) ) ! but exclude dirichletVelocityMask locations set as lateral b.c. To ignore dirichlet b.c. on the basal boundary, just check the surface level + cellMask = ior(cellMask, li_mask_ValueDynamicIce) + end where + endif + + ! Is it floating? (ice thickness equal to floatation is considered floating) + ! For now floating ice and grounded ice are mutually exclusive. + ! This may change if a ground line parameterization is added. + where ( li_mask_is_ice(cellMask) .and. (config_ice_density / config_ocean_density * thickness) <= (config_sea_level - bedTopography) ) + cellMask = ior(cellMask, li_mask_ValueFloating) + end where + + ! Identify the margin + ! For a cell, we define the margin as the last cell with ice (the cell has ice and at least one neighbor is a non-ice cell) + do i=1,nCells + if (li_mask_is_ice(cellMask(i))) then + isMargin = .false. + do j=1,nEdgesOnCell(i) ! Check if any neighbors are non-ice + isMargin = ( isMargin .or. (.not. li_mask_is_ice(cellMask(cellsOnCell(j,i)))) ) + enddo + if (isMargin) then + cellMask(i) = ior(cellMask(i), li_mask_ValueMargin) + endif + endif + enddo + + ! Identify the dynamic margin + ! For a cell, we define the dynamic margin as the last cell with dynamic ice (the cell is dynamic and at least one neighboring cell is not dynamic) + do i=1,nCells + if (li_mask_is_dynamic_ice(cellMask(i))) then + isMargin = .false. + do j=1,nEdgesOnCell(i) ! Check if any neighbors are not dynamic + isMargin = ( isMargin .or. (.not. li_mask_is_dynamic_ice(cellMask(cellsOnCell(j,i)))) ) + enddo + if (isMargin) then + cellMask(i) = ior(cellMask(i), li_mask_ValueDynamicMargin) + endif + endif + enddo + + + ! ==== + ! Calculate vertexMask values based on cellMask values=========================== + ! ==== + ! Bit: Vertices with ice are ones with at least one adjacent cell with ice + ! Bit: Vertices with dynamic ice are ones with at least one adjacent cell with dynamic ice + ! Bit: Floating vertices have at least one neighboring cell floating + ! Bit: Vertices on margin are vertices with at least one neighboring cell with ice and at least one neighboring cell without ice + ! Bit: Vertices on dynamic margin are vertices with at least one neighboring cell with dynamic ice and at least one neighboring cell without dynamic ice + vertexMask = 0 + do i = 1,nVertices + aCellOnVertexHasIce = .false. + aCellOnVertexHasNoIce = .false. + aCellOnVertexHasDynamicIce = .false. + aCellOnVertexHasNoDynamicIce = .false. + aCellOnVertexIsFloating = .false. + do j = 1, vertexDegree ! vertexDegree is usually 3 (e.g. CVT mesh) but could be something else (e.g. 4 for quad mesh) + iCell = cellsOnVertex(j,i) + aCellOnVertexHasIce = (aCellOnVertexHasIce .or. li_mask_is_ice(cellMask(iCell))) + aCellOnVertexHasNoIce = (aCellOnVertexHasNoIce .or. (.not. li_mask_is_ice(cellMask(iCell)))) + aCellOnVertexHasDynamicIce = (aCellOnVertexHasDynamicIce .or. li_mask_is_dynamic_ice(cellMask(iCell))) + aCellOnVertexHasNoDynamicIce = (aCellOnVertexHasNoDynamicIce .or. (.not. (li_mask_is_dynamic_ice(cellMask(iCell))))) + aCellOnVertexIsFloating = (aCellOnVertexIsFloating .or. li_mask_is_floating_ice(cellMask(iCell))) + end do + if (aCellOnVertexHasIce) then + vertexMask(i) = ior(vertexMask(i), li_mask_ValueIce) + endif + if (aCellOnVertexHasDynamicIce) then + vertexMask(i) = ior(vertexMask(i), li_mask_ValueDynamicIce) + endif + if (aCellOnVertexIsFloating) then + vertexMask(i) = ior(vertexMask(i), li_mask_ValueFloating) + endif + if (aCellOnVertexHasIce .and. aCellOnVertexHasNoIce) then + vertexMask(i) = ior(vertexMask(i), li_mask_ValueMargin) ! vertex with both 1+ ice cell and 1+ non-ice cell as neighbors + endif + if (aCellOnVertexHasDynamicIce .and. aCellOnVertexHasNoDynamicIce) then + vertexMask(i) = ior(vertexMask(i), li_mask_ValueDynamicMargin) ! vertex with both 1+ dynamic ice cell(s) and 1+ non-dynamic cell(s) as neighbors + endif + end do + + + ! ==== + ! Calculate edgeMask values based on cellMask values=========================== + ! ==== + ! Bit: Edges with ice are ones with at least one adjacent cell with ice + ! Bit: Edges with dynamic ice are ones with at least one adjacent cell with dynamic ice + ! Bit: Floating Edges have at least one neighboring cell floating + ! Bit: Edges on margin are edges with one neighboring cell with ice and one neighboring cell without ice + ! Bit: Edges on dynamic margin are edges with one neighboring cell with dynamic ice and one neighboring cell without dynamic ice + edgeMask = 0 + do i = 1,nEdges + aCellOnEdgeHasIce = .false. + aCellOnEdgeHasNoIce = .false. + aCellOnEdgeHasDynamicIce = .false. + aCellOnEdgeHasNoDynamicIce = .false. + aCellOnEdgeIsFloating = .false. + do j = 1, 2 + iCell = cellsOnEdge(j,i) + aCellOnEdgeHasIce = (aCellOnEdgeHasIce .or. li_mask_is_ice(cellMask(iCell))) + aCellOnEdgeHasNoIce = (aCellOnEdgeHasNoIce .or. (.not. li_mask_is_ice(cellMask(iCell)))) + aCellOnEdgeHasDynamicIce = (aCellOnEdgeHasDynamicIce .or. li_mask_is_dynamic_ice(cellMask(iCell))) + aCellOnEdgeHasNoDynamicIce = (aCellOnEdgeHasNoDynamicIce .or. (.not. (li_mask_is_dynamic_ice(cellMask(iCell))))) + aCellOnEdgeIsFloating = (aCellOnEdgeIsFloating .or. li_mask_is_floating_ice(cellMask(iCell))) + end do + if (aCellOnEdgeHasIce) then + edgeMask(i) = ior(edgeMask(i), li_mask_ValueIce) + endif + if (aCellOnEdgeHasDynamicIce) then + edgeMask(i) = ior(edgeMask(i), li_mask_ValueDynamicIce) + endif + if (aCellOnEdgeIsFloating) then + edgeMask(i) = ior(edgeMask(i), li_mask_ValueFloating) + endif + if (aCellOnEdgeHasIce .and. aCellOnEdgeHasNoIce) then + edgeMask(i) = ior(edgeMask(i), li_mask_ValueMargin) + endif + if (aCellOnEdgeHasDynamicIce .and. aCellOnEdgeHasNoDynamicIce) then + edgeMask(i) = ior(edgeMask(i), li_mask_ValueDynamicMargin) + endif + + end do + + ! vertexMask and edgeMask needs halo updates before they can be used. Halo updates need to occur outside of block loops. + + ! === error check + if (err > 0) then + write (stderrUnit,*) "An error has occurred in li_calculate_mask." + endif + + !-------------------------------------------------------------------- + end subroutine li_calculate_mask + + +!*********************************************************************** +! +! routine li_calculate_extrapolate_floating_edgemask +! +!> \brief Extrapolates floating edges forward as needed by external FEM dycores +!> \author Matt Hoffman +!> \date 29 January 2015 +!> \details +!> External FEM dycores include the first non-ice cells in their mesh. They +!> also use a mask to apply floating lateral boundary conditions on edges. +!> Because they include extra cell center locations in their meshes, the triangle +!> edges connecting these extra nodes will not be covered by the standard +!> MPAS edge mask. This routine deals with this problem by 'extrapolating' +!> the floating edge mask forward to cover the edges connecting these extra nodes. +!> It does so by looping over edges, and setting as floating any edge that has +!> at least one neighboring vertex that is 'floating'. This makes use of the +!> convention that "Floating vertices have at least one neighboring cell floating". +! +!----------------------------------------------------------------------- + + subroutine li_calculate_extrapolate_floating_edgemask(meshPool, vertexMask, floatingEdges) + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: & + meshPool !< Input: mesh information + integer, dimension(:) :: & + vertexMask !< Input: vertexMask + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + integer, dimension(:) :: & + floatingEdges !< Input/Output: 0/1 mask of floating edges + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + integer, dimension(:,:), pointer :: verticesOnEdge + integer, pointer :: nEdges + integer :: iEdge + + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + + do iEdge = 1, nEdges + floatingEdges(iEdge) = maxval(li_mask_is_floating_ice_int(vertexMask(verticesOnEdge(:, iEdge)))) + enddo + + end subroutine li_calculate_extrapolate_floating_edgemask + + + ! =================================== + ! Functions for decoding bitmasks - will work with cellMask, edgeMask, or vertexMask + ! =================================== + ! Only adding the minimum needed for now. These should be added as needed. + ! functions with names that include '_logout' return logical types + ! -- these should be used with 'if' and 'where' statements + ! functions with names that include '_intout' return integers types with 0 for false, 1 for true. + ! -- these should be used when multiplying against numeric arrays + + + ! -- Functions that check for presence of ice -- + function li_mask_is_ice_logout_1d(mask) + integer, dimension(:), intent(in) :: mask + logical, dimension(size(mask)) :: li_mask_is_ice_logout_1d + + li_mask_is_ice_logout_1d = (iand(mask, li_mask_ValueIce) == li_mask_ValueIce) + end function li_mask_is_ice_logout_1d + + function li_mask_is_ice_logout_0d(mask) + integer, intent(in) :: mask + logical :: li_mask_is_ice_logout_0d + + li_mask_is_ice_logout_0d = (iand(mask, li_mask_ValueIce) == li_mask_ValueIce) + end function li_mask_is_ice_logout_0d + + + function li_mask_is_ice_intout_1d(mask) + integer, dimension(:), intent(in) :: mask + integer, dimension(size(mask)) :: li_mask_is_ice_intout_1d + + li_mask_is_ice_intout_1d = iand(mask, li_mask_ValueIce) / li_mask_ValueIce + end function li_mask_is_ice_intout_1d + + function li_mask_is_ice_intout_0d(mask) + integer, intent(in) :: mask + integer :: li_mask_is_ice_intout_0d + + li_mask_is_ice_intout_0d = iand(mask, li_mask_ValueIce) / li_mask_ValueIce + end function li_mask_is_ice_intout_0d + + + ! -- Functions that check for presence of dynamic ice -- + function li_mask_is_dynamic_ice_logout_1d(mask) + integer, dimension(:), intent(in) :: mask + logical, dimension(size(mask)) :: li_mask_is_dynamic_ice_logout_1d + + li_mask_is_dynamic_ice_logout_1d = (iand(mask, li_mask_ValueDynamicIce) == li_mask_ValueDynamicIce) + end function li_mask_is_dynamic_ice_logout_1d + + function li_mask_is_dynamic_ice_logout_0d(mask) + integer, intent(in) :: mask + logical :: li_mask_is_dynamic_ice_logout_0d + + li_mask_is_dynamic_ice_logout_0d = (iand(mask, li_mask_ValueDynamicIce) == li_mask_ValueDynamicIce) + end function li_mask_is_dynamic_ice_logout_0d + + function li_mask_is_dynamic_ice_intout_1d(mask) + integer, dimension(:), intent(in) :: mask + integer, dimension(size(mask)) :: li_mask_is_dynamic_ice_intout_1d + + li_mask_is_dynamic_ice_intout_1d = iand(mask, li_mask_ValueDynamicIce) / li_mask_ValueDynamicIce + end function li_mask_is_dynamic_ice_intout_1d + + function li_mask_is_dynamic_ice_intout_0d(mask) + integer, intent(in) :: mask + integer :: li_mask_is_dynamic_ice_intout_0d + + li_mask_is_dynamic_ice_intout_0d = iand(mask, li_mask_ValueDynamicIce) / li_mask_ValueDynamicIce + end function li_mask_is_dynamic_ice_intout_0d + + + ! -- Functions that check for presence of dynamic margin -- + function li_mask_is_dynamic_margin_logout_1d(mask) + integer, dimension(:), intent(in) :: mask + logical, dimension(size(mask)) :: li_mask_is_dynamic_margin_logout_1d + + li_mask_is_dynamic_margin_logout_1d = (iand(mask, li_mask_ValueDynamicMargin) == li_mask_ValueDynamicMargin) + end function li_mask_is_dynamic_margin_logout_1d + + function li_mask_is_dynamic_margin_logout_0d(mask) + integer, intent(in) :: mask + logical :: li_mask_is_dynamic_margin_logout_0d + + li_mask_is_dynamic_margin_logout_0d = (iand(mask, li_mask_ValueDynamicMargin) == li_mask_ValueDynamicMargin) + end function li_mask_is_dynamic_margin_logout_0d + + function li_mask_is_dynamic_margin_intout_1d(mask) + integer, dimension(:), intent(in) :: mask + integer, dimension(size(mask)) :: li_mask_is_dynamic_margin_intout_1d + + li_mask_is_dynamic_margin_intout_1d = iand(mask, li_mask_ValueDynamicMargin) / li_mask_ValueDynamicMargin + end function li_mask_is_dynamic_margin_intout_1d + + function li_mask_is_dynamic_margin_intout_0d(mask) + integer, intent(in) :: mask + integer :: li_mask_is_dynamic_margin_intout_0d + + li_mask_is_dynamic_margin_intout_0d = iand(mask, li_mask_ValueDynamicMargin) / li_mask_ValueDynamicMargin + end function li_mask_is_dynamic_margin_intout_0d + + + ! -- Functions that check for presence of floating ice -- + function li_mask_is_floating_ice_logout_1d(mask) + integer, dimension(:), intent(in) :: mask + logical, dimension(size(mask)) :: li_mask_is_floating_ice_logout_1d + + li_mask_is_floating_ice_logout_1d = (iand(mask, li_mask_ValueFloating) == li_mask_ValueFloating) + end function li_mask_is_floating_ice_logout_1d + + function li_mask_is_floating_ice_logout_0d(mask) + integer, intent(in) :: mask + logical :: li_mask_is_floating_ice_logout_0d + + li_mask_is_floating_ice_logout_0d = (iand(mask, li_mask_ValueFloating) == li_mask_ValueFloating) + end function li_mask_is_floating_ice_logout_0d + + function li_mask_is_floating_ice_intout_1d(mask) + integer, dimension(:), intent(in) :: mask + integer, dimension(size(mask)) :: li_mask_is_floating_ice_intout_1d + + li_mask_is_floating_ice_intout_1d = iand(mask, li_mask_ValueFloating) / li_mask_ValueFloating + end function li_mask_is_floating_ice_intout_1d + + function li_mask_is_floating_ice_intout_0d(mask) + integer, intent(in) :: mask + integer :: li_mask_is_floating_ice_intout_0d + + li_mask_is_floating_ice_intout_0d = iand(mask, li_mask_ValueFloating) / li_mask_ValueFloating + end function li_mask_is_floating_ice_intout_0d + + ! -- Functions that check for presence of grounded ice -- + function li_mask_is_grounded_ice_logout_1d(mask) + integer, dimension(:), intent(in) :: mask + logical, dimension(size(mask)) :: li_mask_is_grounded_ice_logout_1d + + li_mask_is_grounded_ice_logout_1d = ( (iand(mask, li_mask_ValueFloating) /= li_mask_ValueFloating) & + .and. (li_mask_is_ice(mask)) ) + end function li_mask_is_grounded_ice_logout_1d + + function li_mask_is_grounded_ice_logout_0d(mask) + integer, intent(in) :: mask + logical :: li_mask_is_grounded_ice_logout_0d + + li_mask_is_grounded_ice_logout_0d = ( (iand(mask, li_mask_ValueFloating) /= li_mask_ValueFloating) & + .and. (li_mask_is_ice(mask)) ) + end function li_mask_is_grounded_ice_logout_0d + + + + + + +!*********************************************************************** +! Private subroutines: +!*********************************************************************** + +! - no private subroutines - (module is not declared private) + + +end module li_mask + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + diff --git a/src/core_landice/shared/mpas_li_setup.F b/src/core_landice/shared/mpas_li_setup.F new file mode 100644 index 0000000000..9578e1843e --- /dev/null +++ b/src/core_landice/shared/mpas_li_setup.F @@ -0,0 +1,312 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! li_setup +! +!> \brief MPAS land ice setup module +!> \author Matt Hoffman +!> \date 17 April 2011 +!> \details +!> This module contains various subroutines for +!> setting up the land ice core. +! +!----------------------------------------------------------------------- +module li_setup + + use mpas_derived_types + use mpas_pool_routines + use mpas_kind_types + use mpas_dmpar + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + type (mpas_pool_type), pointer :: liConfigs !< Public parameter: pool of config options + + public :: liConfigs + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + public :: li_setup_config_options, & + li_setup_vertical_grid, & + li_setup_sign_and_index_fields + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + + +!*********************************************************************** + +contains + + +!*********************************************************************** +! +! routine li_setup_config_options +! +!> \brief Makes any setup changes needed based on chosen config options +!> \author Matt Hoffman +!> \date 16 April 2014 +!> \details +!> This routine makes any adjustments as needed based on which +!> config options were chosen. +! +!----------------------------------------------------------------------- + + subroutine li_setup_config_options( domain, err ) + + use mpas_timekeeping + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain !< Input/Output: domain object + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + + err = 0 + + ! Make config pool publicly available in this module + liConfigs => domain % configs + + ! --- + ! Config-specific setup occurs below + ! --- + + + !-------------------------------------------------------------------- + end subroutine li_setup_config_options + + + +!*********************************************************************** +! +! routine li_setup_vertical_grid +! +!> \brief Initializes vertical coord system +!> \author Matt Hoffman +!> \date 20 April 2012 +!> \details +!> This routine initializes the vertical coord system. +! +!----------------------------------------------------------------------- + + subroutine li_setup_vertical_grid(meshPool, geometryPool, err) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: meshPool !< Input/Output: mesh object + type (mpas_pool_type), intent(inout) :: geometryPool !< Input/Output: geometry object + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + ! Pool pointers + integer, pointer :: nVertLevels ! Dimensions + real (kind=RKIND), dimension(:), pointer :: layerThicknessFractions, layerCenterSigma, layerInterfaceSigma + real (kind=RKIND), dimension(:), pointer :: thickness + real (kind=RKIND), dimension(:,:), pointer :: layerThickness1, layerThickness2 + ! Truly locals + integer :: k + real (kind=RKIND) :: fractionTotal + + ! Get pool stuff + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + ! layerThicknessFractions is provided by input + call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) + call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) + call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness1, timeLevel=1) + call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness2, timeLevel=2) + + ! Check that layerThicknessFractions are valid + ! TODO - switch to having the user input the sigma levels instead??? + fractionTotal = sum(layerThicknessFractions) + if (fractionTotal /= 1.0_RKIND) then + if (abs(fractionTotal - 1.0_RKIND) > 0.001_RKIND) then + write(stderrUnit,*) 'Error: The sum of layerThicknessFractions is different from 1.0 by more than 0.001.' + err = 1 + end if + write (stdoutUnit,*), 'Adjusting upper layerThicknessFrac by small amount because sum of layerThicknessFractions is slightly different from 1.0.' + ! TODO - distribute the residual amongst all layers (and then put the residual of that in a single layer + layerThicknessFractions(1) = layerThicknessFractions(1) - (fractionTotal - 1.0_RKIND) + endif + + ! layerCenterSigma is the fractional vertical position (0-1) of each layer center, with 0.0 at the ice surface and 1.0 at the ice bed + ! layerInterfaceSigma is the fractional vertical position (0-1) of each layer interface, with 0.0 at the ice surface and 1.0 at the ice bed. Interface 1 is the surface, interface 2 is between layers 1 and 2, etc., and interface nVertLevels+1 is the bed. + layerCenterSigma(1) = 0.5_RKIND * layerThicknessFractions(1) + layerInterfaceSigma(1) = 0.0_RKIND + do k = 2, nVertLevels + layerCenterSigma(k) = layerCenterSigma(k-1) + 0.5_RKIND * layerThicknessFractions(k-1) & + + 0.5_RKIND * layerThicknessFractions(k) + layerInterfaceSigma(k) = layerInterfaceSigma(k-1) + layerThicknessFractions(k-1) + end do + layerInterfaceSigma(nVertLevels+1) = 1.0_RKIND + + ! Also, initialize the layerThickness field + do k = 1, nVertLevels + layerThickness1(k,:) = thickness(:) * layerThicknessFractions(k) + enddo + layerThickness2 = layerThickness1 + + !-------------------------------------------------------------------- + end subroutine li_setup_vertical_grid + + + +!*********************************************************************** +! +! routine li_setup_sign_and_index_fields +! +!> \brief Determines signs for various mesh items +!> \author Matt Hoffman - based on code by Doug Jacobsen +!> \date 20 April 2012 +!> \details +!> This routine determines the sign for various mesh items. +! +!----------------------------------------------------------------------- + subroutine li_setup_sign_and_index_fields(meshPool) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh object + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + ! Pool pointers + integer, pointer :: nCells !, nVertices, vertexDegree + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnCell, cellsOnEdge !, edgesOnVertex, cellsOnVertex, verticesOnCell, verticesOnEdge + integer, dimension(:,:), pointer :: edgeSignOnCell !, edgeSignOnVertex, kiteIndexOnCell + ! Truly locals + integer :: iCell, iEdge, iVertex, i, j, k + + ! Get pool stuff + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + + edgeSignOnCell = 0.0_RKIND + !edgeSignOnVertex = 0.0_RKIND + !kiteIndexOnCell = 0.0_RKIND + ! If needed, edgeSignOnVertex and kiteIndexOnCell can also be setup here. + + do iCell = 1, nCells + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + !iVertex = verticesOnCell(i, iCell) + + ! Vector points from cell 1 to cell 2 + if(iCell == cellsOnEdge(1, iEdge)) then + edgeSignOnCell(i, iCell) = -1 + else + edgeSignOnCell(i, iCell) = 1 + end if + + !do j = 1, vertexDegree + ! if(cellsOnVertex(j, iVertex) == iCell) then + ! kiteIndexOnCell(i, iCell) = j + ! end if + !end do + end do + end do + + !do iVertex = 1, nVertices + ! do i = 1, vertexDegree + ! iEdge = edgesOnVertex(i, iVertex) + ! + ! ! Vector points from vertex 1 to vertex 2 + ! if(iVertex == verticesOnEdge(1, iEdge)) then + ! edgeSignOnVertex(i, iVertex) = -1 + ! else + ! edgeSignOnVertex(i, iVertex) = 1 + ! end if + ! end do + !end do + + !-------------------------------------------------------------------- + end subroutine li_setup_sign_and_index_fields + + + +!*********************************************************************** +!*********************************************************************** +! Private subroutines: +!*********************************************************************** +!*********************************************************************** + + + +end module li_setup From b61e88dbaeff5c4128497fb7c2944083e451cf99 Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Tue, 15 Sep 2015 11:43:40 -0600 Subject: [PATCH 0244/1724] delete .F files that were moved --- src/core_landice/mode_forward/mpas_li_mask.F | 650 ------------------ src/core_landice/mode_forward/mpas_li_setup.F | 312 --------- 2 files changed, 962 deletions(-) delete mode 100644 src/core_landice/mode_forward/mpas_li_mask.F delete mode 100644 src/core_landice/mode_forward/mpas_li_setup.F diff --git a/src/core_landice/mode_forward/mpas_li_mask.F b/src/core_landice/mode_forward/mpas_li_mask.F deleted file mode 100644 index b75674536d..0000000000 --- a/src/core_landice/mode_forward/mpas_li_mask.F +++ /dev/null @@ -1,650 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! li_mask -! -!> \MPAS land-ice mask calculations -!> \author Matt Hoffman -!> \date 10 May 2012 -!> \details -!> This module contains the routines for calculating masks for land ice -!> -! -!----------------------------------------------------------------------- - -module li_mask - - use mpas_derived_types - use mpas_pool_routines - use mpas_dmpar - use li_setup - - implicit none - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - integer, parameter :: li_mask_ValueIce = 32 ! Giving this the highest current value so it is obvious during visualization - integer, parameter :: li_mask_ValueDynamicIce = 2 - integer, parameter :: li_mask_ValueFloating = 4 - integer, parameter :: li_mask_ValueMargin = 8 ! This is the last cell with ice. - integer, parameter :: li_mask_ValueDynamicMargin = 16 ! This is the last dynamically active cell with ice - integer, parameter :: li_mask_ValueInitialIceExtent = 1 - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - ! all subroutines and functions in this module are public! - - - ! interfaces without a suffix return logicals - ! interfaces with names that end with '_int' return 0/1 - ! TODO Eventually we may decide to only keep and maintain one of these return types. - - interface li_mask_is_ice - module procedure li_mask_is_ice_logout_1d - module procedure li_mask_is_ice_logout_0d - end interface - - - interface li_mask_is_ice_int - module procedure li_mask_is_ice_intout_1d - module procedure li_mask_is_ice_intout_0d - end interface - - - interface li_mask_is_dynamic_ice - module procedure li_mask_is_dynamic_ice_logout_1d - module procedure li_mask_is_dynamic_ice_logout_0d - end interface - - - interface li_mask_is_dynamic_ice_int - module procedure li_mask_is_dynamic_ice_intout_1d - module procedure li_mask_is_dynamic_ice_intout_0d - end interface - - - interface li_mask_is_dynamic_margin - module procedure li_mask_is_dynamic_margin_logout_1d - module procedure li_mask_is_dynamic_margin_logout_0d - end interface - - - interface li_mask_is_dynamic_margin_int - module procedure li_mask_is_dynamic_margin_logout_1d - module procedure li_mask_is_dynamic_margin_logout_0d - end interface - - - interface li_mask_is_floating_ice - module procedure li_mask_is_floating_ice_logout_1d - module procedure li_mask_is_floating_ice_logout_0d - end interface - - - interface li_mask_is_floating_ice_int - module procedure li_mask_is_floating_ice_intout_1d - module procedure li_mask_is_floating_ice_intout_0d - end interface - - - interface li_mask_is_grounded_ice - module procedure li_mask_is_grounded_ice_logout_1d - module procedure li_mask_is_grounded_ice_logout_0d - end interface - - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - - - -!*********************************************************************** - -contains - - - -!*********************************************************************** -! -! routine li_calculate_mask_init -! -!> \brief Calculates masks for land ice for info needed from initial condition only -!> \author Matt Hoffman -!> \date 25 June 2012 -!> \details -!> This routine Calculates masks for land ice for info needed from initial condition only. -! -!----------------------------------------------------------------------- - - subroutine li_calculate_mask_init(geometryPool, err) - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: & - geometryPool !< Input/Output: geometry information - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - integer, dimension(:), pointer :: cellMask - real(KIND=RKIND), dimension(:), pointer :: thickness - logical, pointer :: config_do_restart - - err = 0 - - ! Assign pointers and variables - call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) - call mpas_pool_get_array(geometryPool, 'thickness', thickness) - - call mpas_pool_get_config(liConfigs, 'config_do_restart', config_do_restart) - - if (config_do_restart .eqv. .false.) then ! We only want to set this bit of the mask when a new simulation starts, but not during a restart. - ! Initialize cell mask to 0 everywhere before we assign anything to it. - cellMask = 0 - where (thickness > 0.0) - cellMask = ior(cellMask, li_mask_ValueInitialIceExtent) - end where - endif - - !-------------------------------------------------------------------- - - end subroutine li_calculate_mask_init - - - -!*********************************************************************** -! -! routine land_ice_calculate_mask -! -!> \brief Calculates masks for land ice -!> \author Matt Hoffman -!> \date 10 May 2012 -!> \details -!> This routine Calculates masks for land ice. -! -!----------------------------------------------------------------------- - - subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - - type (mpas_pool_type), intent(in) :: & - meshPool !< Input: mesh information - - type (mpas_pool_type), intent(inout) :: & - velocityPool !< Input: velocity information - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: & - geometryPool !< Input/Output: geometry information - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - integer, intent(out) :: err !< Output: error flag - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - integer, pointer :: nCells, nVertices, nEdges, vertexDegree - real(KIND=RKIND), dimension(:), pointer :: thickness, bedTopography - integer, dimension(:), pointer :: nEdgesOnCell, cellMask, vertexMask, edgeMask - integer, dimension(:,:), pointer :: cellsOnCell, cellsOnVertex, cellsOnEdge, dirichletVelocityMask - real (kind=RKIND), pointer :: config_ice_density, config_ocean_density, & - config_sea_level, config_dynamic_thickness - character (len=StrKIND), pointer :: config_velocity_solver - - integer :: i, j, iCell - logical :: isMargin - logical :: aCellOnVertexHasIce, aCellOnVertexHasNoIce, aCellOnVertexHasDynamicIce, aCellOnVertexHasNoDynamicIce, aCellOnVertexIsFloating - logical :: aCellOnEdgeHasIce, aCellOnEdgeHasNoIce, aCellOnEdgeHasDynamicIce, aCellOnEdgeHasNoDynamicIce, aCellOnEdgeIsFloating - - - err = 0 - - ! Assign pointers and variables - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) - call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) - - call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) - call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) - call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - - call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) - call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) - call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) - call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel=1) - call mpas_pool_get_array(geometryPool, 'thickness', thickness) - - call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) - call mpas_pool_get_config(liConfigs, 'config_ocean_density', config_ocean_density) - call mpas_pool_get_config(liConfigs, 'config_sea_level', config_sea_level) - call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) - call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) - - ! ==== - ! Calculate cellMask values=========================== - ! ==== - - ! Set mask to 0 everywhere, but need to preserve bits the initial ice extent bit - do i=1, nCells - cellMask(i) = iand(cellMask(i), li_mask_ValueInitialIceExtent) - enddo - - ! Identify cells with ice - where (thickness > 0) - cellMask = ior(cellMask, li_mask_ValueIce) - end where - - ! Identify cells where the ice is above the ice dynamics thickness limit - if (config_velocity_solver == 'sia') then - where ( thickness > config_dynamic_thickness ) - cellMask = ior(cellMask, li_mask_ValueDynamicIce) - end where - else ! HO external FEM dycore - call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel = 1) - ! Identify cells where the ice is above the ice dynamics thickness limit but not with a dirichletVelocity condition set - where ( (thickness > config_dynamic_thickness) .and. & ! same as for SIA case - (dirichletVelocityMask(1,:) == 0) ) ! but exclude dirichletVelocityMask locations set as lateral b.c. To ignore dirichlet b.c. on the basal boundary, just check the surface level - cellMask = ior(cellMask, li_mask_ValueDynamicIce) - end where - endif - - ! Is it floating? (ice thickness equal to floatation is considered floating) - ! For now floating ice and grounded ice are mutually exclusive. - ! This may change if a ground line parameterization is added. - where ( li_mask_is_ice(cellMask) .and. (config_ice_density / config_ocean_density * thickness) <= (config_sea_level - bedTopography) ) - cellMask = ior(cellMask, li_mask_ValueFloating) - end where - - ! Identify the margin - ! For a cell, we define the margin as the last cell with ice (the cell has ice and at least one neighbor is a non-ice cell) - do i=1,nCells - if (li_mask_is_ice(cellMask(i))) then - isMargin = .false. - do j=1,nEdgesOnCell(i) ! Check if any neighbors are non-ice - isMargin = ( isMargin .or. (.not. li_mask_is_ice(cellMask(cellsOnCell(j,i)))) ) - enddo - if (isMargin) then - cellMask(i) = ior(cellMask(i), li_mask_ValueMargin) - endif - endif - enddo - - ! Identify the dynamic margin - ! For a cell, we define the dynamic margin as the last cell with dynamic ice (the cell is dynamic and at least one neighboring cell is not dynamic) - do i=1,nCells - if (li_mask_is_dynamic_ice(cellMask(i))) then - isMargin = .false. - do j=1,nEdgesOnCell(i) ! Check if any neighbors are not dynamic - isMargin = ( isMargin .or. (.not. li_mask_is_dynamic_ice(cellMask(cellsOnCell(j,i)))) ) - enddo - if (isMargin) then - cellMask(i) = ior(cellMask(i), li_mask_ValueDynamicMargin) - endif - endif - enddo - - - ! ==== - ! Calculate vertexMask values based on cellMask values=========================== - ! ==== - ! Bit: Vertices with ice are ones with at least one adjacent cell with ice - ! Bit: Vertices with dynamic ice are ones with at least one adjacent cell with dynamic ice - ! Bit: Floating vertices have at least one neighboring cell floating - ! Bit: Vertices on margin are vertices with at least one neighboring cell with ice and at least one neighboring cell without ice - ! Bit: Vertices on dynamic margin are vertices with at least one neighboring cell with dynamic ice and at least one neighboring cell without dynamic ice - vertexMask = 0 - do i = 1,nVertices - aCellOnVertexHasIce = .false. - aCellOnVertexHasNoIce = .false. - aCellOnVertexHasDynamicIce = .false. - aCellOnVertexHasNoDynamicIce = .false. - aCellOnVertexIsFloating = .false. - do j = 1, vertexDegree ! vertexDegree is usually 3 (e.g. CVT mesh) but could be something else (e.g. 4 for quad mesh) - iCell = cellsOnVertex(j,i) - aCellOnVertexHasIce = (aCellOnVertexHasIce .or. li_mask_is_ice(cellMask(iCell))) - aCellOnVertexHasNoIce = (aCellOnVertexHasNoIce .or. (.not. li_mask_is_ice(cellMask(iCell)))) - aCellOnVertexHasDynamicIce = (aCellOnVertexHasDynamicIce .or. li_mask_is_dynamic_ice(cellMask(iCell))) - aCellOnVertexHasNoDynamicIce = (aCellOnVertexHasNoDynamicIce .or. (.not. (li_mask_is_dynamic_ice(cellMask(iCell))))) - aCellOnVertexIsFloating = (aCellOnVertexIsFloating .or. li_mask_is_floating_ice(cellMask(iCell))) - end do - if (aCellOnVertexHasIce) then - vertexMask(i) = ior(vertexMask(i), li_mask_ValueIce) - endif - if (aCellOnVertexHasDynamicIce) then - vertexMask(i) = ior(vertexMask(i), li_mask_ValueDynamicIce) - endif - if (aCellOnVertexIsFloating) then - vertexMask(i) = ior(vertexMask(i), li_mask_ValueFloating) - endif - if (aCellOnVertexHasIce .and. aCellOnVertexHasNoIce) then - vertexMask(i) = ior(vertexMask(i), li_mask_ValueMargin) ! vertex with both 1+ ice cell and 1+ non-ice cell as neighbors - endif - if (aCellOnVertexHasDynamicIce .and. aCellOnVertexHasNoDynamicIce) then - vertexMask(i) = ior(vertexMask(i), li_mask_ValueDynamicMargin) ! vertex with both 1+ dynamic ice cell(s) and 1+ non-dynamic cell(s) as neighbors - endif - end do - - - ! ==== - ! Calculate edgeMask values based on cellMask values=========================== - ! ==== - ! Bit: Edges with ice are ones with at least one adjacent cell with ice - ! Bit: Edges with dynamic ice are ones with at least one adjacent cell with dynamic ice - ! Bit: Floating Edges have at least one neighboring cell floating - ! Bit: Edges on margin are edges with one neighboring cell with ice and one neighboring cell without ice - ! Bit: Edges on dynamic margin are edges with one neighboring cell with dynamic ice and one neighboring cell without dynamic ice - edgeMask = 0 - do i = 1,nEdges - aCellOnEdgeHasIce = .false. - aCellOnEdgeHasNoIce = .false. - aCellOnEdgeHasDynamicIce = .false. - aCellOnEdgeHasNoDynamicIce = .false. - aCellOnEdgeIsFloating = .false. - do j = 1, 2 - iCell = cellsOnEdge(j,i) - aCellOnEdgeHasIce = (aCellOnEdgeHasIce .or. li_mask_is_ice(cellMask(iCell))) - aCellOnEdgeHasNoIce = (aCellOnEdgeHasNoIce .or. (.not. li_mask_is_ice(cellMask(iCell)))) - aCellOnEdgeHasDynamicIce = (aCellOnEdgeHasDynamicIce .or. li_mask_is_dynamic_ice(cellMask(iCell))) - aCellOnEdgeHasNoDynamicIce = (aCellOnEdgeHasNoDynamicIce .or. (.not. (li_mask_is_dynamic_ice(cellMask(iCell))))) - aCellOnEdgeIsFloating = (aCellOnEdgeIsFloating .or. li_mask_is_floating_ice(cellMask(iCell))) - end do - if (aCellOnEdgeHasIce) then - edgeMask(i) = ior(edgeMask(i), li_mask_ValueIce) - endif - if (aCellOnEdgeHasDynamicIce) then - edgeMask(i) = ior(edgeMask(i), li_mask_ValueDynamicIce) - endif - if (aCellOnEdgeIsFloating) then - edgeMask(i) = ior(edgeMask(i), li_mask_ValueFloating) - endif - if (aCellOnEdgeHasIce .and. aCellOnEdgeHasNoIce) then - edgeMask(i) = ior(edgeMask(i), li_mask_ValueMargin) - endif - if (aCellOnEdgeHasDynamicIce .and. aCellOnEdgeHasNoDynamicIce) then - edgeMask(i) = ior(edgeMask(i), li_mask_ValueDynamicMargin) - endif - - end do - - ! vertexMask and edgeMask needs halo updates before they can be used. Halo updates need to occur outside of block loops. - - ! === error check - if (err > 0) then - write (stderrUnit,*) "An error has occurred in li_calculate_mask." - endif - - !-------------------------------------------------------------------- - end subroutine li_calculate_mask - - -!*********************************************************************** -! -! routine li_calculate_extrapolate_floating_edgemask -! -!> \brief Extrapolates floating edges forward as needed by external FEM dycores -!> \author Matt Hoffman -!> \date 29 January 2015 -!> \details -!> External FEM dycores include the first non-ice cells in their mesh. They -!> also use a mask to apply floating lateral boundary conditions on edges. -!> Because they include extra cell center locations in their meshes, the triangle -!> edges connecting these extra nodes will not be covered by the standard -!> MPAS edge mask. This routine deals with this problem by 'extrapolating' -!> the floating edge mask forward to cover the edges connecting these extra nodes. -!> It does so by looping over edges, and setting as floating any edge that has -!> at least one neighboring vertex that is 'floating'. This makes use of the -!> convention that "Floating vertices have at least one neighboring cell floating". -! -!----------------------------------------------------------------------- - - subroutine li_calculate_extrapolate_floating_edgemask(meshPool, vertexMask, floatingEdges) - - !----------------------------------------------------------------- - ! input variables - !----------------------------------------------------------------- - type (mpas_pool_type), intent(in) :: & - meshPool !< Input: mesh information - integer, dimension(:) :: & - vertexMask !< Input: vertexMask - !----------------------------------------------------------------- - ! input/output variables - !----------------------------------------------------------------- - integer, dimension(:) :: & - floatingEdges !< Input/Output: 0/1 mask of floating edges - - !----------------------------------------------------------------- - ! output variables - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - ! local variables - !----------------------------------------------------------------- - integer, dimension(:,:), pointer :: verticesOnEdge - integer, pointer :: nEdges - integer :: iEdge - - call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) - - do iEdge = 1, nEdges - floatingEdges(iEdge) = maxval(li_mask_is_floating_ice_int(vertexMask(verticesOnEdge(:, iEdge)))) - enddo - - end subroutine li_calculate_extrapolate_floating_edgemask - - - ! =================================== - ! Functions for decoding bitmasks - will work with cellMask, edgeMask, or vertexMask - ! =================================== - ! Only adding the minimum needed for now. These should be added as needed. - ! functions with names that include '_logout' return logical types - ! -- these should be used with 'if' and 'where' statements - ! functions with names that include '_intout' return integers types with 0 for false, 1 for true. - ! -- these should be used when multiplying against numeric arrays - - - ! -- Functions that check for presence of ice -- - function li_mask_is_ice_logout_1d(mask) - integer, dimension(:), intent(in) :: mask - logical, dimension(size(mask)) :: li_mask_is_ice_logout_1d - - li_mask_is_ice_logout_1d = (iand(mask, li_mask_ValueIce) == li_mask_ValueIce) - end function li_mask_is_ice_logout_1d - - function li_mask_is_ice_logout_0d(mask) - integer, intent(in) :: mask - logical :: li_mask_is_ice_logout_0d - - li_mask_is_ice_logout_0d = (iand(mask, li_mask_ValueIce) == li_mask_ValueIce) - end function li_mask_is_ice_logout_0d - - - function li_mask_is_ice_intout_1d(mask) - integer, dimension(:), intent(in) :: mask - integer, dimension(size(mask)) :: li_mask_is_ice_intout_1d - - li_mask_is_ice_intout_1d = iand(mask, li_mask_ValueIce) / li_mask_ValueIce - end function li_mask_is_ice_intout_1d - - function li_mask_is_ice_intout_0d(mask) - integer, intent(in) :: mask - integer :: li_mask_is_ice_intout_0d - - li_mask_is_ice_intout_0d = iand(mask, li_mask_ValueIce) / li_mask_ValueIce - end function li_mask_is_ice_intout_0d - - - ! -- Functions that check for presence of dynamic ice -- - function li_mask_is_dynamic_ice_logout_1d(mask) - integer, dimension(:), intent(in) :: mask - logical, dimension(size(mask)) :: li_mask_is_dynamic_ice_logout_1d - - li_mask_is_dynamic_ice_logout_1d = (iand(mask, li_mask_ValueDynamicIce) == li_mask_ValueDynamicIce) - end function li_mask_is_dynamic_ice_logout_1d - - function li_mask_is_dynamic_ice_logout_0d(mask) - integer, intent(in) :: mask - logical :: li_mask_is_dynamic_ice_logout_0d - - li_mask_is_dynamic_ice_logout_0d = (iand(mask, li_mask_ValueDynamicIce) == li_mask_ValueDynamicIce) - end function li_mask_is_dynamic_ice_logout_0d - - function li_mask_is_dynamic_ice_intout_1d(mask) - integer, dimension(:), intent(in) :: mask - integer, dimension(size(mask)) :: li_mask_is_dynamic_ice_intout_1d - - li_mask_is_dynamic_ice_intout_1d = iand(mask, li_mask_ValueDynamicIce) / li_mask_ValueDynamicIce - end function li_mask_is_dynamic_ice_intout_1d - - function li_mask_is_dynamic_ice_intout_0d(mask) - integer, intent(in) :: mask - integer :: li_mask_is_dynamic_ice_intout_0d - - li_mask_is_dynamic_ice_intout_0d = iand(mask, li_mask_ValueDynamicIce) / li_mask_ValueDynamicIce - end function li_mask_is_dynamic_ice_intout_0d - - - ! -- Functions that check for presence of dynamic margin -- - function li_mask_is_dynamic_margin_logout_1d(mask) - integer, dimension(:), intent(in) :: mask - logical, dimension(size(mask)) :: li_mask_is_dynamic_margin_logout_1d - - li_mask_is_dynamic_margin_logout_1d = (iand(mask, li_mask_ValueDynamicMargin) == li_mask_ValueDynamicMargin) - end function li_mask_is_dynamic_margin_logout_1d - - function li_mask_is_dynamic_margin_logout_0d(mask) - integer, intent(in) :: mask - logical :: li_mask_is_dynamic_margin_logout_0d - - li_mask_is_dynamic_margin_logout_0d = (iand(mask, li_mask_ValueDynamicMargin) == li_mask_ValueDynamicMargin) - end function li_mask_is_dynamic_margin_logout_0d - - function li_mask_is_dynamic_margin_intout_1d(mask) - integer, dimension(:), intent(in) :: mask - integer, dimension(size(mask)) :: li_mask_is_dynamic_margin_intout_1d - - li_mask_is_dynamic_margin_intout_1d = iand(mask, li_mask_ValueDynamicMargin) / li_mask_ValueDynamicMargin - end function li_mask_is_dynamic_margin_intout_1d - - function li_mask_is_dynamic_margin_intout_0d(mask) - integer, intent(in) :: mask - integer :: li_mask_is_dynamic_margin_intout_0d - - li_mask_is_dynamic_margin_intout_0d = iand(mask, li_mask_ValueDynamicMargin) / li_mask_ValueDynamicMargin - end function li_mask_is_dynamic_margin_intout_0d - - - ! -- Functions that check for presence of floating ice -- - function li_mask_is_floating_ice_logout_1d(mask) - integer, dimension(:), intent(in) :: mask - logical, dimension(size(mask)) :: li_mask_is_floating_ice_logout_1d - - li_mask_is_floating_ice_logout_1d = (iand(mask, li_mask_ValueFloating) == li_mask_ValueFloating) - end function li_mask_is_floating_ice_logout_1d - - function li_mask_is_floating_ice_logout_0d(mask) - integer, intent(in) :: mask - logical :: li_mask_is_floating_ice_logout_0d - - li_mask_is_floating_ice_logout_0d = (iand(mask, li_mask_ValueFloating) == li_mask_ValueFloating) - end function li_mask_is_floating_ice_logout_0d - - function li_mask_is_floating_ice_intout_1d(mask) - integer, dimension(:), intent(in) :: mask - integer, dimension(size(mask)) :: li_mask_is_floating_ice_intout_1d - - li_mask_is_floating_ice_intout_1d = iand(mask, li_mask_ValueFloating) / li_mask_ValueFloating - end function li_mask_is_floating_ice_intout_1d - - function li_mask_is_floating_ice_intout_0d(mask) - integer, intent(in) :: mask - integer :: li_mask_is_floating_ice_intout_0d - - li_mask_is_floating_ice_intout_0d = iand(mask, li_mask_ValueFloating) / li_mask_ValueFloating - end function li_mask_is_floating_ice_intout_0d - - ! -- Functions that check for presence of grounded ice -- - function li_mask_is_grounded_ice_logout_1d(mask) - integer, dimension(:), intent(in) :: mask - logical, dimension(size(mask)) :: li_mask_is_grounded_ice_logout_1d - - li_mask_is_grounded_ice_logout_1d = ( (iand(mask, li_mask_ValueFloating) /= li_mask_ValueFloating) & - .and. (li_mask_is_ice(mask)) ) - end function li_mask_is_grounded_ice_logout_1d - - function li_mask_is_grounded_ice_logout_0d(mask) - integer, intent(in) :: mask - logical :: li_mask_is_grounded_ice_logout_0d - - li_mask_is_grounded_ice_logout_0d = ( (iand(mask, li_mask_ValueFloating) /= li_mask_ValueFloating) & - .and. (li_mask_is_ice(mask)) ) - end function li_mask_is_grounded_ice_logout_0d - - - - - - -!*********************************************************************** -! Private subroutines: -!*********************************************************************** - -! - no private subroutines - (module is not declared private) - - -end module li_mask - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| - diff --git a/src/core_landice/mode_forward/mpas_li_setup.F b/src/core_landice/mode_forward/mpas_li_setup.F deleted file mode 100644 index 9578e1843e..0000000000 --- a/src/core_landice/mode_forward/mpas_li_setup.F +++ /dev/null @@ -1,312 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! li_setup -! -!> \brief MPAS land ice setup module -!> \author Matt Hoffman -!> \date 17 April 2011 -!> \details -!> This module contains various subroutines for -!> setting up the land ice core. -! -!----------------------------------------------------------------------- -module li_setup - - use mpas_derived_types - use mpas_pool_routines - use mpas_kind_types - use mpas_dmpar - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - type (mpas_pool_type), pointer :: liConfigs !< Public parameter: pool of config options - - public :: liConfigs - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - public :: li_setup_config_options, & - li_setup_vertical_grid, & - li_setup_sign_and_index_fields - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - - - -!*********************************************************************** - -contains - - -!*********************************************************************** -! -! routine li_setup_config_options -! -!> \brief Makes any setup changes needed based on chosen config options -!> \author Matt Hoffman -!> \date 16 April 2014 -!> \details -!> This routine makes any adjustments as needed based on which -!> config options were chosen. -! -!----------------------------------------------------------------------- - - subroutine li_setup_config_options( domain, err ) - - use mpas_timekeeping - - !----------------------------------------------------------------- - ! input variables - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - ! input/output variables - !----------------------------------------------------------------- - type (domain_type), intent(inout) :: domain !< Input/Output: domain object - - !----------------------------------------------------------------- - ! output variables - !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag - - !----------------------------------------------------------------- - ! local variables - !----------------------------------------------------------------- - - err = 0 - - ! Make config pool publicly available in this module - liConfigs => domain % configs - - ! --- - ! Config-specific setup occurs below - ! --- - - - !-------------------------------------------------------------------- - end subroutine li_setup_config_options - - - -!*********************************************************************** -! -! routine li_setup_vertical_grid -! -!> \brief Initializes vertical coord system -!> \author Matt Hoffman -!> \date 20 April 2012 -!> \details -!> This routine initializes the vertical coord system. -! -!----------------------------------------------------------------------- - - subroutine li_setup_vertical_grid(meshPool, geometryPool, err) - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: meshPool !< Input/Output: mesh object - type (mpas_pool_type), intent(inout) :: geometryPool !< Input/Output: geometry object - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - integer, intent(out) :: err !< Output: error flag - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - ! Pool pointers - integer, pointer :: nVertLevels ! Dimensions - real (kind=RKIND), dimension(:), pointer :: layerThicknessFractions, layerCenterSigma, layerInterfaceSigma - real (kind=RKIND), dimension(:), pointer :: thickness - real (kind=RKIND), dimension(:,:), pointer :: layerThickness1, layerThickness2 - ! Truly locals - integer :: k - real (kind=RKIND) :: fractionTotal - - ! Get pool stuff - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - ! layerThicknessFractions is provided by input - call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) - call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) - call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) - call mpas_pool_get_array(geometryPool, 'thickness', thickness) - call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness1, timeLevel=1) - call mpas_pool_get_array(geometryPool, 'layerThickness', layerThickness2, timeLevel=2) - - ! Check that layerThicknessFractions are valid - ! TODO - switch to having the user input the sigma levels instead??? - fractionTotal = sum(layerThicknessFractions) - if (fractionTotal /= 1.0_RKIND) then - if (abs(fractionTotal - 1.0_RKIND) > 0.001_RKIND) then - write(stderrUnit,*) 'Error: The sum of layerThicknessFractions is different from 1.0 by more than 0.001.' - err = 1 - end if - write (stdoutUnit,*), 'Adjusting upper layerThicknessFrac by small amount because sum of layerThicknessFractions is slightly different from 1.0.' - ! TODO - distribute the residual amongst all layers (and then put the residual of that in a single layer - layerThicknessFractions(1) = layerThicknessFractions(1) - (fractionTotal - 1.0_RKIND) - endif - - ! layerCenterSigma is the fractional vertical position (0-1) of each layer center, with 0.0 at the ice surface and 1.0 at the ice bed - ! layerInterfaceSigma is the fractional vertical position (0-1) of each layer interface, with 0.0 at the ice surface and 1.0 at the ice bed. Interface 1 is the surface, interface 2 is between layers 1 and 2, etc., and interface nVertLevels+1 is the bed. - layerCenterSigma(1) = 0.5_RKIND * layerThicknessFractions(1) - layerInterfaceSigma(1) = 0.0_RKIND - do k = 2, nVertLevels - layerCenterSigma(k) = layerCenterSigma(k-1) + 0.5_RKIND * layerThicknessFractions(k-1) & - + 0.5_RKIND * layerThicknessFractions(k) - layerInterfaceSigma(k) = layerInterfaceSigma(k-1) + layerThicknessFractions(k-1) - end do - layerInterfaceSigma(nVertLevels+1) = 1.0_RKIND - - ! Also, initialize the layerThickness field - do k = 1, nVertLevels - layerThickness1(k,:) = thickness(:) * layerThicknessFractions(k) - enddo - layerThickness2 = layerThickness1 - - !-------------------------------------------------------------------- - end subroutine li_setup_vertical_grid - - - -!*********************************************************************** -! -! routine li_setup_sign_and_index_fields -! -!> \brief Determines signs for various mesh items -!> \author Matt Hoffman - based on code by Doug Jacobsen -!> \date 20 April 2012 -!> \details -!> This routine determines the sign for various mesh items. -! -!----------------------------------------------------------------------- - subroutine li_setup_sign_and_index_fields(meshPool) - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh object - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - ! Pool pointers - integer, pointer :: nCells !, nVertices, vertexDegree - integer, dimension(:), pointer :: nEdgesOnCell - integer, dimension(:,:), pointer :: edgesOnCell, cellsOnEdge !, edgesOnVertex, cellsOnVertex, verticesOnCell, verticesOnEdge - integer, dimension(:,:), pointer :: edgeSignOnCell !, edgeSignOnVertex, kiteIndexOnCell - ! Truly locals - integer :: iCell, iEdge, iVertex, i, j, k - - ! Get pool stuff - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) - call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) - - edgeSignOnCell = 0.0_RKIND - !edgeSignOnVertex = 0.0_RKIND - !kiteIndexOnCell = 0.0_RKIND - ! If needed, edgeSignOnVertex and kiteIndexOnCell can also be setup here. - - do iCell = 1, nCells - do i = 1, nEdgesOnCell(iCell) - iEdge = edgesOnCell(i, iCell) - !iVertex = verticesOnCell(i, iCell) - - ! Vector points from cell 1 to cell 2 - if(iCell == cellsOnEdge(1, iEdge)) then - edgeSignOnCell(i, iCell) = -1 - else - edgeSignOnCell(i, iCell) = 1 - end if - - !do j = 1, vertexDegree - ! if(cellsOnVertex(j, iVertex) == iCell) then - ! kiteIndexOnCell(i, iCell) = j - ! end if - !end do - end do - end do - - !do iVertex = 1, nVertices - ! do i = 1, vertexDegree - ! iEdge = edgesOnVertex(i, iVertex) - ! - ! ! Vector points from vertex 1 to vertex 2 - ! if(iVertex == verticesOnEdge(1, iEdge)) then - ! edgeSignOnVertex(i, iVertex) = -1 - ! else - ! edgeSignOnVertex(i, iVertex) = 1 - ! end if - ! end do - !end do - - !-------------------------------------------------------------------- - end subroutine li_setup_sign_and_index_fields - - - -!*********************************************************************** -!*********************************************************************** -! Private subroutines: -!*********************************************************************** -!*********************************************************************** - - - -end module li_setup From 09301c8e70a71550d08407866e84025993c9e9a0 Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Tue, 15 Sep 2015 13:37:42 -0600 Subject: [PATCH 0245/1724] add calls to dmpar subroutines to sum over procs --- .../analysis_members/mpas_li_global_stats.F | 25 ++++++++----------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/src/core_landice/analysis_members/mpas_li_global_stats.F b/src/core_landice/analysis_members/mpas_li_global_stats.F index 26854fe321..f5ab4fb617 100644 --- a/src/core_landice/analysis_members/mpas_li_global_stats.F +++ b/src/core_landice/analysis_members/mpas_li_global_stats.F @@ -202,6 +202,7 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ dminfo = domain % dminfo + ! compute sums over blocks block => domain % blocklist do while (associated(block)) @@ -243,17 +244,19 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ ! print *, 'blockSumIceArea=', blockSumIceArea ! print *, 'blockSumIceVolume=', blockSumIceVolume - end do + end do ! end sum over cells block => block % next - end do - totalIceArea = blockSumIceArea - totalIceVolume = blockSumIceVolume -! groundedIceArea = blockSumGroundedIceArea -! groundedIceVolume = blockSumGroundedIceVolume -! floatingIceArea = blockSumFloatingIceArea -! floatingIceVolume = blockSumFloatingIceVolume + end do ! end sum over blocks + + ! compute sums over all procs + call mpas_dmpar_sum_real(dminfo, blockSumIceArea, totalIceArea) + call mpas_dmpar_sum_real(dminfo, blockSumIceVolume, totalIceVolume) +! call mpas_dmpar_sum_real(dminfo, blockSumGroundedIceArea, groundedIceArea) +! call mpas_dmpar_sum_real(dminfo, blockSumGroundedIceVolume, groundedIceVolume) +! call mpas_dmpar_sum_real(dminfo, blockSumFloatingIceArea, floatingIceArea) +! call mpas_dmpar_sum_real(dminfo, blockSumFloatingIceVolume, floatingIceVolume) ! debugging print *, 'totalIceArea=', totalIceArea @@ -263,12 +266,6 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ ! print *, 'floatingIceArea=', floatingIceArea ! print *, 'floatingIceVolume=', floatingIceVolume - ! mpi gather/scatter calls may be placed here. - ! Here are some examples. See mpas_oac_global_stats.F for further details. -! call mpas_dmpar_sum_real_array(dminfo, nVariables, sumSquares(1:nVariables), reductions(1:nVariables)) -! call mpas_dmpar_min_real_array(dminfo, nMins, mins(1:nMins), reductions(1:nMins)) -! call mpas_dmpar_max_real_array(dminfo, nMaxes, maxes(1:nMaxes), reductions(1:nMaxes)) - ! Even though some variables do not include an index that is decomposed amongst ! domain partitions, we assign them within a block loop so that all blocks have the ! correct values for writing output. From 734b5d2007e0f5766229a46403765ae1b03169c8 Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Tue, 15 Sep 2015 14:23:32 -0600 Subject: [PATCH 0246/1724] move main analysis driver calls from diag. solve to timestep; clean up some comments --- .../analysis_members/mpas_li_global_stats.F | 4 +--- src/core_landice/mode_forward/mpas_li_core.F | 9 --------- .../mode_forward/mpas_li_time_integration.F | 11 ++++++++++- 3 files changed, 11 insertions(+), 13 deletions(-) diff --git a/src/core_landice/analysis_members/mpas_li_global_stats.F b/src/core_landice/analysis_members/mpas_li_global_stats.F index f5ab4fb617..7c1b285da7 100644 --- a/src/core_landice/analysis_members/mpas_li_global_stats.F +++ b/src/core_landice/analysis_members/mpas_li_global_stats.F @@ -188,7 +188,7 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ real (kind=RKIND) :: blockSumFloatingIceArea real (kind=RKIND) :: blockSumFloatingIceVolume - print *, 'in li_compute_global_stats (start)' ! debug + print *, 'in li_compute_global_stats' err = 0 @@ -278,8 +278,6 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ block => block % next end do - print *, 'in li_compute_global_stats (end)' - end subroutine li_compute_global_stats!}}} !*********************************************************************** diff --git a/src/core_landice/mode_forward/mpas_li_core.F b/src/core_landice/mode_forward/mpas_li_core.F index 9429afaa0d..53193799b3 100644 --- a/src/core_landice/mode_forward/mpas_li_core.F +++ b/src/core_landice/mode_forward/mpas_li_core.F @@ -424,15 +424,6 @@ function li_core_run(domain) result(err) endif err = ior(err, err_tmp) - !SFP added: call analysis driver compute, etc. - call li_analysis_compute(domain, err_tmp) - err = ior(err, err_tmp) - -! call li_analysis_restart(domain, err) - - call li_analysis_write(domain, err_tmp) - err = ior(err, err_tmp) - ! === error check and exit call mpas_dmpar_max_int(domain % dminfo, err, globalErr) ! Find out if any blocks got an error if (globalErr > 0) then diff --git a/src/core_landice/mode_forward/mpas_li_time_integration.F b/src/core_landice/mode_forward/mpas_li_time_integration.F index b926ecfad7..8f5352f3a4 100644 --- a/src/core_landice/mode_forward/mpas_li_time_integration.F +++ b/src/core_landice/mode_forward/mpas_li_time_integration.F @@ -29,6 +29,8 @@ module li_time_integration use li_time_integration_fe use li_setup + use li_analysis_driver ! SFP added + implicit none private @@ -197,10 +199,17 @@ subroutine li_timestep(domain, err) call mpas_pool_get_array(meshPool, 'deltat', deltat_output) deltat_output = dtSeconds - block => block % next end do + !SFP added: call analysis driver compute, etc. subroutines + call li_analysis_compute(domain, err_tmp) + err = ior(err, err_tmp) + call li_analysis_restart(domain, err) + err = ior(err, err_tmp) + call li_analysis_write(domain, err_tmp) + err = ior(err, err_tmp) + ! === error check if (err > 0) then write (stderrUnit,*) "An error has occurred in li_timestep." From 95980d076f509ad99be1b505c759b0bc957c767d Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Tue, 15 Sep 2015 14:29:54 -0600 Subject: [PATCH 0247/1724] Restart capability in time series stats AM. --- .../Registry_time_series_stats.xml | 272 ++++++++++-------- .../mpas_ocn_time_series_stats.F | 111 ++++--- 2 files changed, 217 insertions(+), 166 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_time_series_stats.xml b/src/core_ocean/analysis_members/Registry_time_series_stats.xml index ef9f79eaef..cfdb82d121 100644 --- a/src/core_ocean/analysis_members/Registry_time_series_stats.xml +++ b/src/core_ocean/analysis_members/Registry_time_series_stats.xml @@ -1,136 +1,154 @@ - - - - - - + + + + + + + - - + + - - - - + + + + - + - - - + + + - - - - - + + + + + - - + + - - - - - - - - - - - - + + + + + + + + + + + + + - + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index 5a5fe3d666..7e98456ef4 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -107,6 +107,7 @@ module ocn_time_series_stats character (len=StrKIND), parameter :: FRAMEWORK_PREFIX = 'timeSeriesStats' character (len=StrKIND), parameter :: STREAM_NAME_SUFFIX = '_stream_name' + character (len=StrKIND), parameter :: RESTART_NAME_SUFFIX = '_restart_name' character (len=StrKIND), parameter :: OPERATION_SUFFIX = '_operation' character (len=StrKIND), parameter :: ADD_MESH_SUFFIX = '_add_mesh' @@ -190,12 +191,10 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ ! TODO placeholder for some unique ID if this code is replicated instance = '' ! TODO to be passed in - ! TODO skip all of this if do_restart is true and a restart stream exists - ! get the basic configuration of this stream call start_init(domain, instance, series, err) - ! modify the stream to remove existing vars and add accumulated versions + ! modify the output and restart streams and read restart call modify_stream(domain, instance, series, err) ! get all of the timing and configuration @@ -204,9 +203,6 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ ! set all of the alarms based on timers call set_alarms(domain, instance, series, alarms, err) - ! TODO have a subroutine to put all state and data into restart stream - ! TODO add a restart stream config option - ! clean up the memory do v = 1, series % number_of_variables deallocate(series % variables(v) % output_names) @@ -307,7 +303,6 @@ subroutine ocn_restart_time_series_stats(domain, err)!{{{ ! start procedure err = 0 - ! TODO is there anything needed here? end subroutine ocn_restart_time_series_stats!}}} @@ -509,7 +504,6 @@ subroutine start_init(domain, instance, series, err) integer :: b, v type (field0DChar), pointer :: srcString, dstString type (field0DInteger), pointer :: srcInteger, dstInteger - type (field0DReal), pointer :: srcReal, dstReal ! start procedure err = 0 @@ -707,17 +701,10 @@ subroutine start_init(domain, instance, series, err) call mpas_pool_get_array(domain % blocklist % allFields, & dstString % fieldName, series % buffers(b) % reset_alarm_ID, 1) - ! counter - call mpas_pool_get_field(domain % blocklist % allFields, & - ONE_REAL_MEMORY, srcReal, 1) - call mpas_duplicate_field(srcReal, dstReal) - dstReal % fieldName = counter_naming(storage_prefix, buf_identifier) - call mpas_pool_add_field(domain % blocklist % allFields, & - dstReal % fieldName, dstReal) - call mpas_pool_get_array(domain % blocklist % allFields, & - dstReal % fieldName, series % buffers(b) % counter, 1) + ! + ! counter is not done here, because it is part of the restart stream + ! end do - end subroutine start_init @@ -746,11 +733,12 @@ subroutine modify_stream(domain, instance, series, err)!{{{ ! local variables integer :: v, b - character (len=StrKIND), pointer :: stream_name + character (len=StrKIND), pointer :: stream_name, restart_name + type (field0DReal), pointer :: srcReal, dstReal logical, pointer :: copy_mesh character (len=StrKIND) :: field_name, config, op_name - character (len=StrKIND) :: namelist_prefix, storage_prefix, buf_identifier, & - buf_prefix + character (len=StrKIND) :: namelist_prefix, & + storage_prefix, buf_identifier, buf_prefix type (mpas_pool_field_info_type) :: info ! start procedure @@ -763,9 +751,18 @@ subroutine modify_stream(domain, instance, series, err)!{{{ config = trim(namelist_prefix) // trim(STREAM_NAME_SUFFIX) call mpas_pool_get_config(domain % configs, config, stream_name) - ! - ! assign values to series and modify the stream - ! + ! get restart stream + config = trim(namelist_prefix) // trim(RESTART_NAME_SUFFIX) + call mpas_pool_get_config(domain % configs, config, restart_name) + + ! operator + if (series % operation == AVG_OP) then + op_name = AVG_TOKEN + else if (series % operation == MIN_OP) then + op_name = MIN_TOKEN + else + op_name = MAX_TOKEN + end if ! get the old field names call mpas_stream_mgr_begin_iteration(domain % streamManager, & @@ -783,6 +780,10 @@ subroutine modify_stream(domain, instance, series, err)!{{{ stream_name, series % variables(v) % input_name) end do + ! + ! create memory and modify the stream + ! + ! add xtime to the stream call mpas_stream_mgr_add_field(domain % streamManager, & stream_name, TIME_STREAM, ierr=err) @@ -800,23 +801,38 @@ subroutine modify_stream(domain, instance, series, err)!{{{ end do end if - ! put the counters in the output stream + ! make restart mutable + call mpas_stream_mgr_set_property(domain % streamManager, & + restart_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .false., ierr=err) + + ! add xtime to the restart + call mpas_stream_mgr_add_field(domain % streamManager, & + restart_name, TIME_STREAM, ierr=err) + + ! create and put the counters in the streams do b = 1, series % number_of_buffers write(buf_identifier, '(I0)') b field_name = counter_naming(storage_prefix, buf_identifier) + + ! allocate counter memory + call mpas_pool_get_field(domain % blocklist % allFields, & + ONE_REAL_MEMORY, srcReal, 1) + call mpas_duplicate_field(srcReal, dstReal) + dstReal % fieldName = field_name + call mpas_pool_add_field(domain % blocklist % allFields, & + dstReal % fieldName, dstReal) + call mpas_pool_get_array(domain % blocklist % allFields, & + dstReal % fieldName, series % buffers(b) % counter, 1) + + ! put it in the output stream call mpas_stream_mgr_add_field(domain % streamManager, & - stream_name, field_name, ierr=err) - end do + stream_name, dstReal % fieldName, ierr=err) - ! operator - if (series % operation == AVG_OP) then - op_name = AVG_TOKEN - else if (series % operation == MIN_OP) then - op_name = MIN_TOKEN - else - op_name = MAX_TOKEN - end if + ! put it in the restart stream + call mpas_stream_mgr_add_field(domain % streamManager, & + restart_name, dstReal % fieldName, ierr=err) + end do ! set up the variables call mpas_stream_mgr_begin_iteration(domain % streamManager, & @@ -839,9 +855,11 @@ subroutine modify_stream(domain, instance, series, err)!{{{ do b = 1, series % number_of_buffers write(buf_identifier, '(I0)') b + field_name = output_naming(storage_prefix, op_name, & + series % variables(v) % input_name, buf_identifier) + ! create the name of the output var - series % variables(v) % output_names(b) = output_naming(storage_prefix, & - op_name, series % variables(v) % input_name, buf_identifier) + series % variables(v) % output_names(b) = field_name ! create the field and add to pool call add_new_field(info, & @@ -852,9 +870,21 @@ subroutine modify_stream(domain, instance, series, err)!{{{ ! add the field to the stream call mpas_stream_mgr_add_field(domain % streamManager, & stream_name, series % variables(v) % output_names(b), ierr=err) + + ! put it in the restart stream + call mpas_stream_mgr_add_field(domain % streamManager, & + restart_name, series % variables(v) % output_names(b), ierr=err) end do end do ! number_of_variables + ! make restart immutable + call mpas_stream_mgr_set_property(domain % streamManager, & + restart_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .true., ierr=err) + + ! read the restart stream + call mpas_stream_mgr_read(domain % streamManager, streamID = restart_name, & + ierr=err) + end subroutine modify_stream!}}} @@ -894,6 +924,8 @@ end function output_naming trim(buf_identifier) end function counter_naming + + !*********************************************************************** ! routine get_alarms ! @@ -1043,16 +1075,17 @@ subroutine set_alarms(domain, instance, series, alarms, err) do b = 1, series % number_of_buffers write(buf_identifier, '(I0)') b + ! no reset on start, because it should be zero'd already + series % buffers(b) % reset_flag = 0 + ! see if we start in the future or we have already started if (current_time >= alarms % start_time) then series % buffers(b) % started_flag = 1 - series % buffers(b) % reset_flag = 1 ! no start alarm series % buffers(b) % start_alarm_ID = '' else series % buffers(b) % started_flag = 0 - series % buffers(b) % reset_flag = 0 ! set the start alarm series % buffers(b) % start_alarm_ID = trim(alarm_prefix) // & From 396ef32c1db2118da759c849c0887d1b30dd44cd Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Tue, 15 Sep 2015 15:35:39 -0600 Subject: [PATCH 0248/1724] add mask func. to return int (1 or 0) for grounded ice; add grounded and floating stats to analysis member calc. --- .../analysis_members/mpas_li_global_stats.F | 34 +++++++++++-------- src/core_landice/shared/mpas_li_mask.F | 30 ++++++++++++++++ 2 files changed, 50 insertions(+), 14 deletions(-) diff --git a/src/core_landice/analysis_members/mpas_li_global_stats.F b/src/core_landice/analysis_members/mpas_li_global_stats.F index 7c1b285da7..e10e8bd762 100644 --- a/src/core_landice/analysis_members/mpas_li_global_stats.F +++ b/src/core_landice/analysis_members/mpas_li_global_stats.F @@ -225,14 +225,20 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ do iCell = 1,nCellsSolve ! sums of ice area and volume over cells - blockSumIceArea = blockSumIceArea + li_mask_is_ice_int(cellMask(iCell)) * areaCell(iCell) - blockSumIceVolume = blockSumIceVolume + li_mask_is_ice_int(cellMask(iCell)) * areaCell(iCell) * thickness(iCell) + blockSumIceArea = blockSumIceArea + real(li_mask_is_ice_int(cellMask(iCell)),RKIND) & + * areaCell(iCell) + blockSumIceVolume = blockSumIceVolume + real(li_mask_is_ice_int(cellMask(iCell)),RKIND) & + * areaCell(iCell) * thickness(iCell) -! blockSumGroundedIceArea = blockSumGroundedIceArea + (1-li_mask_is_floating_ice_int(cellMask(iCell))) * areaCell(iCell) -! blockSumGroundedIceVolume = blockSumGroundedIceVolume + (1-li_mask_is_floating_ice_int(cellMask(iCell))) * areaCell(iCell) * thickness(iCell) + blockSumGroundedIceArea = blockSumGroundedIceArea + real(li_mask_is_grounded_ice_int(cellMask(iCell)),RKIND) & + * areaCell(iCell) + blockSumGroundedIceVolume = blockSumGroundedIceVolume + real(li_mask_is_grounded_ice_int(cellMask(iCell)),RKIND) & + * areaCell(iCell) * thickness(iCell) -! blockSumFloatingIceArea = blockSumFloatingIceArea + li_mask_is_floating_ice_int(cellMask(iCell)) * areaCell(iCell) -! blockSumFloatingIceVolume = blockSumFloatingIceVolume + li_mask_is_floating_ice_int(cellMask(iCell)) * areaCell(iCell) * thickness(iCell) + blockSumFloatingIceArea = blockSumFloatingIceArea + real(li_mask_is_floating_ice_int(cellMask(iCell)),RKIND) & + * areaCell(iCell) + blockSumFloatingIceVolume = blockSumFloatingIceVolume + real(li_mask_is_floating_ice_int(cellMask(iCell)),RKIND) & + * areaCell(iCell) * thickness(iCell) ! debugging ! print *, 'CellMask = ', CellMask(iCell) @@ -253,18 +259,18 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ ! compute sums over all procs call mpas_dmpar_sum_real(dminfo, blockSumIceArea, totalIceArea) call mpas_dmpar_sum_real(dminfo, blockSumIceVolume, totalIceVolume) -! call mpas_dmpar_sum_real(dminfo, blockSumGroundedIceArea, groundedIceArea) -! call mpas_dmpar_sum_real(dminfo, blockSumGroundedIceVolume, groundedIceVolume) -! call mpas_dmpar_sum_real(dminfo, blockSumFloatingIceArea, floatingIceArea) -! call mpas_dmpar_sum_real(dminfo, blockSumFloatingIceVolume, floatingIceVolume) + call mpas_dmpar_sum_real(dminfo, blockSumGroundedIceArea, groundedIceArea) + call mpas_dmpar_sum_real(dminfo, blockSumGroundedIceVolume, groundedIceVolume) + call mpas_dmpar_sum_real(dminfo, blockSumFloatingIceArea, floatingIceArea) + call mpas_dmpar_sum_real(dminfo, blockSumFloatingIceVolume, floatingIceVolume) ! debugging print *, 'totalIceArea=', totalIceArea print *, 'totalIceVolume=', totalIceVolume -! print *, 'groundedIceArea=', groundedIceArea -! print *, 'groundedIceVolume=', groundedIceVolume -! print *, 'floatingIceArea=', floatingIceArea -! print *, 'floatingIceVolume=', floatingIceVolume + print *, 'groundedIceArea=', groundedIceArea + print *, 'groundedIceVolume=', groundedIceVolume + print *, 'floatingIceArea=', floatingIceArea + print *, 'floatingIceVolume=', floatingIceVolume ! Even though some variables do not include an index that is decomposed amongst ! domain partitions, we assign them within a block loop so that all blocks have the diff --git a/src/core_landice/shared/mpas_li_mask.F b/src/core_landice/shared/mpas_li_mask.F index b75674536d..d30d3d499e 100644 --- a/src/core_landice/shared/mpas_li_mask.F +++ b/src/core_landice/shared/mpas_li_mask.F @@ -105,6 +105,12 @@ module li_mask module procedure li_mask_is_grounded_ice_logout_0d end interface + !SFP: added + interface li_mask_is_grounded_ice_int + module procedure li_mask_is_grounded_ice_intout_1d + module procedure li_mask_is_grounded_ice_intout_0d + end interface + !-------------------------------------------------------------------- ! @@ -632,6 +638,30 @@ function li_mask_is_grounded_ice_logout_0d(mask) .and. (li_mask_is_ice(mask)) ) end function li_mask_is_grounded_ice_logout_0d + !SFP added + function li_mask_is_grounded_ice_intout_1d(mask) + integer, dimension(:), intent(in) :: mask + integer, dimension(size(mask)) :: li_mask_is_grounded_ice_intout_1d + + where( li_mask_is_ice(mask) ) + li_mask_is_grounded_ice_intout_1d = 1*size(mask,1) - ( iand(mask, li_mask_ValueFloating) / li_mask_ValueFloating ) + elsewhere + li_mask_is_grounded_ice_intout_1d = 0 + endwhere + + end function li_mask_is_grounded_ice_intout_1d + + !SFP added + function li_mask_is_grounded_ice_intout_0d(mask) + integer, intent(in) :: mask + integer :: li_mask_is_grounded_ice_intout_0d + + if( li_mask_is_ice(mask) )then + li_mask_is_grounded_ice_intout_0d = 1 - ( iand(mask, li_mask_ValueFloating) / li_mask_ValueFloating ) + else + li_mask_is_grounded_ice_intout_0d = 0 + endif + end function li_mask_is_grounded_ice_intout_0d From 26c83493ec8db88de113258638cfd7842899879b Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Tue, 15 Sep 2015 15:05:57 -0700 Subject: [PATCH 0249/1724] Added support for a spatially variable attenuation coeff Under land ice, this coefficient is likely to have a larger value (partly because of the compressed layers) than in the open ocean. The attenuation coefficient is computed as a diagnostics at every time step, taking the default as before if land-ice fluxes are turned off or wherever landIceFraction == 0. The attenuation coefficient transitions linearly with the landIceFraction to its value under land ice. --- src/core_ocean/Registry.xml | 3 ++ .../mode_forward/mpas_ocn_forward_mode.F | 2 +- src/core_ocean/shared/mpas_ocn_diagnostics.F | 45 +++++++++++++------ src/core_ocean/shared/mpas_ocn_forcing.F | 22 +++++---- .../shared/mpas_ocn_surface_land_ice_fluxes.F | 3 +- src/core_ocean/shared/mpas_ocn_tendency.F | 5 ++- src/core_ocean/shared/mpas_ocn_vel_forcing.F | 9 ++-- .../mpas_ocn_vel_forcing_surface_stress.F | 21 ++++++--- 8 files changed, 71 insertions(+), 39 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 5ae6fe6f3a..7f015bac8b 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -2127,6 +2127,9 @@ description="GM stream function" packages="forwardMode;analysisMode" /> + block_ptr % next diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index 3069bf0f72..d7b59f0d57 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -143,6 +143,9 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic real (kind=RKIND), pointer :: config_density0, config_apvm_scale_factor, config_coef_3rd_order, config_cvmix_kpp_surface_layer_averaging character (len=StrKIND), pointer :: config_pressure_gradient_type + real (kind=RKIND), pointer :: config_flux_attenuation_coefficient + real (kind=RKIND), dimension(:), pointer :: surfaceFluxAttenuationCoefficient + if (present(timeLevelIn)) then timeLevel = timeLevelIn else @@ -155,6 +158,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic call mpas_pool_get_config(ocnConfigs, 'config_coef_3rd_order', config_coef_3rd_order) call mpas_pool_get_config(ocnConfigs, 'config_cvmix_kpp_surface_layer_averaging', config_cvmix_kpp_surface_layer_averaging) call mpas_pool_get_config(ocnConfigs, 'config_use_cvmix_kpp', config_use_cvmix_kpp) + call mpas_pool_get_config(ocnConfigs, 'config_flux_attenuation_coefficient', config_flux_attenuation_coefficient) call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) @@ -231,6 +235,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic call mpas_pool_get_array(diagnosticsPool, 'normalVelocitySurfaceLayer', normalVelocitySurfaceLayer) call mpas_pool_get_array(diagnosticsPool, 'indexSurfaceLayerDepth', indexSurfaceLayerDepth) + call mpas_pool_get_array(diagnosticsPool, 'surfaceFluxAttenuationCoefficient', surfaceFluxAttenuationCoefficient) ! ! Compute height on cell edges at velocity locations ! Namelist options control the order of accuracy of the reconstructed layerThicknessEdge value @@ -663,6 +668,9 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic endif + ! compute the attenuation coefficient for surface fluxes + surfaceFluxAttenuationCoefficient(:) = config_flux_attenuation_coefficient + ! ! compute fields needed to compute land-ice fluxes, either in the ocean model or in the coupler call computeLandIceFluxInputFields(meshPool, statePool, forcingPool, scratchPool, & @@ -675,6 +683,8 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic gradSSH(1, iEdge) = (ssh(cell2) - ssh(cell1)) / dcEdge(iEdge) end do + + end subroutine ocn_diagnostic_solve!}}} !*********************************************************************** @@ -1320,7 +1330,7 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & type (mpas_pool_type), pointer :: tracersPool integer :: iCell, iEdge, cell1, cell2, iLevel, i - integer, pointer :: nCellsSolve, nEdgesSolve + integer, pointer :: nCells, nEdges integer, dimension(:,:), pointer :: cellsOnCell, cellsOnEdge @@ -1336,7 +1346,8 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & config_land_ice_flux_topDragCoeff, & config_land_ice_flux_rms_tidal_velocity, & config_land_ice_flux_jenkins_heat_transfer_coefficient, & - config_land_ice_flux_jenkins_salt_transfer_coefficient + config_land_ice_flux_jenkins_salt_transfer_coefficient, & + config_land_ice_flux_attenuation_coefficient real (kind=RKIND) :: blThickness, dz, blWeightSum, h_nu, Gamma_turb, landIceEdgeFraction, velocityMagnitude @@ -1349,7 +1360,8 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & topDrag, & topDragMagnitude, & fCell, & - blTempScratch, blSaltScratch + blTempScratch, blSaltScratch, & + surfaceFluxAttenuationCoefficient real (kind=RKIND), dimension(:,:), pointer :: kineticEnergyCell, layerThickness, normalVelocity real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers @@ -1376,19 +1388,19 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & hollandJenkinsOn = .true. end if - call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_topDragCoeff', config_land_ice_flux_topDragCoeff) call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_boundaryLayerThickness', config_land_ice_flux_boundaryLayerThickness) call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_boundaryLayerNeighborWeight', config_land_ice_flux_boundaryLayerNeighborWeight) call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_rms_tidal_velocity', config_land_ice_flux_rms_tidal_velocity) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_attenuation_coefficient', config_land_ice_flux_attenuation_coefficient) if(jenkinsOn) then call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_jenkins_heat_transfer_coefficient', config_land_ice_flux_jenkins_heat_transfer_coefficient) call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_jenkins_salt_transfer_coefficient', config_land_ice_flux_jenkins_salt_transfer_coefficient) end if - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) @@ -1413,6 +1425,7 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & call mpas_pool_get_array(diagnosticsPool, 'landIceHeatTransferVelocity', landIceHeatTransferVelocity) call mpas_pool_get_array(diagnosticsPool, 'landIceSaltTransferVelocity', landIceSaltTransferVelocity) end if + call mpas_pool_get_array(diagnosticsPool, 'surfaceFluxAttenuationCoefficient', surfaceFluxAttenuationCoefficient) call mpas_pool_get_field(scratchPool, 'boundaryLayerTemperatureScratch', boundaryLayerTemperatureField) call mpas_pool_get_field(scratchPool, 'boundaryLayerSalinityScratch', boundaryLayerSalinityField) @@ -1425,7 +1438,7 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & end if ! Compute top drag - do iEdge = 1, nEdgesSolve + do iEdge = 1, nEdges cell1 = cellsOnEdge(1, iEdge) cell2 = cellsOnEdge(2, iEdge) @@ -1439,7 +1452,7 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & end do ! compute top drag magnitude and friction velocity at cell centers - do iCell = 1, nCellsSolve + do iCell = 1, nCells ! the magnitude of the top drag is CD*u**2 = CD*(2*KE) topDragMagnitude(iCell) = landIceFraction(iCell) & * 2.0_RKIND * config_land_ice_flux_topDragCoeff * kineticEnergyCell(1,iCell) @@ -1452,7 +1465,7 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & ! average temperature and salinity over horizontal neighbors and the sub-ice-shelf boundary layer - do iCell = 1, nCellsSolve + do iCell = 1, nCells blThickness = 0.0_RKIND blTempScratch(iCell) = 0.0_RKIND blSaltScratch(iCell) = 0.0_RKIND @@ -1468,13 +1481,13 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & blSaltScratch(iCell) = blSaltScratch(iCell)/blThickness end if end do - do iCell = 1, nCellsSolve + do iCell = 1, nCells blWeightSum = 1.0_RKIND landIceBoundaryLayerTemperature(iCell) = blTempScratch(iCell) landIceBoundaryLayerSalinity(iCell) = blSaltScratch(iCell) do i = 1, nEdgesOnCell(iCell) cell2 = cellsOnCell(i,iCell) - if(cell2 <= 0 .or. cell2 > nCellsSolve) cycle + if(cell2 <= 0 .or. cell2 > nCells) cycle landIceBoundaryLayerTemperature(iCell) = landIceBoundaryLayerTemperature(iCell) & + config_land_ice_flux_boundaryLayerNeighborWeight*blTempScratch(cell2) @@ -1489,13 +1502,13 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & end do if(jenkinsOn) then - do iCell = 1, nCellsSolve + do iCell = 1, nCells ! transfer coefficients from namelist landIceHeatTransferVelocity(iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_heat_transfer_coefficient landIceSaltTransferVelocity(iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_salt_transfer_coefficient end do else if(hollandJenkinsOn) then - do iCell = 1, nCellsSolve + do iCell = 1, nCells ! friction-velocity dependent non-dimensional transfer coefficients from ! Holland and Jenkins 1999, (14)-(16) with eta_* = 1 h_nu = 5.0_RKIND*nuSaltWater/landIceFrictionVelocity(iCell) ! uStar should never be zero because of tidal term @@ -1514,6 +1527,12 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & call mpas_deallocate_scratch_field(boundaryLayerTemperatureField, .true.) call mpas_deallocate_scratch_field(boundaryLayerSalinityField, .true.) + ! recompute the spatially-varying attenuation coefficient based on landIceFraction + do iCell = 1, nCells + surfaceFluxAttenuationCoefficient(iCell) = landIceFraction(iCell)*config_land_ice_flux_attenuation_coefficient & + + (1.0_RKIND - landIceFraction(iCell))*surfaceFluxAttenuationCoefficient(iCell) + end do + !-------------------------------------------------------------------- end subroutine computeLandIceFluxInputFields!}}} diff --git a/src/core_ocean/shared/mpas_ocn_forcing.F b/src/core_ocean/shared/mpas_ocn_forcing.F index 6724ca2691..4818643851 100644 --- a/src/core_ocean/shared/mpas_ocn_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_forcing.F @@ -56,8 +56,6 @@ module ocn_forcing ! !-------------------------------------------------------------------- - real (kind=RKIND) :: attenuationCoefficient - !*********************************************************************** contains @@ -80,11 +78,7 @@ subroutine ocn_forcing_init(err)!{{{ integer, intent(out) :: err !< Output: error flag - real (kind=RKIND), pointer :: config_flux_attenuation_coefficient - - call mpas_pool_get_config(ocnConfigs, 'config_flux_attenuation_coefficient', config_flux_attenuation_coefficient) - - attenuationCoefficient = config_flux_attenuation_coefficient + err = 0 end subroutine ocn_forcing_init!}}} @@ -101,9 +95,10 @@ end subroutine ocn_forcing_init!}}} ! !----------------------------------------------------------------------- - subroutine ocn_forcing_build_fraction_absorbed_array(meshPool, statePool, forcingPool, err, timeLevelIn)!{{{ + subroutine ocn_forcing_build_fraction_absorbed_array(meshPool, statePool, diagnosticsPool, forcingPool, err, timeLevelIn)!{{{ type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information type (mpas_pool_type), intent(in) :: statePool !< Input: State information + type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostics information type (mpas_pool_type), intent(inout) :: forcingPool !< Input/Output: Forcing information integer, intent(out) :: err !< Output: Error code integer, intent(in), optional :: timeLevelIn @@ -116,6 +111,7 @@ subroutine ocn_forcing_build_fraction_absorbed_array(meshPool, statePool, forcin real (kind=RKIND) :: zTop, zBot, transmissionCoeffTop, transmissionCoeffBot + real (kind=RKIND), dimension(:), pointer :: surfaceFluxAttenuationCoefficient real (kind=RKIND), dimension(:,:), pointer :: layerThickness, fractionAbsorbed integer :: iCell, k, timeLevel @@ -137,14 +133,16 @@ subroutine ocn_forcing_build_fraction_absorbed_array(meshPool, statePool, forcin call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) + call mpas_pool_get_array(diagnosticsPool, 'surfaceFluxAttenuationCoefficient', surfaceFluxAttenuationCoefficient) + call mpas_pool_get_array(forcingPool, 'fractionAbsorbed', fractionAbsorbed) do iCell = 1, nCells zTop = 0.0_RKIND - transmissionCoeffTop = ocn_forcing_transmission(zTop) + transmissionCoeffTop = ocn_forcing_transmission(zTop, surfaceFluxAttenuationCoefficient(iCell)) do k = 1, maxLevelCell(iCell) zBot = zTop - layerThickness(k,iCell) - transmissionCoeffBot = ocn_forcing_transmission(zBot) + transmissionCoeffBot = ocn_forcing_transmission(zBot, surfaceFluxAttenuationCoefficient(iCell)) fractionAbsorbed(k, iCell) = transmissionCoeffTop - transmissionCoeffBot @@ -169,8 +167,8 @@ end subroutine ocn_forcing_build_fraction_absorbed_array!}}} ! !----------------------------------------------------------------------- - real (kind=RKIND) function ocn_forcing_transmission(z)!{{{ - real (kind=RKIND), intent(in) :: z + real (kind=RKIND) function ocn_forcing_transmission(z, attenuationCoefficient)!{{{ + real (kind=RKIND), intent(in) :: z, attenuationCoefficient ocn_forcing_transmission = exp( z / attenuationCoefficient ) diff --git a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F index ef3b9ce72e..d0a35625de 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F +++ b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F @@ -410,7 +410,6 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) call mpas_pool_get_array(forcingPool, 'landIceFraction', landIceFraction) - call mpas_pool_get_array(forcingPool, 'landIceSurfaceTemperature', landIceSurfaceTemperature) call mpas_pool_get_array(forcingPool, 'landIceFreshwaterFlux', landIceFreshwaterFlux) call mpas_pool_get_array(forcingPool, 'landIceHeatFlux', landIceHeatFlux) @@ -420,6 +419,8 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & call mpas_pool_get_array(forcingPool, 'landIceFrictionVelocity', landIceFrictionVelocity) if(config_land_ice_flux_useHollandJenkinsAdvDiff) then + call mpas_pool_get_array(forcingPool, 'landIceSurfaceTemperature', landIceSurfaceTemperature) + call mpas_pool_get_field(scratchPool, 'freezeInterfaceSalinityScratch', freezeInterfaceSalinityField) call mpas_pool_get_field(scratchPool, 'freezeInterfaceTemperatureScratch', freezeInterfaceTemperatureField) call mpas_pool_get_field(scratchPool, 'freezeFreshwaterFluxScratch', freezeFreshwaterFluxField) diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index c853d33605..29f699d851 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -205,7 +205,7 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP type (mpas_pool_type), pointer :: tracersPool - real (kind=RKIND), dimension(:), pointer :: surfaceStress, surfaceStressMagnitude + real (kind=RKIND), dimension(:), pointer :: surfaceStress, surfaceStressMagnitude, surfaceFluxAttenuationCoefficient real (kind=RKIND), dimension(:,:), pointer :: & layerThicknessEdge, normalVelocity, tangentialVelocity, density, potentialDensity, zMid, pressure, & tend_normalVelocity, circulation, relativeVorticity, viscosity, kineticEnergyCell, & @@ -255,6 +255,7 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP call mpas_pool_get_array(diagnosticsPool, 'density', density) call mpas_pool_get_array(diagnosticsPool, 'potentialDensity', potentialDensity) call mpas_pool_get_array(diagnosticsPool, 'tangentialVelocity', tangentialVelocity) + call mpas_pool_get_array(diagnosticsPool, 'surfaceFluxAttenuationCoefficient', surfaceFluxAttenuationCoefficient) call mpas_pool_get_array(tendPool, 'normalVelocity', tend_normalVelocity) @@ -329,7 +330,7 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP ! call mpas_timer_start("forcings", .false., velForceTimer) - call ocn_vel_forcing_tend(meshPool, normalVelocity, surfaceStress, layerThicknessEdge, tend_normalVelocity, err) + call ocn_vel_forcing_tend(meshPool, normalVelocity, surfaceFluxAttenuationCoefficient, surfaceStress, layerThicknessEdge, tend_normalVelocity, err) call mpas_timer_stop("forcings", velForceTimer) ! diff --git a/src/core_ocean/shared/mpas_ocn_vel_forcing.F b/src/core_ocean/shared/mpas_ocn_vel_forcing.F index 5e5e9ed424..1b79b50b45 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing.F @@ -75,7 +75,8 @@ module ocn_vel_forcing ! !----------------------------------------------------------------------- - subroutine ocn_vel_forcing_tend(meshPool, normalVelocity, surfaceStress, layerThicknessEdge, tend, err)!{{{ + subroutine ocn_vel_forcing_tend(meshPool, normalVelocity, surfaceFluxAttenuationCoefficient, & + surfaceStress, layerThicknessEdge, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -87,7 +88,8 @@ subroutine ocn_vel_forcing_tend(meshPool, normalVelocity, surfaceStress, layerTh normalVelocity !< Input: Normal velocity at edges real (kind=RKIND), dimension(:), intent(in) :: & - surfaceStress !< Input: surface stress at surface of normal velocity at edges + surfaceFluxAttenuationCoefficient, & !< Input: attenuation coefficient for surface fluxes at cell centers + surfaceStress !< Input: surface stress at edges real (kind=RKIND), dimension(:,:), intent(in) :: & layerThicknessEdge !< Input: thickness at edge @@ -128,7 +130,8 @@ subroutine ocn_vel_forcing_tend(meshPool, normalVelocity, surfaceStress, layerTh ! !----------------------------------------------------------------- - call ocn_vel_forcing_surface_stress_tend(meshPool, surfaceStress, layerThicknessEdge, tend, err1) + call ocn_vel_forcing_surface_stress_tend(meshPool, surfaceFluxAttenuationCoefficient, & + surfaceStress, layerThicknessEdge, tend, err1) call ocn_vel_forcing_rayleigh_tend(meshPool, normalVelocity, tend, err2) err = ior(err1, err2) diff --git a/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F b/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F index 2e41b052ac..27876fecd7 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F @@ -70,7 +70,7 @@ module ocn_vel_forcing_surface_stress ! !----------------------------------------------------------------------- - subroutine ocn_vel_forcing_surface_stress_tend(meshPool, surfaceStress, layerThicknessEdge, tend, err)!{{{ + subroutine ocn_vel_forcing_surface_stress_tend(meshPool, surfaceFluxAttenuationCoefficient, surfaceStress, layerThicknessEdge, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -79,7 +79,8 @@ subroutine ocn_vel_forcing_surface_stress_tend(meshPool, surfaceStress, layerThi !----------------------------------------------------------------- real (kind=RKIND), dimension(:), intent(in) :: & - surfaceStress !< Input: Wind stress at surface + surfaceStress, & !< Input: Wind stress at surface + surfaceFluxAttenuationCoefficient !< Input: attenuation coefficient for surface fluxes real (kind=RKIND), dimension(:,:), intent(in) :: & layerThicknessEdge !< Input: thickness at edge @@ -110,12 +111,13 @@ subroutine ocn_vel_forcing_surface_stress_tend(meshPool, surfaceStress, layerThi ! !----------------------------------------------------------------- - integer :: iEdge, k + integer :: iEdge, k, cell1, cell2 integer, pointer :: nEdgesSolve integer, dimension(:), pointer :: maxLevelEdgeTop - integer, dimension(:,:), pointer :: edgeMask + integer, dimension(:,:), pointer :: edgeMask, cellsOnEdge - real (kind=RKIND) :: transmissionCoeffTop, transmissionCoeffBot, zTop, zBot, remainingStress + real (kind=RKIND) :: transmissionCoeffTop, transmissionCoeffBot, zTop, zBot, remainingStress, & + attenuationCoeff real (kind=RKIND), pointer :: config_density0 @@ -137,15 +139,20 @@ subroutine ocn_vel_forcing_surface_stress_tend(meshPool, surfaceStress, layerThi call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) do iEdge = 1, nEdgesSolve zTop = 0.0_RKIND - transmissionCoeffTop = ocn_forcing_transmission(zTop) + cell1 = cellsOnEdge(iEdge,1) + cell2 = cellsOnEdge(iEdge,2) + attenuationCoeff = 0.5_RKIND * (surfaceFluxAttenuationCoefficient(cell1) & + + surfaceFluxAttenuationCoefficient(cell2)) + transmissionCoeffTop = ocn_forcing_transmission(zTop, attenuationCoeff) remainingStress = 1.0_RKIND do k = 1, maxLevelEdgeTop(iEdge) zBot = zTop - layerThicknessEdge(k, iEdge) - transmissionCoeffBot = ocn_forcing_transmission(zBot) + transmissionCoeffBot = ocn_forcing_transmission(zBot, attenuationCoeff) remainingStress = remainingStress - (transmissionCoeffTop - transmissionCoeffBot) From 4da2a60454af37fece474baf743168fce142f4c4 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Tue, 15 Sep 2015 19:08:50 -0600 Subject: [PATCH 0250/1724] Fixing a referenece to a var_array that is really a var_struct This commit updates the default stream configurations to convert a var_array to a var_struct, since tracersSurfaceFlux was changed to a var_struct in the previous commit. --- src/core_ocean/Registry.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index a9cc16af91..8545a09892 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1250,10 +1250,10 @@ mode="forward"> + - From 98e9a345337acb247f498775b078fb7d3fa422ce Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Wed, 16 Sep 2015 11:42:07 -0600 Subject: [PATCH 0251/1724] comment out new function for generating a 1d (vector) ones / zeros integer mask for grounded ice --- src/core_landice/shared/mpas_li_mask.F | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/src/core_landice/shared/mpas_li_mask.F b/src/core_landice/shared/mpas_li_mask.F index d30d3d499e..f7d86db2b2 100644 --- a/src/core_landice/shared/mpas_li_mask.F +++ b/src/core_landice/shared/mpas_li_mask.F @@ -638,20 +638,18 @@ function li_mask_is_grounded_ice_logout_0d(mask) .and. (li_mask_is_ice(mask)) ) end function li_mask_is_grounded_ice_logout_0d - !SFP added - function li_mask_is_grounded_ice_intout_1d(mask) - integer, dimension(:), intent(in) :: mask - integer, dimension(size(mask)) :: li_mask_is_grounded_ice_intout_1d - - where( li_mask_is_ice(mask) ) - li_mask_is_grounded_ice_intout_1d = 1*size(mask,1) - ( iand(mask, li_mask_ValueFloating) / li_mask_ValueFloating ) - elsewhere - li_mask_is_grounded_ice_intout_1d = 0 - endwhere - - end function li_mask_is_grounded_ice_intout_1d +!! SFP: the function below has not been tested yet - activate and use at your own risk! +! function li_mask_is_grounded_ice_intout_1d(mask) +! integer, dimension(:), intent(in) :: mask +! integer, dimension(size(mask)) :: li_mask_is_grounded_ice_intout_1d +! +! where( li_mask_is_ice(mask) ) +! li_mask_is_grounded_ice_intout_1d = int(mask*0 + 1) - ( iand(mask, li_mask_ValueFloating) / li_mask_ValueFloating ) +! elsewhere +! li_mask_is_grounded_ice_intout_1d = 0 +! endwhere +! end function li_mask_is_grounded_ice_intout_1d - !SFP added function li_mask_is_grounded_ice_intout_0d(mask) integer, intent(in) :: mask integer :: li_mask_is_grounded_ice_intout_0d From 415f8237d7b67b20cb44d405891cff9c256c5f6a Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Wed, 16 Sep 2015 11:48:58 -0600 Subject: [PATCH 0252/1724] minor change in how inactive code is commented out --- src/core_landice/shared/mpas_li_mask.F | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core_landice/shared/mpas_li_mask.F b/src/core_landice/shared/mpas_li_mask.F index f7d86db2b2..d85d65333b 100644 --- a/src/core_landice/shared/mpas_li_mask.F +++ b/src/core_landice/shared/mpas_li_mask.F @@ -99,15 +99,15 @@ module li_mask module procedure li_mask_is_floating_ice_intout_0d end interface - interface li_mask_is_grounded_ice module procedure li_mask_is_grounded_ice_logout_1d module procedure li_mask_is_grounded_ice_logout_0d end interface - !SFP: added +!! SFP: the 1d versions below have not been tested yet - activate and use at your own risk! +!! Also check the corresponding function below. interface li_mask_is_grounded_ice_int - module procedure li_mask_is_grounded_ice_intout_1d +! module procedure li_mask_is_grounded_ice_intout_1d module procedure li_mask_is_grounded_ice_intout_0d end interface @@ -638,7 +638,7 @@ function li_mask_is_grounded_ice_logout_0d(mask) .and. (li_mask_is_ice(mask)) ) end function li_mask_is_grounded_ice_logout_0d -!! SFP: the function below has not been tested yet - activate and use at your own risk! +!! SFP: has not been tested yet - activate and use at your own risk! Also check the corresponding interface at top. ! function li_mask_is_grounded_ice_intout_1d(mask) ! integer, dimension(:), intent(in) :: mask ! integer, dimension(size(mask)) :: li_mask_is_grounded_ice_intout_1d From d3b03491139666d64ba8fc10e43f9d8f29e8329f Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Wed, 16 Sep 2015 15:06:59 -0600 Subject: [PATCH 0253/1724] add forcing tracers to init streams fixes an issue with default namelist.ocean.init files not having appropriate namelist records available for forcing --- src/core_ocean/Registry.xml | 2 +- src/core_ocean/tracer_groups/Registry_activeTracers.xml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index d2204fac47..deff40eb5a 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -588,7 +588,7 @@ possible_values="Any positive value" /> - + + Date: Wed, 16 Sep 2015 16:10:12 -0600 Subject: [PATCH 0254/1724] moving subroutine calls around to try and figure out i/o problems --- .../mpas_li_analysis_driver.F | 4 ++++ src/core_landice/mode_forward/mpas_li_core.F | 19 +++++++++++++++---- .../mode_forward/mpas_li_time_integration.F | 8 -------- 3 files changed, 19 insertions(+), 12 deletions(-) diff --git a/src/core_landice/analysis_members/mpas_li_analysis_driver.F b/src/core_landice/analysis_members/mpas_li_analysis_driver.F index 89477fa1d1..1ec033c69d 100644 --- a/src/core_landice/analysis_members/mpas_li_analysis_driver.F +++ b/src/core_landice/analysis_members/mpas_li_analysis_driver.F @@ -580,6 +580,8 @@ subroutine li_analysis_write(domain, err)!{{{ err = 0 + print *, 'inside analysis driver: START of write subroutine' + call mpas_timer_start('analysis_write', .false.) call mpas_pool_begin_iteration(analysisMemberList) @@ -606,6 +608,8 @@ subroutine li_analysis_write(domain, err)!{{{ call mpas_timer_stop('analysis_write') + print *, 'inside analysis driver: END of write subroutine' + end subroutine li_analysis_write!}}} !*********************************************************************** diff --git a/src/core_landice/mode_forward/mpas_li_core.F b/src/core_landice/mode_forward/mpas_li_core.F index 53193799b3..cddcf1732b 100644 --- a/src/core_landice/mode_forward/mpas_li_core.F +++ b/src/core_landice/mode_forward/mpas_li_core.F @@ -290,8 +290,10 @@ function li_core_run(domain) result(err) endif !SFP added: compute analysis members on startup if option activiated - call li_analysis_compute_startup(domain, err_tmp) - err = ior(err, err_tmp) + call mpas_timer_start("analysis member startup calculations") + call li_analysis_compute_startup(domain, err_tmp) + err = ior(err, err_tmp) + call mpas_timer_stop("analysis member startup calculations") ! === ! === Write Initial Output @@ -380,6 +382,13 @@ function li_core_run(domain) result(err) call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_INPUT, ierr=err_tmp) err = ior(err, err_tmp) + !SFP added: call analysis driver compute, etc. subroutines + call li_analysis_compute(domain, err_tmp) + err = ior(err, err_tmp) + call li_analysis_restart(domain, err) + err = ior(err, err_tmp) + call li_analysis_write(domain, err_tmp) + err = ior(err, err_tmp) ! === ! === Write Output and/or Restart, if needed @@ -490,13 +499,15 @@ function li_core_finalize(domain) result(err) call li_velocity_finalize(domain, err_tmp) err = ior(err, err_tmp) + !SFP: added call to finalize subroutine in analysis driver + call li_analysis_finalize(domain, err_tmp) + err = ior(err, err_tmp) + call mpas_destroy_clock(domain % clock, err_tmp) err = ior(err, err_tmp) call mpas_decomp_destroy_decomp_list(domain % decompositions) - !SFP: added call to finalize subroutine in analysis driver - call li_analysis_finalize(domain, err_tmp) err = ior(err, err_tmp) ! === error check and exit diff --git a/src/core_landice/mode_forward/mpas_li_time_integration.F b/src/core_landice/mode_forward/mpas_li_time_integration.F index 8f5352f3a4..2687c40fbc 100644 --- a/src/core_landice/mode_forward/mpas_li_time_integration.F +++ b/src/core_landice/mode_forward/mpas_li_time_integration.F @@ -202,14 +202,6 @@ subroutine li_timestep(domain, err) block => block % next end do - !SFP added: call analysis driver compute, etc. subroutines - call li_analysis_compute(domain, err_tmp) - err = ior(err, err_tmp) - call li_analysis_restart(domain, err) - err = ior(err, err_tmp) - call li_analysis_write(domain, err_tmp) - err = ior(err, err_tmp) - ! === error check if (err > 0) then write (stderrUnit,*) "An error has occurred in li_timestep." From f83509a9d3b4b00d761dc12ef210ed108f278d14 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Wed, 16 Sep 2015 15:26:04 -0700 Subject: [PATCH 0255/1724] Moving topDrag and topDragMagnitude to diagnostics pool --- src/core_ocean/Registry.xml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 7f015bac8b..d1403c40fd 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -2153,6 +2153,14 @@ description="friction velocity times nondimensional salt transfer coefficient" packages="landIceFluxesPKG" /> + + - - Date: Wed, 16 Sep 2015 15:30:42 -0700 Subject: [PATCH 0256/1724] Fixing unitialized variables, incorrect pools, bad indexing --- src/core_ocean/shared/mpas_ocn_diagnostics.F | 4 ++++ src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F | 2 +- src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F | 4 ++-- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index d7b59f0d57..192cd032d2 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -1381,6 +1381,8 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & call mpas_pool_get_config(ocnConfigs, 'config_use_land_ice_fluxes', config_use_land_ice_fluxes) if(.not. config_use_land_ice_fluxes) return + jenkinsOn = .false. + hollandJenkinsOn = .false. call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_formulation', config_land_ice_flux_formulation) if ( trim(config_land_ice_flux_formulation) == 'Jenkins' ) then jenkinsOn = .true. @@ -1416,6 +1418,8 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & call mpas_pool_get_array(forcingPool, 'landIceFraction', landIceFraction) + call mpas_pool_get_array(diagnosticsPool, 'kineticEnergyCell', kineticEnergyCell) + call mpas_pool_get_array(diagnosticsPool, 'landIceFrictionVelocity', landIceFrictionVelocity) call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerTemperature', landIceBoundaryLayerTemperature) call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerSalinity', landIceBoundaryLayerSalinity) diff --git a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F index d0a35625de..30786d33dc 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F +++ b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F @@ -407,6 +407,7 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerSalinity', landIceBoundaryLayerSalinity) call mpas_pool_get_array(diagnosticsPool, 'landIceHeatTransferVelocity', landIceHeatTransferVelocity) call mpas_pool_get_array(diagnosticsPool, 'landIceSaltTransferVelocity', landIceSaltTransferVelocity) + call mpas_pool_get_array(diagnosticsPool, 'landIceFrictionVelocity', landIceFrictionVelocity) call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) call mpas_pool_get_array(forcingPool, 'landIceFraction', landIceFraction) @@ -416,7 +417,6 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & call mpas_pool_get_array(forcingPool, 'heatFluxToLandIce', heatFluxToLandIce) call mpas_pool_get_array(forcingPool, 'landIceInterfaceTemperature', landIceInterfaceTemperature) call mpas_pool_get_array(forcingPool, 'landIceInterfaceSalinity', landIceInterfaceSalinity) - call mpas_pool_get_array(forcingPool, 'landIceFrictionVelocity', landIceFrictionVelocity) if(config_land_ice_flux_useHollandJenkinsAdvDiff) then call mpas_pool_get_array(forcingPool, 'landIceSurfaceTemperature', landIceSurfaceTemperature) diff --git a/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F b/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F index 27876fecd7..dbd6f14ea6 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F @@ -143,8 +143,8 @@ subroutine ocn_vel_forcing_surface_stress_tend(meshPool, surfaceFluxAttenuationC do iEdge = 1, nEdgesSolve zTop = 0.0_RKIND - cell1 = cellsOnEdge(iEdge,1) - cell2 = cellsOnEdge(iEdge,2) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) attenuationCoeff = 0.5_RKIND * (surfaceFluxAttenuationCoefficient(cell1) & + surfaceFluxAttenuationCoefficient(cell2)) transmissionCoeffTop = ocn_forcing_transmission(zTop, attenuationCoeff) From 4bc50f25b733944f2f1f18ec102b8bd00555d613 Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Wed, 16 Sep 2015 22:30:14 -0600 Subject: [PATCH 0257/1724] remove debug output and cleanup comments; working as expected now for dome test case (following change to streams file) --- .../mpas_li_analysis_driver.F | 4 --- .../analysis_members/mpas_li_global_stats.F | 30 ++++--------------- src/core_landice/mode_forward/mpas_li_core.F | 11 ++++--- .../mode_forward/mpas_li_core_interface.F | 5 ++-- .../mode_forward/mpas_li_time_integration.F | 2 -- 5 files changed, 13 insertions(+), 39 deletions(-) diff --git a/src/core_landice/analysis_members/mpas_li_analysis_driver.F b/src/core_landice/analysis_members/mpas_li_analysis_driver.F index 1ec033c69d..89477fa1d1 100644 --- a/src/core_landice/analysis_members/mpas_li_analysis_driver.F +++ b/src/core_landice/analysis_members/mpas_li_analysis_driver.F @@ -580,8 +580,6 @@ subroutine li_analysis_write(domain, err)!{{{ err = 0 - print *, 'inside analysis driver: START of write subroutine' - call mpas_timer_start('analysis_write', .false.) call mpas_pool_begin_iteration(analysisMemberList) @@ -608,8 +606,6 @@ subroutine li_analysis_write(domain, err)!{{{ call mpas_timer_stop('analysis_write') - print *, 'inside analysis driver: END of write subroutine' - end subroutine li_analysis_write!}}} !*********************************************************************** diff --git a/src/core_landice/analysis_members/mpas_li_global_stats.F b/src/core_landice/analysis_members/mpas_li_global_stats.F index e10e8bd762..192fb907fa 100644 --- a/src/core_landice/analysis_members/mpas_li_global_stats.F +++ b/src/core_landice/analysis_members/mpas_li_global_stats.F @@ -105,8 +105,6 @@ subroutine li_init_global_stats(domain, memberName, err)!{{{ err = 0 - print *, 'in li_init_global_stats' - end subroutine li_init_global_stats!}}} !*********************************************************************** @@ -188,8 +186,6 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ real (kind=RKIND) :: blockSumFloatingIceArea real (kind=RKIND) :: blockSumFloatingIceVolume - print *, 'in li_compute_global_stats' - err = 0 ! initialize sums over blocks to 0 @@ -240,16 +236,6 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ blockSumFloatingIceVolume = blockSumFloatingIceVolume + real(li_mask_is_floating_ice_int(cellMask(iCell)),RKIND) & * areaCell(iCell) * thickness(iCell) - ! debugging -! print *, 'CellMask = ', CellMask(iCell) -! print *, 'iceMask = ', li_mask_is_ice_int(cellMask(iCell)) -! print *, 'groundedMask = ', (1 - li_mask_is_floating_ice_int(cellMask(iCell)) ) -! print *, 'floatingMask = ', li_mask_is_floating_ice_int(cellMask(iCell)) -! print *, 'areaCell = ', areaCell(iCell) -! print *, 'thickness = ', thickness(iCell) -! print *, 'blockSumIceArea=', blockSumIceArea -! print *, 'blockSumIceVolume=', blockSumIceVolume - end do ! end sum over cells block => block % next @@ -265,12 +251,12 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ call mpas_dmpar_sum_real(dminfo, blockSumFloatingIceVolume, floatingIceVolume) ! debugging - print *, 'totalIceArea=', totalIceArea - print *, 'totalIceVolume=', totalIceVolume - print *, 'groundedIceArea=', groundedIceArea - print *, 'groundedIceVolume=', groundedIceVolume - print *, 'floatingIceArea=', floatingIceArea - print *, 'floatingIceVolume=', floatingIceVolume +! print *, 'totalIceArea=', totalIceArea +! print *, 'totalIceVolume=', totalIceVolume +! print *, 'groundedIceArea=', groundedIceArea +! print *, 'groundedIceVolume=', groundedIceVolume +! print *, 'floatingIceArea=', floatingIceArea +! print *, 'floatingIceVolume=', floatingIceVolume ! Even though some variables do not include an index that is decomposed amongst ! domain partitions, we assign them within a block loop so that all blocks have the @@ -333,8 +319,6 @@ subroutine li_restart_global_stats(domain, memberName, err)!{{{ err = 0 - print *, 'in li_restart_global_stats' - end subroutine li_restart_global_stats!}}} !*********************************************************************** @@ -384,8 +368,6 @@ subroutine li_finalize_global_stats(domain, memberName, err)!{{{ err = 0 - print *, 'in li_finalize_global_stats' - end subroutine li_finalize_global_stats!}}} end module li_global_stats diff --git a/src/core_landice/mode_forward/mpas_li_core.F b/src/core_landice/mode_forward/mpas_li_core.F index cddcf1732b..2d68a39004 100644 --- a/src/core_landice/mode_forward/mpas_li_core.F +++ b/src/core_landice/mode_forward/mpas_li_core.F @@ -9,8 +9,7 @@ module li_core use mpas_framework use mpas_timekeeping - - use li_analysis_driver !SFP added + use li_analysis_driver implicit none private @@ -154,7 +153,7 @@ function li_core_init(domain, startTimeStamp) result(err) block => block % next end do - !SFP added: initialize analysis driver + ! initialize analysis driver call li_analysis_init(domain, err_tmp) err = ior(err, err_tmp) @@ -289,7 +288,7 @@ function li_core_run(domain) result(err) call mpas_timer_stop("compute_statistics") endif - !SFP added: compute analysis members on startup if option activiated + ! compute analysis members on startup if option activiated call mpas_timer_start("analysis member startup calculations") call li_analysis_compute_startup(domain, err_tmp) err = ior(err, err_tmp) @@ -382,7 +381,7 @@ function li_core_run(domain) result(err) call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_INPUT, ierr=err_tmp) err = ior(err, err_tmp) - !SFP added: call analysis driver compute, etc. subroutines + ! call analysis driver compute, etc. subroutines call li_analysis_compute(domain, err_tmp) err = ior(err, err_tmp) call li_analysis_restart(domain, err) @@ -499,7 +498,7 @@ function li_core_finalize(domain) result(err) call li_velocity_finalize(domain, err_tmp) err = ior(err, err_tmp) - !SFP: added call to finalize subroutine in analysis driver + ! call finalize subroutine in analysis driver call li_analysis_finalize(domain, err_tmp) err = ior(err, err_tmp) diff --git a/src/core_landice/mode_forward/mpas_li_core_interface.F b/src/core_landice/mode_forward/mpas_li_core_interface.F index 7725edf2a9..a67f2eaa19 100644 --- a/src/core_landice/mode_forward/mpas_li_core_interface.F +++ b/src/core_landice/mode_forward/mpas_li_core_interface.F @@ -13,8 +13,7 @@ module li_core_interface use mpas_constants use mpas_io_units use li_core - - use li_analysis_driver !SFP added + use li_analysis_driver public @@ -124,7 +123,7 @@ function li_setup_packages(configPool, packagePool) result(ierr) write (stdoutUnit,*) "The 'calcDiffusivity' package and associated variables have been enabled because 'config_adaptive_timestep_include_DCFL' is set to .true." endif - !SFP added: call to setup packages in analysis driver + ! call setup packages in analysis driver call li_analysis_setup_packages(configPool, packagePool, ierr) diff --git a/src/core_landice/mode_forward/mpas_li_time_integration.F b/src/core_landice/mode_forward/mpas_li_time_integration.F index 2687c40fbc..dd540289e7 100644 --- a/src/core_landice/mode_forward/mpas_li_time_integration.F +++ b/src/core_landice/mode_forward/mpas_li_time_integration.F @@ -29,8 +29,6 @@ module li_time_integration use li_time_integration_fe use li_setup - use li_analysis_driver ! SFP added - implicit none private From 5b2d5f97b2b10bdf2c567da568a08549dc7425d9 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Wed, 16 Sep 2015 15:45:12 -0600 Subject: [PATCH 0258/1724] Small corrections to init mode templates. --- src/core_ocean/mode_init/Registry_TEMPLATE.xml | 2 +- src/core_ocean/mode_init/mpas_ocn_init_TEMPLATE.F | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/mode_init/Registry_TEMPLATE.xml b/src/core_ocean/mode_init/Registry_TEMPLATE.xml index d8e52ad626..f80e1f7e75 100644 --- a/src/core_ocean/mode_init/Registry_TEMPLATE.xml +++ b/src/core_ocean/mode_init/Registry_TEMPLATE.xml @@ -1,4 +1,4 @@ - + 5. Add these lines for default namelist parsing: !> in src/core_ocean/Makefile: !> (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.TEMPLATE mode=init configuration=TEMPLATE) -!> in src/core_ocean/Registry.xml +!> +!> in src/core_ocean/Registry.xml, add your case to +!> nml_option name="config_init_configuration" +!> as !> TEMPLATE_value="TEMPLATE" ! !----------------------------------------------------------------------- From a5a1514a77b67df1d2a9988250963413fb5e74a9 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Thu, 17 Sep 2015 10:30:47 -0700 Subject: [PATCH 0259/1724] Bug fix: rho_sw missing from top drag --- src/core_ocean/shared/mpas_ocn_diagnostics.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index 192cd032d2..ea7826ecb9 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -1450,7 +1450,7 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & velocityMagnitude = sqrt(kineticEnergyCell(1,cell1) + kineticEnergyCell(1,cell2)) landIceEdgeFraction = 0.5_RKIND*(landIceFraction(cell1)+landIceFraction(cell2)) - topDrag(iEdge) = - landIceEdgeFraction * config_land_ice_flux_topDragCoeff & + topDrag(iEdge) = - rho_sw * landIceEdgeFraction * config_land_ice_flux_topDragCoeff & * velocityMagnitude * normalVelocity(1,iEdge) end do @@ -1458,7 +1458,7 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & ! compute top drag magnitude and friction velocity at cell centers do iCell = 1, nCells ! the magnitude of the top drag is CD*u**2 = CD*(2*KE) - topDragMagnitude(iCell) = landIceFraction(iCell) & + topDragMagnitude(iCell) = rho_sw * landIceFraction(iCell) & * 2.0_RKIND * config_land_ice_flux_topDragCoeff * kineticEnergyCell(1,iCell) ! the friction velocity is the square root of the top drag + variance of tidal velocity (computed regardless of land-ice coverage) From fe7fd83497dbebff1887dcc1b5b06578dff1b961 Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Thu, 17 Sep 2015 11:57:09 -0600 Subject: [PATCH 0260/1724] added some global stats (mean, min, max) for ice thickness --- .../Registry_global_stats.xml | 12 ++++++ .../analysis_members/mpas_li_global_stats.F | 43 ++++++++++++++----- 2 files changed, 44 insertions(+), 11 deletions(-) diff --git a/src/core_landice/analysis_members/Registry_global_stats.xml b/src/core_landice/analysis_members/Registry_global_stats.xml index c8acbe19fd..98abfab027 100644 --- a/src/core_landice/analysis_members/Registry_global_stats.xml +++ b/src/core_landice/analysis_members/Registry_global_stats.xml @@ -42,6 +42,15 @@ + + + + + + diff --git a/src/core_landice/analysis_members/mpas_li_global_stats.F b/src/core_landice/analysis_members/mpas_li_global_stats.F index 192fb907fa..c358646d59 100644 --- a/src/core_landice/analysis_members/mpas_li_global_stats.F +++ b/src/core_landice/analysis_members/mpas_li_global_stats.F @@ -177,6 +177,9 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ real (kind=RKIND), pointer :: groundedIceVolume real (kind=RKIND), pointer :: floatingIceArea real (kind=RKIND), pointer :: floatingIceVolume + real (kind=RKIND), pointer :: iceThicknessMax + real (kind=RKIND), pointer :: iceThicknessMin + real (kind=RKIND), pointer :: iceThicknessMean ! scalar sums over blocks real (kind=RKIND) :: blockSumIceArea @@ -185,9 +188,13 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ real (kind=RKIND) :: blockSumGroundedIceVolume real (kind=RKIND) :: blockSumFloatingIceArea real (kind=RKIND) :: blockSumFloatingIceVolume + real (kind=RKIND) :: blockThickMin + real (kind=RKIND) :: blockThickMax err = 0 + dminfo = domain % dminfo + ! initialize sums over blocks to 0 blockSumIceArea = 0.0_RKIND blockSumIceVolume = 0.0_RKIND @@ -196,28 +203,37 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ blockSumFloatingIceArea = 0.0_RKIND blockSumFloatingIceVolume = 0.0_RKIND - dminfo = domain % dminfo + ! initialize max, min, mean values to 0 + blockThickMin = 0.0_RKIND + blockThickMax = 0.0_RKIND - ! compute sums over blocks + ! loop over blocks block => domain % blocklist do while (associated(block)) + ! get structs from pools call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'globalStatsAM', globalStatsAMPool) call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + ! get values and arrays from standard pools call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) call mpas_pool_get_array(meshPool, 'areaCell', areaCell) call mpas_pool_get_array(geometryPool, 'thickness', thickness) call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + ! get values from global stats pool call mpas_pool_get_array(globalStatsAMPool, 'totalIceArea', totalIceArea) call mpas_pool_get_array(globalStatsAMPool, 'totalIceVolume', totalIceVolume) call mpas_pool_get_array(globalStatsAMPool, 'floatingIceArea', floatingIceArea) call mpas_pool_get_array(globalStatsAMPool, 'floatingIceVolume', floatingIceVolume) call mpas_pool_get_array(globalStatsAMPool, 'groundedIceArea', groundedIceArea) call mpas_pool_get_array(globalStatsAMPool, 'groundedIceVolume', groundedIceVolume) + call mpas_pool_get_array(globalStatsAMPool, 'iceThicknessMax', iceThicknessMax) + call mpas_pool_get_array(globalStatsAMPool, 'iceThicknessMin', iceThicknessMin) + call mpas_pool_get_array(globalStatsAMPool, 'iceThicknessMean', iceThicknessMean) + ! loop over cells do iCell = 1,nCellsSolve ! sums of ice area and volume over cells @@ -236,11 +252,19 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ blockSumFloatingIceVolume = blockSumFloatingIceVolume + real(li_mask_is_floating_ice_int(cellMask(iCell)),RKIND) & * areaCell(iCell) * thickness(iCell) - end do ! end sum over cells + ! max, min thickness values + if( thickness(iCell) > blockThickMax)then + blockThickMax = thickness(iCell) + endif + if( thickness(iCell) < blockThickMin .and. thickness(iCell) > 0.0_RKIND)then + blockThickMin = thickness(iCell) + endif + + end do ! end loop over cells block => block % next - end do ! end sum over blocks + end do ! end loop over blocks ! compute sums over all procs call mpas_dmpar_sum_real(dminfo, blockSumIceArea, totalIceArea) @@ -250,13 +274,10 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ call mpas_dmpar_sum_real(dminfo, blockSumFloatingIceArea, floatingIceArea) call mpas_dmpar_sum_real(dminfo, blockSumFloatingIceVolume, floatingIceVolume) - ! debugging -! print *, 'totalIceArea=', totalIceArea -! print *, 'totalIceVolume=', totalIceVolume -! print *, 'groundedIceArea=', groundedIceArea -! print *, 'groundedIceVolume=', groundedIceVolume -! print *, 'floatingIceArea=', floatingIceArea -! print *, 'floatingIceVolume=', floatingIceVolume + ! find min, max, mean thickness over all procs + call mpas_dmpar_min_real(dminfo, blockThickMin, iceThicknessMin) + call mpas_dmpar_max_real(dminfo, blockThickMax, iceThicknessMax) + iceThicknessMean = totalIceVolume / totalIceArea ! Even though some variables do not include an index that is decomposed amongst ! domain partitions, we assign them within a block loop so that all blocks have the From 36eadfe182f19a2268d52f13483c9a7e1cd0abda Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 17 Sep 2015 13:16:54 -0600 Subject: [PATCH 0261/1724] Protect procsSharingVertex call to Albany with ifdef The recent commit 7d730126 adds support for a new function called procsSharingVertex which is used by Albany. However, the call to Albany was not protected by an ifdef, which breaks the build for standalone MPAS. This fixes that. --- src/core_landice/mode_forward/mpas_li_velocity_external.F | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/core_landice/mode_forward/mpas_li_velocity_external.F b/src/core_landice/mode_forward/mpas_li_velocity_external.F index 3ce7f07360..a1a8194add 100644 --- a/src/core_landice/mode_forward/mpas_li_velocity_external.F +++ b/src/core_landice/mode_forward/mpas_li_velocity_external.F @@ -322,7 +322,9 @@ subroutine li_velocity_external_block_init(block, err) ! Set physical parameters needed on the other side call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) +#if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) call velocity_solver_set_parameters(config_ice_density, li_mask_ValueDynamicIce, li_mask_ValueIce) +#endif ! === error check if (err > 0) then From 3a80747363f7eeff14a4de04bbf2d9316cce2df3 Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Thu, 17 Sep 2015 14:27:11 -0600 Subject: [PATCH 0262/1724] add calculation and output of global sfc and basal mass balance sums --- .../Registry_global_stats.xml | 20 ++++--- .../analysis_members/mpas_li_global_stats.F | 53 ++++++++++++------- 2 files changed, 47 insertions(+), 26 deletions(-) diff --git a/src/core_landice/analysis_members/Registry_global_stats.xml b/src/core_landice/analysis_members/Registry_global_stats.xml index 98abfab027..69d5ede68b 100644 --- a/src/core_landice/analysis_members/Registry_global_stats.xml +++ b/src/core_landice/analysis_members/Registry_global_stats.xml @@ -24,22 +24,22 @@ - - - - - - + + + + diff --git a/src/core_landice/analysis_members/mpas_li_global_stats.F b/src/core_landice/analysis_members/mpas_li_global_stats.F index c358646d59..9925988c65 100644 --- a/src/core_landice/analysis_members/mpas_li_global_stats.F +++ b/src/core_landice/analysis_members/mpas_li_global_stats.F @@ -24,7 +24,6 @@ module li_global_stats use mpas_timekeeping use mpas_stream_manager - use li_constants use li_mask implicit none @@ -163,33 +162,32 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ type (mpas_pool_type), pointer :: globalStatsAM type (mpas_pool_type), pointer :: geometryPool + ! arrays, vars needed from other pools for calculations here real (kind=RKIND), dimension(:), pointer :: areaCell real (kind=RKIND), dimension(:), pointer :: thickness + real (kind=RKIND), dimension(:), pointer :: sfcMassBal + real (kind=RKIND), dimension(:), pointer :: basalMassBal integer, dimension(:), pointer :: cellMask integer, pointer :: nCellsSolve integer :: k, iCell ! scalars to be calculated here from global sums - real (kind=RKIND), pointer :: totalIceArea - real (kind=RKIND), pointer :: totalIceVolume - real (kind=RKIND), pointer :: groundedIceArea - real (kind=RKIND), pointer :: groundedIceVolume - real (kind=RKIND), pointer :: floatingIceArea - real (kind=RKIND), pointer :: floatingIceVolume - real (kind=RKIND), pointer :: iceThicknessMax - real (kind=RKIND), pointer :: iceThicknessMin - real (kind=RKIND), pointer :: iceThicknessMean + real (kind=RKIND), pointer :: totalIceArea, totalIceVolume + real (kind=RKIND), pointer :: groundedIceArea, groundedIceVolume + real (kind=RKIND), pointer :: floatingIceArea, floatingIceVolume + real (kind=RKIND), pointer :: iceThicknessMax, iceThicknessMin, iceThicknessMean + real (kind=RKIND), pointer :: totalSfcMassBal, totalBasalMassBal ! scalar sums over blocks - real (kind=RKIND) :: blockSumIceArea - real (kind=RKIND) :: blockSumIceVolume - real (kind=RKIND) :: blockSumGroundedIceArea - real (kind=RKIND) :: blockSumGroundedIceVolume - real (kind=RKIND) :: blockSumFloatingIceArea - real (kind=RKIND) :: blockSumFloatingIceVolume - real (kind=RKIND) :: blockThickMin - real (kind=RKIND) :: blockThickMax + real (kind=RKIND) :: blockSumIceArea, blockSumIceVolume + real (kind=RKIND) :: blockSumGroundedIceArea, blockSumGroundedIceVolume + real (kind=RKIND) :: blockSumFloatingIceArea, blockSumFloatingIceVolume + real (kind=RKIND) :: blockThickMin, blockThickMax + real (kind=RKIND) :: blockSumSfcMassBal, blockSumBasalMassBal + + ! local parameters + real (kind=RKIND), parameter :: scyr = 31536000.0_RKIND ! seconds per 365-day year err = 0 @@ -202,6 +200,8 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ blockSumGroundedIceVolume = 0.0_RKIND blockSumFloatingIceArea = 0.0_RKIND blockSumFloatingIceVolume = 0.0_RKIND + blockSumSfcMassBal = 0.0_RKIND + blockSumBasalMassBal = 0.0_RKIND ! initialize max, min, mean values to 0 blockThickMin = 0.0_RKIND @@ -221,6 +221,8 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ call mpas_pool_get_array(meshPool, 'areaCell', areaCell) call mpas_pool_get_array(geometryPool, 'thickness', thickness) call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(geometryPool, 'sfcMassBal', sfcMassBal) + call mpas_pool_get_array(geometryPool, 'basalMassBal', basalMassBal) ! get values from global stats pool call mpas_pool_get_array(globalStatsAMPool, 'totalIceArea', totalIceArea) @@ -232,11 +234,13 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ call mpas_pool_get_array(globalStatsAMPool, 'iceThicknessMax', iceThicknessMax) call mpas_pool_get_array(globalStatsAMPool, 'iceThicknessMin', iceThicknessMin) call mpas_pool_get_array(globalStatsAMPool, 'iceThicknessMean', iceThicknessMean) + call mpas_pool_get_array(globalStatsAMPool, 'totalSfcMassBal', totalSfcMassBal) + call mpas_pool_get_array(globalStatsAMPool, 'totalBasalMassBal', totalBasalMassBal) ! loop over cells do iCell = 1,nCellsSolve - ! sums of ice area and volume over cells + ! sums of ice area and volume over cells (m^2 and m^3) blockSumIceArea = blockSumIceArea + real(li_mask_is_ice_int(cellMask(iCell)),RKIND) & * areaCell(iCell) blockSumIceVolume = blockSumIceVolume + real(li_mask_is_ice_int(cellMask(iCell)),RKIND) & @@ -252,7 +256,7 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ blockSumFloatingIceVolume = blockSumFloatingIceVolume + real(li_mask_is_floating_ice_int(cellMask(iCell)),RKIND) & * areaCell(iCell) * thickness(iCell) - ! max, min thickness values + ! max, min thickness values (m) if( thickness(iCell) > blockThickMax)then blockThickMax = thickness(iCell) endif @@ -260,6 +264,13 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ blockThickMin = thickness(iCell) endif + ! sfc and basal mass balance (kg yr^{-1}) + !SFP: These calculations need to be tested still + blockSumSfcMassBal = blockSumSfcMassBal + real(li_mask_is_ice_int(cellMask(iCell)),RKIND) & + * areaCell(iCell) * sfcMassBal(iCell) * scyr + blockSumBasalMassBal = blockSumBasalMassBal + real(li_mask_is_ice_int(cellMask(iCell)),RKIND) & + * areaCell(iCell) * basalMassBal(iCell) * scyr + end do ! end loop over cells block => block % next @@ -273,6 +284,8 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ call mpas_dmpar_sum_real(dminfo, blockSumGroundedIceVolume, groundedIceVolume) call mpas_dmpar_sum_real(dminfo, blockSumFloatingIceArea, floatingIceArea) call mpas_dmpar_sum_real(dminfo, blockSumFloatingIceVolume, floatingIceVolume) + call mpas_dmpar_sum_real(dminfo, blockSumSfcMassBal, totalSfcMassBal) + call mpas_dmpar_sum_real(dminfo, blockSumBasalMassBal, totalBasalMassBal) ! find min, max, mean thickness over all procs call mpas_dmpar_min_real(dminfo, blockThickMin, iceThicknessMin) From ae300130e42caafde49d2e5de810b1927fbef9f7 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Fri, 18 Sep 2015 10:52:09 -0700 Subject: [PATCH 0263/1724] Removing smoothing of boundary-layer T and S if not needed Previously, horizontal smoothing was performed even when config_land_ice_flux_boundaryLayerNeighborWeight = 0.0. Also, set the default to be config_land_ice_flux_boundaryLayerNeighborWeight = 0.0, since horizontal smoothing doesn't seem to be necessary. --- src/core_ocean/Registry.xml | 2 +- src/core_ocean/shared/mpas_ocn_diagnostics.F | 30 +++++++++++--------- 2 files changed, 17 insertions(+), 15 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index d1403c40fd..9d564f4d49 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -643,7 +643,7 @@ description="The thickness of the sub-ice-shelf boundary layer, over which T and S will be averaged." possible_values="Any non-negative real number. A value of 0 means that T and S are taken top level." /> - diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index ea7826ecb9..865325253d 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -1486,22 +1486,24 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & end if end do do iCell = 1, nCells - blWeightSum = 1.0_RKIND landIceBoundaryLayerTemperature(iCell) = blTempScratch(iCell) landIceBoundaryLayerSalinity(iCell) = blSaltScratch(iCell) - do i = 1, nEdgesOnCell(iCell) - cell2 = cellsOnCell(i,iCell) - if(cell2 <= 0 .or. cell2 > nCells) cycle - - landIceBoundaryLayerTemperature(iCell) = landIceBoundaryLayerTemperature(iCell) & - + config_land_ice_flux_boundaryLayerNeighborWeight*blTempScratch(cell2) - landIceBoundaryLayerSalinity(iCell) = landIceBoundaryLayerSalinity(iCell) & - + config_land_ice_flux_boundaryLayerNeighborWeight*blSaltScratch(cell2) - blWeightSum = blWeightSum + config_land_ice_flux_boundaryLayerNeighborWeight - end do - if(blWeightSum > 0.0_RKIND) then - landIceBoundaryLayerTemperature(iCell) = landIceBoundaryLayerTemperature(iCell)/blWeightSum - landIceBoundaryLayerSalinity(iCell) = landIceBoundaryLayerSalinity(iCell)/blWeightSum + if(config_land_ice_flux_boundaryLayerNeighborWeight > 0.0_RKIND) then + blWeightSum = 1.0_RKIND + do i = 1, nEdgesOnCell(iCell) + cell2 = cellsOnCell(i,iCell) + if(cell2 <= 0 .or. cell2 > nCells) cycle + + landIceBoundaryLayerTemperature(iCell) = landIceBoundaryLayerTemperature(iCell) & + + config_land_ice_flux_boundaryLayerNeighborWeight*blTempScratch(cell2) + landIceBoundaryLayerSalinity(iCell) = landIceBoundaryLayerSalinity(iCell) & + + config_land_ice_flux_boundaryLayerNeighborWeight*blSaltScratch(cell2) + blWeightSum = blWeightSum + config_land_ice_flux_boundaryLayerNeighborWeight + end do + if(blWeightSum > 0.0_RKIND) then + landIceBoundaryLayerTemperature(iCell) = landIceBoundaryLayerTemperature(iCell)/blWeightSum + landIceBoundaryLayerSalinity(iCell) = landIceBoundaryLayerSalinity(iCell)/blWeightSum + end if end if end do From cf72a636d8f4975d698a68639593f6886c1d84ae Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Mon, 21 Sep 2015 03:22:35 -0700 Subject: [PATCH 0264/1724] Add missing landIceFluxesOn check in 3 places --- src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F index 30786d33dc..f42da5ce8b 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F +++ b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F @@ -110,6 +110,8 @@ subroutine ocn_surface_land_ice_fluxes_tracers(meshPool, groupName, forcingPool, err = 0 + if ( .not. landIceFluxesOn ) return + if ( trim(groupName) == 'activeTracers' ) then call ocn_surface_land_ice_fluxes_active_tracers(meshPool, forcingPool, tracersSurfaceFlux, err) end if @@ -303,6 +305,8 @@ subroutine ocn_surface_land_ice_fluxes_active_tracers(meshPool, forcingPool, tra err = 0 + if ( .not. landIceFluxesOn ) return + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_array(forcingPool, 'landIceHeatFlux', landIceHeatFlux) @@ -398,6 +402,8 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & err = 0 + if ( .not. landIceFluxesOn ) return + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_ISOMIP_gammaT', config_land_ice_flux_ISOMIP_gammaT) call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_useHollandJenkinsAdvDiff', config_land_ice_flux_useHollandJenkinsAdvDiff) From b1a87d2cb0b39b51bf2a8526413750f4350c1245 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Mon, 21 Sep 2015 08:37:18 -0600 Subject: [PATCH 0265/1724] Add associated tests to the RK4 time integrator for tracer groups This commit fixes an issue with the RK4 time integrator where tracer groups that were not active were used without checking if they were active first, causing a segfault. --- .../mpas_ocn_time_integration_rk4.F | 52 +++++++++++-------- 1 file changed, 31 insertions(+), 21 deletions(-) diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F index 82b08a4612..e3898e7eba 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F @@ -235,11 +235,13 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_array(tracersPool, trim(groupItr % memberName), tracersCur, 1) call mpas_pool_get_array(tracersPool, trim(groupItr % memberName), tracersNew, 2) - do iCell = 1, nCells ! couple tracers to thickness - do k = 1, maxLevelCell(iCell) - tracersNew(:,k,iCell) = tracersCur(:,k,iCell) * layerThicknessCur(k,iCell) + if ( associated(tracersCur) .and. associated(tracersNew) ) then + do iCell = 1, nCells ! couple tracers to thickness + do k = 1, maxLevelCell(iCell) + tracersNew(:,k,iCell) = tracersCur(:,k,iCell) * layerThicknessCur(k,iCell) + end do end do - end do + end if end if end do @@ -538,14 +540,16 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ modifiedGroupName = trim(groupItr % memberName) // 'Tend' call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) - do iCell = 1, nCells - do k = 1, maxLevelCell(iCell) - tracersGroupProvis(:,k,iCell) = ( layerThicknessCur(k,iCell) * tracersCur(:,k,iCell) & - + rk_substep_weights(rk_step) * tracersGroupTend(:,k,iCell) & - ) / layerThicknessProvis(k,iCell) - end do + if ( associated(tracersGroupProvis) .and. associated(tracersCur) .and. associated(tracersGroupTend) ) then + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersGroupProvis(:,k,iCell) = ( layerThicknessCur(k,iCell) * tracersCur(:,k,iCell) & + + rk_substep_weights(rk_step) * tracersGroupTend(:,k,iCell) & + ) / layerThicknessProvis(k,iCell) + end do - end do + end do + end if end if end if end do @@ -635,11 +639,13 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ modifiedGroupName = trim(groupItr % memberName) // 'Tend' call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) - do iCell = 1, nCells - do k = 1, maxLevelCell(iCell) - tracersNew(:,k,iCell) = tracersNew(:,k,iCell) + rk_weights(rk_step) * tracersGroupTend(:,k,iCell) + if ( associated(tracersNew) .and. associated(tracersGroupTend) ) then + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersNew(:,k,iCell) = tracersNew(:,k,iCell) + rk_weights(rk_step) * tracersGroupTend(:,k,iCell) + end do end do - end do + end if end if end if end do @@ -692,11 +698,13 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) if ( groupItr % memberType == MPAS_POOL_FIELD ) then call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersNew, 2) - do iCell = 1, nCells - do k = 1, maxLevelCell(iCell) - tracersNew(:, k, iCell) = tracersNew(:, k, iCell) / layerThicknessNew(k, iCell) - end do - end do + if ( associated(tracersNew) ) then + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + tracersNew(:, k, iCell) = tracersNew(:, k, iCell) / layerThicknessNew(k, iCell) + end do + end do + end if end if end do @@ -765,7 +773,9 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) if ( groupItr % memberType == MPAS_POOL_FIELD ) then call mpas_pool_get_field(tracersPool, groupItr % memberName, tracersGroupField, 2) - call mpas_dmpar_exch_halo_field(tracersGroupField) + if ( tracersGroupField % isActive ) then + call mpas_dmpar_exch_halo_field(tracersGroupField) + end if end if end do From d480fccd54d73aa9e9650ba6444c40b0629b1190 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Mon, 21 Sep 2015 11:13:36 -0600 Subject: [PATCH 0266/1724] Change references to config_density0 to rho_sw This commit updates all references to config_density0 to use rho_sw instead. rho_sw is a constant that the coupler defines when run in a coupled model, and this allows all use of a reference density to use consistent values of the reference density. Additionally, this commit moves config_density0 from the pressure_gradient namelist record to a new record named ocean_constants. Finally, this commit performs some whitespace clean up and adds _RKIND to some constants. --- src/core_ocean/Registry.xml | 10 +++--- .../analysis_members/mpas_ocn_eliassen_palm.F | 20 +++--------- src/core_ocean/shared/mpas_ocn_constants.F | 6 +++- src/core_ocean/shared/mpas_ocn_diagnostics.F | 11 +++---- src/core_ocean/shared/mpas_ocn_gm.F | 9 +++--- src/core_ocean/shared/mpas_ocn_sea_ice.F | 22 ++++++------- .../shared/mpas_ocn_surface_bulk_forcing.F | 8 ++--- src/core_ocean/shared/mpas_ocn_test.F | 23 +++++++------ .../shared/mpas_ocn_vel_forcing_windstress.F | 8 ++--- .../shared/mpas_ocn_vel_pressure_grad.F | 8 ++--- .../shared/mpas_ocn_vmix_coefs_rich.F | 32 ++++++++----------- 11 files changed, 66 insertions(+), 91 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index d2204fac47..eb334d451e 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -646,15 +646,17 @@ possible_values="any positive real, typically 1.0e-3" /> + + + - domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'eliassenPalmAM', amEPFTPool) @@ -178,7 +175,7 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ nBuoyancyLayers = config_AM_eliassenPalm_nBuoyancyLayers deltaDensity = (config_AM_eliassenPalm_rhomax_buoycoor & - config_AM_eliassenPalm_rhomin_buoycoor) / config_AM_eliassenPalm_nBuoyancyLayers - deltaBuoyancy = -gravity * deltaDensity / config_density0 + deltaBuoyancy = -gravity * deltaDensity / rho_sw !----------------------------------------------------------------- ! compute density/bouyancy at top of each layer @@ -186,7 +183,7 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ do k = 1, nBuoyancyLayers potentialDensityTopRef(k) = config_AM_eliassenPalm_rhomin_buoycoor + deltaDensity * (k-1) buoyancyInterfaceRef(k) = -gravity & - * (config_AM_eliassenPalm_rhomin_buoycoor - config_density0) / config_density0 & + * (config_AM_eliassenPalm_rhomin_buoycoor - rho_sw) / rho_sw & + deltaBuoyancy * (k-1) end do k=nBuoyancyLayers @@ -320,8 +317,6 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ type (mpas_pool_type), pointer :: forcingPool type (mpas_pool_type), pointer :: diagnosticsPool - real (kind=RKIND), pointer :: config_density0 - !----------------------------------------------------------------- ! define pointers to namelist config variables local to the EPFT module !----------------------------------------------------------------- @@ -527,8 +522,6 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ ! define local work variables !----------------------------------------------------------------- integer :: nCellsGlobal, k, i - real(KIND=RKIND) :: rho0 - err = 0 @@ -553,9 +546,6 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ config_AM_eliassenPalm_rhomin_buoycoor) call mpas_pool_get_config(domain % configs, 'config_AM_eliassenPalm_rhomax_buoycoor', & config_AM_eliassenPalm_rhomax_buoycoor) - - call mpas_pool_get_config(domain % configs, 'config_density0', config_density0) - rho0 = config_density0 if(config_AM_eliassenPalm_debug) then write(stderrUnit, *) ' ' @@ -1146,7 +1136,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ ! compute the total force from the EPFT: div(EPFT) !------------------------------------------------------------- call calculateDivEPFT(config_AM_eliassenPalm_debug, & - domain % on_a_sphere, rho0, nBuoyancyLayers, nCells, nEdges, & + domain % on_a_sphere, rho_sw, nBuoyancyLayers, nCells, nEdges, & meshPool, buoyancyMidRef, sigmaEA, buoyancyMaskEA, EPFT, divEPFT) ! decompose the vector into its components for output divEPFT1 = divEPFT(1,:,:) @@ -1158,7 +1148,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ wrkTensor = 0.0 wrkTensor(1:2,1:2,:,:) = EPFT(1:2,1:2,:,:) call calculateDivEPFT(config_AM_eliassenPalm_debug, & - domain % on_a_sphere, rho0, nBuoyancyLayers, nCells, nEdges, & + domain % on_a_sphere, rho_sw, nBuoyancyLayers, nCells, nEdges, & meshPool, buoyancyMidRef, sigmaEA, buoyancyMaskEA, wrkTensor, wrkVector) divEPFTshear1 = wrkVector(1,:,:) divEPFTshear2 = wrkVector(2,:,:) @@ -1169,7 +1159,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ wrkTensor = 0.0 wrkTensor(3,1:2,:,:) = EPFT(3,1:2,:,:) call calculateDivEPFT(config_AM_eliassenPalm_debug, & - domain % on_a_sphere, rho0, nBuoyancyLayers, nCells, nEdges, & + domain % on_a_sphere, rho_sw, nBuoyancyLayers, nCells, nEdges, & meshPool, buoyancyMidRef, sigmaEA, buoyancyMaskEA, wrkTensor, wrkVector) divEPFTdrag1 = wrkVector(1,:,:) divEPFTdrag2 = wrkVector(2,:,:) diff --git a/src/core_ocean/shared/mpas_ocn_constants.F b/src/core_ocean/shared/mpas_ocn_constants.F index ad5d1f4501..bc4da36962 100644 --- a/src/core_ocean/shared/mpas_ocn_constants.F +++ b/src/core_ocean/shared/mpas_ocn_constants.F @@ -96,9 +96,13 @@ subroutine ocn_constants_init(configPool, packagePool)!{{{ type (mpas_pool_type), pointer :: packagePool integer :: n + real (kind=RKIND), pointer :: config_density0 + ocnConfigs => configPool ocnPackages => packagePool + call mpas_pool_get_config(configPool, 'config_density0', config_density0) + !----------------------------------------------------------------------- ! ! physical constants @@ -109,7 +113,7 @@ subroutine ocn_constants_init(configPool, packagePool)!{{{ T0_Kelvin = 273.16_RKIND ! zero point for Celsius rho_air = 1.2_RKIND ! ambient air density (kg/m^3) - rho_sw = 1.026e3_RKIND ! density of salt water (kg/m^3) + rho_sw = config_density0 ! density of salt water (kg/m^3) rho_fw = 1.0e3_RKIND ! avg. water density (kg/m^3) rho_ice = 0.917e3_RKIND ! density of ice (kg/m^3) cp_sw = 3.996e3_RKIND ! specific heat salt water diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index 9a4ef96498..f7faa1a1e7 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -140,7 +140,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic integer :: timeLevel integer, pointer :: indexTemperature, indexSalinity logical, pointer :: config_use_cvmix_kpp - real (kind=RKIND), pointer :: config_density0, config_apvm_scale_factor, config_coef_3rd_order, config_cvmix_kpp_surface_layer_averaging + real (kind=RKIND), pointer :: config_apvm_scale_factor, config_coef_3rd_order, config_cvmix_kpp_surface_layer_averaging character (len=StrKIND), pointer :: config_pressure_gradient_type if (present(timeLevelIn)) then @@ -149,7 +149,6 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic timeLevel = 1 end if - call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) call mpas_pool_get_config(ocnConfigs, 'config_apvm_scale_factor', config_apvm_scale_factor) call mpas_pool_get_config(ocnConfigs, 'config_pressure_gradient_type', config_pressure_gradient_type) call mpas_pool_get_config(ocnConfigs, 'config_coef_3rd_order', config_coef_3rd_order) @@ -561,7 +560,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ! ! Brunt-Vaisala frequency (this has units of s^{-2}) ! - coef = -gravity / config_density0 + coef = -gravity / rho_sw do iCell = 1, nCells BruntVaisalaFreqTop(1,iCell) = 0.0 do k = 2, maxLevelCell(iCell) @@ -1129,7 +1128,6 @@ subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPo real (kind=RKIND), dimension(:), allocatable :: buoySmoothed, shearSmoothed type (field2DReal), pointer :: densitySurfaceDisplacedField, thermalExpansionCoeffField, salineContractionCoeffField - real (kind=RKIND), pointer :: config_density0 if (present(timeLevelIn)) then timeLevel = timeLevelIn @@ -1138,7 +1136,6 @@ subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPo end if call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceFlux', tracersSurfaceFluxPool) - call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) ! set the parameter turbulentVelocitySquared turbulentVelocitySquared = 0.001_RKIND @@ -1234,7 +1231,7 @@ subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPo surfacewindStressMagnitude(iCell) = sqrt(deltaVelocitySquared) ! compute surface friction velocity - surfaceFrictionVelocity(iCell) = sqrt(surfacewindStressMagnitude(iCell) / config_density0) + surfaceFrictionVelocity(iCell) = sqrt(surfacewindStressMagnitude(iCell) / rho_sw) ! zero the bulk Richardson number within the ocean surface layer ! this prevent CVMix/KPP from mis-diagnosing the OBL to be within the surface layer @@ -1253,7 +1250,7 @@ subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPo deltaVelocitySquared = deltaVelocitySquared + factor * delU2 enddo - buoyContribution = gravity * (density(k,iCell) - densitySurfaceDisplaced(k,iCell)) / config_density0 + buoyContribution = gravity * (density(k,iCell) - densitySurfaceDisplaced(k,iCell)) / rho_sw shearContribution = max(deltaVelocitySquared,1.0e-15_RKIND) ! store the buoyancy and resolved shear contributions to bulk Richardson number diff --git a/src/core_ocean/shared/mpas_ocn_gm.F b/src/core_ocean/shared/mpas_ocn_gm.F index 8fa1c0b275..d6fb0fd50a 100644 --- a/src/core_ocean/shared/mpas_ocn_gm.F +++ b/src/core_ocean/shared/mpas_ocn_gm.F @@ -41,7 +41,7 @@ module ocn_gm private :: tridiagonal_solve ! Config options - real (kind=RKIND), pointer :: config_gravWaveSpeed_trunc, config_standardGM_tracer_kappa, config_density0, & + real (kind=RKIND), pointer :: config_gravWaveSpeed_trunc, config_standardGM_tracer_kappa, & config_max_relative_slope, config_Redi_kappa logical, pointer :: config_use_standardGM logical, pointer :: config_disable_redi_k33 @@ -385,7 +385,7 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) BruntVaisalaFreqTopEdge = max(BruntVaisalaFreqTopEdge, 0.0_RKIND) tridiagB(k-1) = - 2.0_RKIND * config_gravWaveSpeed_trunc**2/(layerThicknessEdge(k-1,iEdge)*layerThicknessEdge(k,iEdge)) - BruntVaisalaFreqTopEdge tridiagC(k-1) = 2.0_RKIND * config_gravWaveSpeed_trunc**2/layerThicknessEdge(k,iEdge)/(layerThicknessEdge(k-1,iEdge)+layerThicknessEdge(k,iEdge)) - rightHandSide(k-1) = config_standardGM_tracer_kappa * gravity / config_density0 * gradDensityConstZTopOfEdge(k,iEdge) + rightHandSide(k-1) = config_standardGM_tracer_kappa * gravity / rho_sw * gradDensityConstZTopOfEdge(k,iEdge) ! Second to next to the last rows do k = 3, maxLevelEdgeTop(iEdge)-1 @@ -394,7 +394,7 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) tridiagA(k-2) = 2.0_RKIND * config_gravWaveSpeed_trunc**2/layerThicknessEdge(k-1,iEdge)/(layerThicknessEdge(k-1,iEdge)+layerThicknessEdge(k,iEdge)) tridiagB(k-1) = - 2.0_RKIND * config_gravWaveSpeed_trunc**2/(layerThicknessEdge(k-1,iEdge)*layerThicknessEdge(k,iEdge)) - BruntVaisalaFreqTopEdge tridiagC(k-1) = 2.0_RKIND * config_gravWaveSpeed_trunc**2/layerThicknessEdge(k,iEdge)/(layerThicknessEdge(k-1,iEdge)+layerThicknessEdge(k,iEdge)) - rightHandSide(k-1) = config_standardGM_tracer_kappa * gravity / config_density0 * gradDensityConstZTopOfEdge(k,iEdge) + rightHandSide(k-1) = config_standardGM_tracer_kappa * gravity / rho_sw * gradDensityConstZTopOfEdge(k,iEdge) end do ! Last row @@ -403,7 +403,7 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) BruntVaisalaFreqTopEdge = max(BruntVaisalaFreqTopEdge, 0.0_RKIND) tridiagA(k-2) = 2.0_RKIND * config_gravWaveSpeed_trunc**2/layerThicknessEdge(k-1,iEdge)/(layerThicknessEdge(k-1,iEdge)+layerThicknessEdge(k,iEdge)) tridiagB(k-1) = - 2.0_RKIND * config_gravWaveSpeed_trunc**2/(layerThicknessEdge(k-1,iEdge)*layerThicknessEdge(k,iEdge)) - BruntVaisalaFreqTopEdge - rightHandSide(k-1) = config_standardGM_tracer_kappa * gravity / config_density0 * gradDensityConstZTopOfEdge(k,iEdge) + rightHandSide(k-1) = config_standardGM_tracer_kappa * gravity / rho_sw * gradDensityConstZTopOfEdge(k,iEdge) ! Total number of rows N = maxLevelEdgeTop(iEdge) - 1 @@ -546,7 +546,6 @@ subroutine ocn_gm_init(err)!{{{ call mpas_pool_get_config(ocnConfigs, 'config_gravWaveSpeed_trunc',config_gravWaveSpeed_trunc) call mpas_pool_get_config(ocnConfigs, 'config_standardGM_tracer_kappa',config_standardGM_tracer_kappa) call mpas_pool_get_config(ocnConfigs, 'config_max_relative_slope',config_max_relative_slope) - call mpas_pool_get_config(ocnConfigs, 'config_density0',config_density0) call mpas_pool_get_config(ocnConfigs, 'config_Redi_kappa', config_Redi_kappa) call mpas_pool_get_config(ocnConfigs, 'config_use_standardGM',config_use_standardGM) call mpas_pool_get_config(ocnConfigs, 'config_disable_redi_k33',config_disable_redi_k33) diff --git a/src/core_ocean/shared/mpas_ocn_sea_ice.F b/src/core_ocean/shared/mpas_ocn_sea_ice.F index 2b8b077c28..55809b8c58 100644 --- a/src/core_ocean/shared/mpas_ocn_sea_ice.F +++ b/src/core_ocean/shared/mpas_ocn_sea_ice.F @@ -117,7 +117,6 @@ subroutine ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, laye real (kind=RKIND) :: referenceSalinity, iceSalinity real (kind=RKIND) :: freezingTemp, density_ice real (kind=RKIND), dimension(:), allocatable :: iceTracer - real (kind=RKIND), pointer :: config_density0 if(.not. frazilFormationOn) return @@ -126,7 +125,6 @@ subroutine ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, laye call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) nTracers = size(tracers, dim=1) - call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) @@ -146,7 +144,7 @@ subroutine ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, laye ! availableEnergyChange is: ! positive when frazil ice is formed ! negative when frazil ice can be melted - availableEnergyChange = config_density0 * cp_sw * layerThickness(k, iCell) & + availableEnergyChange = rho_sw * cp_sw * layerThickness(k, iCell) & * (freezingTemp - tracers(indexTemperature, k, iCell)) ! energyChange is capped when negative. @@ -155,9 +153,9 @@ subroutine ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, laye energyChange = max(availableEnergyChange, -netEnergyChange) ! Compute temperature change in ocean cell due to energy change - temperatureChange = energyChange / ( config_density0 * cp_sw * layerThickness(k, iCell) ) + temperatureChange = energyChange / ( rho_sw * cp_sw * layerThickness(k, iCell) ) ! Compute thickness change in ocean cell due to energy change - thicknessChange = energyChange / ( config_density0 * latent_heat_fusion_mks ) + thicknessChange = energyChange / ( rho_sw * latent_heat_fusion_mks ) ! Compute thickness change in sea ice due to energy change iceThicknessChange = energyChange / ( density_ice * latent_heat_fusion_mks ) @@ -167,9 +165,9 @@ subroutine ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, laye ! computed as: ! \rho_{ocn} h_{ocn}^{pre} \theta_{ocn}^{pre} = ! \rho_{ocn}^{new} h_{ocn}^{new} \theta_{ocn}^{new} = \rho_{si} h_{si} \theta_{si} - tracers(iTracer, k, iCell) = ( config_density0 * layerThickness(k,iCell) * tracers(iTracer, k, iCell) & + tracers(iTracer, k, iCell) = ( rho_sw * layerThickness(k,iCell) * tracers(iTracer, k, iCell) & - density_ice * iceThicknessChange * iceTracer(iTracer)) / & - (config_density0 * (layerThickness(k,iCell) + thicknessChange)) + (rho_sw * (layerThickness(k,iCell) + thicknessChange)) end if end do @@ -197,7 +195,7 @@ subroutine ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, laye ! availableEnergyChange is: ! positive when frazil ice is formed ! negative when frazil ice can be melted - availableEnergyChange = config_density0 * cp_sw * layerThickness(k, iCell) & + availableEnergyChange = rho_sw * cp_sw * layerThickness(k, iCell) & * (freezingTemp - tracers(indexTemperature, k, iCell)) ! energyChange is capped when negative. @@ -207,9 +205,9 @@ subroutine ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, laye energyChange = max(availableEnergyChange, -seaIceEnergy(iCell)) ! Compute temperature change in ocean cell due to energy change - temperatureChange = energyChange / ( config_density0 * cp_sw * layerThickness(k, iCell) ) + temperatureChange = energyChange / ( rho_sw * cp_sw * layerThickness(k, iCell) ) ! Compute thickness change in ocean cell due to energy change - thicknessChange = energyChange / ( config_density0 * latent_heat_fusion_mks ) + thicknessChange = energyChange / ( rho_sw * latent_heat_fusion_mks ) ! Compute thickness change in sea ice due to energy change iceThicknessChange = energyChange / ( density_ice * latent_heat_fusion_mks ) @@ -219,9 +217,9 @@ subroutine ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, laye ! computed as: ! \rho_{ocn} h_{ocn}^{pre} \theta_{ocn}^{pre} = ! \rho_{ocn}^{new} h_{ocn}^{new} \theta_{ocn}^{new} = \rho_{si} h_{si} \theta_{si} - tracers(iTracer, k, iCell) = ( config_density0 * layerThickness(k,iCell) * tracers(iTracer, k, iCell) & + tracers(iTracer, k, iCell) = ( rho_sw * layerThickness(k,iCell) * tracers(iTracer, k, iCell) & - density_ice * iceThicknessChange * iceTracer(iTracer)) / & - (config_density0 * (layerThickness(k,iCell) + thicknessChange)) + (rho_sw * (layerThickness(k,iCell) + thicknessChange)) end if end do diff --git a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F index 49bad1d47c..f8a29b6fb2 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F @@ -53,7 +53,6 @@ module ocn_surface_bulk_forcing ! !-------------------------------------------------------------------- - real (kind=RKIND) :: refDensity logical :: bulkWindStressOn, bulkThicknessFluxOn !*********************************************************************** @@ -267,7 +266,9 @@ subroutine ocn_surface_bulk_forcing_thick(meshPool, forcingPool, surfaceThicknes ! Build surface fluxes at cell centers do iCell = 1, nCells - surfaceThicknessFlux(iCell) = ( snowFlux(iCell) + rainFlux(iCell) + evaporationFlux(iCell) + seaIceFreshWaterFlux(iCell) + iceRunoffFlux(iCell) + riverRunoffFlux(iCell) ) / refDensity + surfaceThicknessFlux(iCell) = ( snowFlux(iCell) + rainFlux(iCell) + evaporationFlux(iCell) & + + seaIceFreshWaterFlux(iCell) + iceRunoffFlux(iCell) & + + riverRunoffFlux(iCell) ) / rho_sw end do end subroutine ocn_surface_bulk_forcing_thick!}}} @@ -288,16 +289,13 @@ subroutine ocn_surface_bulk_forcing_init(err)!{{{ integer, intent(out) :: err !< Output: error flag - real (kind=RKIND), pointer :: config_density0 logical, pointer :: config_use_bulk_wind_stress, config_use_bulk_thickness_flux err = 0 - call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) call mpas_pool_get_config(ocnConfigs, 'config_use_bulk_wind_stress', config_use_bulk_wind_stress) call mpas_pool_get_config(ocnConfigs, 'config_use_bulk_thickness_flux', config_use_bulk_thickness_flux) - refDensity = config_density0 bulkWindStressOn = config_use_bulk_wind_stress bulkThicknessFluxOn = config_use_bulk_thickness_flux diff --git a/src/core_ocean/shared/mpas_ocn_test.F b/src/core_ocean/shared/mpas_ocn_test.F index dcf4e71712..4d771e3d45 100644 --- a/src/core_ocean/shared/mpas_ocn_test.F +++ b/src/core_ocean/shared/mpas_ocn_test.F @@ -283,14 +283,13 @@ subroutine ocn_init_gm_test_functions(diagnosticsPool, meshPool, scratchPool)!{{ real(kind=RKIND) :: zTop, config_gm_analytic_temperature2, config_gm_analytic_temperature3, config_gm_analytic_ymax, & config_gm_analytic_bottom_depth, L, R, c1, c2, zMax, zBot - real (kind=RKIND), pointer :: config_gravWaveSpeed_trunc, config_density0, config_standardGM_tracer_kappa, config_eos_linear_alpha + real (kind=RKIND), pointer :: config_gravWaveSpeed_trunc, config_standardGM_tracer_kappa, config_eos_linear_alpha real(kind=RKIND), dimension(:), pointer :: bottomDepth, refBottomDepthTopOfCell, yCell, yEdge real(kind=RKIND), dimension(:,:), pointer :: yRelativeSlopeSolution, yGMStreamFuncSolution, yGMBolusVelocitySolution, zMid type (field2DReal), pointer :: yRelativeSlopeSolutionField, yGMStreamFuncSolutionField, yGMBolusVelocitySolutionField - call mpas_pool_get_config(ocnConfigs, 'config_density0',config_density0) call mpas_pool_get_config(ocnConfigs, 'config_eos_linear_alpha', config_eos_linear_alpha) call mpas_pool_get_config(ocnConfigs, 'config_gravWaveSpeed_trunc',config_gravWaveSpeed_trunc) call mpas_pool_get_config(ocnConfigs, 'config_standardGM_tracer_kappa',config_standardGM_tracer_kappa) @@ -314,20 +313,20 @@ subroutine ocn_init_gm_test_functions(diagnosticsPool, meshPool, scratchPool)!{{ yGMBolusVelocitySolution => yGMBolusVelocitySolutionField % array ! These are flags that must match your initial conditions settings. See gm_analytic initial condition in mode_init. - config_gm_analytic_temperature2 = 10; - config_gm_analytic_temperature3 = -10; - config_gm_analytic_ymax = 500000; - config_gm_analytic_bottom_depth = 1000; + config_gm_analytic_temperature2 = 10 + config_gm_analytic_temperature3 = -10 + config_gm_analytic_ymax = 500000 + config_gm_analytic_bottom_depth = 1000 ! zMax is associated with linear temperature profile in z - zMax = -config_gm_analytic_bottom_depth; + zMax = -config_gm_analytic_bottom_depth ! zBot is location we apply boundary conditions on the ODE for stream function. - zBot = zMax; + zBot = zMax - L = config_gravWaveSpeed_trunc * sqrt(config_density0*zMax/gravity/config_eos_linear_alpha/config_gm_analytic_temperature3); - R = - config_standardGM_tracer_kappa * config_gm_analytic_temperature2 * zMax / config_gm_analytic_temperature3 / config_gm_analytic_ymax; - c1 = R*(1-exp(-zBot/L))/(exp(zBot/L) - exp(-zBot/L)); - c2 = R-c1; + L = config_gravWaveSpeed_trunc * sqrt(rho_sw * zMax / gravity / config_eos_linear_alpha / config_gm_analytic_temperature3) + R = - config_standardGM_tracer_kappa * config_gm_analytic_temperature2 * zMax / config_gm_analytic_temperature3 / config_gm_analytic_ymax + c1 = R*(1-exp(-zBot/L))/(exp(zBot/L) - exp(-zBot/L)) + c2 = R-c1 do iCell = 1, nCells diff --git a/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F b/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F index 033bacdc69..2b8d8b49d4 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing_windstress.F @@ -117,8 +117,6 @@ subroutine ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThi real (kind=RKIND) :: transmissionCoeffTop, transmissionCoeffBot, zTop, zBot, remainingStress - real (kind=RKIND), pointer :: config_density0 - !----------------------------------------------------------------- ! ! call relevant routines for computing tendencies @@ -131,8 +129,6 @@ subroutine ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThi if ( .not. windStressOn ) return - call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) - call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) @@ -150,7 +146,7 @@ subroutine ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThi remainingStress = remainingStress - (transmissionCoeffTop - transmissionCoeffBot) tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * surfaceWindStress(iEdge) & - * (transmissionCoeffTop - transmissionCoeffBot) / config_density0 / layerThicknessEdge(k,iEdge) + * (transmissionCoeffTop - transmissionCoeffBot) / rho_sw / layerThicknessEdge(k,iEdge) zTop = zBot transmissionCoeffTop = transmissionCoeffBot @@ -159,7 +155,7 @@ subroutine ocn_vel_forcing_windstress_tend(meshPool, surfaceWindStress, layerThi if ( maxLevelEdgeTop(iEdge) > 0 .and. remainingStress > 0.0_RKIND) then tend(maxLevelEdgeTop(iEdge), iEdge) = tend(maxLevelEdgeTop(iEdge), iEdge) & + edgeMask(maxLevelEdgeTop(iEdge), iEdge) * surfaceWindStress(iEdge) * remainingStress & - / config_density0 / layerThicknessEdge(maxLevelEdgeTop(iEdge), iEdge) + / rho_sw / layerThicknessEdge(maxLevelEdgeTop(iEdge), iEdge) end if enddo diff --git a/src/core_ocean/shared/mpas_ocn_vel_pressure_grad.F b/src/core_ocean/shared/mpas_ocn_vel_pressure_grad.F index bf3fa1c19d..b4303b29b5 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_pressure_grad.F +++ b/src/core_ocean/shared/mpas_ocn_vel_pressure_grad.F @@ -618,21 +618,19 @@ subroutine ocn_vel_pressure_grad_init(err)!{{{ ! call individual init routines for each parameterization ! !----------------------------------------------------------------- - real (kind=RKIND), pointer :: config_density0 logical, pointer :: config_disable_vel_pgrad err = 0 call mpas_pool_get_config(ocnConfigs, 'config_pressure_gradient_type', config_pressure_gradient_type) call mpas_pool_get_config(ocnConfigs, 'config_common_level_weight', config_common_level_weight) - call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) call mpas_pool_get_config(ocnConfigs, 'config_disable_vel_pgrad', config_disable_vel_pgrad) pgradOn = .true. - density0Inv = 1.0/config_density0 - gdensity0Inv = gravity/config_density0 - inv12 = 1.0/12.0 + density0Inv = 1.0_RKIND / rho_sw + gdensity0Inv = gravity / rho_sw + inv12 = 1.0_RKIND / 12.0_RKIND if (config_disable_vel_pgrad) pgradOn = .false. diff --git a/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F b/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F index f62d3d222d..31fed48b4a 100644 --- a/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F +++ b/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F @@ -330,13 +330,12 @@ subroutine ocn_tracer_vmix_coefs_rich(meshPool, RiTopOfCell, layerThickness, ver integer, dimension(:), pointer :: maxLevelCell real (kind=RKIND) :: coef - real (kind=RKIND), pointer :: config_density0, config_bkrd_vert_diff, config_bkrd_vert_visc, config_rich_mix, config_convective_diff + real (kind=RKIND), pointer :: config_bkrd_vert_diff, config_bkrd_vert_visc, config_rich_mix, config_convective_diff err = 0 if(.not.richDiffOn) return - call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) call mpas_pool_get_config(ocnConfigs, 'config_bkrd_vert_diff', config_bkrd_vert_diff) call mpas_pool_get_config(ocnConfigs, 'config_bkrd_vert_visc', config_bkrd_vert_visc) call mpas_pool_get_config(ocnConfigs, 'config_rich_mix', config_rich_mix) @@ -346,7 +345,7 @@ subroutine ocn_tracer_vmix_coefs_rich(meshPool, RiTopOfCell, layerThickness, ver call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - coef = -gravity / config_density0 / 2.0 + coef = -gravity / rho_sw / 2.0_RKIND do iCell = 1, nCells do k = 2, maxLevelCell(iCell) ! efficiency note: these if statements are inside iEdge and k loops. @@ -441,15 +440,10 @@ subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell real (kind=RKIND), dimension(:,:), allocatable :: ddensityTopOfCell, du2TopOfCell, & ddensityTopOfEdge, du2TopOfEdge - - real (kind=RKIND), pointer :: config_density0 - err = 0 if ( ( .not. richViscOn ) .and. ( .not. richDiffOn ) ) return - call mpas_pool_get_config(ocnConfigs, 'config_density0', config_density0) - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) @@ -470,7 +464,7 @@ subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, du2TopOfCell(nVertLevels+1,nCells+1), du2TopOfEdge(nVertLevels+1,nEdges)) ! ddensityTopOfCell(k) = $\rho^*_{k-1}-\rho_k$, where $\rho^*$ has been adiabatically displaced to level k. - ddensityTopOfCell = 0.0 + ddensityTopOfCell = 0.0_RKIND do iCell = 1, nCells do k = 2, maxLevelCell(iCell) ddensityTopOfCell(k,iCell) = displacedDensity(k-1,iCell) - density(k,iCell) @@ -478,7 +472,7 @@ subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, end do ! interpolate ddensityTopOfCell to ddensityTopOfEdge - ddensityTopOfEdge = 0.0 + ddensityTopOfEdge = 0.0_RKIND do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -490,7 +484,7 @@ subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, end do ! du2TopOfEdge(k) = $u_{k-1}-u_k$ - du2TopOfEdge=0.0 + du2TopOfEdge=0.0_RKIND do iEdge = 1, nEdges do k = 2, maxLevelEdgeTop(iEdge) du2TopOfEdge(k,iEdge) = (normalVelocity(k-1,iEdge) - normalVelocity(k,iEdge))**2 @@ -498,38 +492,38 @@ subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, end do ! interpolate du2TopOfEdge to du2TopOfCell - du2TopOfCell = 0.0 + du2TopOfCell = 0.0_RKIND do iCell = 1, nCells - invAreaCell = 1.0 / areaCell(iCell) + invAreaCell = 1.0_RKIND / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) iEdge = edgesOnCell(i, iCell) do k = 2, maxLevelEdgeBot(iEdge) - du2TopOfCell(k, iCell) = du2TopOfCell(k, iCell) + 0.5 * dcEdge(iEdge) * dvEdge(iEdge) * du2TopOfEdge(k, iEdge) * invAreaCell + du2TopOfCell(k, iCell) = du2TopOfCell(k, iCell) + 0.5_RKIND * dcEdge(iEdge) * dvEdge(iEdge) * du2TopOfEdge(k, iEdge) * invAreaCell end do end do end do ! compute RiTopOfEdge using ddensityTopOfEdge and du2TopOfEdge ! coef = -g/density_0/2 - RiTopOfEdge = 0.0 - coef = -gravity / config_density0 / 2.0 + RiTopOfEdge = 0.0_RKIND + coef = -gravity / rho_sw / 2.0_RKIND do iEdge = 1, nEdges do k = 2, maxLevelEdgeTop(iEdge) RiTopOfEdge(k,iEdge) = coef * ddensityTopOfEdge(k,iEdge) & * ( layerThicknessEdge(k-1,iEdge) + layerThicknessEdge(k,iEdge) ) & - / ( du2TopOfEdge(k,iEdge) + 1e-20 ) + / ( du2TopOfEdge(k,iEdge) + 1e-20_RKIND ) end do end do ! compute RiTopOfCell using ddensityTopOfCell and du2TopOfCell ! coef = -g/density_0/2 - RiTopOfCell = 0.0 + RiTopOfCell = 0.0_RKIND do iCell = 1,nCells do k = 2,maxLevelCell(iCell) RiTopOfCell(k,iCell) = coef * ddensityTopOfCell(k,iCell) & * (layerThickness(k-1,iCell) + layerThickness(k,iCell)) & - / (du2TopOfCell(k,iCell) + 1e-20) + / (du2TopOfCell(k,iCell) + 1e-20_RKIND) end do end do From 9e3719c3b76579d0109a2084d31de58edd7ef1f2 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Mon, 21 Sep 2015 13:59:44 -0600 Subject: [PATCH 0267/1724] Remove in_defaults from registry entries in_defaults is no longer used (we use mode="..." in the ocean instead), and so this commit removes the in_defaults attribute from all namelist records / options. --- src/core_ocean/mode_init/Registry_soma.xml | 2 +- src/core_ocean/tracer_groups/Registry_activeTracers.xml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/mode_init/Registry_soma.xml b/src/core_ocean/mode_init/Registry_soma.xml index 851713cdfc..b123e03953 100644 --- a/src/core_ocean/mode_init/Registry_soma.xml +++ b/src/core_ocean/mode_init/Registry_soma.xml @@ -1,4 +1,4 @@ - + + Date: Mon, 21 Sep 2015 21:52:55 -0700 Subject: [PATCH 0268/1724] Adding two timers for building land-ice flux fields One is in diagnostics, the other in ocn_forward_mode. The latter covers building the flux arrays once per time step, which are later added to the thickness, velocity and tracer surface fluxes in separate calls. --- src/core_ocean/mode_forward/mpas_ocn_forward_mode.F | 2 ++ src/core_ocean/shared/mpas_ocn_diagnostics.F | 2 ++ 2 files changed, 4 insertions(+) diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index c1e671eede..f029fb0725 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -453,8 +453,10 @@ function ocn_forward_mode_run(domain) result(ierr)!{{{ call mpas_pool_get_subpool(block_ptr % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) call ocn_forcing_build_fraction_absorbed_array(meshPool, statePool, diagnosticsPool, forcingPool, ierr, 1) + call mpas_timer_start("land_ice_build_arrays", .false.) call ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & forcingPool, scratchPool, err) + call mpas_timer_stop("land_ice_build_arrays") block_ptr => block_ptr % next end do diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index 865325253d..642a0c59f1 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -673,8 +673,10 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ! ! compute fields needed to compute land-ice fluxes, either in the ocean model or in the coupler + call mpas_timer_start("land_ice_diagnostic_fields", .false.) call computeLandIceFluxInputFields(meshPool, statePool, forcingPool, scratchPool, & diagnosticsPool, timeLevel) + call mpas_timer_stop("land_ice_diagnostic_fields") do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1, iEdge) From 8758ab57eedfbf56cfd2d2c69804f39c3b6e5b28 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 22 Sep 2015 10:08:30 -0600 Subject: [PATCH 0269/1724] Add err argument to landice_init_block Previously, if an error occurred in landice_init_block, it was not handed up to the calling routine, so the code would not abort. This returns an 'err' argument so that the calling routine can abort if needed. --- src/core_landice/mode_forward/mpas_li_core.F | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/core_landice/mode_forward/mpas_li_core.F b/src/core_landice/mode_forward/mpas_li_core.F index 2d68a39004..1cfa1bf7d2 100644 --- a/src/core_landice/mode_forward/mpas_li_core.F +++ b/src/core_landice/mode_forward/mpas_li_core.F @@ -148,7 +148,8 @@ function li_core_init(domain, startTimeStamp) result(err) ! === block => domain % blocklist do while (associated(block)) - call landice_init_block(block, startTimeStamp, domain % dminfo) + call landice_init_block(block, startTimeStamp, domain % dminfo, err_tmp) + err = ior(err, err_tmp) block => block % next end do @@ -539,7 +540,7 @@ end function li_core_finalize !> This routine initializes blocks for the land ice core. ! !----------------------------------------------------------------------- - subroutine landice_init_block(block, startTimeStamp, dminfo) + subroutine landice_init_block(block, startTimeStamp, dminfo, err) use mpas_derived_types use mpas_pool_routines @@ -571,6 +572,7 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) ! output variables ! !----------------------------------------------------------------- + integer, intent(out) :: err !< error flag !----------------------------------------------------------------- ! @@ -584,7 +586,7 @@ subroutine landice_init_block(block, startTimeStamp, dminfo) character (len=StrKIND), pointer :: config_velocity_solver logical, pointer :: config_do_velocity_reconstruction_for_external_dycore logical, pointer :: config_adaptive_timestep_include_DCFL - integer :: err, err_tmp + integer :: err_tmp err = 0 err_tmp = 0 From fb49501d12bb964a23c430146fe1d3a49164a73c Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 22 Sep 2015 10:30:57 -0600 Subject: [PATCH 0270/1724] Handle mpas_calculate_barycentric_weights_for_points error Until framework can handle periodic meshs gracefully, mpas_calculate_barycentric_weights_for_points will return an error for periodic meshes. This error means that the velocity solver will be very wrong across the periodicity, but it will be correct everywhere else. For now, just print a warning in li_sia_block_init but don't make this a fatal error. --- src/core_landice/mode_forward/mpas_li_sia.F | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/core_landice/mode_forward/mpas_li_sia.F b/src/core_landice/mode_forward/mpas_li_sia.F index 62d9565b60..19167a3985 100644 --- a/src/core_landice/mode_forward/mpas_li_sia.F +++ b/src/core_landice/mode_forward/mpas_li_sia.F @@ -188,7 +188,16 @@ subroutine li_sia_block_init(block, err) xVertex(1:nVertices), yVertex(1:nVertices), zVertex(1:nVertices), & vertexIndicesField % array(1:nVertices), & baryCellsOnVertex(:, 1:nVertices), baryWeightsOnVertex(:, 1:nVertices), err_tmp) - err = ior(err, err_tmp) + ! TODO: Until framework can handle periodic meshs gracefully, this will return an error + ! for periodic meshes. This error means that the velocity solver will be very wrong across + ! the periodicity, but it will be fine everywhere else. For now, just print a warning but + ! don't make this a fatal error. + !err = ior(err, err_tmp) + if (err_tmp > 0) then + write (stderrUnit,*) "Warning: The 'from_vertex_barycentric' option for 'config_sia_tangent_slope_calculation' " & + // "does NOT work across the periodicity in periodic meshes. However, it does work within the interior " & + // "of the mesh." + endif call mpas_deallocate_scratch_field(vertexIndicesField, .true.) endif From d2c1d05a10985cbdfdefc11f311d68c86417e524 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Tue, 22 Sep 2015 11:45:07 -0600 Subject: [PATCH 0271/1724] Add vim folds. --- src/core_ocean/shared/mpas_ocn_diagnostics.F | 2 +- .../shared/mpas_ocn_surface_land_ice_fluxes.F | 16 +++++++++------- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index 642a0c59f1..7d7218a5b3 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -1558,7 +1558,7 @@ end subroutine computeLandIceFluxInputFields!}}} ! !----------------------------------------------------------------------- - subroutine ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) + subroutine ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) !{{{ type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostic information diff --git a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F index f42da5ce8b..2260bf66e1 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F +++ b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F @@ -333,7 +333,7 @@ end subroutine ocn_surface_land_ice_fluxes_active_tracers!}}} !----------------------------------------------------------------------- subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & - forcingPool, scratchPool, err)!{{{ + forcingPool, scratchPool, err) !{{{ !----------------------------------------------------------------- ! @@ -662,7 +662,7 @@ subroutine compute_melt_fluxes( & err, & iceTemperature, & iceTemperatureDistance, & - kappa_land_ice) + kappa_land_ice) !{{{ !----------------------------------------------------------------- ! @@ -766,8 +766,7 @@ subroutine compute_melt_fluxes( & !-------------------------------------------------------------------- - end subroutine compute_melt_fluxes - + end subroutine compute_melt_fluxes !}}} !*********************************************************************** @@ -797,7 +796,7 @@ end subroutine compute_melt_fluxes ! !----------------------------------------------------------------------- - subroutine compute_HJ99_melt_fluxes( & + subroutine compute_HJ99_melt_fluxes( & oceanTemperature, & oceanSalinity, & oceanHeatTransferVelocity, & @@ -810,7 +809,7 @@ subroutine compute_HJ99_melt_fluxes( & outOceanHeatFlux, & outIceHeatFlux, & nCells, & - err) + err) !{{{ !----------------------------------------------------------------- ! @@ -899,9 +898,12 @@ subroutine compute_HJ99_melt_fluxes( & !-------------------------------------------------------------------- - end subroutine compute_HJ99_melt_fluxes + end subroutine compute_HJ99_melt_fluxes !}}} !*********************************************************************** end module ocn_surface_land_ice_fluxes + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker From 4450021c9c528e46ffac71012063f434b213480a Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Tue, 22 Sep 2015 14:08:13 -0600 Subject: [PATCH 0272/1724] Change subroutines from camelCase to underscore_case --- src/core_ocean/shared/mpas_ocn_diagnostics.F | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index 7d7218a5b3..874f6b4dc7 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -664,7 +664,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ! ! compute fields used as intent(in) to CVMix/KPP - call computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, timeLevel) + call ocn_compute_KPP_input_fields(statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, timeLevel) endif @@ -674,7 +674,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ! ! compute fields needed to compute land-ice fluxes, either in the ocean model or in the coupler call mpas_timer_start("land_ice_diagnostic_fields", .false.) - call computeLandIceFluxInputFields(meshPool, statePool, forcingPool, scratchPool, & + call ocn_compute_land_ice_flux_input_fields(meshPool, statePool, forcingPool, scratchPool, & diagnosticsPool, timeLevel) call mpas_timer_stop("land_ice_diagnostic_fields") @@ -1088,7 +1088,7 @@ end subroutine ocn_diagnostics_init!}}} !*********************************************************************** ! -! routine computeKPPInputFields +! routine ocn_compute_KPP_input_fields ! !> \brief !> Compute fields necessary to drive the CVMix KPP module @@ -1104,7 +1104,7 @@ end subroutine ocn_diagnostics_init!}}} ! !----------------------------------------------------------------------- - subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, timeLevelIn)!{{{ + subroutine ocn_compute_KPP_input_fields(statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, timeLevelIn)!{{{ type (mpas_pool_type), intent(in) :: statePool !< Input/Output: State information type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information @@ -1297,12 +1297,12 @@ subroutine computeKPPInputFields(statePool, forcingPool, meshPool, diagnosticsPo deallocate(buoySmoothed) deallocate(shearSmoothed) - end subroutine computeKPPInputFields!}}} + end subroutine ocn_compute_KPP_input_fields!}}} !*********************************************************************** ! -! routine computeLandIceFluxInputFields +! routine ocn_compute_land_ice_flux_input_fields ! !> \brief Builds the forcing array for land-ice forcing !> \author Xylar Asay-Davis @@ -1312,7 +1312,7 @@ end subroutine computeKPPInputFields!}}} ! !----------------------------------------------------------------------- - subroutine computeLandIceFluxInputFields(meshPool, statePool, & + subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & forcingPool, scratchPool, diagnosticsPool, timeLevel)!{{{ type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information @@ -1543,7 +1543,7 @@ subroutine computeLandIceFluxInputFields(meshPool, statePool, & !-------------------------------------------------------------------- - end subroutine computeLandIceFluxInputFields!}}} + end subroutine ocn_compute_land_ice_flux_input_fields!}}} !*********************************************************************** From 694fdec8d8be419e70e863a441b7384a131885bd Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Wed, 23 Sep 2015 08:42:19 -0600 Subject: [PATCH 0273/1724] update / add some comments; alter standard output format for global stats data --- src/core_landice/analysis_members/Registry_global_stats.xml | 2 +- src/core_landice/analysis_members/mpas_li_analysis_driver.F | 2 -- src/core_landice/mode_forward/mpas_li_core.F | 2 +- 3 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/core_landice/analysis_members/Registry_global_stats.xml b/src/core_landice/analysis_members/Registry_global_stats.xml index 69d5ede68b..ef7b811003 100644 --- a/src/core_landice/analysis_members/Registry_global_stats.xml +++ b/src/core_landice/analysis_members/Registry_global_stats.xml @@ -61,7 +61,7 @@ \details !> This routine calls all output writing subroutines required for the !> MPAS-Land Ice analysis driver. -!> At this time this is just a stub, and all analysis output is written -!> to the output file specified by config_output_name. ! !----------------------------------------------------------------------- diff --git a/src/core_landice/mode_forward/mpas_li_core.F b/src/core_landice/mode_forward/mpas_li_core.F index 1cfa1bf7d2..df59cfbccf 100644 --- a/src/core_landice/mode_forward/mpas_li_core.F +++ b/src/core_landice/mode_forward/mpas_li_core.F @@ -382,7 +382,7 @@ function li_core_run(domain) result(err) call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_INPUT, ierr=err_tmp) err = ior(err, err_tmp) - ! call analysis driver compute, etc. subroutines + ! call analysis driver compute, restart, write subroutines (note: alarms and timers are handled by the analysis member code) call li_analysis_compute(domain, err_tmp) err = ior(err, err_tmp) call li_analysis_restart(domain, err) From 0a0e7dd514d6e1ee2d2b36315f09f57869eea74a Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Wed, 23 Sep 2015 12:22:01 -0600 Subject: [PATCH 0274/1724] Update ESM ifdef in mpas_li_constants The MPAS_CESM ifdef variable was replaced by MPAS_ESM_SHR_CONST but MPASLI was never udpated accordingly. --- src/core_landice/shared/mpas_li_constants.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_landice/shared/mpas_li_constants.F b/src/core_landice/shared/mpas_li_constants.F index 88eff64c8c..d9db0e6913 100644 --- a/src/core_landice/shared/mpas_li_constants.F +++ b/src/core_landice/shared/mpas_li_constants.F @@ -22,7 +22,7 @@ module li_constants use mpas_derived_types use mpas_kind_types -#ifdef MPAS_CESM +#ifdef MPAS_ESM_SHR_CONST use shr_const_mod, only: & cp_ice => SHR_CONST_CPICE,& latent_heat_ice => SHR_CONST_LATICE,& From 3d98d9d7f7ccddb336bdc0f8ceb4044ca99d339f Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Wed, 23 Sep 2015 12:48:47 -0600 Subject: [PATCH 0275/1724] Separate initial LI solve into new routine The LI diagnostic variables (velocity, upperSurface, masks, etc.) need to be calculated at the initial time. Previously these calculations were done in core_run but this generalizes them into their own public function. This allows an ESM to call those calculations in the same way the standalone model would. --- src/core_landice/mode_forward/mpas_li_core.F | 258 ++++++++++++------- 1 file changed, 171 insertions(+), 87 deletions(-) diff --git a/src/core_landice/mode_forward/mpas_li_core.F b/src/core_landice/mode_forward/mpas_li_core.F index 9e4de6934a..f757c18de2 100644 --- a/src/core_landice/mode_forward/mpas_li_core.F +++ b/src/core_landice/mode_forward/mpas_li_core.F @@ -24,7 +24,8 @@ module li_core public :: li_core_init, & li_core_run, & li_core_finalize, & - li_simulation_clock_init + li_simulation_clock_init, & + li_core_initial_solve !-------------------------------------------------------------------- ! @@ -251,7 +252,6 @@ function li_core_run(domain) result(err) type (block_type), pointer :: block type (mpas_pool_type), pointer :: geometryPool integer, pointer :: config_stats_interval !< interval (number of timesteps) for writing stats - logical, pointer :: config_do_restart, config_write_output_on_startup, config_write_stats_on_startup character(len=StrKIND), pointer :: config_restart_timestamp_name character(len=StrKIND), pointer :: config_velocity_solver ! Variables needed for printing timestamps @@ -259,9 +259,6 @@ function li_core_run(domain) result(err) character(len=StrKIND) :: timeStamp integer :: err, err_tmp, globalErr - logical :: solveVelo - - integer, dimension(:), pointer :: vertexMask err = 0 @@ -269,96 +266,17 @@ function li_core_run(domain) result(err) globalErr = 0 ! Get Pool stuff that will be needed - call mpas_pool_get_config(liConfigs, 'config_do_restart', config_do_restart) - call mpas_pool_get_config(liConfigs, 'config_write_output_on_startup', config_write_output_on_startup) call mpas_pool_get_config(liConfigs, 'config_restart_timestamp_name', config_restart_timestamp_name) - call mpas_pool_get_config(liConfigs, 'config_write_stats_on_startup', config_write_stats_on_startup) call mpas_pool_get_config(liConfigs, 'config_stats_interval', config_stats_interval) call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) call mpas_timer_start("land ice core run") - currTime = mpas_get_clock_time(domain % clock, MPAS_NOW, err_tmp) - err = ior(err, err_tmp) - call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=err_tmp) - err = ior(err, err_tmp) - write(stderrUnit,*) 'Initial timestep ', trim(timeStamp) - write(stdoutUnit,*) 'Initial timestep ', trim(timeStamp) - - - ! === - ! === Calculate Initial state - ! === - call mpas_timer_start("initial state calculation") - - ! On a restart, we already have the exact velocity field we need, - ! so don't do the expensive calculation again. - if (config_do_restart) then - solveVelo = .false. - else - ! Otherwise, we need to calculate velocity for the initial state - ! (Note: even if the velocity is supplied, we should still calculate it - ! to ensure it is consistent with the current geometry/B.C. If the - ! velocity solver is iterative, the supplied field will be used as an - ! initial guess, so the solution should be quick. - solveVelo = .true. - endif - - call li_calculate_diagnostic_vars(domain, solveVelo=solveVelo, err=err_tmp) - err = ior(err, err_tmp) - - call mpas_timer_stop("initial state calculation") - - if (config_write_stats_on_startup) then - call mpas_timer_start("compute_statistics") - call li_compute_statistics(domain, 0) ! itimestep = 0 - ! (itimestep is initialized below) - call mpas_timer_stop("compute_statistics") - endif - - ! compute analysis members on startup if option activiated - call mpas_timer_start("analysis member startup calculations") - call li_analysis_compute_startup(domain, err_tmp) - err = ior(err, err_tmp) - call mpas_timer_stop("analysis member startup calculations") ! === - ! === Write Initial Output + ! Solve initial state before beginning time stepping ! === - call mpas_timer_start("write output") - - if (config_write_output_on_startup) then - call mpas_stream_mgr_write(domain % streamManager, 'output', forceWriteNow=.true., ierr=err_tmp) - endif - - call mpas_timer_stop("write output") - - ! Move time level 1 fields (current values) into time level 2 (old values) for next time step - ! (for those fields with multiple time levels) - block => domain % blocklist - do while(associated(block)) - call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) - call mpas_pool_shift_time_levels(geometryPool) - block => block % next - end do - - if (config_do_restart .and. (trim(config_velocity_solver) /= 'sia')) then - ! On a restart with the HO dycore, we need to make sure the FEM mesh will be rebuilt - ! on the first time step. Force this by setting the vertexMask at the end of the - ! initial time to 0. (Do this after writing output.) - block => domain % blocklist - do while(associated(block)) - call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) - call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel=2) ! Get the old vertexMask - vertexMask = 0 - block => block % next - end do - endif - - ! === error check and exit - call mpas_dmpar_max_int(domain % dminfo, err, globalErr) ! Find out if any blocks got an error - if (globalErr > 0) then - call mpas_dmpar_global_abort("An error has occurred in li_core_run before time-stepping. Aborting...") - endif + err_tmp = li_core_initial_solve(domain) + err = ior(err,err_tmp) ! li_core_finalize would abort if there was an error, but being safe. ! During integration, time level 1 stores the model state at the beginning of the @@ -547,6 +465,172 @@ end function li_core_finalize +!*********************************************************************** +! +! function li_core_initial_solve +! +!> \brief Performs the initial diagnostic solve for the LI core +!> \author Matt Hoffman +!> \date 23 September 2015 +!> \details +!> This routine performs the initial diagnostic solve for the LI core. +!> Rather than inlining these calculations, there are done in this +!> routine to keep them modular. +!> This has been made public so it can be called from an ESM. +! +!----------------------------------------------------------------------- + function li_core_initial_solve(domain) result(err) + + use mpas_derived_types + use mpas_pool_routines + use mpas_kind_types + use mpas_stream_manager + use mpas_timer + use li_diagnostic_vars + use li_setup + use li_statistics + use mpas_io_streams, only: MPAS_STREAM_LATEST_BEFORE + + implicit none + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: domain !< Input/output: Domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + integer :: itimestep + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: geometryPool + logical, pointer :: config_do_restart, config_write_output_on_startup, config_write_stats_on_startup + character(len=StrKIND), pointer :: config_velocity_solver + ! Variables needed for printing timestamps + type (MPAS_Time_Type) :: currTime + character(len=StrKIND) :: timeStamp + + integer :: err, err_tmp, globalErr + logical :: solveVelo + + integer, dimension(:), pointer :: vertexMask + + + err = 0 + err_tmp = 0 + globalErr = 0 + + ! Get Pool stuff that will be needed + call mpas_pool_get_config(liConfigs, 'config_do_restart', config_do_restart) + call mpas_pool_get_config(liConfigs, 'config_write_output_on_startup', config_write_output_on_startup) + call mpas_pool_get_config(liConfigs, 'config_write_stats_on_startup', config_write_stats_on_startup) + call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + + currTime = mpas_get_clock_time(domain % clock, MPAS_NOW, err_tmp) + err = ior(err, err_tmp) + call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=err_tmp) + err = ior(err, err_tmp) + write(stderrUnit,*) 'Initial timestep ', trim(timeStamp) + write(stdoutUnit,*) 'Initial timestep ', trim(timeStamp) + + + ! === + ! === Calculate Initial state + ! === + call mpas_timer_start("initial state calculation") + + ! On a restart, we already have the exact velocity field we need, + ! so don't do the expensive calculation again. + if (config_do_restart) then + solveVelo = .false. + else + ! Otherwise, we need to calculate velocity for the initial state + ! (Note: even if the velocity is supplied, we should still calculate it + ! to ensure it is consistent with the current geometry/B.C. If the + ! velocity solver is iterative, the supplied field will be used as an + ! initial guess, so the solution should be quick. + solveVelo = .true. + endif + + call li_calculate_diagnostic_vars(domain, solveVelo=solveVelo, err=err_tmp) + err = ior(err, err_tmp) + + call mpas_timer_stop("initial state calculation") + + if (config_write_stats_on_startup) then + call mpas_timer_start("compute_statistics") + call li_compute_statistics(domain, 0) ! itimestep = 0 + ! (itimestep is initialized below) + call mpas_timer_stop("compute_statistics") + endif + + ! compute analysis members on startup if option activated + call mpas_timer_start("analysis member startup calculations") + call li_analysis_compute_startup(domain, err_tmp) + err = ior(err, err_tmp) + call mpas_timer_stop("analysis member startup calculations") + + ! === + ! === Write Initial Output + ! === + call mpas_timer_start("write output") + + if (config_write_output_on_startup) then + call mpas_stream_mgr_write(domain % streamManager, 'output', forceWriteNow=.true., ierr=err_tmp) + endif + + call mpas_timer_stop("write output") + + ! Move time level 1 fields (current values) into time level 2 (old values) for next time step + ! (for those fields with multiple time levels) + block => domain % blocklist + do while(associated(block)) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_shift_time_levels(geometryPool) + block => block % next + end do + + if (config_do_restart .and. (trim(config_velocity_solver) /= 'sia')) then + ! On a restart with the HO dycore, we need to make sure the FEM mesh will be rebuilt + ! on the first time step. Force this by setting the vertexMask at the end of the + ! initial time to 0. (Do this after writing output.) + block => domain % blocklist + do while(associated(block)) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel=2) ! Get the old vertexMask + vertexMask = 0 + block => block % next + end do + endif + + ! === error check and exit + call mpas_dmpar_max_int(domain % dminfo, err, globalErr) ! Find out if any blocks got an error + if (globalErr > 0) then + call mpas_dmpar_global_abort("An error has occurred in li_core_initial_solve. Aborting...") + endif + + + end function li_core_initial_solve + !-------------------------------------------------------------------- + + + !*********************************************************************** !*********************************************************************** ! Private subroutines: From ee80e5afc056282347a73186301fd1c868639a43 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 24 Sep 2015 11:29:04 -0600 Subject: [PATCH 0276/1724] Fix some issues with XML formatting Specifically, this commit replaces "<=" with "less than or equal" as some XML parsers cannot parse this (even if it's in an attribute, it breaks the parser). Additionally, this commit cleans up whitespace differences to ensure the registry file is formatted the same as other registry files. --- .../Registry_mixed_layer_depths.xml | 87 +++++++++---------- 1 file changed, 42 insertions(+), 45 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml index f19448fdd7..768ae1d00f 100644 --- a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml +++ b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml @@ -1,65 +1,63 @@ + - + - - + - - @@ -67,17 +65,16 @@ - + description="mixed layer depth based on temperature threshold" + /> - From 0820694844a8312d341a88e80573341e62297e9e Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 24 Sep 2015 11:38:22 -0600 Subject: [PATCH 0277/1724] Adding a missing type specification in EPFT This commit adds a missing type specifiction to a real defined within the EPFT analysis member. Without this type definition, some compilers assume the real is an r4 rather than an r8 and fail to build as the input arguments don't match the interface. --- src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index 69cb02b0ae..0b5d83cc96 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -2899,7 +2899,7 @@ end subroutine mpas_divergence_in_r3_buoyancy!}}} subroutine mpas_vector_R3Cell_to_Edge(vectorCell, meshPool, & vectorEdge) - real, dimension(:,:,:), intent(in) :: vectorCell + real (kind=RKIND), dimension(:,:,:), intent(in) :: vectorCell type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:,:), intent(out) :: vectorEdge From 2f8071c18a2f5dcdff3cab158562c8b84b6d4aed Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 24 Sep 2015 11:42:01 -0600 Subject: [PATCH 0278/1724] Add missing kind specifications to SOMA This commit adds missing kind specifications to the SOMA init configuration. Without these type specifications, some compilers assume the reals are r4 instead of r8 and the model fails to build since the input arguments don't match the interface. --- src/core_ocean/mode_init/mpas_ocn_init_soma.F | 28 +++++++++---------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_soma.F b/src/core_ocean/mode_init/mpas_ocn_init_soma.F index 8c27e023be..6aee7f16e9 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_soma.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_soma.F @@ -97,20 +97,20 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ ! SOMA test case run-time configuration parameters integer, pointer :: config_soma_vert_levels - real, pointer :: config_eos_linear_alpha - real, pointer :: config_soma_surface_salinity - real, pointer :: config_soma_surface_temperature - real, pointer :: config_soma_density_difference_linear - real, pointer :: config_soma_thermocline_depth - real, pointer :: config_soma_center_latitude - real, pointer :: config_soma_center_longitude - real, pointer :: config_soma_domain_width - real, pointer :: config_soma_shelf_width - real, pointer :: config_soma_shelf_depth - real, pointer :: config_soma_bottom_depth - real, pointer :: config_soma_phi - real, pointer :: config_soma_ref_density - real, pointer :: config_soma_density_difference + real (kind=RKIND), pointer :: config_eos_linear_alpha + real (kind=RKIND), pointer :: config_soma_surface_salinity + real (kind=RKIND), pointer :: config_soma_surface_temperature + real (kind=RKIND), pointer :: config_soma_density_difference_linear + real (kind=RKIND), pointer :: config_soma_thermocline_depth + real (kind=RKIND), pointer :: config_soma_center_latitude + real (kind=RKIND), pointer :: config_soma_center_longitude + real (kind=RKIND), pointer :: config_soma_domain_width + real (kind=RKIND), pointer :: config_soma_shelf_width + real (kind=RKIND), pointer :: config_soma_shelf_depth + real (kind=RKIND), pointer :: config_soma_bottom_depth + real (kind=RKIND), pointer :: config_soma_phi + real (kind=RKIND), pointer :: config_soma_ref_density + real (kind=RKIND), pointer :: config_soma_density_difference ! Define dimension pointers integer, pointer :: nVertLevels, nCells, nVertLevelsP1 From 14b3cae3d1131b0978fb68cb2e239b9caf2daecc Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 24 Sep 2015 12:54:41 -0600 Subject: [PATCH 0279/1724] Sync analysis member restart streams with main restart stream This commit updates the output_interval of restart streams for analysis members to ensure they are synchronized with the output_interval of the restart stream, based on a new feature from the lastest MPAS framework. --- src/core_ocean/analysis_members/Registry_eliassen_palm.xml | 2 +- src/core_ocean/analysis_members/Registry_time_filters.xml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index b361fea60d..82106da530 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -651,7 +651,7 @@ filename_template="restarts/eliassenPalm_restart.$Y-$M-$D.nc" filename_interval="01-00-00_00:00:00" input_interval="initial_only" - output_interval="00-00-01_00:00:00" + output_interval="stream:restart:output_interval" packages="eliassenPalmAMPKG" clobber_mode="truncate" runtime_format="single_file"> diff --git a/src/core_ocean/analysis_members/Registry_time_filters.xml b/src/core_ocean/analysis_members/Registry_time_filters.xml index 6fb671b955..078f49b62d 100644 --- a/src/core_ocean/analysis_members/Registry_time_filters.xml +++ b/src/core_ocean/analysis_members/Registry_time_filters.xml @@ -66,7 +66,7 @@ filename_template="restarts/timeFiltersRestart.$Y-$M-$D_$h.nc" filename_interval="01-00-00_00:00:00" input_interval="initial_only" - output_interval="00-00-01_00:00:00" + output_interval="stream:restart:output_interval" packages="timeFiltersAMPKG" clobber_mode="truncate" runtime_format="single_file"> From eb697758eed69940c544db53ee2edcd611684cac Mon Sep 17 00:00:00 2001 From: Luke Van Roekel Date: Fri, 25 Sep 2015 11:11:50 -0600 Subject: [PATCH 0280/1724] This updates the cvmix test case to include differing stratifications in the upper ocean (mixed layer) and lower ocean. Differing mixed layer depths can be set for temperature and salinity. Users can also specify temperature and salinity jumps across the mixed layer. NOTE: for the mixed layer jumps in temperature and salinity positive values reflect an increase in temperature/salinity as you move downward This also adds a KPP_testing stream to Registry.xml and adds necessary forcing information to the forcing stream Finally, a small bug was noticed in the mixed layer depth analysis member (num_tracers was referenced without the need for it) --- src/core_ocean/Registry.xml | 63 ++++- .../mpas_ocn_mixed_layer_depths.F | 4 +- .../mode_init/Registry_cvmix_WSwSBF.xml | 26 +- .../mode_init/mpas_ocn_init_cvmix_WSwSBF.F | 258 ++++++++++++------ 4 files changed, 255 insertions(+), 96 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 761072ff35..34af0ecac6 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -135,7 +135,7 @@ baroclinic_channel_value="baroclinic_channel" cvmix_convection_unit_test_value="cvmix_convection_unit_test" cvmix_shear_unit_test_value="cvmix_shear_unit_test" - cvmx_WSwSBF_value="cvmx_WSwSBF" + cvmix_WSwSBF_value="cvmix_WSwSBF" global_ocean_value="global_ocean" internal_waves_value="internal_waves" lock_exchange_value="lock_exchange" @@ -588,7 +588,7 @@ possible_values="Any positive value" /> - + - + + + + + + + + + + + + @@ -1115,6 +1126,39 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F index 8ab224e116..8a0b3070d8 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F +++ b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F @@ -163,7 +163,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ type (mpas_pool_type), pointer :: mixedLayerDepthsAM ! Here are some example variables which may be needed for your analysis member - integer, pointer :: nVertLevels, nCellsSolve, num_tracers + integer, pointer :: nVertLevels, nCellsSolve integer :: k, iCell, i, refIndex, refLevel(1) integer, pointer :: index_temperature integer, dimension(:), pointer :: maxLevelCell @@ -195,8 +195,6 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ call mpas_pool_get_subpool(domain % blocklist % structs, 'mixedLayerDepthsAM', mixedLayerDepthsAMPool) call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) - call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) - call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_Tthreshold', tThresholdFlag) call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_Dthreshold', dThresholdFlag) call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_Tgradient', tGradientFlag) diff --git a/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml b/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml index 911371d6ab..9f3143e6fa 100644 --- a/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml +++ b/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml @@ -62,7 +62,31 @@ + /> + + + + + + domain % blocklist @@ -177,7 +197,7 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) - + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) @@ -216,6 +236,7 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_array(forcingPool, 'evaporationFlux', evaporationFlux) call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) + ! Set refBottomDepth and refBottomDepthTopOfCell do k = 1, nVertLevels refBottomDepth(k) = config_cvmix_WSwSBF_bottom_depth * interfaceLocations(k+1) @@ -224,106 +245,167 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ ! Set vertCoordMovementWeights vertCoordMovementWeights(:) = 1.0_RKIND - + do iCell = 1, nCellsSolve - ! Set temperature and salinity - do k = 1, nVertLevels - if ( associated(activeTracers) ) then - temperature = config_cvmix_WSwSBF_surface_temperature + refZMid(k) * config_cvmix_WSwSBF_temperature_gradient - activeTracers(index_temperature, k, iCell) = temperature - salinity = config_cvmix_WSwSBF_surface_salinity + refZMid(k) * config_cvmix_WSwSBF_salinity_gradient - activeTracers(index_salinity, k, iCell) = salinity - end if - - if ( associated(debugTracers) ) then - debugTracers(index_tracer1, k, iCell) = 1.0_RKIND - end if - end do - - ! Set layerThickness - do k = 1, nVertLevels - layerThickness(k, iCell) = config_cvmix_WSwSBF_bottom_depth * (interfaceLocations(k+1) - interfaceLocations(k)) - restingThickness(k, iCell) = layerThickness(k, iCell) - end do - - ! Set surface temperature restoring value and rate - ! Value in units of C, piston velocity in units of m/s - if ( associated(activeTracersSurfaceRestoringValue) ) then - activeTracersSurfaceRestoringValue(index_temperature, iCell) = config_cvmix_WSwSBF_surface_restoring_temperature + if(associated(activeTracers) ) then + + ! Loop from surface through surface layer depth + k=1 + + do while (k .le. nVertLevels .and. refZMid(k) > - config_cvmix_WSwSBF_mixed_layer_depth_temperature) + temperature = config_cvmix_WSwSBF_surface_temperature + refZMid(k) * & + config_cvmix_WSwSBF_temperature_gradient_mixed_layer + activeTracers(index_temperature, k, iCell) = temperature + k = k + 1 + enddo + + ! the value of k is now the first layer below the surface layer + if ( k > 1 ) then + temperature = activeTracers(index_temperature, k-1, iCell) + config_cvmix_WSwSBF_mixed_layer_temperature_change + activeTracers(index_temperature, k, iCell) = temperature + BLdepth = refZMid(k) + else + activeTracers(index_temperature, k, iCell) = config_cvmix_WSwSBF_surface_temperature + BLdepth = 0.0 + endif + + ! find the first level below the mixed layer + kML = k + 1 + + ! now loop from the bottom of the mixed layer thru to the bottom of the domain + do k = kML, nVertLevels + temperature = activeTracers(index_temperature, kML-1, iCell) + (refZMid(k) - BLdepth) * & + config_cvmix_WSwSBF_temperature_gradient + activeTracers(index_temperature, k, iCell) = temperature + enddo + + ! + ! next compute the salinity profile + ! + + ! Loop from surface through surface layer depth + k=1 + do while (k .le. nVertLevels .and. refZMid(k) > - config_cvmix_WSwSBF_mixed_layer_depth_salinity) + salinity = config_cvmix_WSwSBF_surface_salinity + refZMid(k) * config_cvmix_WSwSBF_salinity_gradient_mixed_layer + activeTracers(index_salinity, k, iCell) = salinity + k = k + 1 + enddo + + ! the value of k is now the first layer below the surface layer + if ( k > 1 ) then + salinity = activeTracers(index_salinity, k-1, iCell) + config_cvmix_WSwSBF_mixed_layer_salinity_change + activeTracers(index_salinity, k, iCell) = salinity + BLdepth = refZMid(k) + else + activeTracers(index_salinity, k, iCell) = config_cvmix_WSwSBF_surface_salinity + BLdepth = 0.0 + endif + + ! find the first level below the mixed layer + kML = k + 1 + + ! now loop from the bottom of the mixed layer thru to the bottom of the domain + do k = kML, nVertLevels + salinity = activeTracers(index_salinity, kML-1, iCell) + (refZMid(k) - BLdepth) * & + config_cvmix_WSwSBF_salinity_gradient + activeTracers(index_salinity, k, iCell) = salinity + enddo + + endif ! if (associated(activeTracer)) + + ! as a place holder, have some debug tracer in the top few layers and zero below + if ( associated(debugTracers) ) then + debugTracers(index_tracer1, k, iCell) = 0.0_RKIND + do k=1,min(4,nVertLevels) + debugTracers(index_tracer1, k, iCell) = 1.0_RKIND + enddo + endif + + ! Set layerThickness + do k = 1, nVertLevels + layerThickness(k, iCell) = config_cvmix_WSwSBF_bottom_depth * (interfaceLocations(k+1) - interfaceLocations(k)) + restingThickness(k, iCell) = layerThickness(k, iCell) + end do + + ! Set surface temperature restoring value and rate + ! Value in units of C, piston velocity in units of m/s + if ( associated(activeTracersSurfaceRestoringValue) ) then + activeTracersSurfaceRestoringValue(index_temperature, iCell) = config_cvmix_WSwSBF_surface_restoring_temperature + end if + if ( associated(activeTracersPistonVelocity) ) then + activeTracersPistonVelocity(index_temperature, iCell) = config_cvmix_WSwSBF_temperature_piston_velocity + end if + + ! Set surface salinity restoring value and rate + ! Value in units of PSU, piston velocity in units of m/s + if ( associated(activeTracersSurfaceRestoringValue) ) then + activeTracersSurfaceRestoringValue(index_salinity, iCell) = config_cvmix_WSwSBF_surface_restoring_salinity + end if + if ( associated(activeTracersPistonVelocity) ) then + activeTracersPistonVelocity(index_salinity, iCell) = config_cvmix_WSwSBF_salinity_piston_velocity + end if + + ! Set sensible heat flux + sensibleHeatFlux(iCell) = config_cvmix_WSwSBF_sensible_heat_flux + + ! Set latent heat flux + latentHeatFlux(iCell) = config_cvmix_WSwSBF_latent_heat_flux + + ! Set shortwave heat flux + shortWaveHeatFlux(iCell) = config_cvmix_WSwSBF_shortwave_heat_flux + + ! Set precipation and evaporation + rainFlux(iCell) = config_cvmix_WSwSBF_rain_flux + evaporationFlux(iCell) = config_cvmix_WSwSBF_evaporation_flux + + ! Set interior temperature restoring value and rate + do k = 1, nVertLevels + if ( associated(activeTracersInteriorRestoringValue) ) then + activeTracersInteriorRestoringValue(index_temperature, k, iCell) = activeTracers(index_temperature, k, iCell) end if - if ( associated(activeTracersPistonVelocity) ) then - activeTracersPistonVelocity(index_temperature, iCell) = config_cvmix_WSwSBF_temperature_piston_velocity + if ( associated(activeTracersInteriorRestoringRate) ) then + activeTracersInteriorRestoringRate(index_temperature, k, iCell) = config_cvmix_WSwSBF_interior_temperature_restoring_rate end if + enddo - ! Set surface salinity restoring value and rate - ! Value in units of PSU, piston velocity in units of m/s - if ( associated(activeTracersSurfaceRestoringValue) ) then - activeTracersSurfaceRestoringValue(index_salinity, iCell) = config_cvmix_WSwSBF_surface_restoring_salinity + ! Set interior salinity restoring value and rate + do k = 1, nVertLevels + if ( associated(activeTracersInteriorRestoringValue) ) then + activeTracersInteriorRestoringValue(index_salinity, k, iCell) = activeTracers(index_salinity, k, iCell) end if - if ( associated(activeTracersPistonVelocity) ) then - activeTracersPistonVelocity(index_salinity, iCell) = config_cvmix_WSwSBF_salinity_piston_velocity + if ( associated(activeTracersInteriorRestoringRate) ) then + activeTracersInteriorRestoringRate(index_salinity, k, iCell) = config_cvmix_WSwSBF_interior_salinity_restoring_rate end if + enddo - ! Set sensible heat flux - sensibleHeatFlux(iCell) = config_cvmix_WSwSBF_sensible_heat_flux - - ! Set latent heat flux - latentHeatFlux(iCell) = config_cvmix_WSwSBF_latent_heat_flux - - ! Set shortwave heat flux - shortWaveHeatFlux(iCell) = config_cvmix_WSwSBF_shortwave_heat_flux - - ! Set precipation and evaporation - rainFlux(iCell) = config_cvmix_WSwSBF_rain_flux - evaporationFlux(iCell) = config_cvmix_WSwSBF_evaporation_flux - - ! Set interior temperature restoring value and rate - do k = 1, nVertLevels - if ( associated(activeTracersInteriorRestoringValue) ) then - activeTracersInteriorRestoringValue(index_temperature, k, iCell) = activeTracers(index_temperature, k, iCell) - end if - if ( associated(activeTracersInteriorRestoringRate) ) then - activeTracersInteriorRestoringRate(index_temperature, k, iCell) = config_cvmix_WSwSBF_interior_temperature_restoring_rate - end if - enddo + ! Set Coriolis parameter + fCell(iCell) = config_cvmix_WSwSBF_coriolis_parameter - ! Set interior salinity restoring value and rate - do k = 1, nVertLevels - if ( associated(activeTracersInteriorRestoringValue) ) then - activeTracersInteriorRestoringValue(index_salinity, k, iCell) = activeTracers(index_salinity, k, iCell) - end if - if ( associated(activeTracersInteriorRestoringRate) ) then - activeTracersInteriorRestoringRate(index_salinity, k, iCell) = config_cvmix_WSwSBF_interior_salinity_restoring_rate - end if - enddo + ! Set bottomDepth + bottomDepth(iCell) = config_cvmix_WSwSBF_bottom_depth - ! Set Coriolis parameter - fCell(iCell) = config_cvmix_WSwSBF_coriolis_parameter + ! Set maxLevelCell + maxLevelCell(iCell) = nVertLevels - ! Set bottomDepth - bottomDepth(iCell) = config_cvmix_WSwSBF_bottom_depth + end do ! do iCell - ! Set maxLevelCell - maxLevelCell(iCell) = nVertLevels - end do + do iCell = 1, nCellsSolve + windStressZonal(iCell) = config_cvmix_WSwSBF_max_windstress + windStressMeridional(iCell) = 0.0_RKIND + enddo - do iCell = 1, nCellsSolve - windStressZonal(iCell) = config_cvmix_WSwSBF_max_windstress - windStressMeridional(iCell) = 0.0_RKIND - enddo + do iEdge = 1, nEdgesSolve + fEdge(iEdge) = config_cvmix_WSwSBF_coriolis_parameter + end do - do iEdge = 1, nEdgesSolve - fEdge(iEdge) = config_cvmix_WSwSBF_coriolis_parameter - end do - - do iVertex=1, nVerticesSolve - fVertex(iVertex) = config_cvmix_WSwSBF_coriolis_parameter - end do + do iVertex=1, nVerticesSolve + fVertex(iVertex) = config_cvmix_WSwSBF_coriolis_parameter + end do - block_ptr => block_ptr % next - end do + block_ptr => block_ptr % next + end do - deallocate(interfaceLocations) + deallocate(interfaceLocations) !-------------------------------------------------------------------- From 7027ea987491382aebc4d406c157c8dbabb102bc Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Fri, 25 Sep 2015 16:12:21 -0600 Subject: [PATCH 0281/1724] Fixed restart bug on time series stats AM. --- .../mpas_ocn_time_series_stats.F | 89 +++++++++++-------- 1 file changed, 52 insertions(+), 37 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index 7e98456ef4..b02bcaa192 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -200,7 +200,7 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ ! get all of the timing and configuration call get_alarms(domain, instance, series, alarms, err) - ! set all of the alarms based on timers + ! set all of the alarms and current flag state based on timers call set_alarms(domain, instance, series, alarms, err) ! clean up the memory @@ -1063,30 +1063,31 @@ subroutine set_alarms(domain, instance, series, alarms, err) type (mpas_time_type) :: current_time, when, & duration_time, repeat_time, reset_time type (mpas_timeinterval_type) :: elapsed, zero, & - repeat_rem, duration_rem, reset_rem + repeat_rem, duration_rem, reset_rem, zero_intv ! start procedure alarm_prefix = trim(FRAMEWORK_PREFIX) // trim(instance) ! get current time current_time = mpas_get_clock_time(domain % clock, MPAS_NOW, err) + call mpas_set_timeInterval(zero_intv, S=0) ! configure alarms do b = 1, series % number_of_buffers write(buf_identifier, '(I0)') b - ! no reset on start, because it should be zero'd already + ! zero flags + series % buffers(b) % started_flag = 0 series % buffers(b) % reset_flag = 0 + series % buffers(b) % accumulate_flag = 0 - ! see if we start in the future or we have already started + ! set start time and flag if (current_time >= alarms % start_time) then series % buffers(b) % started_flag = 1 ! no start alarm series % buffers(b) % start_alarm_ID = '' else - series % buffers(b) % started_flag = 0 - ! set the start alarm series % buffers(b) % start_alarm_ID = trim(alarm_prefix) // & trim(START_ALARM_PREFIX) // trim(buf_identifier) @@ -1095,55 +1096,67 @@ subroutine set_alarms(domain, instance, series, alarms, err) alarms % start_time, ierr=err) end if - ! - ! determine next alarm times - ! + ! set next reset time and flag + when = alarms % start_time + alarms % reset_interval + if (current_time >= when) then + elapsed = current_time - when + call mpas_interval_division(when, elapsed, & + alarms % reset_interval, reset_n, reset_rem) - ! set next duration time + if (reset_rem == zero_intv) then + ! reset right now + reset_time = current_time + alarms % reset_interval + series % buffers(b) % reset_flag = 1 + else + reset_rem = alarms % reset_interval - reset_rem + reset_time = current_time + reset_rem + end if + else + reset_time = when + end if + + ! set next duration time and flag when = alarms % start_time + alarms % duration_interval ! duration is offset - if (current_time > when) then + if (current_time >= when) then elapsed = current_time - when call mpas_interval_division(when, elapsed, & alarms % repeat_interval, & ! repeat is correct duration_n, duration_rem) - duration_rem = alarms % repeat_interval - duration_rem - duration_time = current_time + duration_rem ! remainder of repeat + + if (duration_rem == zero_intv) then + ! turn off accumulation + duration_time = current_time + alarms % repeat_interval ! yes, repeat + else + duration_rem = alarms % repeat_interval - duration_rem ! yes, repeat + duration_time = current_time + duration_rem ! remainder of repeat + end if else - duration_time = alarms % start_time + alarms % duration_interval - duration_n = 0 + duration_time = when + duration_n = -1 end if - ! set next repeat time + ! set next repeat time and flag when = alarms % start_time + alarms % repeat_interval - if (current_time > when) then + if (current_time >= when) then elapsed = current_time - when call mpas_interval_division(when, elapsed, & alarms % repeat_interval, repeat_n, repeat_rem) - repeat_rem = alarms % repeat_interval - repeat_rem - repeat_time = current_time + repeat_rem - else - repeat_time = alarms % start_time + alarms % repeat_interval - repeat_n = 0 - end if - ! set next reset time - when = alarms % start_time + alarms % reset_interval - if (current_time > when) then - elapsed = current_time - when - call mpas_interval_division(when, elapsed, & - alarms % reset_interval, reset_n, reset_rem) - reset_rem = alarms % reset_interval - reset_rem - reset_time = current_time + reset_rem + if (repeat_rem == zero_intv) then + repeat_time = current_time + alarms % repeat_interval + else + repeat_rem = alarms % repeat_interval - repeat_rem + repeat_time = current_time + repeat_rem + end if else - reset_time = alarms % start_time + alarms % reset_interval - reset_n = 0 + repeat_time = when + repeat_n = -1 end if - ! we're accumulating if we are in a window between duration and repeat - if (duration_n == repeat_n) then + ! accumulate now if in a window (both duration & repeat are untriggered) + if ((duration_n == repeat_n) .and. & + (series % buffers(b) % started_flag == 1)) then series % buffers(b) % accumulate_flag = 1 - else - series % buffers(b) % accumulate_flag = 0 end if ! @@ -1399,6 +1412,8 @@ subroutine timer_checking(series, clock, err)!{{{ series % buffers(b) % started_flag = 1 series % buffers(b) % reset_flag = 1 series % buffers(b) % accumulate_flag = 1 + + series % buffers(b) % start_alarm_ID = '' end if end if From 73dc6ef9733c5834d1dd9ba59888163eb09cb7ce Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Fri, 25 Sep 2015 17:05:41 -0600 Subject: [PATCH 0282/1724] Fixed clobbering of alarms that are acquired from namelist. --- .../mpas_ocn_time_series_stats.F | 77 ++++++++++--------- 1 file changed, 40 insertions(+), 37 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index b02bcaa192..4b33e5d4ac 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -183,7 +183,7 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ integer :: v character (len=StrKIND) :: instance ! TODO intent(in) type (time_series_type) :: series - type (time_series_alarms_type) :: alarms + type (time_series_alarms_type), allocatable, dimension(:) :: alarms ! start procedure err = 0 @@ -198,10 +198,12 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ call modify_stream(domain, instance, series, err) ! get all of the timing and configuration + allocate(alarms(series % number_of_buffers)) call get_alarms(domain, instance, series, alarms, err) ! set all of the alarms and current flag state based on timers call set_alarms(domain, instance, series, alarms, err) + deallocate(alarms) ! clean up the memory do v = 1, series % number_of_variables @@ -946,7 +948,7 @@ subroutine get_alarms(domain, instance, series, alarms, err) ! output variables integer, intent(out) :: err !< Output: error flag - type (time_series_alarms_type), intent(out) :: alarms + type (time_series_alarms_type), dimension(:), intent(out) :: alarms ! local variables character (len=StrKIND), pointer :: config_results @@ -1009,26 +1011,26 @@ subroutine get_alarms(domain, instance, series, alarms, err) call mpas_set_timeInterval(zero, s=0) do b = 1, series % number_of_buffers - call mpas_interval_division(alarms % start_time, & - alarms % repeat_interval, & - alarms % reset_interval, n, rem) + call mpas_interval_division(alarms(b) % start_time, & + alarms(b) % repeat_interval, & + alarms(b) % reset_interval, n, rem) if (n > 1 .or. (n == 1 .and. rem /= zero)) then write(stderrUnit,*) 'Warning: repeat_interval > ' // & 'reset_interval in time averaging analysis member ' // & 'configuration. Truncating repeat_interval.' - alarms % repeat_interval = alarms % reset_interval + alarms(b) % repeat_interval = alarms(b) % reset_interval end if - call mpas_interval_division(alarms % start_time, & - alarms % duration_interval, & - alarms % repeat_interval, n, rem) + call mpas_interval_division(alarms(b) % start_time, & + alarms(b) % duration_interval, & + alarms(b) % repeat_interval, n, rem) if (n > 1 .or. (n == 1 .and. rem /= zero)) then write(stderrUnit,*) 'Warning: duration_interval > ' // & 'repeat_interval in time averaging analysis member ' // & 'configuration. Truncating duration_interval.' - alarms % repeat_interval = alarms % reset_interval + alarms(b) % repeat_interval = alarms(b) % reset_interval end if end do end subroutine get_alarms @@ -1052,7 +1054,7 @@ subroutine set_alarms(domain, instance, series, alarms, err) ! input/output variables type (domain_type), intent(inout) :: domain type (time_series_type), intent(inout) :: series - type (time_series_alarms_type), intent(in) :: alarms + type (time_series_alarms_type), dimension(:), intent(inout) :: alarms ! output variables integer, intent(out) :: err !< Output: error flag @@ -1082,7 +1084,7 @@ subroutine set_alarms(domain, instance, series, alarms, err) series % buffers(b) % accumulate_flag = 0 ! set start time and flag - if (current_time >= alarms % start_time) then + if (current_time >= alarms(b) % start_time) then series % buffers(b) % started_flag = 1 ! no start alarm @@ -1093,22 +1095,22 @@ subroutine set_alarms(domain, instance, series, alarms, err) trim(START_ALARM_PREFIX) // trim(buf_identifier) call mpas_add_clock_alarm(domain % clock, & series % buffers(b) % start_alarm_ID, & - alarms % start_time, ierr=err) + alarms(b) % start_time, ierr=err) end if ! set next reset time and flag - when = alarms % start_time + alarms % reset_interval + when = alarms(b) % start_time + alarms(b) % reset_interval if (current_time >= when) then elapsed = current_time - when call mpas_interval_division(when, elapsed, & - alarms % reset_interval, reset_n, reset_rem) + alarms(b) % reset_interval, reset_n, reset_rem) if (reset_rem == zero_intv) then ! reset right now - reset_time = current_time + alarms % reset_interval + reset_time = current_time + alarms(b) % reset_interval series % buffers(b) % reset_flag = 1 else - reset_rem = alarms % reset_interval - reset_rem + reset_rem = alarms(b) % reset_interval - reset_rem reset_time = current_time + reset_rem end if else @@ -1116,18 +1118,18 @@ subroutine set_alarms(domain, instance, series, alarms, err) end if ! set next duration time and flag - when = alarms % start_time + alarms % duration_interval ! duration is offset + when = alarms(b) % start_time + alarms(b) % duration_interval ! is offset if (current_time >= when) then elapsed = current_time - when call mpas_interval_division(when, elapsed, & - alarms % repeat_interval, & ! repeat is correct + alarms(b) % repeat_interval, & ! repeat is correct duration_n, duration_rem) if (duration_rem == zero_intv) then ! turn off accumulation - duration_time = current_time + alarms % repeat_interval ! yes, repeat + duration_time = current_time + alarms(b) % repeat_interval ! repeat else - duration_rem = alarms % repeat_interval - duration_rem ! yes, repeat + duration_rem = alarms(b) % repeat_interval - duration_rem ! repeat duration_time = current_time + duration_rem ! remainder of repeat end if else @@ -1136,16 +1138,16 @@ subroutine set_alarms(domain, instance, series, alarms, err) end if ! set next repeat time and flag - when = alarms % start_time + alarms % repeat_interval + when = alarms(b) % start_time + alarms(b) % repeat_interval if (current_time >= when) then elapsed = current_time - when call mpas_interval_division(when, elapsed, & - alarms % repeat_interval, repeat_n, repeat_rem) + alarms(b) % repeat_interval, repeat_n, repeat_rem) if (repeat_rem == zero_intv) then - repeat_time = current_time + alarms % repeat_interval + repeat_time = current_time + alarms(b) % repeat_interval else - repeat_rem = alarms % repeat_interval - repeat_rem + repeat_rem = alarms(b) % repeat_interval - repeat_rem repeat_time = current_time + repeat_rem end if else @@ -1167,21 +1169,21 @@ subroutine set_alarms(domain, instance, series, alarms, err) call mpas_add_clock_alarm(domain % clock, & series % buffers(b) % duration_alarm_ID, & duration_time, & ! duration sets the offset - alarms % repeat_interval, ierr=err) ! but repeat is interval + alarms(b) % repeat_interval, ierr=err) ! but repeat is interval series % buffers(b) % repeat_alarm_ID = trim(alarm_prefix) // & trim(REPEAT_ALARM_PREFIX) // trim(buf_identifier) call mpas_add_clock_alarm(domain % clock, & series % buffers(b) % repeat_alarm_ID, & repeat_time, & - alarms % repeat_interval, ierr=err) + alarms(b) % repeat_interval, ierr=err) series % buffers(b) % reset_alarm_ID = trim(alarm_prefix) // & trim(RESET_ALARM_PREFIX) // trim(buf_identifier) call mpas_add_clock_alarm(domain % clock, & series % buffers(b) % reset_alarm_ID, & reset_time, & - alarms % reset_interval, ierr=err) + alarms(b) % reset_interval, ierr=err) end do end subroutine set_alarms @@ -1256,9 +1258,9 @@ subroutine set_times(series, alarms, clock, which, config, ok, err) ! input/output variables type (time_series_type), intent(inout) :: series type (MPAS_Clock_type), intent(inout) :: clock + type (time_series_alarms_type), dimension(:), intent(inout) :: alarms ! output variables - type (time_series_alarms_type) :: alarms logical, intent(out) :: ok integer, intent(out) :: err @@ -1282,27 +1284,28 @@ subroutine set_times(series, alarms, clock, which, config, ok, err) ! set the time if (which == START_TIMES) then if (time == INITIAL_TIME_TOKEN) then - alarms % start_time = mpas_get_clock_time(clock, MPAS_START_TIME, err) + alarms(b) % start_time = & + mpas_get_clock_time(clock, MPAS_START_TIME, err) else - call mpas_set_time(alarms % start_time, dateTimeString=time, ierr=err) + call mpas_set_time(alarms(b) % start_time, & + dateTimeString=time, ierr=err) end if else if (which == DURATION_INTERVALS) then if (time == REPEAT_INTERVAL_TOKEN) then - alarms % duration_interval = alarms % repeat_interval + alarms(b) % duration_interval = alarms(b) % repeat_interval else - call mpas_set_timeInterval(alarms % duration_interval, & + call mpas_set_timeInterval(alarms(b) % duration_interval, & timeString=time, ierr=err) end if else if (which == REPEAT_INTERVALS) then if (time == RESET_INTERVAL_TOKEN) then - alarms % repeat_interval = & - alarms % reset_interval + alarms(b) % repeat_interval = alarms(b) % reset_interval else - call mpas_set_timeInterval(alarms % repeat_interval, & + call mpas_set_timeInterval(alarms(b) % repeat_interval, & timeString=time, ierr=err) end if else - call mpas_set_timeInterval(alarms % reset_interval, & + call mpas_set_timeInterval(alarms(b) % reset_interval, & timeString=time, ierr=err) end if From 7f41ad7043c78a31aca4d3f88a5f3b8d58452697 Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Fri, 25 Sep 2015 17:28:01 -0600 Subject: [PATCH 0283/1724] Improved the description of the namelist options for time series stats. --- .../Registry_time_series_stats.xml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_time_series_stats.xml b/src/core_ocean/analysis_members/Registry_time_series_stats.xml index cfdb82d121..fce5d80e31 100644 --- a/src/core_ocean/analysis_members/Registry_time_series_stats.xml +++ b/src/core_ocean/analysis_members/Registry_time_series_stats.xml @@ -53,7 +53,7 @@ type="character" default_value="avg" units="unitless" - description="An operation describing the reduction operations to apply to the time series." + description="An operation describing the statistic to apply to the time series for all variables in the output stream." possible_values="An operation, where it can be 'avg', 'min', or 'max'." /> @@ -61,29 +61,29 @@ type="character" default_value="initial_time" units="unitless" - description="A list of absolute times describing when to start accumulating." + description="A list of absolute times describing when to start accumulating statistics. Each token indicates one statistic per variable in the output stream." possible_values="A list of absolute times or 'initial_time's, separated by ;." /> From d93a6b71f8e3cd149e997c55715c6e39b6428022 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 28 Sep 2015 12:52:43 -0600 Subject: [PATCH 0284/1724] Fix intel build since analysis_members 986572f introduced analysis members into MPAS-LI. However build_options.mk was not updated to add the analysis_members directory into the FC includes list of directories. This prevented the code from compiling with Intel. (GCC worked fine.) This commit adds the new directory to the includes list so that Intel will compile. --- src/core_landice/build_options.mk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_landice/build_options.mk b/src/core_landice/build_options.mk index 707ba2cee9..fb4a7d1855 100644 --- a/src/core_landice/build_options.mk +++ b/src/core_landice/build_options.mk @@ -3,7 +3,7 @@ ifeq "$(ROOT_DIR)" "" endif EXE_NAME=landice_model NAMELIST_SUFFIX=landice -FCINCLUDES += -I$(ROOT_DIR)/core_landice/mode_forward -I$(ROOT_DIR)/core_landice/shared +FCINCLUDES += -I$(ROOT_DIR)/core_landice/mode_forward -I$(ROOT_DIR)/core_landice/shared -I$(ROOT_DIR)/core_landice/analysis_members override CPPFLAGS += -DCORE_LANDICE # =================================== From c31a3da20b9b418aab32886cf3511291f9654362 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Tue, 29 Sep 2015 15:42:36 -0600 Subject: [PATCH 0285/1724] Add isActive tests to tracers halo exchanges This commit adds tests to see if a tracers group is active prior to performing a halo exchange. Without this test, halo exchanges can cause a segfault if a tracer group is deactivated, as the halo exchange will still be executed with an unallocated array. --- .../mode_forward/mpas_ocn_time_integration_rk4.F | 4 +++- .../mode_forward/mpas_ocn_time_integration_split.F | 9 +++++++-- src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F | 4 +++- 3 files changed, 13 insertions(+), 4 deletions(-) diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F index e3898e7eba..1f361219af 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F @@ -479,7 +479,9 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ do while ( mpas_pool_get_next_member(tracersTendPool, groupItr) ) if ( groupItr % memberType == MPAS_POOL_FIELD ) then call mpas_pool_get_field(tracersTendPool, trim(groupItr % memberName), tracersGroupField) - call mpas_dmpar_exch_halo_field(tracersGroupField) + if ( tracersGroupField % isActive ) then + call mpas_dmpar_exch_halo_field(tracersGroupField) + end if end if end do diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F index a959876c26..58230e7392 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F @@ -1278,7 +1278,9 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ if ( groupItr % memberType == MPAS_POOL_FIELD ) then call mpas_pool_get_field(tracersTendPool, groupItr % memberName, tracersGroupField) - call mpas_dmpar_exch_halo_field(tracersGroupField) + if ( tracersGroupField % isActive ) then + call mpas_dmpar_exch_halo_field(tracersGroupField) + end if end if end do call mpas_timer_stop("se halo tracers", timer_halo_tracers) @@ -1536,7 +1538,10 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) if ( groupItr % memberType == MPAS_POOL_FIELD ) then call mpas_pool_get_field(tracersPool, groupItr % memberName, tracersGroupField, 2) - call mpas_dmpar_exch_halo_field(tracersGroupField) + + if ( tracersGroupField % isActive ) then + call mpas_dmpar_exch_halo_field(tracersGroupField) + end if end if end do call mpas_timer_stop("se implicit vert mix halos") diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F index 7d441b0aa4..7cb6e3c5e5 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F @@ -1229,7 +1229,9 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_field(tracersPool, 'activeTracers', activeTracersField,1) - call mpas_dmpar_exch_halo_field(activeTracersField) + if ( activeTracersField % isActive ) then + call mpas_dmpar_exch_halo_field(activeTracersField) + end if end do ! iSmooth From 70ed392231f04b37c6b8541cc740682f2a62a912 Mon Sep 17 00:00:00 2001 From: Phillip Wolfram Date: Tue, 29 Sep 2015 19:50:37 -0600 Subject: [PATCH 0286/1724] bug fix: analysis members initialized after core Fixes an issue where core routines were initilized after analysis member initialization. Analysis members, LIGHT in particular, may rely upon routines for RBF interpolation, for example. Ensuring that core initialization occurs prior to initialization of the analysis member ensures that the model state is ready to be used by the analysis member, e.g., there should be no need to call RBF initialization routines within an analysis member requiring interpolation. --- src/core_ocean/mode_forward/mpas_ocn_forward_mode.F | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index 878369e01d..df1eadd36e 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -234,9 +234,6 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ call ocn_sea_ice_init(nVertLevels, err_tmp) ierr = ior(ierr, err_tmp) - call ocn_analysis_init(domain, err_tmp) - ierr = ior(ierr, err_tmp) - call mpas_timer_init(domain) if(ierr.eq.1) then @@ -310,6 +307,13 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ call mpas_timer_stop("test suite", testSuiteTimer) endif + call ocn_analysis_init(domain, err_tmp) + ierr = ior(ierr, err_tmp) + + if(ierr.eq.1) then + call mpas_dmpar_global_abort('ERROR: An error was encountered while initializing the analysis members in the MPAS-Ocean forward mode') + endif + end function ocn_forward_mode_init!}}} !*********************************************************************** From b277e2e8dfcfcb37588d7ba31525f039a3ba87d8 Mon Sep 17 00:00:00 2001 From: Phillip Wolfram Date: Tue, 29 Sep 2015 22:43:43 -0600 Subject: [PATCH 0287/1724] analysis member output at startup w/o computation This allows analysis members, like LIGHT, to output analysis member input data at startup and avoid a computational step (e.g., output the initial particle positions within LIGHT). This commit adds generality and a warning is still issue if output at start up and computation at startup are not both selected. This follows the premise that, in general, it should be the user responsibility to make sure that computations are enable at startup because otherwise analysis member functionality is adversely limited for the general case as discussed above using LIGHT as a use case. --- .../analysis_members/mpas_ocn_analysis_driver.F | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F index f46c8a3e67..8b42b76daf 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -364,18 +364,17 @@ subroutine ocn_analysis_compute_startup(domain, err)!{{{ call ocn_compute_analysis_members(domain, timeLevel, poolItr % memberName, err_tmp) call mpas_timer_stop(timerName) err = ior(err, err_tmp) + end if - if ( config_AM_write_on_startup ) then - configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_stream_name' - call mpas_pool_get_config(domain % configs, configName, config_AM_stream_name) - if ( config_AM_stream_name /= 'none' ) then - call mpas_stream_mgr_write(domain % streamManager, streamID=config_AM_stream_name, forceWriteNow=.true., ierr=err_tmp) - end if + if ( config_AM_write_on_startup ) then + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_stream_name' + call mpas_pool_get_config(domain % configs, configName, config_AM_stream_name) + if ( config_AM_stream_name /= 'none' ) then + call mpas_stream_mgr_write(domain % streamManager, streamID=config_AM_stream_name, forceWriteNow=.true., ierr=err_tmp) end if - else - if ( config_AM_write_on_startup ) then + if (.not. config_AM_compute_on_startup) then write(stderrUnit, *) ' *** WARNING: write_on_startup called without compute_on_startup for analysis member: ' & - // poolItr % memberName(1:nameLength) // '. Skipping output...' + // poolItr % memberName(1:nameLength) // '.' end if end if end if From d74e074af7f7bb46e15e6efee65bd2009378bc90 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Thu, 1 Oct 2015 07:40:00 -0700 Subject: [PATCH 0288/1724] Reading input streams before 1st diagnostic solve This is necessary if fields from the forcing input stream are used in diagnostics (e.g. landIceFraction). --- src/core_ocean/mode_forward/mpas_ocn_forward_mode.F | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index 878369e01d..959205399d 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -164,11 +164,17 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ else call MPAS_stream_mgr_read(domain % streamManager, streamID='input', ierr=err_tmp) end if + + call mpas_stream_mgr_read(domain % streamManager, ierr=err_tmp) + ierr = ior(ierr, err_tmp) + call mpas_timer_stop('io_read') call mpas_timer_start('reset_io_alarms', .false.) call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID='input', ierr=err_tmp) call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID='restart', ierr=err_tmp) call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) + call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_INPUT, ierr=err_tmp) + ierr = ior(ierr, err_tmp) call mpas_timer_stop('reset_io_alarms') ! Initialize submodules before initializing blocks. From f8528ee4b57e694af42822c4893381fa8c13ee16 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 1 Oct 2015 11:37:20 -0600 Subject: [PATCH 0289/1724] Fix vertical dimension for velocity in stats module This fixes a TODO item in the statistics module to replace the vertical dimension used for calculating velocity statistics from nVertLevels to nVertInterfaces. Without this fix, the model would die in debug mode if statistics were enabled due to an array bounds mismatch. --- .../mode_forward/mpas_li_statistics.F | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/core_landice/mode_forward/mpas_li_statistics.F b/src/core_landice/mode_forward/mpas_li_statistics.F index 1827486683..d3130bc8f0 100644 --- a/src/core_landice/mode_forward/mpas_li_statistics.F +++ b/src/core_landice/mode_forward/mpas_li_statistics.F @@ -91,7 +91,7 @@ subroutine li_compute_statistics(domain, itimestep) type (mpas_pool_type), pointer :: scratchPool ! mesh dimensions - integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve + integer, pointer :: nVertLevels, nVertInterfaces, nCellsSolve, nEdgesSolve ! mesh arrays integer, dimension(:), pointer :: indexToCellID, indexToEdgeID @@ -213,6 +213,7 @@ subroutine li_compute_statistics(domain, itimestep) ! mesh dimensions call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nVertInterfaces', nVertInterfaces) call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) @@ -378,10 +379,9 @@ subroutine li_compute_statistics(domain, itimestep) iceEnergySum = iceEnergySum + localSum*rhoi*cp_ice ! normal velocity at cell edges; find the maximum magnitude - !TODO - If velocity is defined at layer interfaces, then nVertLevels -> nVertLevels + 1 call li_compute_field_local_stats(dminfo, & - nVertLevels, nEdgesSolve, & + nVertInterfaces, nEdgesSolve, & normalVelocity(:,1:nEdgesSolve), & iceEdgeMask(1:nEdgesSolve), & localSum, & @@ -409,7 +409,7 @@ subroutine li_compute_statistics(domain, itimestep) call li_compute_field_local_stats(dminfo, & 1, nEdgesSolve, & - normalVelocity(nVertLevels,1:nEdgesSolve), & + normalVelocity(nVertInterfaces,1:nEdgesSolve), & iceEdgeMask(1:nEdgesSolve), & localSum, & localMin, localMax, & @@ -429,9 +429,8 @@ subroutine li_compute_statistics(domain, itimestep) endif ! allocate and initialize some diagnostic arrays if not done already - !TODO - If velocity is defined at layer interfaces, then nVertLevels -> nVertLevels + 1 if (.not. allocated(diagnosticSpeed)) then - allocate(diagnosticSpeed(nVertLevels)) + allocate(diagnosticSpeed(nVertInterfaces)) diagnosticSpeed(:) = 0.0_RKIND endif @@ -540,13 +539,15 @@ subroutine li_compute_statistics(domain, itimestep) call mpas_dmpar_sum_real (dminfo, diagnosticSurfaceTemperature, diagnosticSurfaceTemperature) call mpas_dmpar_sum_real (dminfo, diagnosticBasalTemperature, diagnosticBasalTemperature) - !TODO - Change to nVertLevels + 1 if velocity lives on layer interfaces - allocate (workLevel(nVertLevels)) - call mpas_dmpar_sum_real_array(dminfo, nVertLevels, diagnosticSpeed, workLevel) + allocate (workLevel(nVertInterfaces)) + call mpas_dmpar_sum_real_array(dminfo, nVertInterfaces, diagnosticSpeed, workLevel) diagnosticSpeed(:) = workLevel(:) + deallocate(workLevel) + allocate (workLevel(nVertLevels)) call mpas_dmpar_sum_real_array(dminfo, nVertLevels, diagnosticTemperature, workLevel) diagnosticTemperature(:) = workLevel(:) + deallocate(workLevel) ! Write global and local stats to the log file @@ -599,7 +600,6 @@ subroutine li_compute_statistics(domain, itimestep) endif ! my_proc_id = IO_NODE ! clean up - deallocate(workLevel) deallocate(diagnosticTemperature) deallocate(diagnosticSpeed) From 2d60fc003126c930e444cae228e0368f2a061d08 Mon Sep 17 00:00:00 2001 From: Phillip Wolfram Date: Tue, 29 Sep 2015 19:48:15 -0600 Subject: [PATCH 0290/1724] adds LIGHT particle tracking analysis member Add Lagrangian In-situ Global High-performance particle Tracking (LIGHT) to MPAS-O as an analysis member. Development and application to the SOMA eddying double-gyre basin published in P.J. Wolfram, T.D. Ringler, M.E. Maltrud, D.W. Jacobsen, and M.R. Petersen. Diagnosing isopycnal diffusivity in an eddying, idealized mid-latitude ocean basin via Lagrangian In-situ, Global, High-performance particle Tracking (LIGHT), Journal of Physical Oceanography, 2015, http://journals.ametsoc.org/doi/abs/10.1175/JPO-D-14-0260.1. Working design documents can be found at https://github.com/pwolfram/MPAS-Scratch/tree/oceanLPTs/oceanLPTs/documents/design LIGHT is meant to be validated via testing with 1. solid-body rotation test case: cd LIGHT_test_cases/LIGHT_feature_test_radial ./drive_tests.py 2. bit-reproducible restart demonstration for particles that are transferred across multiple compute processors: cd LIGHT_test_cases/LIGHT_feature_test_short_restart ./test_bit_reproducible_restart.sh 3. bit-for-bit demonstration of processor independence: cd LIGHT-test_cases/LIGHT_feature_test_brb ./test_bit_reproducible.sh Tests can be temporarily found at https://www.dropbox.com/sh/wnxc9wlb7aol7lr/AABTzyvh0BaoIs6XeSlyBBn5a?dl=0 --- src/core_ocean/analysis_members/Makefile | 7 + .../Registry_analysis_members.xml | 1 + .../Registry_lagrangian_particle_tracking.xml | 305 ++ .../mpas_ocn_analysis_driver.F | 10 + .../mpas_ocn_lagrangian_particle_tracking.F | 2698 +++++++++++ ...rangian_particle_tracking_interpolations.F | 616 +++ .../analysis_members/mpas_ocn_particle_list.F | 3986 +++++++++++++++++ 7 files changed, 7623 insertions(+) create mode 100644 src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml create mode 100644 src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F create mode 100644 src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_interpolations.F create mode 100644 src/core_ocean/analysis_members/mpas_ocn_particle_list.F diff --git a/src/core_ocean/analysis_members/Makefile b/src/core_ocean/analysis_members/Makefile index d1898c2ba7..0f2ef25c64 100644 --- a/src/core_ocean/analysis_members/Makefile +++ b/src/core_ocean/analysis_members/Makefile @@ -11,6 +11,9 @@ MEMBERS = mpas_ocn_global_stats.o \ mpas_ocn_test_compute_interval.o \ mpas_ocn_high_frequency_output.o \ mpas_ocn_zonal_mean.o \ + mpas_ocn_lagrangian_particle_tracking_interpolations.o \ + mpas_ocn_particle_list.o \ + mpas_ocn_lagrangian_particle_tracking.o \ mpas_ocn_eliassen_palm.o \ mpas_ocn_time_filters.o \ mpas_ocn_mixed_layer_depths.o @@ -21,6 +24,10 @@ mpas_ocn_analysis_driver.o: $(MEMBERS) mpas_ocn_okubo_weiss.o: mpas_ocn_okubo_weiss_eigenvalues.o +mpas_ocn_particle_list.o: + +mpas_ocn_lagrangian_particle_tracking.o: mpas_ocn_particle_list.o mpas_ocn_lagrangian_particle_tracking_interpolations.o + clean: $(RM) *.o *.i *.mod *.f90 diff --git a/src/core_ocean/analysis_members/Registry_analysis_members.xml b/src/core_ocean/analysis_members/Registry_analysis_members.xml index e98753ee9d..526098f8af 100644 --- a/src/core_ocean/analysis_members/Registry_analysis_members.xml +++ b/src/core_ocean/analysis_members/Registry_analysis_members.xml @@ -8,5 +8,6 @@ #include "Registry_test_compute_interval.xml" #include "Registry_high_frequency_output.xml" #include "Registry_time_filters.xml" +#include "Registry_lagrangian_particle_tracking.xml" #include "Registry_eliassen_palm.xml" #include "Registry_mixed_layer_depths.xml" diff --git a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml new file mode 100644 index 0000000000..7cba75fa56 --- /dev/null +++ b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml @@ -0,0 +1,305 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F index 8b42b76daf..669b5c96e7 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -36,6 +36,7 @@ module ocn_analysis_driver use ocn_test_compute_interval use ocn_high_frequency_output use ocn_time_filters + use ocn_lagrangian_particle_tracking use ocn_eliassen_palm use ocn_mixed_layer_depths ! use ocn_TEM_PLATE @@ -151,6 +152,7 @@ subroutine ocn_analysis_setup_packages(configPool, packagePool, iocontext, err)! call mpas_pool_add_config(analysisMemberList, 'zonalMean', 1) call mpas_pool_add_config(analysisMemberList, 'highFrequencyOutput', 1) call mpas_pool_add_config(analysisMemberList, 'timeFilters', 1) + call mpas_pool_add_config(analysisMemberList, 'lagrPartTrack', 1) call mpas_pool_add_config(analysisMemberList, 'eliassenPalm', 1) call mpas_pool_add_config(analysisMemberList, 'mixedLayerDepths', 1) ! call mpas_pool_add_config(analysisMemberList, 'temPlate', 1) @@ -749,6 +751,8 @@ subroutine ocn_init_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_init_high_frequency_output(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'timeFilters' ) then call ocn_init_time_filters(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'lagrPartTrack' ) then + call ocn_init_lagrangian_particle_tracking(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'eliassenPalm' ) then call ocn_init_eliassen_palm(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'mixedLayerDepths' ) then @@ -804,6 +808,8 @@ subroutine ocn_compute_analysis_members(domain, timeLevel, analysisMemberName, i call ocn_compute_high_frequency_output(domain, timeLevel, err_tmp) else if ( analysisMemberName(1:nameLength) == 'timeFilters' ) then call ocn_compute_time_filters(domain, timeLevel, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'lagrPartTrack' ) then + call ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err_tmp) else if ( analysisMemberName(1:nameLength) == 'eliassenPalm' ) then call ocn_compute_eliassen_palm(domain, timeLevel, err_tmp) else if ( analysisMemberName(1:nameLength) == 'mixedLayerDepths' ) then @@ -858,6 +864,8 @@ subroutine ocn_restart_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_restart_high_frequency_output(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'timeFilters' ) then call ocn_restart_time_filters(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'lagrPartTrack' ) then + call ocn_restart_lagrangian_particle_tracking(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'eliassenPalm' ) then call ocn_restart_eliassen_palm(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'mixedLayerDepths' ) then @@ -912,6 +920,8 @@ subroutine ocn_finalize_analysis_members(domain, analysisMemberName, iErr)!{{{ call ocn_finalize_high_frequency_output(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'timeFilters' ) then call ocn_finalize_time_filters(domain, err_tmp) + else if ( analysisMemberName(1:nameLength) == 'lagrPartTrack' ) then + call ocn_finalize_lagrangian_particle_tracking(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'eliassenPalm' ) then call ocn_finalize_eliassen_palm(domain, err_tmp) else if ( analysisMemberName(1:nameLength) == 'mixedLayerDepths' ) then diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F new file mode 100644 index 0000000000..55a41f38e5 --- /dev/null +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -0,0 +1,2698 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_lagrangian_particle_tracking +! +!> \brief MPAS ocean analysis mode member: lagrangian_particle_tracking +!> \author Phillip J. Wolfram +!> \date 02/20/14 and 07/23/2015 +!> \details +!> MPAS ocean analysis core member: lagrangian particle tracking +!> module computes Lagrangian particle trajectories and associated +!> diagnostics +!----------------------------------------------------------------------- + +module ocn_lagrangian_particle_tracking + + use mpas_timer + use mpas_dmpar + use mpas_timekeeping + use mpas_stream_manager + + use ocn_constants + + use ocn_particle_list + use ocn_lagrangian_particle_tracking_interpolations + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_lagrangian_particle_tracking, & + ocn_compute_lagrangian_particle_tracking, & + ocn_restart_lagrangian_particle_tracking, & + ocn_finalize_lagrangian_particle_tracking + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + ! timer + type (timer_node), pointer :: timerTotalLPT, timerInitAlarms, timerInit, timerComputeStartup, timerCompute, timerWrite, timerRestart, timerFinalize, timerValidatedCell + type (timer_node), pointer :: timerValidatedCell_out, timerValidatedCell_init, timerVerticalID, timerTransferParticles, timerVelTimeInterp + type (timer_node), pointer :: timerVelTimeInterp_out, timerHorizMovement, timerUpdateIOHalo, timerConvertXYZLatLon, timerCellID, timerCellID_init, timerReconstFilter + type (timer_node), pointer :: timerReconstFilter_init, timerVelocityPotDensity, timerTimeStepLPT, timerTransferParticles_init, timerTransferParticles_write, timerMemTasksLPT + type (timer_node), pointer :: timerSinglePartStats, timerParticleAssignment, timerHorizVelInterp + ! neighboring processors and arrays for send numbers / recvs, total number of neighboring processors to a particular processor + ! allocated in init, deallocated in finalize + ! these globals could be moved to the framework component, as well + ! as quite a few of the subroutines + integer, dimension(:), pointer :: g_ProcNeighs => null(), g_ioProcNeighs=>null() + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_lagrangian_particle_tracking +! +!> \brief Initialize MPAS-Ocean analysis member +!> \author Phillip J. Wolfram +!> \date 02/20/14 +!> \details +!> This routine conducts all initializations required for the +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_lagrangian_particle_tracking(domain, err)!{{{ + + implicit none + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + logical, pointer :: config_do_restart + + err = 0 + + write(stderrUnit,*) 'starting ocn_init_lagrangian_particle_tracking' + call mpas_timer_start("totalLPT", .false., timerTotalLPT) + call mpas_timer_start("initLPT", .false., timerInit) + + ! load in data +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'starting reading stream for lagrPartTrack' +#endif + call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) + if (config_do_restart) then + call MPAS_stream_mgr_read(domain % streamManager, streamID='lagrPartTrackRestart', ierr=err) + else + call MPAS_stream_mgr_read(domain % streamManager, streamID='lagrPartTrackInput', ierr=err) + end if +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'finished reading stream for lagrPartTrack' +#endif + ! resets likely are unnecessary + !call mpas_stream_mgr_reset_alarms(stream_manager, streamID='lagrPartTrackInput', ierr=err) + !call mpas_stream_mgr_reset_alarms(stream_manager, streamID='lagrPartTrackRestart', ierr=err) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! init + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! build up the particles lists and fill them with their data + call mpas_particle_list_build_and_assign_particle_list(domain, err) + ! now we have built the particlelist for a given block +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'finished building and allocating particles in init' +#endif + + ! parallel code: + + ! get "MPI halos" for communication of particles in halo during computational step + call mpas_particle_list_build_computation_halos(domain, err, g_ProcNeighs) +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'finished building and computational halos' +#endif + + ! get "MPI halos" for IO communication during write and restart steps (ioBlock to currentBlocks) + call mpas_particle_list_build_io_halos(domain, err, 'currentBlock', g_ioProcNeighs) +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'g_ioProcNeighs=', g_ioProcNeighs + write(stderrUnit,*) 'finished building io halos' +#endif + + ! transfer particles to their appropriate blocks (currentBlock) via MPI + ! note, don't necessarily need to have g_ionSend and g_ionRecv comeout +#ifdef MPAS_DEBUG + call mpas_timer_start("trans_from_block_to_blockLPT", .false., timerTransferParticles_init) + call mpas_particle_list_test_numparticles_to_neighprocs(domain % dminfo % my_proc_id, g_ProcNeighs, g_ioProcNeighs) +#endif + call mpas_particle_list_transfer_particles_from_block_to_named_block(domain, err, .True., .False., 'currentBlock', & + g_ioProcNeighs) +#ifdef MPAS_DEBUG + call mpas_timer_stop("trans_from_block_to_blockLPT", timerTransferParticles_init) + !call MPI_Barrier(domain % dminfo % comm, err) +#endif + + ! tests to make sure all the values are ok !{{{ +#ifdef MPAS_DEBUG + call mpas_particle_list_test_neighscalc(domain, err) + call mpas_particle_list_test_numparticles_to_neighprocs(domain % dminfo % my_proc_id, g_ProcNeighs, g_ioProcNeighs) + call mpas_particle_list_test_num_current_particlelist(domain) +#endif + !}}} + + ! now set sums for autocorrelation calculation to be zero + call zero_autocorrelation_sums(domain) + + ! previous compute startup calls + call intialize_wachspress_coefficients(domain, err) + call initalize_fields(domain, err) + call compute_velocity_on_potentialdensity_surface(domain,err,1) + call compute_velocity_on_potentialdensity_surface(domain,err,2) + call initialize_particle_properties(domain,2,err) + call write_lagrangian_particle_tracking(domain, err) + + write(stderrunit,*) 'finished ocn_init_lagrangian_particle_tracking' + call mpas_timer_stop("initLPT", timerInit) + + call mpas_timer_stop("totalLPT", timerTotalLPT) + + end subroutine ocn_init_lagrangian_particle_tracking!}}} + + +!*********************************************************************** +! +! routine ocn_compute_lagrangian_particle_tracking +! +!> \brief Compute MPAS-Ocean analysis member +!> \author Phillip J. Wolfram +!> \date 02/20/14 +!> \details +!> This routine conducts all computation required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ + + implicit none + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + integer, intent(in) :: timeLevel + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (dm_info) :: dminfo + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: scratchPool + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: lagrPartTrackFieldsPool, lagrPartTrackCellsPool, lagrPartTrackScratchPool + integer, dimension(:), pointer :: cellOwnerBlock + integer, pointer :: currentBlock, ioBlock, indexToParticleID, transfered + type (mpas_particle_list_type), pointer :: particlelist + type (mpas_particle_type), pointer :: particle + + real (kind=RKIND), dimension(3) :: particlePosition, particleVelocity + real (kind=RKIND), pointer :: xParticle, yParticle, zParticle, lonVel, latVel, buoyancyParticle, sumU, sumV, sumUU, sumUV, sumVV + real (kind=RKIND), dimension(3) :: xSubStep, diffSubStep, diffParticlePosition + real (kind=RKIND), pointer :: zLevelParticle + real (kind=RKIND), dimension(:,:), pointer :: zTop, vertVelocityTop, zMid, areaBArray + real (kind=RKIND), dimension(:), pointer :: bottomDepth + type (field2DReal), pointer :: normalVelocity, uVertexVelocity, vVertexVelocity, wVertexVelocity, layerThickness + + real (kind=RKIND), dimension(:,:), pointer :: uVertexVelocityArray, vVertexVelocityArray, wVertexVelocityArray, buoyancyTimeInterp, potentialDensity + + real(kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real(kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + + integer, dimension(:,:), pointer :: verticesOnCell, boundaryVertex + integer, dimension(:), pointer :: maxLevelCell + + integer theVertex, iLevel, iLevelBuoyancy, aVertex, & + nSteps, timeStep, subStep, subStepOrder, timeInterpOrder, aTimeLevel, nCellVertices, blockProc, arrayIndex + integer, pointer :: nCells, nVertLevels, iCell + integer, dimension(:), pointer :: nCellVerticesArray + integer, dimension(:,:), pointer :: cellsOnCell + logical, dimension(:,:), pointer :: ioProcRecvList + logical, dimension(:), pointer :: ioProcSendList + logical, pointer :: onSphere + + real (kind=RKIND), dimension(4) :: kWeightK, kWeightKVert + real (kind=RKIND), dimension(3,4) :: kWeightX + real (kind=RKIND), dimension(4) :: kWeightXVert + real (kind=RKIND), dimension(4) :: kWeightT, kWeightTVert + real (kind=RKIND), dimension(3,5) :: kCoeff + real (kind=RKIND), dimension(5) :: kCoeffVert + real (kind=RKIND), dimension(2) :: timeCoeff + real (kind=RKIND) :: dt, dtSim, tSubStep + real (kind=RKIND), pointer :: dtParticle + real (kind=RKIND) :: zSubStep + real (kind=RKIND) :: diffSubStepVert, diffParticlePositionVert, particleVelocityVert, verticalVelocityInterp + real (kind=RKIND) :: buoyancyInterp + real (kind=RKIND), pointer :: sphereRadius + integer, pointer :: verticalTreatment, vertexReconstMethod, timeIntegration, indexLevel, filterNum + character(len=StrKIND), pointer :: config_dt + type (MPAS_timeInterval_type) :: timeStepESMF + integer :: err_tmp + + err = 0 + + !! don't do compute for debugging purposes + !write(stderrUnit,*) 'Computing Lagrangian Particle Tracking -- NO COMPUTATION!' + !return + + dminfo = domain % dminfo + + write(stderrUnit,*) 'Computing Lagrangian Particle Tracking...' + call mpas_timer_start("totalLPT", .false., timerTotalLPT) + call mpas_timer_start("computeLPT", .false., timerCompute) + + call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_filter_number', filterNum) + + allocate(ioProcRecvList(size(g_ioProcNeighs), domain % dminfo % nprocs)) + allocate(ioProcSendList(domain % dminfo % nprocs)) + ioProcRecvList = .False. + ioProcSendList = .False. + + ! get the most recent velocities on the potential density surfaces +#ifdef MPAS_DEBUG + call mpas_timer_start("velocity_pot_density_LPT", .false., timerVelocityPotDensity) +#endif + call compute_velocity_on_potentialdensity_surface(domain,err,2) +#ifdef MPAS_DEBUG + call mpas_timer_stop("velocity_pot_density_LPT",timerVelocityPotDensity) +#endif + + block => domain % blocklist + do while (associated(block)) !{{{ +#ifdef MPAS_DEBUG + call mpas_timer_start("memtasksLPT", .false., timerMemTasksLPT) +#endif + ! allocate scratch memory / setup pointers / get block !{{{ + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackFields', lagrPartTrackFieldsPool) + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackScratch', lagrPartTrackScratchPool) + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackCells', lagrPartTrackCellsPool) + + ! particlelist should be stored in the structs pool probably (need to seriously rework the code!) + particlelist => block % particlelist + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + call mpas_pool_get_array(lagrPartTrackCellsPool, 'wachspressAreaB', areaBArray) + call mpas_pool_get_array(diagnosticsPool, 'zTop', zTop) + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + call mpas_pool_get_array(diagnosticsPool, 'vertVelocityTop', vertVelocityTop) + + ! note, originally this was diagnostics % state % normalVelocity (without time level), but + ! now there is a time level so selection of the correct time level appears to be tricky + ! the issue is large, nearly NAN normalVelocities with timeLevel=2 + call mpas_pool_get_field(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + ! potentially a costly function call, but ensures halos are ok + !call mpas_dmpar_exch_halo_field(normalVelocity) + call mpas_pool_get_field(statePool, 'layerThickness', layerThickness, timeLevel=timeLevel) + + call mpas_pool_get_array(meshPool, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'boundaryVertex', boundaryVertex) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nCellVerticesArray) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + + call mpas_pool_get_config(meshPool, 'on_a_sphere', onSphere) + call mpas_pool_get_config(meshPool, 'sphere_radius', sphereRadius) + call mpas_pool_get_config(block % configs, 'config_dt', config_dt) + call mpas_set_timeInterval(timeStepESMF, timeString=config_dt, ierr=err) + !}}} + + !{{{ + ! flip previous time level to back (switching memory pointers) + call mpas_pool_shift_time_levels(lagrPartTrackFieldsPool) + call mpas_pool_get_field(lagrPartTrackFieldsPool, 'uVertexVelocity', uVertexVelocity, timeLevel=2) + call mpas_pool_get_field(lagrPartTrackFieldsPool, 'vVertexVelocity', vVertexVelocity, timeLevel=2) + call mpas_pool_get_field(lagrPartTrackFieldsPool, 'wVertexVelocity', wVertexVelocity, timeLevel=2) +#ifdef MPAS_DEBUG + call mpas_timer_stop("memtasksLPT",timerMemTasksLPT) +#endif + +#ifdef MPAS_DEBUG + call mpas_timer_start("reconst_filter_LPT", .false., timerReconstFilter) +#endif + call ocn_vertex_reconstruction(filterNum, meshPool, lagrPartTrackScratchPool, lagrPartTrackCellsPool, & + layerThickness % array, normalVelocity % array, & + uVertexVelocity, vVertexVelocity, wVertexVelocity) +#ifdef MPAS_DEBUG + call mpas_timer_stop("reconst_filter_LPT", timerReconstFilter) + write(stderrUnit,*) 'uVertexVelocity=',uVertexVelocity % array + write(stderrUnit,*) 'vVertexVelocity=',vVertexVelocity % array + write(stderrUnit,*) 'wVertexVelocity=',wVertexVelocity % array +#endif + !}}} + +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'beginning particle loop with particlelist associated = ', associated(particlelist) + ! error is here + call mpas_particle_list_test_num_current_particlelist(domain) +#endif + + !!!!!!!!!! LOOP OVER PARTICLES !!!!!!!!!! + ! update the particle position (just from initialized value for now) + ! this is a loop over particle list and its datastructures + do while(associated(particlelist)) !{{{ + ! get pointers / option values + particle => particlelist % particle + + ! get values {{{ +#ifdef MPAS_DEBUG + call mpas_timer_start("memtasksLPT", .false., timerMemTasksLPT) +#endif + call mpas_pool_get_array(particle % haloDataPool, 'xParticle', xParticle) + call mpas_pool_get_array(particle % haloDataPool, 'yParticle', yParticle) + call mpas_pool_get_array(particle % haloDataPool, 'zParticle', zParticle) + particlePosition(1) = xParticle + particlePosition(2) = yParticle + particlePosition(3) = zParticle + + call mpas_pool_get_array(particle % haloDataPool, 'zLevelParticle', zLevelParticle) + + call mpas_pool_get_array(particle % haloDataPool, 'verticalTreatment', verticalTreatment) + call mpas_pool_get_array(particle % haloDataPool, 'vertexReconstMethod', vertexReconstMethod) + call mpas_pool_get_array(particle % haloDataPool, 'indexLevel', indexLevel) + call mpas_pool_get_array(particle % haloDataPool, 'timeIntegration', timeIntegration) + call mpas_pool_get_array(particle % haloDataPool, 'dtParticle', dtParticle) + call mpas_pool_get_array(particle % haloDataPool, 'buoyancyParticle', buoyancyParticle) + call mpas_pool_get_array(particle % haloDataPool, 'indexToParticleID', indexToParticleID) + call mpas_pool_get_array(particle % haloDataPool, 'currentCell', iCell) + + call mpas_pool_get_array(particle % haloDataPool, 'lonVel', lonVel) + call mpas_pool_get_array(particle % haloDataPool, 'latVel', latVel) + call mpas_pool_get_array(particle % haloDataPool, 'sumU', sumU) + call mpas_pool_get_array(particle % haloDataPool, 'sumV', sumV) + call mpas_pool_get_array(particle % haloDataPool, 'sumUU', sumUU) + call mpas_pool_get_array(particle % haloDataPool, 'sumUV', sumUV) + call mpas_pool_get_array(particle % haloDataPool, 'sumVV', sumVV) +#ifdef MPAS_DEBUG + call mpas_timer_stop("memtasksLPT",timerMemTasksLPT) +#endif + ! process timers / particle reset functions here (need a timer and ability to reset particle to + ! some set of initial values for the reset + !}}} + + !!!!!!!!!! COMPUTE TIME STEP INFORMATION !!!!!!!!!! +#ifdef MPAS_DEBUG + call mpas_timer_start("time_step_LPT", .false., timerTimeStepLPT) +#endif + ! would eventually need to correspond to domain dt, but for now this is a + ! global constant + call mpas_get_timeInterval(timeStepESMF, dt=dtSim) + ! adjust time step for consistency with integer number of steps + nSteps = ceiling(dtSim/dtParticle) + dt = dtSim/nSteps + + !!!!!!!!!! ASSIGN TEMPORAL INTEGRATION COEFFICIENTS !!!!!!!!!! + ! kCoeff is (3,subStepOrder+1) + ! kWeightX is subStepOrder + ! kWeightK is subStepOrder + ! kWeightT is subStepOrder + select case (timeIntegration) !{{{ + case(1) ! EE integration + kWeightK(1) = 0.0_RKIND + + kWeightT(1) = 0.0_RKIND + + kWeightX(:,1) = 1.0_RKIND + + subStepOrder = 1 + case(2) ! RK2 integration + kWeightK(1) = 0.0_RKIND + kWeightK(2) = 0.5_RKIND + + kWeightT(1) = 0.0_RKIND + kWeightT(2) = 0.5_RKIND + + kWeightX(:,1) = 0.0_RKIND + kWeightX(:,2) = 1.0_RKIND + + subStepOrder = 2 + case(4) ! RK4 integration + kWeightK(1) = 0.0_RKIND + kWeightK(2) = 0.5_RKIND + kWeightK(3) = 0.5_RKIND + kWeightK(4) = 1.0_RKIND + + kWeightT(1) = 0.0_RKIND + kWeightT(2) = 0.5_RKIND + kWeightT(3) = 0.5_RKIND + kWeightT(4) = 1.0_RKIND + + kWeightX(:,1) = 1.0_RKIND/6.0_RKIND + kWeightX(:,2) = 1.0_RKIND/3.0_RKIND + kWeightX(:,3) = 1.0_RKIND/3.0_RKIND + kWeightX(:,4) = 1.0_RKIND/6.0_RKIND + + subStepOrder = 4 + case default ! RK2 integration + kWeightK(1) = 0.0_RKIND + kWeightK(2) = 0.5_RKIND + + kWeightT(1) = 0.0_RKIND + kWeightT(2) = 0.5_RKIND + + kWeightX(:,1) = 0.0_RKIND + kWeightX(:,2) = 1.0_RKIND + + subStepOrder = 2 + end select !}}} + + ! use same integration coefficients for the vertical + kWeightKVert = kWeightK + kWeightXVert = kWeightX(1,:) + kWeightTVert = kWeightT + kCoeffVert = kCoeff(1,:) + + !!!!!!!!!! LOOP OVER TIME STEPS !!!!!!!!!! + do timeStep = 1, nSteps !{{{ + ! kCoeff is (3,subStepOrder+1) + kCoeff = 0.0_RKIND + kCoeffVert = 0.0_RKIND + ! compute first + do subStep = 1, subStepOrder !{{{ + + !!!!!!!!!! COMPUTE PARTICLE SUBSTEP POSITIONS USE FOR VELOCITY !!!!!!!!!! + ! horizontal + xSubStep = particlePosition + diffSubStep = kWeightK(subStep) * kCoeff(:,subStep) + + if(kWeightK(subStep) /= 0.0_RKIND) then + ! project substep to correct spherical shell because diffSubStep isn't 0 and particle moves +#ifdef MPAS_DEBUG + call mpas_timer_start("particle_horizontal_movementLPT", .false., timerHorizMovement) +#endif + call particle_horizontal_movement(xSubStep, diffSubStep, onSphere) +#ifdef MPAS_DEBUG + call mpas_timer_stop("particle_horizontal_movementLPT", timerHorizMovement) +#endif + end if + + ! vertical + zSubStep = zLevelParticle + diffSubStepVert = kWeightKVert(subStep) * kCoeffVert(subStep) + + if(kWeightKVert(subStep) /= 0.0_RKIND) then + zSubStep = zSubStep + diffSubStepVert + end if + + ! get new time step (tm = (timestep-1)*dt) + tSubStep = (timeStep-1 + kWeightT(subStep)) * dt + + !!!!!!!!!! GET SPECIFIC CELL INDICES AND GEOMETRY !!!!!!!!!! + + ! determine cell location +#ifdef MPAS_DEBUG + call mpas_timer_start("get_validated_cell_idLPT", .false., timerValidatedCell) + write(stderrUnit, *) 'beginning of substeps' +#endif + call get_validated_cell_id(nCells, xCell,yCell,zCell , xVertex,yVertex,zVertex, & + xSubStep(1),xSubStep(2),xSubStep(3), onSphere, & + nCellVerticesArray, verticesOnCell, iCell, nCellVertices, cellsOnCell) +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'iCell=',iCell + call mpas_timer_stop("get_validated_cell_idLPT", timerValidatedCell) +#endif + + if(verticalTreatment /= 4) then + ! other cases using zSubStep for iLevel and vertical interpolation +#ifdef MPAS_DEBUG + call mpas_timer_start("mpas_get_vertical_idLPT", .false., timerVerticalID) +#endif + iLevel = mpas_get_vertical_id(maxLevelCell(iCell), zSubStep, zMid(:,iCell)) +#ifdef MPAS_DEBUG + call mpas_timer_stop("mpas_get_vertical_idLPT", timerVerticalID) + write(stderrUnit,*) 'iLevel=', iLevel +#endif + end if + + !!!!!!!!!! TEMPORALLY INTERPOLATE TIME FIELD !!!!!!!!!! + ! use these coefficients to just get the velocity at n + !timeInterpOrder = 1 + !timeCoeff(1) =1.0_RKIND + ! use these coefficients to just get the velocity at n+1 + !timeInterpOrder = 2 + !timeCoeff(1) =0.0_RKIND + !timeCoeff(2) =1.0_RKIND + ! get interpolation coefficients for linear interpolation in time + timeInterpOrder = 2 + timeCoeff(1) = tSubStep / dtSim + timeCoeff(2) = 1.0_RKIND - timeCoeff(1) + + ! ensure that buoyancy is fixed for each run + buoyancyInterp = buoyancyParticle + ! return interpolated horizontal velocity "particleVelocity" and vertical velocity "particleVelocityVert" + +#ifdef MPAS_DEBUG + call mpas_timer_start("velocity_time_interpolationLPT", .false., timerVelTimeInterp) +#endif + call velocity_time_interpolation(particleVelocity, particleVelocityVert, & + diagnosticsPool, lagrPartTrackFieldsPool, & + timeInterpOrder, timeCoeff, iCell, iLevel, buoyancyInterp, maxLevelCell, & + verticalTreatment, indexLevel, nCellVertices, verticesOnCell, boundaryVertex, & + xSubStep, zSubStep, zMid, zTop, vertVelocityTop, xVertex, yVertex, zVertex, meshPool, areaBArray) +#ifdef MPAS_DEBUG + call mpas_timer_stop("velocity_time_interpolationLPT", timerVelTimeInterp) +#endif + + !!!!!!!!!! FORM INTEGRATION WEIGHTS kj !!!!!!!!!! + kCoeff(:,subStep+1) = dt * particleVelocity + kCoeffVert(subStep+1) = dt * particleVelocityVert + end do + + !!!!!!!!!! UPDATE PARTICLE POSITIONS !!!!!!!!!! + !!!!!!!!!! HORIZONTAL AND VERTICAL CONSIDERED SEPARATELY !!!!!!!!!! + diffParticlePosition = 0.0_RKIND + diffParticlePositionVert = 0.0_RKIND + do subStep = 1, subStepOrder + ! first complete particle integration + diffParticlePosition = diffParticlePosition + kWeightX(:,subStep) * kCoeff(:,subStep+1) + diffParticlePositionVert = diffParticlePositionVert + kWeightXVert(subStep) * kCoeffVert(subStep+1) + end do + ! now, make sure particle position is still on same spherical shell as before +#ifdef MPAS_DEBUG + call mpas_timer_start("particle_horizontal_movementLPT", .false., timerHorizMovement) +#endif + call particle_horizontal_movement(particlePosition, diffParticlePosition, onSphere) +#ifdef MPAS_DEBUG + call mpas_timer_stop("particle_horizontal_movementLPT", timerHorizMovement) +#endif + ! now can do any vertical movements independent of the horizontal movement + ! that was just calculated ( probably need to have more output from the vertical_treatment + ! and aggregate here + zLevelParticle = zLevelParticle + diffParticlePositionVert + + end do !}}} +#ifdef MPAS_DEBUG + call mpas_timer_stop("time_step_LPT", timerTimeStepLPT) +#endif + !}}} + + !!!!!!!!!! PERFORM SAMPLING (VELOCITY, TEMP, SALINITY, ETC) !!!!!!!!!! + ! this could be done just before the output anyway + + ! need iCell computed for final position + ! need scalar values interpolated in time to yield single value + ! probably need to store zMid too, including flipping it + ! get updated cell location +#ifdef MPAS_DEBUG + call mpas_timer_start("get_validated_cell_idLPT", .false., timerValidatedCell_out) + write(stderrUnit,*) 'do sampling' +#endif + call get_validated_cell_id(nCells, xCell,yCell,zCell , xVertex,yVertex,zVertex, & + particlePosition(1),particlePosition(2),particlePosition(3), onSphere, & + nCellVerticesArray, verticesOnCell, iCell, nCellVertices, cellsOnCell) +#ifdef MPAS_DEBUG + call mpas_timer_stop("get_validated_cell_idLPT", timerValidatedCell_out) +#endif + + if(verticalTreatment == 4) then !('buoyancySurface') !{{{ + !! determine index level (don't need validated version because that will "fix" values which we may not want + !! however, if the particle's target buoyancy surface doesn't exist then we will need to + !! ensure that vertical location is valid, placing particles outside of range of zMid back inside + !! we don't validate this because we want the code to fail, at least initially, in the case that + !! the particle is in a cell that does not have the proper buoyancy target because this implies + !! that the buoyancy tracking mode has completely failed. + !! need to make sure it is validated for buoyancy particles +#ifdef MPAS_DEBUG + !call mpas_timer_start("mpas_get_vertical_idLPT", .false., timerVerticalID) +#endif + !iLevelBuoyancy = mpas_get_vertical_id(maxLevelCell(iCell), buoyancyInterp, buoyancyTimeInterp(:,iCell)) +#ifdef MPAS_DEBUG + !call mpas_timer_stop("mpas_get_vertical_idLPT", timerVerticalID) +#endif + !! interpolate the scalars now (assumes that scalar value is constant within a particular cell) + !call interp_cell_scalars(iLevelBuoyancy, maxLevelCell(iCell), buoyancyInterp, buoyancyTimeInterp(:,iCell), & + ! zMid(:,iCell), zLevelParticle) + !deallocate(buoyancyTimeInterp) + !!}}} + else + ! make sure final zLevelParticle is ok so that it can't extent past zMid range +#ifdef MPAS_DEBUG + call mpas_timer_start("mpas_get_vertical_idLPT", .false., timerVerticalID) +#endif + iLevel = mpas_get_vertical_id(maxLevelCell(iCell), zLevelParticle, zMid(:,iCell)) +#ifdef MPAS_DEBUG + call mpas_timer_stop("mpas_get_vertical_idLPT", timerVerticalID) +#endif + end if + + ! compute necessary information for autocorrelation !{{{ + ! get the updated velocity + ! ensure that buoyancy is fixed for each run + buoyancyInterp = buoyancyParticle + ! we just need the last part of the velocity field interpolation because we are at the end of the timestep + timeInterpOrder = 2 + timeCoeff(1) = 0.0_RKIND + timeCoeff(2) = 1.0_RKIND + ! return interpolated horizontal velocity "particleVelocity" and vertical velocity "particleVelocityVert" + ! noting we use the final positions +#ifdef MPAS_DEBUG + call mpas_timer_start("velocity_time_interpolationLPT", .false., timerVelTimeInterp_out) +#endif + call velocity_time_interpolation(particleVelocity, particleVelocityVert, & + diagnosticsPool, lagrPartTrackFieldsPool, & + timeInterpOrder, timeCoeff, iCell, iLevel, buoyancyInterp, maxLevelCell, & + verticalTreatment, indexLevel, nCellVertices, verticesOnCell, boundaryVertex, & + particlePosition, zLevelParticle, zMid, zTop, vertVelocityTop, xVertex, yVertex, zVertex, & + meshPool, areaBArray) +#ifdef MPAS_DEBUG + call mpas_timer_stop("velocity_time_interpolationLPT", timerVelTimeInterp_out) +#endif + ! convert horizontal velocity to lat/lon velocity + + ! store velocity for use in computing normalized autocorrelation offline +#ifdef MPAS_DEBUG + call mpas_timer_start("mpas_convert_xyz_velocity_to_latlonLPT", .false., timerConvertXYZLatLon) +#endif + call mpas_convert_xyz_velocity_to_latlon(lonVel, latVel, particlePosition, particleVelocity) +#ifdef MPAS_DEBUG + call mpas_timer_stop("mpas_convert_xyz_velocity_to_latlonLPT", timerConvertXYZLatLon) +#endif + + ! now store components needed to compute integral timescale +#ifdef MPAS_DEBUG + call mpas_timer_start("storeSingleParticleStats", .false., timerSinglePartStats) +#endif + sumU = sumU + lonVel + sumV = sumV + latVel + sumUU = sumUU + lonVel*lonVel + sumUV = sumUV + lonVel*latVel + sumVV = sumVV + latVel*latVel +#ifdef MPAS_DEBUG + call mpas_timer_stop("storeSingleParticleStats", timerSinglePartStats) +#endif + !}}} + + ! properly store particle position (because we can't store arrays directly for particles and must + ! work entirely in vectors + xParticle = particlePosition(1) + yParticle = particlePosition(2) + zParticle = particlePosition(3) + + !!!!!!!!!! PASS PARTICLES FROM PROCESSOR TO PROCESSOR !!!!!!!!!! + !{{{ + ! 1. determine if iCell is on halo (just set each particle's currentBlock to the correct currentBlock + ! 2. determine owning block in halo, update particle's currentBlock + + ! determine currentBlock ownership of iCell + ! and set cellOwnerBlock to be current block +#ifdef MPAS_DEBUG + call mpas_timer_start("particleAssignments", .false., timerParticleAssignment) +#endif + ! update halo fields + call mpas_particle_list_update_computational_halos(domain, block, particle, 'lagrPartTrackCells', iCell, arrayIndex, ioProcRecvList, g_ioProcNeighs) +#ifdef MPAS_DEBUG + call mpas_timer_stop("particleAssignments", timerParticleAssignment) +#endif + !}}} + + ! get next particle to process on the list + particlelist => particlelist % next + end do !}}} + + ! get next block + block => block % next + end do !}}} + + !!!!!!!!!! PASS PARTICLES FROM PROCESSOR TO PROCESSOR !!!!!!!!!! + ! MPI calls + ! 3. place particle on temporary list to be sent to processor, removing particle from present list + ! 4. pass list of particles to owning block (outside block loop so that all blocks can be processed) + ! 5. delete all particles on the temporary lists (potentially if on different proc) + ! because they have been permenantly moved to block owning the halo + ! + ! Items 3-5 should be able to be described in terms of current code + ! noting that the most important thing is to ensure that the particle's currentBlock is + ! updated. Then, a routine can be called to make sure particles are placed on their appropriate + ! currentBlocks + + ! particle transfer can then occur from computational processor to computational processor +#ifdef MPAS_DEBUG + call mpas_timer_start("trans_from_block_to_blockLPT", .false., timerTransferParticles) +#endif + call mpas_particle_list_transfer_particles_from_block_to_named_block(domain, err, .True., .False., 'currentBlock', & + g_ProcNeighs) +#ifdef MPAS_DEBUG + call mpas_timer_stop("trans_from_block_to_blockLPT", timerTransferParticles) + call mpas_timer_start("update_io_haloLPT", .false., timerUpdateIOHalo) +#endif + call mpas_particle_list_update_io_halos(domain, err, g_ioProcNeighs, ioProcSendList, ioProcRecvList) +#ifdef MPAS_DEBUG + call mpas_timer_stop("update_io_haloLPT",timerUpdateIOHalo) +#endif + deallocate(ioProcSendList, ioProcRecvList) + + ! do IO communications if this is an output time step + if (mpas_stream_mgr_ringing_alarms(domain % streamManager, streamID='lagrPartTrackOutput', direction=MPAS_STREAM_OUTPUT, ierr=err)) then + call write_lagrangian_particle_tracking(domain, err) + end if + + call mpas_timer_stop("computeLPT", timerCompute) + call mpas_timer_stop("totalLPT", timerTotalLPT) + + write(stderrUnit,*) 'finished computing Lagrangian Particle Tracking' + + end subroutine ocn_compute_lagrangian_particle_tracking!}}} + +!*********************************************************************** +! +! routine ocn_restart_lagrangian_particle_tracking +! +!> \brief Save restart for MPAS-Ocean analysis member +!> \author Phillip J. Wolfram +!> \date 02/20/14 and 07/23/15 +!> \details +!> This routine conducts computation required to save a restart state +!> for the MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + subroutine ocn_restart_lagrangian_particle_tracking(domain, err)!{{{ + + implicit none + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + call mpas_timer_start("totalLPT", .false., timerTotalLPT) + call mpas_timer_start("restartLPT", .false., timerRestart) + + ! do restart if this is a restart step + if (mpas_stream_mgr_ringing_alarms(domain % streamManager, streamID='lagrPartTrackRestart', direction=MPAS_STREAM_OUTPUT, ierr=err)) then + call mpas_timer_start("restartLPT", .false., timerRestart) + + write(stderrUnit,*) 'start ocn_restart_lagrangian_particle_tracking' + ! transfer particles to their appropriate blocks (ioBlock) via MPI + ! note, don't necessarily need to have g_ionSend and g_ionRecv comeout + call mpas_particle_list_transfer_particles_from_block_to_named_block(domain, err, .True., .True., 'ioBlock', & + g_ioProcNeighs) + + ! write out all the data, sorting to make sure that shuffled particles + ! are ouptut correctly (done separately in each function, could be + ! pulled out as an optimization) + ! write halo data out, but don't need nonhalo data because it is + ! computed for output (diagnostic, not prognostic) + call mpas_particle_list_write_halo_data(domain, err) + !call mpas_particle_list_write_nonhalo_data(domain, err) + + ! need to now remove the io particles (remove particles that don't have the + ! correct currentBlock) + call mpas_particle_list_remove_particles_not_on_current_block(domain,err) + + write(stderrUnit,*) 'end ocn_restart_lagrangian_particle_tracking' + call mpas_timer_stop("restartLPT", timerRestart) + end if + + call mpas_timer_stop("totalLPT", timerTotalLPT) + + end subroutine ocn_restart_lagrangian_particle_tracking!}}} + +!*********************************************************************** +! +! routine write_lagrangian_particle_tracking +! +!> \brief Driver for MPAS-Ocean analysis output +!> \author Phillip Wolfram +!> \date 02/20/14 +!> \details +!> This routine writes all output for this MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + subroutine write_lagrangian_particle_tracking(domain, err)!{{{ + + implicit none + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + write(stderrUnit,*) 'start write_lagrangian_particle_tracking' + call mpas_timer_start("totalLPT", .false., timerTotalLPT) + call mpas_timer_start("writeLPT", .false., timerWrite) + + !call mpas_particle_list_test_num_current_particlelist(domain) + + ! transfer particles to their appropriate blocks (ioBlock) via MPI + ! note, don't necessarily need to have g_ionSend and g_ionRecv comeout + !write(stderrUnit,*) 'g_ioProcNeighs = ', g_ioProcNeighs +#ifdef MPAS_DEBUG + call mpas_timer_start("trans_from_block_to_blockLPT", .false., timerTransferParticles_write) +#endif + ! depreciated (can just use update_halo_io to keep g_ioProcNeighs up to date) + !! get "MPI halos" for IO communication during write and restart steps (currentBlock to ioBlock) + !call mpas_particle_list_build_io_halos(domain, err, 'ioBlock', g_ioProcNeighs) + ! transfer the data + call mpas_particle_list_transfer_particles_from_block_to_named_block(domain, err, .False., .True., 'ioBlock', & + g_ioProcNeighs) +#ifdef MPAS_DEBUG + call mpas_timer_stop("trans_from_block_to_blockLPT", timerTransferParticles_write) +#endif + + ! write out all the data, sorting to make sure that shuffled particles + ! are ouptut correctly (done separately in each function, could be + ! pulled out as an optimization) + call mpas_particle_list_write_halo_data(domain, err) + call mpas_particle_list_write_nonhalo_data(domain, err) + +#ifdef MPAS_DEBUG + call mpas_particle_list_test_num_current_particlelist(domain) +#endif + ! need to now remove the io particles (remove particles that don't have the + ! correct currentBlock) + call mpas_particle_list_remove_particles_not_on_current_block(domain,err) + +#ifdef MPAS_DEBUG + call mpas_particle_list_test_num_current_particlelist(domain) +#endif + write(stderrUnit,*) 'end write_lagrangian_particle_tracking' + call mpas_timer_stop("writeLPT", timerWrite) + call mpas_timer_stop("totalLPT", timerTotalLPT) + + + end subroutine write_lagrangian_particle_tracking!}}} + +!*********************************************************************** +! +! routine ocn_finalize_lagrangian_particle_tracking +! +!> \brief Finalize MPAS-Ocean analysis member +!> \author Phillip J. Wolfram +!> \date 02/20/14 +!> \details +!> This routine conducts all finalizations required for this +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + subroutine ocn_finalize_lagrangian_particle_tracking(domain, err)!{{{ + + implicit none + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (block_type), pointer :: block + integer :: timeLev + + call mpas_timer_start("totalLPT", .false., timerTotalLPT) + call mpas_timer_start("finalizeLPT", .false., timerFinalize) + err = 0 + + write(stderrUnit,*) 'start ocn_finalize_lagrangian_particle_tracking' + block => domain % blocklist + do while (associated(block)) + call mpas_particle_list_destroy_particle_list(block % particlelist) + block => block % next + end do + + deallocate(g_ProcNeighs, g_ioProcNeighs) + ! these following ones should be deallocated once rest of the code is sketched in + !deallocate(g_nPartSend, g_nPartRecv, g_ionSend, g_ionRecv) + + write(stderrUnit,*) 'end ocn_finalize_lagrangian_particle_tracking' + call mpas_timer_stop("finalizeLPT", timerFinalize) + call mpas_timer_stop("totalLPT", timerTotalLPT) + + end subroutine ocn_finalize_lagrangian_particle_tracking!}}} + +!----------------------------------------------------------------------- +! +! PRIVATE SUBROUTINES +! +!----------------------------------------------------------------------- +!{{{ + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! SUBROUTINE GET_VALIDATED_CELL_ID + ! + ! Computes the validated cell ID for a particular location base on proximity to point. + ! Phillip Wolfram 06/18/2014 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_validated_cell_id(nCells, xCell,yCell,zCell , xVertex,yVertex,zVertex, & + xSubStep,ySubStep,zSubStep, onSphere, nCellVerticesArray, verticesOnCell, & + iCell, nCellVertices, cellsOnCell) + + implicit none + + ! intent (in) + integer, intent(in) :: nCells !< number of cells + integer, dimension(:,:), pointer, intent(in) :: verticesOnCell !< vertex indices on cell + integer, dimension(:), pointer, intent(in) :: nCellVerticesArray + real (kind=RKIND), dimension(:), intent(in) :: xCell,yCell,zCell !< spatial location of cell centers + real (kind=RKIND), dimension(:), intent(in) :: xVertex,yVertex,zVertex !< spatial location of cell vertices + real (kind=RKIND), intent(in) :: xSubStep,ySubStep,zSubStep + logical, intent(in) :: onSphere + integer, dimension(:,:), intent(in) :: cellsOnCell ! cell connectivity + + !intent (out) + integer, intent(inout) :: iCell + integer, intent(out) :: nCellVertices + + + ! get cell index +!#ifdef MPAS_DEBUG +! iCell = -1 +!#endif + call mpas_get_nearby_cell_index(nCells, xCell,yCell,zCell , & + xSubStep,ySubStep,zSubStep, onSphere, iCell, cellsOnCell, nCellVerticesArray) + + nCellVertices = nCellVerticesArray(iCell) + +#ifdef MPAS_DEBUG + ! check to make sure the horizontal location is valid, otherwise report an error + !write(stderrUnit,*) 'max verticesOnCell = ', maxval(verticesOnCell(:,iCell)), 'nVertices = ', size(xVertex) + if(.not. point_in_cell(nCellVertices, & + xVertex(verticesOnCell(1:nCellVertices,iCell)), & + yVertex(verticesOnCell(1:nCellVertices,iCell)), & + zVertex(verticesOnCell(1:nCellVertices,iCell)), & + xSubStep,ySubStep,zSubStep , onSphere)) then + write(stderrUnit,*) 'Point (', xSubStep,ySubStep,zSubStep ,') is horizontally outside cell ', iCell + write(stderrUnit,*) 'Cell (',& + xCell(iCell),yCell(iCell),zCell(iCell), ') with index ' , iCell + write(stderrUnit,*) 'xVertex = ', xVertex(verticesOnCell(1:nCellVertices,iCell)) + write(stderrUnit,*) 'yVertex = ', yVertex(verticesOnCell(1:nCellVertices,iCell)) + write(stderrUnit,*) 'zVertex = ', zVertex(verticesOnCell(1:nCellVertices,iCell)) + end if +#endif + + end subroutine get_validated_cell_id + +#ifdef MPAS_DEBUG + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! FUNCTION POINT_IN_CELL + ! + ! Check to make sure point (xp,yp,zp) is within cell iCell (implicit via xv,yv,zv) + ! Phillip Wolfram 05/01/2014 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + logical function point_in_cell(nVertices, xv,yv,zv , xp,yp,zp, on_a_sphere) !{{{ + implicit none + + integer, intent(in) :: nVertices ! number of vertices for cell + real (kind=RKIND), dimension(:), intent(in) :: xv,yv,zv ! cell vertex locations + real (kind=RKIND), intent(in) :: xp,yp,zp ! point location + logical, intent(in) :: on_a_sphere ! flag designating if we are on a sphere + + integer :: aPoint, v1, v0 + real (kind=RKIND) :: pointRadius ! magnitude of a point radius + real (kind=RKIND), dimension(3) :: pPoint ! point vector + real (kind=RKIND), dimension(3, nVertices) :: pVertices ! vertices vectors + real (kind=RKIND), dimension(3) :: vec1, vec2, crossProd ! temporary vectors + integer, dimension(nVertices+1) :: cyclePlusOne + + ! normalize locations to same spherical shell (unit) for direct comparison + if (on_a_sphere) then + pointRadius = sqrt(xp*xp + yp*yp + zp*zp) + pPoint = (/ xp/pointRadius , yp/pointRadius , zp/pointRadius /) + do aPoint = 1, nVertices + pointRadius = sqrt(xv(aPoint)*xv(aPoint) + yv(aPoint)*yv(aPoint) + zv(aPoint)*zv(aPoint)) + pVertices(:,aPoint) = (/ xv(aPoint), yv(aPoint), zv(aPoint) /) / pointRadius + end do + else + pPoint = (/ xp,yp,zp /) + do aPoint = 1, nVertices + pVertices(:, aPoint) = (/ xv(aPoint), yv(aPoint), zv(aPoint) /) + end do + end if + + ! build up vertex cycle for the cell + do aPoint = 1, nVertices-1 + cyclePlusOne(aPoint) = aPoint + 1 + end do + cyclePlusOne(nVertices) = 1 + + ! check, using cross-products, that point is within the cell, assuming it is to start + point_in_cell = .true. + do aPoint = 1, nVertices + ! get indices of points + v0 = aPoint + v1 = cyclePlusOne(aPoint) + + ! compute the local vectors + vec1 = pVertices(:,v1) - pVertices(:,v0) + vec2 = pPoint - pVertices(:,v0) + + ! compute the cross product and dot with normal, if negative we are outside cell + ! we only need to fail on a single test! + call mpas_cross_product_in_r3(vec1,vec2,crossProd) + if(sum(crossProd*pVertices(:,v0)) < 0) then + point_in_cell = .false. + end if + + end do + + end function point_in_cell!}}} +#endif + +!*********************************************************************** +! +! routine initalize_fields +! +!> \brief Initialize fields +!> \author Phillip Wolfram +!> \date 05/22/2014 +!> \details +!> This routine inializes the fields necessary for particle tracking +! +!----------------------------------------------------------------------- + subroutine initalize_fields(domain, err)!{{{ + + implicit none + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: lagrPartTrackFieldsPool, lagrPartTrackScratchPool, lagrPartTrackCellsPool + real(kind=RKIND), dimension(:,:), pointer :: normalVelocity, layerThickness + integer :: timeLev + integer, pointer :: filterNum + type (field2DReal), pointer :: uVV, vVV, wVV + real (kind=RKIND), dimension(:,:), pointer :: potentialDensity + + !write(stderrUnit,*) 'inialize_vertex_velocity start' + + call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_filter_number', filterNum) + + err = 0 + + block => domain % blocklist + do while (associated(block)) + ! setup pointers / get block + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackFields', lagrPartTrackFieldsPool) + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackScratch', lagrPartTrackScratchPool) + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackCells', lagrPartTrackCellsPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + + !! initialize field for RBF (needed depending upon calling pattern of analysis member) + !call mpas_initialize_vectors(meshPool) + !call mpas_init_reconstruct(meshPool) + + ! initialize fresh memory for both levels + do timeLev = 1, 2 + ! connect variables to pointer array + call mpas_pool_get_field(lagrPartTrackFieldsPool, 'uVertexVelocity', uVV, timeLevel=timeLev) + call mpas_pool_get_field(lagrPartTrackFieldsPool, 'vVertexVelocity', vVV, timeLevel=timeLev) + call mpas_pool_get_field(lagrPartTrackFieldsPool, 'wVertexVelocity', wVV, timeLevel=timeLev) + + ! initialize, but could potentially remove these lines + uVV % array = 0.0_RKIND + vVV % array = 0.0_RKIND + wVV % array = 0.0_RKIND + + ! make sure memory has been allocated +#ifdef MPAS_DEBUG + if(.not.associated(uVV) .or. & + .not.associated(vVV) .or. & + .not.associated(wVV)) then + write(stderrUnit,*) '[u,v,w]VertexVelocity memory not allocated!' + end if +#endif + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLev) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel=timeLev) + + ! get new time level velocity (linear RBF) + !write(stderrUnit,*) 'uVV= ', uVV % array +#ifdef MPAS_DEBUG + call mpas_timer_start("init_reconst_filter_LPT", .false., timerReconstFilter_init) +#endif + call ocn_vertex_reconstruction(filterNum, meshPool, lagrPartTrackScratchPool, lagrPartTrackCellsPool, & + layerThickness, normalVelocity, uVV, vVV, wVV) +#ifdef MPAS_DEBUG + call mpas_timer_stop("init_reconst_filter_LPT", timerReconstFilter_init) +#endif + + end do + + block => block % next + end do + !write(stderrUnit,*) 'inialize_vertex_velocity end' + + end subroutine initalize_fields!}}} + +!*********************************************************************** +! +! routine initalize_wachspress_coefficients +! +!> \brief Initialize Wachspress coefficients +!> \author Phillip Wolfram +!> \date 01/26/2015 +!> \details +!> This routine inializes the B_i Wachspress coefficients which are +!> static in time +! +!----------------------------------------------------------------------- + subroutine intialize_wachspress_coefficients(domain, err) !{{{ + + implicit none + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: lagrPartTrackCellsPool + type (mpas_pool_type), pointer :: meshPool + integer :: nVertices, iCell, i, im1, i0, ip1 + integer, pointer :: nCells + real (kind=RKIND), dimension(:), allocatable :: xv,yv,zv + real (kind=RKIND), pointer :: radiusLocal + integer, dimension(:,:), pointer :: verticesOnCell + integer, dimension(:), pointer :: nCellVerticesArray + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:,:), pointer :: areaBArray + + err = 0 + + block => domain % blocklist + do while (associated(block)) + ! setup pointers / get block + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackCells', lagrPartTrackCellsPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nCellVerticesArray) + call mpas_pool_get_config(meshPool, 'sphere_radius', radiusLocal) + call mpas_pool_get_array(meshPool, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + call mpas_pool_get_array(lagrPartTrackCellsPool, 'wachspressAreaB', areaBArray) + + ! compute B_i coefficients + areaBArray = 0.0_RKIND + do iCell = 1, nCells + nVertices = nCellVerticesArray(iCell) + allocate(xv(nVertices), yv(nVertices), zv(nVertices)) + xv = xVertex(verticesOnCell(:,iCell)) + yv = yVertex(verticesOnCell(:,iCell)) + zv = zVertex(verticesOnCell(:,iCell)) + do i = 1, nVertices + ! compute first area B_i + ! get vertex indices + im1 = mod(nVertices + i - 2, nVertices) + 1 + i0 = mod(nVertices + i - 1, nVertices) + 1 + ip1 = mod(nVertices + i , nVertices) + 1 + + ! precompute B_i areas + ! always the same because B_i independent of xp,yp,zp + areaBArray(iCell, i) = mpas_triangle_signed_area( (/ xv(im1),yv(im1),zv(im1) /) , & + (/ xv(i0),yv(i0),zv(i0) /) , & + (/ xv(ip1),yv(ip1),zv(ip1) /) , meshPool) + end do + deallocate(xv, yv, zv) + + end do + + + block => block % next + end do + + end subroutine intialize_wachspress_coefficients !}}} + +!*********************************************************************** +! +! routine compute_velocity_on_potentialdensity_surface +! +!> \brief compute_velocity_on_potentialdensity_surface +!> \author Phillip Wolfram +!> \date 09/15/2014 +!> \details +!> This routine interpolates the velocity field onto the potential +!> density surface +! +!----------------------------------------------------------------------- + subroutine compute_velocity_on_potentialdensity_surface(domain,err,aTimeLevel) !{{{ + + implicit none + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(in) :: domain + integer, intent(in) :: aTimeLevel + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: meshPool, diagnosticsPool, lagrPartTrackCellsPool + real (kind=RKIND), dimension(:,:), pointer :: zonVel, merVel, depth, normalVelocityMer, normalVelocityZon + real (kind=RKIND), dimension(:), pointer :: buoyancySurfaceValues + integer, pointer :: nBuoyancySurfaces, nCells + real (kind=RKIND), dimension(:,:), pointer :: buoyancy, zMid + integer :: iLevel, aBuoyancySurface, iCell + integer, dimension(:), pointer :: maxLevelCell + real (kind=RKIND) :: phiInterp !< location to interpolate + real (kind=RKIND) :: alpha + integer :: iHigh, iLow, aval + real (kind=RKIND) :: eps=1e-14_RKIND + + !write(stderrUnit,*) 'compute_velocity_on_potentialdensity_surface start' + + err = 0 + + block => domain % blocklist + do while (associated(block)) + ! get pools + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackCells', lagrPartTrackCellsPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + ! connect variables to pointer array + call mpas_pool_get_array(diagnosticsPool, 'velocityMeridional', normalVelocityMer) + call mpas_pool_get_array(diagnosticsPool, 'velocityZonal', normalVelocityZon) + call mpas_pool_get_array(lagrPartTrackCellsPool, 'buoyancySurfaceVelocityZonal', zonVel) + call mpas_pool_get_array(lagrPartTrackCellsPool, 'buoyancySurfaceVelocityMeridional', merVel) + call mpas_pool_get_array(lagrPartTrackCellsPool, 'buoyancySurfaceDepth', depth) + call mpas_pool_get_array(diagnosticsPool, 'potentialDensity', buoyancy) + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nBuoyancySurfaces', nBuoyancySurfaces) + call mpas_pool_get_array(lagrPartTrackCellsPool,'buoyancySurfaceValues', buoyancySurfaceValues) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + !write(stderrUnit,*) 'nBuoyancySurfaces =', nBuoyancySurfaces + !write(stderrUnit,*) 'buoyancySurfaceValues=', buoyancySurfaceValues + !write(stderrUnit,*) 'size(buoyancy)=',size(buoyancy) + !write(stderrUnit,*) 'shape(buoyancy)=',shape(buoyancy) + zonVel = -9999.0_RKIND + merVel = -9999.0_RKIND + ! for each buoyancy surface + do aBuoyancySurface = 1, nBuoyancySurfaces + ! for each cell + do iCell = 1, nCells + + phiInterp = buoyancySurfaceValues(aBuoyancySurface) + + ! get correct vertical levels + +#ifdef MPAS_DEBUG + !call mpas_timer_start("mpas_get_vertical_idLPT", .false., timerVerticalID) +#endif + iLevel = mpas_get_vertical_id(maxLevelCell(iCell), phiInterp, buoyancy(:,iCell)) +#ifdef MPAS_DEBUG + !call mpas_timer_stop("mpas_get_vertical_idLPT", timerVerticalID) +#endif + + if(iLevel < 1) then + ! top level + if (iLevel == 0) then + aval = maxloc(buoyancy(1:maxLevelCell(iCell),iCell),1) + ! bottom level + else if (iLevel == -1) then + aval = minloc(buoyancy(1:maxLevelCell(iCell),iCell),1) + end if + zonVel(aBuoyancySurface, iCell) = normalVelocityZon(aval,iCell) + merVel(aBuoyancySurface, iCell) = normalVelocityMer(aval,iCell) + depth(aBuoyancySurface, iCell) = zMid(aval,iCell) + else + ! perform the interpolation + call get_bounding_indices(iLow, iHigh, phiInterp, buoyancy(:,iCell), iLevel, maxLevelCell(iCell)) + ! get alpha between points + if(abs(buoyancy(iHigh,iCell) - buoyancy(iLow,iCell)) < eps) then + ! we really can't distinguish between each of these points numerically, just take the + ! average of both + alpha = 0.5_RKIND + else + alpha = (phiInterp - buoyancy(iLow,iCell))/(buoyancy(iHigh,iCell) - buoyancy(iLow,iCell)) + end if + + ! interpolate to the correct surface + zonVel(aBuoyancySurface, iCell) = alpha * normalVelocityZon(iHigh, iCell) + & + (1.0_RKIND - alpha) * normalVelocityZon(iLow, iCell) + merVel(aBuoyancySurface, iCell) = alpha * normalVelocityMer(iHigh, iCell) + & + (1.0_RKIND - alpha) * normalVelocityMer(iLow, iCell) + depth(aBuoyancySurface, iCell) = alpha * zMid(iHigh, iCell) + & + (1.0_RKIND - alpha) * zMid(iLow, iCell) + end if + + end do + + end do + + block => block % next + end do + !write(stderrUnit,*) 'compute_velocity_on_potentialdensity_surface end' + + end subroutine compute_velocity_on_potentialdensity_surface !}}} + +!*********************************************************************** +! +! routine initialize_particle_properties +! +!> \brief Initialize particle properties +!> \author Phillip Wolfram +!> \date 09/24/2014 +!> \details +!> This routine initializes particle data for +!> MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + subroutine initialize_particle_properties(domain, timeLevel, err)!{{{ + + implicit none + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + integer, intent(in) :: timeLevel + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (dm_info) :: dminfo + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: scratchPool + type (mpas_pool_type), pointer :: diagnosticsPool + type (mpas_pool_type), pointer :: lagrPartTrackFieldsPool, lagrPartTrackCellsPool, lagrPartTrackScratchPool + integer, dimension(:), pointer :: cellOwnerBlock + integer, pointer :: currentBlock, ioBlock, indexToParticleID, transfered + integer :: currentProc, ioProc + type (mpas_particle_list_type), pointer :: particlelist + type (mpas_particle_type), pointer :: particle + + real (kind=RKIND), dimension(3) :: particlePosition, particleVelocity + real (kind=RKIND), pointer :: xParticle, yParticle, zParticle, lonVel, latVel, buoyancyParticle, sumU, sumV, sumUU, sumUV, sumVV + real (kind=RKIND), dimension(3) :: xSubStep, diffSubStep, diffParticlePosition + real (kind=RKIND), pointer :: zLevelParticle + real (kind=RKIND), dimension(:,:), pointer :: zTop, vertVelocityTop, zMid, areaBArray + real (kind=RKIND), dimension(:), pointer :: bottomDepth + type (field2DReal), pointer :: normalVelocity, uVertexVelocity, vVertexVelocity, wVertexVelocity, layerThickness + + real (kind=RKIND), dimension(:,:), pointer :: uVertexVelocityArray, vVertexVelocityArray, wVertexVelocityArray, buoyancy, buoyancyTimeInterp, potentialDensity + + real(kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real(kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + + integer, dimension(:,:), pointer :: verticesOnCell, boundaryVertex + integer, dimension(:), pointer :: maxLevelCell + + integer theVertex, iLevel, iLevelBuoyancy, aVertex, & + nSteps, timeStep, subStep, subStepOrder, timeInterpOrder, aTimeLevel, nCellVertices, blockProc, arrayIndex + integer, pointer :: nCells, nVertLevels + integer, dimension(:), pointer :: nCellVerticesArray + integer, dimension(:,:), pointer :: cellsOnCell + logical, dimension(:,:), pointer :: ioProcRecvList + logical, dimension(:), pointer :: ioProcSendList + logical, pointer :: onSphere + + real (kind=RKIND), dimension(4) :: kWeightK, kWeightKVert + real (kind=RKIND), dimension(3,4) :: kWeightX + real (kind=RKIND), dimension(4) :: kWeightXVert + real (kind=RKIND), dimension(4) :: kWeightT, kWeightTVert + real (kind=RKIND), dimension(3,5) :: kCoeff + real (kind=RKIND), dimension(5) :: kCoeffVert + real (kind=RKIND), dimension(2) :: timeCoeff + real (kind=RKIND) :: dt, dtSim, tSubStep + real (kind=RKIND), pointer :: dtParticle + real (kind=RKIND) :: zSubStep + real (kind=RKIND) :: diffSubStepVert, diffParticlePositionVert, particleVelocityVert, verticalVelocityInterp + real (kind=RKIND) :: buoyancyInterp + real (kind=RKIND), pointer :: sphereRadius + integer, pointer :: verticalTreatment, vertexReconstMethod, timeIntegration, indexLevel, filterNum, iCell + + err = 0 + + dminfo = domain % dminfo + + block => domain % blocklist + do while (associated(block)) !{{{ + ! allocate scratch memory / setup pointers / get block + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackFields', lagrPartTrackFieldsPool) + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackScratch', lagrPartTrackScratchPool) + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackCells', lagrPartTrackCellsPool) + + ! particlelist should be stored in the structs pool probably (need to seriously rework the code!) + particlelist => block % particlelist + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + call mpas_pool_get_array(lagrPartTrackCellsPool, 'wachspressAreaB', areaBArray) + call mpas_pool_get_array(diagnosticsPool, 'zTop', zTop) + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + call mpas_pool_get_array(diagnosticsPool, 'vertVelocityTop', vertVelocityTop) + + call mpas_pool_get_field(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) + call mpas_dmpar_exch_halo_field(normalVelocity) + call mpas_pool_get_field(statePool, 'layerThickness', layerThickness, timeLevel=timeLevel) + + call mpas_pool_get_array(meshPool, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'boundaryVertex', boundaryVertex) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nCellVerticesArray) + + call mpas_pool_get_config(meshPool, 'on_a_sphere', onSphere) + call mpas_pool_get_config(meshPool, 'sphere_radius', sphereRadius) + + !!!!!!!!!! LOOP OVER PARTICLES !!!!!!!!!! + ! update the particle position (just from initialized value for now) + ! this is a loop over particle list and its datastructures + do while(associated(particlelist)) !{{{ + ! get pointers / option values + particle => particlelist % particle + + ! get values {{{ + call mpas_pool_get_array(particle % haloDataPool, 'xParticle', xParticle) + call mpas_pool_get_array(particle % haloDataPool, 'yParticle', yParticle) + call mpas_pool_get_array(particle % haloDataPool, 'zParticle', zParticle) + call mpas_pool_get_array(particle % haloDataPool, 'currentCell', iCell) + particlePosition(1) = xParticle + particlePosition(2) = yParticle + particlePosition(3) = zParticle + + call mpas_pool_get_array(particle % haloDataPool, 'zLevelParticle', zLevelParticle) + + call mpas_pool_get_array(particle % haloDataPool, 'verticalTreatment', verticalTreatment) + call mpas_pool_get_array(particle % haloDataPool, 'vertexReconstMethod', vertexReconstMethod) + call mpas_pool_get_array(particle % haloDataPool, 'indexLevel', indexLevel) + call mpas_pool_get_array(particle % haloDataPool, 'timeIntegration', timeIntegration) + call mpas_pool_get_array(particle % haloDataPool, 'dtParticle', dtParticle) + call mpas_pool_get_array(particle % haloDataPool, 'buoyancyParticle', buoyancyParticle) + call mpas_pool_get_array(particle % haloDataPool, 'indexToParticleID', indexToParticleID) + + call mpas_pool_get_array(particle % haloDataPool, 'lonVel', lonVel) + call mpas_pool_get_array(particle % haloDataPool, 'latVel', latVel) + call mpas_pool_get_array(particle % haloDataPool, 'sumU', sumU) + call mpas_pool_get_array(particle % haloDataPool, 'sumV', sumV) + call mpas_pool_get_array(particle % haloDataPool, 'sumUU', sumUU) + call mpas_pool_get_array(particle % haloDataPool, 'sumUV', sumUV) + call mpas_pool_get_array(particle % haloDataPool, 'sumVV', sumVV) + + !}}} + + !!!!!!!!!! PERFORM SAMPLING (VELOCITY, TEMP, SALINITY, ETC) !!!!!!!!!! + ! this could be done just before the output anyway + + ! need iCell computed for final position + ! need scalar values interpolated in time to yield single value + ! probably need to store zMid too, including flipping it + ! get updated cell location +#ifdef MPAS_DEBUG + call mpas_timer_start("get_validated_cell_idLPT", .false., timerValidatedCell_init) + write(stderrUnit,*) 'sampling initialization' +#endif + call get_validated_cell_id(nCells, xCell,yCell,zCell , xVertex,yVertex,zVertex, & + particlePosition(1),particlePosition(2),particlePosition(3), onSphere, & + nCellVerticesArray, verticesOnCell, iCell, nCellVertices, cellsOnCell) +#ifdef MPAS_DEBUG + call mpas_timer_stop("get_validated_cell_idLPT", timerValidatedCell_init) +#endif + + if(verticalTreatment == 4) then !('buoyancySurface') !{{{ + ! pass + else + ! make sure final zLevelParticle is ok so that it can't extent past zMid range + +#ifdef MPAS_DEBUG + !call mpas_timer_start("mpas_get_vertical_idLPT", .false., timerVerticalID) +#endif + iLevel = mpas_get_vertical_id(maxLevelCell(iCell), zLevelParticle, zMid(:,iCell)) +#ifdef MPAS_DEBUG + !call mpas_timer_stop("mpas_get_vertical_idLPT", timerVerticalID) +#endif + end if + + ! compute necessary information for autocorrelation !{{{ + ! get the updated velocity + ! ensure that buoyancy is fixed for each run + buoyancyInterp = buoyancyParticle + ! we just need the last part of the velocity field interpolation because we are at the end of the timestep + timeInterpOrder = 1 + timeCoeff(1) = 1.0_RKIND + timeCoeff(2) = 0.0_RKIND + ! return interpolated horizontal velocity "particleVelocity" and vertical velocity "particleVelocityVert" + ! noting we use the final positions + call velocity_time_interpolation(particleVelocity, particleVelocityVert, & + diagnosticsPool, lagrPartTrackFieldsPool, & + timeInterpOrder, timeCoeff, iCell, iLevel, buoyancyInterp, maxLevelCell, & + verticalTreatment, indexLevel, nCellVertices, verticesOnCell, boundaryVertex, & + particlePosition, zLevelParticle, zMid, zTop, vertVelocityTop, xVertex, yVertex, zVertex, & + meshPool, areaBArray) + ! convert horizontal velocity to lat/lon velocity + + !write(stderrUnit,*) iLevel, particleVelocity + + ! store velocity for use in computing normalized autocorrelation offline +#ifdef MPAS_DEBUG + !call mpas_timer_start("mpas_convert_xyz_velocity_to_latlonLPT", .false., timerConvertXYZLatLon) +#endif + + call mpas_convert_xyz_velocity_to_latlon(lonVel, latVel, particlePosition, particleVelocity) + +#ifdef MPAS_DEBUG + !call mpas_timer_stop("mpas_convert_xyz_velocity_to_latlonLPT", timerConvertXYZLatLon) +#endif + + !}}} + + ! get next particle to process on the list + particlelist => particlelist % next + end do !}}} + + ! get next block + block => block % next !}}} + end do !}}} + + end subroutine initialize_particle_properties !}}} + +!*********************************************************************** +! +! routine particle_vertical_treatment +! +!> \brief Vertical treatment to obtain correct horizontal velocity field +!> \author Phillip Wolfram +!> \date 03/31/2014 +!> \details +!> This routine returns the vertex values which will be used in the +!> Wachspress interoplant (uvCell) based on +!> vertex velocities uVertexVelocity, vVertexVelocity, wVertexVelocity +!> for a given cell which has nCellVertices which are determined from +!> the list verticesOnCell. +!> The routine collapses the vertical to a scalar. +! +!----------------------------------------------------------------------- + subroutine particle_vertical_treatment(verticalTreatment, indexLevel, nCellVertices, verticesOnCell, & !{{{ + uVertexVelocity, vVertexVelocity, wVertexVelocity, & + uvCell, boundaryVertex, iLevel, nVertLevels, & + zLoc, zMid, zTop, phiInterp, phiMid, vertVelocityTop, vertVelocityInterp) + + implicit none + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:,:), intent(in) :: & + uVertexVelocity, vVertexVelocity, wVertexVelocity !< vertex velocities + integer, dimension(:), intent(in) :: verticesOnCell !< list of vertex indices on cell + integer, intent(in) :: nCellVertices !< current cell and the number of cell vertices + integer, intent(in) :: iLevel !< vertical level / cell of zLoc + integer, intent(in) :: nVertLevels !< number of vertical levels + integer, intent(in) :: verticalTreatment !< vertical treatment encoded as int + integer, intent(in) :: indexLevel !< value of index for fixed index space + integer, dimension(:), intent(in) :: boundaryVertex !< boundary vertices for particular level + real (kind=RKIND), intent(in) :: zLoc !< location to interpolate + real (kind=RKIND), dimension(:), intent(in) :: zTop !< elevation of cell top + real (kind=RKIND), dimension(:), intent(in) :: zMid !< elevation of cell middle + real (kind=RKIND), intent(in) :: phiInterp !< buoyancy value to interpolate + real (kind=RKIND), dimension(:), intent(in) :: phiMid !< buoyancy values at cell mid points + real (kind=RKIND), dimension(:), intent(in) :: vertVelocityTop !< velocity at top of cell + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:,:), intent(out) :: uvCell !< components of vertex velocity (vertically selected) + real (kind=RKIND), intent(out) :: vertVelocityInterp ! vertically interpolated velocity + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + integer :: aVertex, theVertex + + vertVelocityInterp = 0.0_RKIND + + verticalTreatmentCase: select case (verticalTreatment) + + case (1) verticalTreatmentCase !('indexLevel') !{{{ + ! get vertically interpolanted values for vertexes in cell + ! and form polygon vertex values + do aVertex = 1, nCellVertices + theVertex = verticesOnCell(aVertex) + ! assume that we only care about the top level for a surface drifter + ! assumes that velocity is constant in top half of the cell + uvCell(1,aVertex) = uVertexVelocity(indexLevel,theVertex) + uvCell(2,aVertex) = vVertexVelocity(indexLevel,theVertex) + uvCell(3,aVertex) = wVertexVelocity(indexLevel,theVertex) + end do + + !! ensure that the boundary condition is enforced + !call zero_boundary_nodal_values(nCellVertices, verticesOnCell, & + ! boundaryVertex, uvUcell, uvVcell, uvWcell) + + ! no vertical motion, just horizontal motion + return + !}}} + + case (2) verticalTreatmentCase !('fixedZLevel') !{{{ + + ! interpolate the horizontal velocity based on z-levels + call interp_nodal_vectors(ncellvertices, verticesoncell, & + ilevel, nVertLevels, zLoc, zmid, & + uvertexvelocity, vvertexvelocity, wvertexvelocity, uvCell) + + !! ensure that there is zero nodal velocity on the boundary + !call zero_boundary_nodal_values(nCellVertices, verticesOnCell, & + ! boundaryVertex, uvUcell, uvVcell, uvWcell) + + ! no vertical motion, just horizontal motion + return + !}}} + + case (3) verticalTreatmentCase !('passiveFloat') !{{{ + + ! interpolate the vertical velocity + vertVelocityInterp = interp_vert_velocity_to_zlevel( & + iLevel, zLoc, zTop, vertVelocityTop) + + ! interpolate the horizontal velocity based on z-levels + call interp_nodal_vectors(ncellvertices, verticesoncell, & + ilevel, nVertLevels, zLoc, zmid, & + uvertexvelocity, vvertexvelocity, wvertexvelocity, uvCell) + + !! ensure that there is zero nodal velocity on the boundary + !call zero_boundary_nodal_values(nCellVertices, verticesOnCell, & + ! boundaryVertex, uvUcell, uvVcell, uvWcell) + + return + !}}} + + case (4) verticalTreatmentCase !('buoyancySurface') !{{{ + ! no vertical velocity required because there is not vertical integration for position + + ! interpolate the horizontal velocity + call interp_nodal_vectors(ncellvertices, verticesoncell, & + ilevel, nVertLevels, phiInterp, phiMid, & + uvertexvelocity, vvertexvelocity, wvertexvelocity, uvCell) + + ! ensure that there is zero nodal velocity on the boundary + !call zero_boundary_nodal_values(nCellVertices, verticesOnCell, & + ! boundaryVertex, uvUcell, uvVcell, uvWcell) + + ! no vertical motion, just horizontal motion + return + !}}} + + case (5) verticalTreatmentCase !('argoFloat') !{{{ + + + !}}} + + case default verticalTreatmentCase !{{{ + write(stderrUnit,*) 'Vertical treatment for particle integration unknwon (', verticalTreatment, ')!' + return + !}}} + + end select verticalTreatmentCase + + end subroutine particle_vertical_treatment!}}} + +!*********************************************************************** +! +! routine velocity_time_interpolation +! +!> \brief Compute velocity interpolations, including in time +!> \author Phillip Wolfram +!> \date 09/12/2014 +!> \details +!> This routine interpolates velocity in time and space to a particular +!> location xSubStep +! +!----------------------------------------------------------------------- + subroutine velocity_time_interpolation(particleVelocity, particleVelocityVert, & + diagnosticsPool, lagrPartTrackFieldsPool, & + timeInterpOrder, timeCoeff, iCell, iLevel, buoyancyInterp, maxLevelCell, & + verticalTreatment, indexLevel, nCellVertices, verticesOnCell, boundaryVertex, & + xSubStep, zSubStep, zMid, zTop, vertVelocityTop, xVertex, yVertex, zVertex, meshPool, areaBArray) !{{{ + implicit none + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + type (mpas_pool_type), pointer, intent(in) :: diagnosticsPool, lagrPartTrackFieldsPool + integer, intent(in) :: timeInterpOrder + real (kind=RKIND), dimension(2), intent(in) :: timeCoeff + integer, intent(in) :: iCell + integer, dimension(:), intent(in) :: maxLevelCell + integer, intent(in) :: verticalTreatment + integer, pointer, intent(in) :: indexLevel + integer, intent(in) :: nCellVertices + integer, dimension(:,:), intent(in) :: verticesOnCell + integer, dimension(:,:), intent(in) :: boundaryVertex + real (kind=RKIND), intent(in) :: zSubStep + real (kind=RKIND), dimension(:,:), intent(in) :: zMid + real (kind=RKIND), dimension(:,:), intent(in) :: zTop + real (kind=RKIND), dimension(:,:), intent(in) :: vertVelocityTop + real (kind=RKIND), dimension(:,:), intent(in) :: areaBArray + real (kind=RKIND), dimension(:), intent(in) :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(3), intent(in) :: xSubStep + type (mpas_pool_type), pointer, intent(in) :: meshPool + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + real (kind=RKIND), intent(in) :: buoyancyInterp + integer, intent(inout) :: iLevel + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(3), intent(out) :: particleVelocity + real (kind=RKIND), intent(out) :: particleVelocityVert + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + integer :: aVertex, aTimeLevel + real (kind=RKIND), dimension(:,:), pointer :: uVertexVelocityArray, vVertexVelocityArray, wVertexVelocityArray, buoyancy + real (kind=RKIND) :: verticalVelocityInterp + real(kind=RKIND), dimension(:), allocatable :: areaB + real(kind=RKIND), dimension(:,:), allocatable :: vertCoords + real(kind=RKIND), dimension(:,:), allocatable :: uvCell +#ifdef MPAS_DEBUG + call mpas_timer_start("velocity_time_interpolationLPT", .false., timerVelTimeInterp) +#endif + + ! allocations for particular cell !{{{ + allocate(vertCoords(3,nCellVertices), uvCell(3,nCellVertices), areaB(nCellVertices)) + !}}} + + ! get horizontal vertex locations (noting that there may be a + ! bit of error because the particle could be at the top + ! of the cell or at the bottom of the cell) + do aVertex = 1, nCellVertices + vertCoords(1,aVertex) = xVertex(verticesOnCell(aVertex,iCell)) + vertCoords(2,aVertex) = yVertex(verticesOnCell(aVertex,iCell)) + vertCoords(3,aVertex) = zVertex(verticesOnCell(aVertex,iCell)) + areaB(aVertex) = areaBArray(iCell, aVertex) + end do + + ! initialize velocities to 0 + particleVelocity = 0.0_RKIND + particleVelocityVert = 0.0_RKIND + + ! general interpolation for the velocity field + do aTimeLevel = 1, timeInterpOrder + + ! define arrays!{{{ + call mpas_pool_get_array(lagrPartTrackFieldsPool, 'uVertexVelocity', uVertexVelocityArray, timeLevel=aTimeLevel) + call mpas_pool_get_array(lagrPartTrackFieldsPool, 'vVertexVelocity', vVertexVelocityArray, timeLevel=aTimeLevel) + call mpas_pool_get_array(lagrPartTrackFieldsPool, 'wVertexVelocity', wVertexVelocityArray, timeLevel=aTimeLevel) + call mpas_pool_get_array(diagnosticsPool, 'potentialDensity', buoyancy) + !}}} + + ! get final, interpolated particle velocity at this point (collapse to point) + if (verticalTreatment == 4) then + ! buoyancy case (not using zSubStep for interpolation / iLevel) + ! use existing code noting we need to flip the order to get the right iLevel + +#ifdef MPAS_DEBUG + !call mpas_timer_start("mpas_get_vertical_idLPT", .false., timerVerticalID) +#endif + iLevel = mpas_get_vertical_id(maxLevelCell(iCell), buoyancyInterp, buoyancy(:,iCell)) +#ifdef MPAS_DEBUG + !call mpas_timer_stop("mpas_get_vertical_idLPT", timerVerticalID) + write(stderrUnit,*) 'iLevel=',iLevel +#endif + ! note, if buoyancyInterp out of range this will try to reorient the particle to the top / bottom but there + ! will definitely be some error with this type of computation because the buoyancy is not available at this location + ! the time interpolation, as a consequency, can mix velocities from different buoyancy surfaces in order to advect + ! the particle + !write(stderrUnit,*) 'iLevel = ', iLevel + end if + + call particle_vertical_treatment(verticalTreatment, indexLevel, nCellVertices, verticesOnCell(:,iCell), & + uVertexVelocityArray, vVertexVelocityArray, wVertexVelocityArray, uvCell, boundaryVertex(iLevel,:), & + iLevel, maxLevelCell(iCell), zSubStep, zMid(:,iCell), zTop(:,iCell), buoyancyInterp, buoyancy(:,iCell), & + vertVelocityTop(:,iCell), verticalVelocityInterp) + + ! vertical + particleVelocityVert = particleVelocityVert + & + timeCoeff(aTimeLevel) * verticalVelocityInterp + + ! horizontal + ! timer commented out because it is used in more than just compute... +#ifdef MPAS_DEBUG + call mpas_timer_start("part_horiz_interpLPT", .false., timerHorizVelInterp) + write(stderrUnit,*) 'particleVelocityVert=',particleVelocityVert +#endif + particleVelocity = particleVelocity + & + timeCoeff(aTimeLevel) * particle_horizontal_interpolation(nCellVertices, vertCoords, & + xSubStep, uvCell, meshPool, areaB) +#ifdef MPAS_DEBUG + call mpas_timer_stop("part_horiz_interpLPT", timerHorizVelInterp) + write(stderrUnit,*) 'particleVelocity=',particleVelocity +#endif + + + end do + + ! deallocations of temp memory + deallocate(vertCoords, uvCell, areaB) + +#ifdef MPAS_DEBUG + call mpas_timer_stop("velocity_time_interpolationLPT", timerVelTimeInterp) +#endif + + end subroutine velocity_time_interpolation !}}} + + subroutine zero_autocorrelation_sums(domain) !{{{ + implicit none + + ! input/output variables + type (domain_type), intent(inout) :: domain + ! local + type (block_type), pointer :: block + type (mpas_particle_list_type), pointer :: particlelist + type (mpas_particle_type), pointer :: particle + ! output variables (per particle) + real (kind=RKIND), pointer :: sumU, sumV, sumUU, sumUV, sumVV + integer, pointer :: currentCell + + ! get the appropriate pools + block => domain % blocklist + do while (associated(block)) !{{{ + particlelist => block % particlelist + do while(associated(particlelist)) !{{{ + ! get pointers / option values + particle => particlelist % particle + + ! get values (may want a flag for reinitialization in the future) + !call mpas_pool_get_array(particle % haloDataPool, 'sumU', sumU) + !call mpas_pool_get_array(particle % haloDataPool, 'sumV', sumV) + !call mpas_pool_get_array(particle % haloDataPool, 'sumUU', sumUU) + !call mpas_pool_get_array(particle % haloDataPool, 'sumUV', sumUV) + !call mpas_pool_get_array(particle % haloDataPool, 'sumVV', sumVV) + call mpas_pool_get_array(particle % haloDataPool, 'currentCell', currentCell) + + ! initialize the values + !sumU = 0.0_RKIND + !sumV = 0.0_RKIND + !sumUU = 0.0_RKIND + !sumUV = 0.0_RKIND + !sumVV = 0.0_RKIND + currentCell = -1 + + ! get next particle to process on the list + particlelist => particlelist % next + end do !}}} + + ! get next block + block => block % next + end do !}}} + + end subroutine zero_autocorrelation_sums !}}} + +!*********************************************************************** +! +! routine particle_horizontal_interpolation +! +!> \brief Horizontal treatment to obtain correct velocity field at point +!> \author Phillip Wolfram +!> \date 03/31/2014 +!> \details +!> This routine returns the point values which will be used in the +!> particle interpolation time integration based on +!> vertex velocities uVertexVelocity, vVertexVelocity, wVertexVelocity +! +!----------------------------------------------------------------------- + function particle_horizontal_interpolation(nCellVertices, vertCoords, & !{{{ + pointInterp, uVertex, meshPool, areaB) + + implicit none + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + integer, intent(in) :: nCellVertices + real (kind=RKIND), dimension(3, nCellVertices), intent(in) :: vertCoords + real (kind=RKIND), dimension(3), intent(in) :: pointInterp + real (kind=RKIND), dimension(3, nCellVertices), intent(in) :: uVertex + real (kind=RKIND), dimension(nCellVertices), intent(in) :: areaB + type (mpas_pool_type), pointer :: meshPool + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(nCellVertices) :: lambda + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(3) :: particle_horizontal_interpolation + + + ! get lambda coordinate for particle + lambda = mpas_wachspress_coordinates(nCellVertices, vertCoords , & + pointInterp, meshPool, areaB) +!#ifdef MPAS_DEBUG +!write(stderrUnit,*) 'lambda=',lambda +!write(stderrUnit,*) 'uVertex=',uVertex(1,:) +!write(stderrUnit,*) 'vVertex=',uVertex(2,:) +!write(stderrUnit,*) 'wVertex=',uVertex(3,:) +!#endif + + ! update particle velocities via horizontal interpolation + particle_horizontal_interpolation(1) = mpas_wachspress_interpolate(lambda, uVertex(1,:)) + particle_horizontal_interpolation(2) = mpas_wachspress_interpolate(lambda, uVertex(2,:)) + particle_horizontal_interpolation(3) = mpas_wachspress_interpolate(lambda, uVertex(3,:)) + + end function particle_horizontal_interpolation !}}} + +!*********************************************************************** +! +! routine particle_horizontal_movement +! +!> \brief Compute horizontal movement for particle so particle stays +!> in spherical shell +!> \author Phillip Wolfram +!> \date 05/20/2014 +!> \details +!> This routine returns the particle position pParticle corresponding +!> to an initial particle position pParticle for a Cartesian movemnt +!> dpParticle. If the calculation is onSphere, then the distance +!> |dpParticle| must be along the great circle route of pParticle +!> and the projection of pParticle + dpParticle on the spherical +!> shell corresponding to pParticle. +! +!----------------------------------------------------------------------- + subroutine particle_horizontal_movement(pParticle, dpParticle, onSphere) !{{{ + + implicit none + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:), intent(in) :: dpParticle + logical, intent(in) :: onSphere + + !----------------------------------------------------------------- + ! input / output variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:), intent(inout) :: pParticle + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + real (kind=RKIND) :: lenPath, arcLen + real (kind=RKIND) :: radiusShell + real (kind=RKIND), dimension(size(pParticle)) :: pParticleTemp + real (kind=RKIND), dimension(size(pParticle)) :: pParticleInterp + real (kind=RKIND) :: alpha + real (kind=RKIND), parameter :: eps=1e-10_RKIND + ! choosen based on the parameters, note that we loose about 6 - 7 units of precision because R is so large! + ! therefore, eps = 1e-10 is conservative, if not too high! this just helps with numerical stability + !dpParticle = -4.2428037617887103E-011 4.3076544298828060E-011 5.0760704444480953E-011 + !pParticle = 4444887.2990309987 -891565.00525021972 4476665.3916420965 + !pParticleTemp = 4444887.2990309987 -891565.00525021972 4476665.3916420965 + !mpas_arc_length = 0.0000000000000000 lenPath = 7.8945399869363434E-011 + + + ! may need a condition to determine if we need to project back to the sphere + if(onSphere) then + ! need to make sure new point is on the spherical shell + + ! get path length + !write(stderrUnit, *) 'dpParticle = ', dpParticle + lenPath = sqrt(sum(dpParticle*dpParticle)) + + ! consider case of particle not moving (need to have this code here in general) + !if (lenPath < eps) then + ! this is ok because this is only the case if the points are the same. If there is a + ! numerical instability it probably should be handled differently. + if (lenPath < eps) then + return + end if + + ! get radius of particle's horizontal shell + radiusShell = sqrt(sum(pParticle*pParticle)) + + ! project endpoint to spherical shell containing pParticle + pParticleTemp = pParticle + dpParticle + pParticleTemp = ( radiusShell / sqrt(sum(pParticleTemp*pParticleTemp)) ) * pParticleTemp + + ! compute alpha parameter for spherical interpolant / extrapolant + !write(stderrUnit,*) 'dpParticle = ', dpParticle + !write(stderrUnit,*) 'pParticle = ', pParticle + !write(stderrUnit,*) 'pParticleTemp = ', pParticleTemp + !write(stderrUnit,*) 'mpas_arc_length = ', mpas_arc_length(pParticle(1),pParticle(2),pParticle(3) , pParticleTemp(1), pParticleTemp(2), pParticleTemp(3)), 'lenPath = ', lenPath + arcLen = mpas_arc_length(pParticle(1),pParticle(2),pParticle(3) , pParticleTemp(1),pParticleTemp(2),pParticleTemp(3)) + if (arcLen > eps) then + alpha = lenPath / arcLen + else + return + endif + + ! compute final position based on spherical interpolant + call mpas_spherical_linear_interp(pParticleInterp, pParticle, pParticleTemp, alpha) + pParticle = pParticleInterp + else + ! we are just on a plane so there is no need for spherical interpolation to keep + ! the new particle location on a spherical shell + pParticle = pParticle + dpParticle + endif + + + end subroutine particle_horizontal_movement!}}} + +!*********************************************************************** +! +! routine interp_cell_scalars +! +!> \brief Interpolate cell scalar vector based on a criteria (z-level, buoyancy, etc) +!> \author Phillip Wolfram +!> \date 06/18/2014 +!> \details +!> This routine interpolates cell scalar vector to a particular scalar value +!> depending upon a criteria such as z-level, buoyancy, etc. +! +!----------------------------------------------------------------------- + subroutine interp_cell_scalars(iLevel, nVertLevels, zInterp, zVals, & !{{{ + phiVals, phiInterp) + + implicit none + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:), intent(in) :: zVals !< scalar values (x) on cell for interpolant + integer, intent(in) :: iLevel !< vertical level / cell of phiInterp + integer, intent(in) :: nVertLevels !< number of vertical levels + real (kind=RKIND), intent(in) :: zInterp !< location to interpolate + real (kind=RKIND), dimension(:), intent(in) :: phiVals !< values at elevation of cell middle (where vertex velocities are defined) + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + real (kind=RKIND), intent(out) :: phiInterp !< interpolated cell scalar + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + real (kind=RKIND) :: alpha + integer :: aVertex, theVertex, iHigh, iLow + real (kind=RKIND) :: eps=1e-14 + + call get_bounding_indices(iLow, iHigh, zInterp, zVals, iLevel, nVertLevels) + + ! interpolate to vertical level now + if(abs(zVals(iHigh) - zVals(iLow)) < eps) then + ! we really can't distinguish between each of these points numerically, just take the + ! average of both + alpha = 0.5_RKIND + else + ! interpolate to vertical level now + alpha = (zInterp - zVals(iLow))/(zVals(iHigh) - zVals(iLow)) + end if + + ! interpolate to the vertical level + phiInterp = alpha * phiVals(iHigh) + (1.0_RKIND - alpha) * phiVals(iLow) + + end subroutine interp_cell_scalars!}}} + +!*********************************************************************** +! +! routine interp_nodal_scalars +! +!> \brief Interpolate nodal scalar vector based on a criteria (z-level, buoyancy, etc) +!> \author Phillip Wolfram +!> \date 05/27/2014 +!> \details +!> This routine interpolates nodal scalar vector to a particular scalar value +!> depending upon a criteria such as z-level, buoyancy, etc. +! +!----------------------------------------------------------------------- + subroutine interp_nodal_scalars(nCellVertices, verticesOnCell, & !{{{ + iLevel, nVertLevels, phiInterp, phiVals, & + scalarVec, vertexScalar) + + implicit none + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:,:), intent(in) :: scalarVec !< vertex scalar + integer, dimension(:), intent(in) :: verticesOnCell !< list of vertex indices on cell + integer, intent(in) :: nCellVertices !< number of cell vertices + integer, intent(in) :: iLevel !< vertical level / cell of phiInterp + integer, intent(in) :: nVertLevels !< number of vertical levels + real (kind=RKIND), intent(in) :: phiInterp !< location to interpolate + real (kind=RKIND), dimension(:), intent(in) :: phiVals !< values at elevation of cell middle (where vertex velocities are defined) + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:), intent(out) :: vertexScalar !< components of vertex scalar (interpolated) + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + real (kind=RKIND) :: alpha + integer :: aVertex, theVertex, iHigh, iLow + + call get_bounding_indices(iLow, iHigh, phiInterp, phiVals, iLevel, nVertLevels) + + ! interpolate to vertical level now + alpha = (phiInterp - phiVals(iLow))/(phiVals(iHigh) - phiVals(iLow)) + + ! interpolate to the vertical level + do aVertex = 1, nCellVertices + theVertex = verticesOnCell(aVertex) + ! assume for now that we only care about the top level for a surface drifter + vertexScalar(aVertex) = alpha * scalarVec(iHigh, theVertex) + (1.0_RKIND - alpha) * scalarVec(iLow, theVertex) + end do + + end subroutine interp_nodal_scalars!}}} + +!*********************************************************************** +! +! routine interp_nodal_vectors +! +!> \brief Interpolate nodal vector to scalar based on a criteria (z-level, buoyancy, etc) +!> \author Phillip Wolfram +!> \date 05/27/2014 +!> \details +!> This routine interpolates nodal vectors to a particular scalar value +!> depending upon a criteria such as z-level, buoyancy, etc. +! +!----------------------------------------------------------------------- + subroutine interp_nodal_vectors(nCellVertices, verticesOnCell, & !{{{ + iLevel, nVertLevels, phiInterp, phiVals, & + uVertexVelocity, vVertexVelocity, wVertexVelocity, uvCell) + + implicit none + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:,:), intent(in) :: & + uVertexVelocity, vVertexVelocity, wVertexVelocity !< vertex velocities + integer, dimension(:), intent(in) :: verticesOnCell !< list of vertex indices on cell + integer, intent(in) :: nCellVertices !< number of cell vertices + integer, intent(in) :: iLevel !< vertical level / cell of phiInterp + integer, intent(in) :: nVertLevels !< number of vertical levels + real (kind=RKIND), intent(in) :: phiInterp !< location to interpolate + real (kind=RKIND), dimension(:), intent(in) :: phiVals !< values at elevation of cell middle (where vertex velocities are defined) + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:,:), intent(out) :: uvCell !< components of vertex velocity (vertically selected) + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + real (kind=RKIND) :: alpha + integer :: aVertex, theVertex, iHigh, iLow + real (kind=RKIND) :: eps=1e-14_RKIND + + uvCell = 0.0_RKIND + + !write(stderrUnit,*) 'interp' + if(iLevel < 1) then + if(iLevel == 0) then + !write(stderrUnit,*) 'nCellVertices = ', nCellVertices, 'buoyancyInterp= ', phiInterp + do aVertex = 1, nCellVertices + theVertex = verticesOnCell(aVertex) + !write(stderrUnit,*) maxloc(phiVals,1), phiVals(1:nVertLevels), uVertexVelocity(1:nVertLevels,theVertex) + uvCell(1,aVertex) = uVertexVelocity(maxloc(phiVals(1:nVertLevels),1), theVertex) + uvCell(2,aVertex) = vVertexVelocity(maxloc(phiVals(1:nVertLevels),1), theVertex) + uvCell(3,aVertex) = wVertexVelocity(maxloc(phiVals(1:nVertLevels),1), theVertex) + end do + else if(iLevel == -1) then + do aVertex = 1, nCellVertices + theVertex = verticesOnCell(aVertex) + uvCell(1,aVertex) = uVertexVelocity(minloc(phiVals(1:nVertLevels),1), theVertex) + uvCell(2,aVertex) = vVertexVelocity(minloc(phiVals(1:nVertLevels),1), theVertex) + uvCell(3,aVertex) = wVertexVelocity(minloc(phiVals(1:nVertLevels),1), theVertex) + end do + end if + else + call get_bounding_indices(iLow, iHigh, phiInterp, phiVals, iLevel, nVertLevels) + + ! interpolate to vertical level now + if(abs(phiVals(iHigh) - phiVals(iLow)) < eps) then + ! we really can't distinguish between each of these points numerically, just take the + ! average of both + alpha = 0.5_RKIND + else + alpha = (phiInterp - phiVals(iLow))/(phiVals(iHigh) - phiVals(iLow)) + end if + + ! interpolate to the vertical level + do aVertex = 1, nCellVertices + theVertex = verticesOnCell(aVertex) + ! assume for now that we only care about the top level for a surface drifter + uvCell(1,aVertex) = alpha * uVertexVelocity(iHigh, theVertex) + & + (1.0_RKIND - alpha) * uVertexVelocity(iLow, theVertex) + uvCell(2,aVertex) = alpha * vVertexVelocity(iHigh, theVertex) + & + (1.0_RKIND - alpha) * vVertexVelocity(iLow, theVertex) + uvCell(3,aVertex) = alpha * wVertexVelocity(iHigh, theVertex) + & + (1.0_RKIND - alpha) * wVertexVelocity(iLow, theVertex) + end do + end if + + end subroutine interp_nodal_vectors!}}} + +!*********************************************************************** +! +! routine zero_boundary_nodal_values +! +!> \brief Enfore boundary condition for nodal value, setting to 0 +!> \author Phillip Wolfram +!> \date 05/27/2014 +!> \details +!> This routine ensures zero Dirchilet boundary conditions +!> (commonly for the nodal velocity) +! +!----------------------------------------------------------------------- + subroutine zero_boundary_nodal_values(nCellVertices, verticesOnCell, & !{{{ + boundaryVertex, uvCell) + + implicit none + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + integer, dimension(:), intent(in) :: verticesOnCell !< list of vertex indices on cell + integer, intent(in) :: nCellVertices !< number of cell vertices + integer, dimension(:), intent(in) :: boundaryVertex !< boundary vertices for particular level + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + real (kind=RKIND), dimension(:,:), intent(out) :: uvCell !< components of vertex velocity (vertically selected) + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + integer :: aVertex, theVertex + + ! make sure to mask all boundary vertexes to be zero to enforce boundary conditions + do aVertex = 1, nCellVertices + theVertex = verticesOnCell(aVertex) + !write(stderrUnit,*) boundaryVertex(theVertex) + ! make all the boundary values be zero to prevent particle from horizontally leaving cell + uvCell(1,aVertex) = uvCell(1,aVertex) * (1-boundaryVertex(theVertex)) + uvCell(2,aVertex) = uvCell(2,aVertex) * (1-boundaryVertex(theVertex)) + uvCell(3,aVertex) = uvCell(3,aVertex) * (1-boundaryVertex(theVertex)) + end do + + end subroutine zero_boundary_nodal_values!}}} + +!*********************************************************************** +! +! routine get_bounding_indices +! +!> \brief Get indices for high and low values for interpolation +!> \author Phillip Wolfram +!> \date 05/28/2014 +!> \details +!> This routine returns the indices (iLow, iHigh) on either side of phiInterp +! +!----------------------------------------------------------------------- + subroutine get_bounding_indices(iLow, iHigh, phiInterp, phiVals, iLevel, nVertLevels) !{{{ + + implicit none + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + integer, intent(in) :: iLevel !< vertical level / cell of phiInterp + integer, intent(in) :: nVertLevels !< number of vertical levels + real (kind=RKIND), intent(in) :: phiInterp !< location to interpolate + real (kind=RKIND), dimension(:), intent(in) :: phiVals !< values at elevation of cell middle (where vertex velocities are defined) + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: iLow, iHigh !< interpolation indices + + ! assumes increasing index is in decreasing phi space, and phiInterp in range of phiVals + !write(stderrUnit,*) 'phiInterp = ', phiInterp, 'phiVals = ', phiVals, 'nVertLevels = ', nVertLevels, 'iLevel = ', iLevel + if(phiInterp > phiVals(iLevel)) then + iHigh = iLevel + 1 + iLow = iLevel + else + iHigh = iLevel + iLow = iLevel + 1 + end if + + ! check to make sure points are in range + ! optimization point: smarter algorithm won't have to call this ever + if(.not.((phiInterp <= phiVals(iHigh)) .and. (phiInterp >= phiVals(iLow)))) then + !write(stderrUnit,*) 'fast interpolation failed, trying general, brute force search for interpolation bounds' + !write(stderrUnit,*) 'iLow = ', iLow, ' iHigh = ', iHigh + !write(stderrUnit,*) 'phiInterp = ', phiInterp , ' phiLow =', phiVals(iLow), ' phiHigh = ', phiVals(iHigh) + call get_bounding_indices_brute_force(nVertLevels, phiInterp, phiVals, iLow, iHigh) + end if + + end subroutine get_bounding_indices !}}} + +!*********************************************************************** +! +! routine get_bounding_indices_brute_force +! +!> \brief Get the interpolation bounds via brute force +!> \author Phillip Wolfram +!> \date 05/27/2014 +!> \details +!> This routine finds the interpolation bounds directly (brute force). +! +!----------------------------------------------------------------------- + subroutine get_bounding_indices_brute_force(nVertLevels, phiInterp, phiVals, iLow, iHigh) !{{{ + + implicit none + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + integer, intent(in) :: nVertLevels !< number of vertical levels + real (kind=RKIND), intent(in) :: phiInterp !< location to interpolate + real (kind=RKIND), dimension(:), intent(in) :: phiVals !< values at elevation of cell middle (where vertex velocities are defined) + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: iLow, iHigh !< indexes for the high and low components for the interpolant + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + integer :: aLevel + + ! make no assumptions + do aLevel = 1, nVertLevels-1 + if(phiVals(aLevel) <= phiInterp .and. phiInterp <= phiVals(aLevel+1)) then + iLow = aLevel + iHigh = aLevel+1 + exit + else if (phiVals(aLevel+1) <= phiInterp .and. phiInterp <= phiVals(aLevel)) then + iLow = aLevel+1 + iHigh = aLevel + exit + end if + end do + +#ifdef MPAS_DEBUG + if(phiVals(iLow) <= phiInterp .and. phiInterp <= phiVals(iHigh)) then + ! we are ok + !write(stderrUnit,*) 'brute force interpolation successful' + !write(stderrUnit,*) 'iLow = ', iLow, ' iHigh = ', iHigh + !write(stderrUnit,*) 'phiInterp = ', phiInterp , ' phiLow =', phiVals(iLow), ' phiHigh = ', phiVals(iHigh) + else + write(stderrUnit,*) 'brute force interpolation failed with phiInterp = ', phiInterp, ' phiLow = ', phiVals(iLow), ' phiHigh = ', phiVals(iHigh) + !write(stderrUnit,*) ' phiVals = ', phiVals(1:nVertLevels) + end if + + write(stderrUnit,*) 'Warning!: brute force interpolation used, boundary condition may be wrong!' +#endif + + end subroutine get_bounding_indices_brute_force!}}} + +!*********************************************************************** +! +! routine interp_vert_velocity_to_zlevel +! +!> \brief Interpolate the vertical velcity to a z level +!> \author Phillip Wolfram +!> \date 05/08/2014 +!> \details +!> This routine interpolates the vertical velocity to a particular +!> z-level. +! +!----------------------------------------------------------------------- + real (kind=RKIND) function interp_vert_velocity_to_zlevel( & !{{{ + iLevel, zSubStep, zTop, vertVelocityTop) + + implicit none + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + integer, intent(in) :: iLevel !< vertical level / cell of zSubStep + real (kind=RKIND), intent(in) :: zSubStep !< location to interpolate + real (kind=RKIND), dimension(:), intent(in) :: zTop !< elevation of cell top + real (kind=RKIND), dimension(:), intent(in) :: vertVelocityTop !< vertical velocity at top of cell + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + !real (kind=RKIND), intent(out) :: interp_vert_velocity_to_zlevel + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + real (kind=RKIND) :: alpha + + if(iLevel < 1) then + if(iLevel == 0) then + interp_vert_velocity_to_zlevel = vertVelocityTop(maxloc(zTop,1)) + else if(iLevel == -1) then + interp_vert_velocity_to_zlevel = vertVelocityTop(minloc(zTop,1)) + end if + else + ! interpolate the velocity [assumes zTop(iLevel+1) <= zSubStep <= zTop(iLevel)] + if (zTop(iLevel+1) <= zSubStep .and. zSubStep <= zTop(iLevel)) then + alpha = (zSubStep - zTop(iLevel+1))/(zTop(iLevel)- zTop(iLevel+1)) + else if (zTop(iLevel) <= zSubStep .and. zSubStep <= zTop(iLevel+1)) then + alpha = (zSubStep - zTop(iLevel))/(zTop(iLevel+1)- zTop(iLevel)) +#ifdef MPAS_DEBUG + else + write(stderrUnit,*) 'Error with vertical velocity interpolation!' +#endif + end if + interp_vert_velocity_to_zlevel = alpha * vertVelocityTop(iLevel)+ (1.0_RKIND - alpha) * vertVelocityTop(iLevel+1) + end if + + end function interp_vert_velocity_to_zlevel!}}} + +!*********************************************************************** +! +! routine time_interp_field +! +!> \brief Interpolate a field in time +!> \author Phillip Wolfram +!> \date 07/16/2014 +!> \details +!> This routine interpolates a field in time over multiple levels. +! +!----------------------------------------------------------------------- + subroutine time_interp_field(basePool, timeInterpOrder, timeCoeff, field, fieldname) !{{{ + implicit none + + type (mpas_pool_type), pointer, intent(in) :: basePool + integer, intent(in) :: timeInterpOrder + real (kind=RKIND), dimension(:), intent(in) :: timeCoeff + real (kind=RKIND), dimension(:,:), pointer, intent(out) :: field + character(len=*), intent(in) :: fieldname + + real (kind=RKIND), dimension(:,:), pointer :: tempfield + integer :: aTimeLevel + + field = 0.0_RKIND + do aTimeLevel = 1, timeInterpOrder + call mpas_pool_get_array(basePool, trim(fieldname), tempfield, timeLevel=aTimeLevel) + field = field + timeCoeff(aTimeLevel) * tempfield + end do + + end subroutine time_interp_field !}}} +!}}} + +end module ocn_lagrangian_particle_tracking + +! vim: foldmethod=marker diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_interpolations.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_interpolations.F new file mode 100644 index 0000000000..6a3821bd37 --- /dev/null +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_interpolations.F @@ -0,0 +1,616 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!*********************************************************************** +! +! ocn_lagrangian_particle_tracking_interpolations +! +!> \brief LIGHT Vector reconstruction and filtering module +!> \author Phillip J. Wolfram +!> \date 07/21/2015 +!> \details +!> This module provides routines for performing vector interpolations +!> and spatial filtering. +! +!----------------------------------------------------------------------- +module ocn_lagrangian_particle_tracking_interpolations + + use mpas_derived_types + use mpas_constants + use mpas_rbf_interpolation + use mpas_geometry_utils + use mpas_vector_reconstruction + + implicit none + + contains + +!*********************************************************************** +! +! routine ocn_vertex_reconstruction +! +!> \brief Reconstruct vertex velocity driver / interface +!> \author Phillip Wolfram +!> \date 03/27/2014 +!> \details +!> Purpose: reconstruct vector field at vertex locations based on +!> particular choice of reconstruction method +!> Input: mesh meta data and vector component data residing at cell edges +!> initialize_weights logical is to determine if weights should be initialized +!> Output: reconstructed vector field (measured in X,Y,Z) located at vertices +!----------------------------------------------------------------------- + subroutine ocn_vertex_reconstruction(filterNum, meshPool, scratchPool, particleCellPool, layerThickness, u, uvReconstructX, uvReconstructY, uvReconstructZ )!{{{ + + implicit none + + type (mpas_pool_type), pointer, intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), pointer, intent(in) :: scratchPool !< Input: Scratch variables + type (mpas_pool_type), pointer, intent(in) :: particleCellPool !< Input: particlefield variables + integer, intent(in) :: filterNum ! filtering strength employed + real (kind=RKIND), dimension(:,:), pointer, intent(in) :: layerThickness !< Input: layerThickness on cells + real (kind=RKIND), dimension(:,:), pointer, intent(in) :: u !< Input: Velocity field on edges (normalVelocity) + type (field2DReal), pointer, intent(out) :: uvReconstructX !< Output: X Component of velocity reconstructed to vertices + type (field2DReal), pointer, intent(out) :: uvReconstructY !< Output: Y Component of velocity reconstructed to vertices + type (field2DReal), pointer, intent(out) :: uvReconstructZ !< Output: Z Component of velocity reconstructed to vertices + + ! could add additional reconstruction techniques here with switch if desired + + ! assumption is made that mpas_init_reconstruct was previously called + call ocn_RBFvertex(meshPool, filterNum, layerThickness, u, uvReconstructX, uvReconstructY, uvReconstructZ, .false., scratchPool, particleCellPool) + + end subroutine ocn_vertex_reconstruction!}}} + +!*********************************************************************** +! +! routine ocn_RBFvertex +! +!> \brief Reconstruct vertex velocity using linear interpolation of +!> RBFs reconstruction at cell centers +!> \author Phillip Wolfram, Todd Ringler +!> \date 03/26/2014 +!> \details +!> Purpose: reconstruct vector field at vertex locations based on radial basis functions +!> Input: mesh meta data and vector component data residing at cell edges +!> initialize_weights logical is to determine if weights should be initialized +!> Output: reconstructed vector field (measured in X,Y,Z) located at vertices +!----------------------------------------------------------------------- + subroutine ocn_RBFvertex(meshPool, filterNum, layerThickness, u, uvReconstructX, uvReconstructY, uvReconstructZ, initialize_weights, scratchPool, particleCellPool)!{{{ + + implicit none + + ! inputs + type (mpas_pool_type), pointer, intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), pointer, intent(in) :: scratchPool + type (mpas_pool_type), pointer, intent(in) :: particleCellPool !< Input: particlefield variables + real (kind=RKIND), dimension(:,:), pointer, intent(in) :: u !< Input: Velocity field on edges + real (kind=RKIND), dimension(:,:), pointer, intent(in) :: layerThickness !< Input: layerThickness on cells + integer, intent(in) :: filterNum !< number of times to filter + logical, intent(in) :: initialize_weights !< Input: Determine if weights for RBF should be pre-computed + + ! outputs + type (field2DReal), pointer, intent(out) :: uvReconstructX !< Output: X Component of velocity reconstructed to vertices + type (field2DReal), pointer, intent(out) :: uvReconstructY !< Output: Y Component of velocity reconstructed to vertices + type (field2DReal), pointer, intent(out) :: uvReconstructZ !< Output: Z Component of velocity reconstructed to vertices + + ! local / temporary arrays needed in the compute procedure + type (field2DReal), pointer :: & + ucReconstructX, ucReconstructY, ucReconstructZ, ucReconstructZonal, ucReconstructMeridional ! cell center values + type (field2DReal), pointer :: ucStore, vcStore, wcStore + type (field2DInteger), pointer :: boundaryVertex, boundaryCell, boundaryCellGlobal, boundaryVertexGlobal + + ! get pointers + call mpas_pool_get_field(scratchPool, 'ucReconstructX', ucReconstructX) + call mpas_pool_get_field(scratchPool, 'ucReconstructY', ucReconstructY) + call mpas_pool_get_field(scratchPool, 'ucReconstructZ', ucReconstructZ) + call mpas_pool_get_field(scratchPool, 'ucReconstructZonal', ucReconstructZonal) + call mpas_pool_get_field(scratchPool, 'ucReconstructMeridional', ucReconstructMeridional) + call mpas_pool_get_field(scratchPool, 'boundaryVertexGlobal', boundaryVertexGlobal) + + ! allocate memory + call mpas_allocate_scratch_field(ucReconstructX, .True.) + call mpas_allocate_scratch_field(ucReconstructY, .True.) + call mpas_allocate_scratch_field(ucReconstructZ, .True.) + call mpas_allocate_scratch_field(ucReconstructZonal, .True.) + call mpas_allocate_scratch_field(ucReconstructMeridional, .True.) + call mpas_allocate_scratch_field(boundaryVertexGlobal, .True.) + + ucReconstructX % array = 0.0_RKIND + ucReconstructY % array = 0.0_RKIND + ucReconstructZ % array = 0.0_RKIND + + ! initialize weights (should be pre-initialized) + if (initialize_weights) then + call mpas_init_reconstruct(meshPool) + end if + + ! get cell center reconstructed RBF values + call mpas_reconstruct(meshPool, u, ucReconstructX % array, ucReconstructY % array, ucReconstructZ % array, & + ucReconstructZonal % array, ucReconstructMeridional % array) + + ! need to do exchange for uc components (we don't use Zonal / Meridional for this calculation) + call mpas_dmpar_exch_halo_field(ucReconstructX) + call mpas_dmpar_exch_halo_field(ucReconstructY) + call mpas_dmpar_exch_halo_field(ucReconstructZ) + + ! get boundaries + call mpas_pool_get_field(meshPool,'boundaryVertex', boundaryVertex) + call mpas_pool_get_field(meshPool,'boundaryCell', boundaryCell) + + + if (filternum > 0) then + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! filter the cell velocity field + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call ocn_second_order_shapiro_filter_ops(filterNum, meshPool, scratchPool, boundaryVertex, boundaryCell, & + layerThickness, ucReconstructX, ucReconstructY, ucReconstructZ) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! store filter data & + ! write data to file for output + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call mpas_pool_get_field(particleCellPool, 'filteredVelocityU', ucStore) + call mpas_pool_get_field(particleCellPool, 'filteredVelocityV', vcStore) + call mpas_pool_get_field(particleCellPool, 'filteredVelocityW', wcStore) + ucStore % array = ucReconstructX % array + vcStore % array = ucReconstructY % array + wcStore % array = ucReconstructZ % array + + end if + + ! interpolate to vertex locations for use in Wachspress + call ocn_vector_cell_center_to_vertex(meshPool, boundaryVertex % array, boundaryCell % array, & + ucReconstructX % array, ucReconstructY % array, ucReconstructZ % array, & + uvReconstructX % array, uvReconstructY % array, uvReconstructZ % array) + + ! handle boundary vertices (should be zero). Can potentially remove if mpas_init_block initializes to 0 vs -1e34 + boundaryVertexGlobal % array = boundaryVertex % array + call mpas_dmpar_exch_halo_field(boundaryVertexGlobal) + ! definite change between these fields! + uvReconstructX % array = uvReconstructX % array * (1.0_RKIND - boundaryVertexGlobal % array) + uvReconstructY % array = uvReconstructY % array * (1.0_RKIND - boundaryVertexGlobal % array) + uvReconstructZ % array = uvReconstructZ % array * (1.0_RKIND - boundaryVertexGlobal % array) + + ! do halo exchanges + call mpas_dmpar_exch_halo_field(uvReconstructX) + call mpas_dmpar_exch_halo_field(uvReconstructY) + call mpas_dmpar_exch_halo_field(uvReconstructZ) + + ! deallocate memory + call mpas_deallocate_scratch_field(ucReconstructX, .True.) + call mpas_deallocate_scratch_field(ucReconstructY, .True.) + call mpas_deallocate_scratch_field(ucReconstructZ, .True.) + call mpas_deallocate_scratch_field(ucReconstructZonal, .True.) + call mpas_deallocate_scratch_field(ucReconstructMeridional, .True.) + call mpas_deallocate_scratch_field(boundaryVertexGlobal, .True.) + + end subroutine ocn_RBFvertex!}}} + +!*********************************************************************** +! +! routine ocn_vector_cell_center_to_vertex +! +!> \brief Interpolate cell center values to vertex values +!> \author Phillip Wolfram +!> \date 05/27/2014 +!> \details +!> Purpose: interpolate vector field at vertex locations from cell center values +!> using Barycentric (via Wachspress) interpolation +!> Input: cell center data and mesh information +!> Output: interpolated vertex values +!----------------------------------------------------------------------- + subroutine ocn_vector_cell_center_to_vertex(meshPool, boundaryVertex, boundaryCell, & !{{{ + ucReconstructX, ucReconstructY, ucReconstructZ, & + uvReconstructX, uvReconstructY, uvReconstructZ) + + implicit none + + ! input variables + type (mpas_pool_type), pointer, intent(in) :: meshPool !< Input: Mesh information + real (kind=RKIND), dimension(:,:), pointer, intent(in) :: ucReconstructX, ucReconstructY, ucReconstructZ !< Input: Cell center values + integer, dimension(:,:), pointer, intent(in) :: boundaryVertex, boundaryCell !< Input: Boundary flags + + ! output variables + real (kind=RKIND), dimension(:,:), pointer, intent(out) :: uvReconstructX !< Output: X Component of velocity reconstructed to vertices + real (kind=RKIND), dimension(:,:), pointer, intent(out) :: uvReconstructY !< Output: Y Component of velocity reconstructed to vertices + real (kind=RKIND), dimension(:,:), pointer, intent(out) :: uvReconstructZ !< Output: Z Component of velocity reconstructed to vertices + + ! local variables + integer, pointer :: nVerticesSolve, nCells, vertexDegree, nVertLevels + integer :: aVertex, aCell, aLevel + integer, dimension(:,:), pointer :: cellsOnVertex + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + ! temporary arrays needed in the (to be constructed) init procedure + ! note that lambda is going to be constant for this and could be cached + real (kind=RKIND), dimension(:), allocatable :: lambda + real (kind=RKIND), dimension(:,:), allocatable :: pointVertex + real (kind=RKIND), dimension(3) :: pointInterp + real (kind=RKIND) :: xp,yp,zp , sumArea, kiteArea + + uvReconstructX = 0.0_RKIND + uvReconstructY = 0.0_RKIND + uvReconstructZ = 0.0_RKIND + + call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) + + allocate(lambda(vertexDegree), pointVertex(3,vertexDegree)) + + ! setup pointers + call mpas_pool_get_dimension(meshPool, 'nVerticesSolve', nVerticesSolve) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) + + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + + call mpas_pool_get_array(meshPool, 'kiteAreasOnVertex', kiteAreasOnVertex) + + ! loop over all vertices + do aVertex = 1, nVerticesSolve + ! could precompute the list as an optimization + ! really, condition is any boundaryVertex in column greater than 0 + if(any(boundaryVertex(:,aVertex) < 1)) then + ! get vertex location and cell center locations + do aCell = 1, vertexDegree + pointVertex(1,aCell) = xCell(cellsOnVertex(aCell, aVertex)) + pointVertex(2,aCell) = yCell(cellsOnVertex(aCell, aVertex)) + pointVertex(3,aCell) = zCell(cellsOnVertex(aCell, aVertex)) + end do + ! vertex point for reconstruction + pointInterp(1) = xVertex(aVertex) + pointInterp(2) = yVertex(aVertex) + pointInterp(3) = zVertex(aVertex) + ! get interpolation constants (could be cached) + lambda = mpas_wachspress_coordinates(vertexDegree, pointVertex , pointInterp, meshPool) + else + lambda = 0.0_RKIND + end if + + do aLevel = 1, nVertLevels + if(boundaryVertex(aLevel,aVertex) < 1) then + ! perform interpolation + uvReconstructX(aLevel,aVertex) = sum(ucReconstructX(aLevel,cellsOnVertex(:,aVertex)) * lambda) + uvReconstructY(aLevel,aVertex) = sum(ucReconstructY(aLevel,cellsOnVertex(:,aVertex)) * lambda) + uvReconstructZ(aLevel,aVertex) = sum(ucReconstructZ(aLevel,cellsOnVertex(:,aVertex)) * lambda) + end if + end do + + ! need to specify boundary conditions for the vertexes (outside this subroutine) + + end do + + deallocate(lambda, pointVertex) + + end subroutine ocn_vector_cell_center_to_vertex!}}} + +!*********************************************************************** +! +! routine ocn_vector_vertex_to_cell_center +! +!> \brief Interpolate vertex values to cell center +!> \author Phillip Wolfram +!> \date 08/01/2014 +!> \details +!> Purpose: interpolate vector field at cell center locations from vertex values +!> using Wachspress interpolation +!> Input: vertex vector data and mesh information +!> Output: interpolated cell values +!----------------------------------------------------------------------- + subroutine ocn_vector_vertex_to_cell_center(meshPool, & !{{{ + uvReconstructX, uvReconstructY, uvReconstructZ, & + ucReconstructX, ucReconstructY, ucReconstructZ) + + implicit none + + ! input variables + type (mpas_pool_type), pointer, intent(in) :: meshPool !< Input: Mesh information + real (kind=RKIND), dimension(:,:), pointer, intent(in) :: uvReconstructX, uvReconstructY, uvReconstructZ !< Input: Vertex values + + ! output variables + real (kind=RKIND), dimension(:,:), pointer, intent(out) :: ucReconstructX !< Output: X Component of velocity reconstructed to cells + real (kind=RKIND), dimension(:,:), pointer, intent(out) :: ucReconstructY !< Output: Y Component of velocity reconstructed to cells + real (kind=RKIND), dimension(:,:), pointer, intent(out) :: ucReconstructZ !< Output: Z Component of velocity reconstructed to cells + + ! local variables + integer, pointer :: nCellsSolve, nVertLevels + integer, dimension(:), pointer :: nEdgesOnCell + integer :: aVertex, aCell, aLevel, nLocalVertices + integer, dimension(:,:), pointer :: verticesOnCell + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xVertex, yVertex, zVertex + ! temporary arrays needed in the (to be constructed) init procedure + ! note that lambda is going to be constant for this and could be cached + real (kind=RKIND), dimension(:), allocatable :: lambda + real (kind=RKIND), dimension(3) :: pointInterp + real (kind=RKIND), dimension(:,:), allocatable :: pointVertex + real (kind=RKIND) :: xp,yp,zp + + ucReconstructX = 0.0_RKIND + ucReconstructY = 0.0_RKIND + ucReconstructZ = 0.0_RKIND + + ! setup pointers + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(meshPool, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) + + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + + + ! loop over all vertices + do aCell = 1, nCellsSolve + ! could precompute the list as an optimization to + ! remove the following lines !{{{ + nLocalVertices = nEdgesOnCell(aCell) + ! really, condition is any boundaryVertex in column greater than 0 + allocate(lambda(nLocalVertices), pointVertex(3,nLocalVertices)) + ! get vertex location and cell center locations + do aVertex = 1, nLocalVertices + pointVertex(1,aVertex) = xVertex(verticesOnCell(aVertex, aCell)) + pointVertex(2,aVertex) = yVertex(verticesOnCell(aVertex, aCell)) + pointVertex(3,aVertex) = zVertex(verticesOnCell(aVertex, aCell)) + end do + ! vertex point for reconstruction + pointInterp(1) = xCell(aCell) + pointInterp(2) = yCell(aCell) + pointInterp(3) = zCell(aCell) + ! get interpolation constants (should be cached as an optimization!) + lambda = mpas_wachspress_coordinates(nLocalVertices, pointVertex , pointInterp, meshPool) + !}}} + + do aLevel = 1, nVertLevels + ! perform interpolation + ucReconstructX(aLevel,aCell) = sum(uvReconstructX(aLevel,verticesOnCell(1:nLocalVertices,aCell)) * lambda) + ucReconstructY(aLevel,aCell) = sum(uvReconstructY(aLevel,verticesOnCell(1:nLocalVertices,aCell)) * lambda) + ucReconstructZ(aLevel,aCell) = sum(uvReconstructZ(aLevel,verticesOnCell(1:nLocalVertices,aCell)) * lambda) + end do + + deallocate(lambda, pointVertex) + end do + + end subroutine ocn_vector_vertex_to_cell_center !}}} + +!*********************************************************************** +! +! routine ocn_second_order_shapiro_filter_ops +! +!> \brief Do Ntimes simple shapiro filtering operations, but make +!> higher order +!> \author Phillip Wolfram +!> \date 08/01/2014 +!> \details +!> Purpose: multiple applications of digital shapiro filter (discrete Laplacian) +!> Input: cell centered data and mesh information +!> Output: filtered cell values +!----------------------------------------------------------------------- + subroutine ocn_second_order_shapiro_filter_ops(Ntimes, meshPool, scratchPool, boundaryVertex, boundaryCell, & + layerThickness, ucReconstructX, ucReconstructY, ucReconstructZ) !{{{ + implicit none + + type (mpas_pool_type), pointer, intent(in) :: meshPool, scratchPool + type (field2DInteger), pointer, intent(in) :: boundaryVertex, boundaryCell + type (field2DReal), pointer, intent(inout) :: ucReconstructX, ucReconstructY, ucReconstructZ ! cell center values + integer, intent(in) :: Ntimes ! number of filter applications + real (kind=RKIND), dimension(:,:), pointer, intent(in) :: layerThickness + + type (field2DReal), pointer :: ucStore, vcStore, wcStore + + call mpas_pool_get_field(scratchPool,'ucX',ucStore) + call mpas_pool_get_field(scratchPool,'ucY',vcStore) + call mpas_pool_get_field(scratchPool,'ucZ',wcStore) + call mpas_allocate_scratch_field(ucStore,.True.) + call mpas_allocate_scratch_field(vcStore,.True.) + call mpas_allocate_scratch_field(wcStore,.True.) + + + call ocn_multiple_vector_shapiro_filter_ops(Ntimes, meshPool, scratchPool, boundaryVertex, boundaryCell, & + layerThickness, ucReconstructX, ucReconstructY, ucReconstructZ) + ucStore % array = 2.0_RKIND*ucReconstructX % array + vcStore % array = 2.0_RKIND*ucReconstructY % array + wcStore % array = 2.0_RKIND*ucReconstructZ % array + call ocn_multiple_vector_shapiro_filter_ops(Ntimes, meshPool, scratchPool, boundaryVertex, boundaryCell, & + layerThickness, ucReconstructX, ucReconstructY, ucReconstructZ) + ucStore % array = ucStore % array - ucReconstructX % array + vcStore % array = vcStore % array - ucReconstructY % array + wcStore % array = wcStore % array - ucReconstructZ % array + + ! move temporary storage into final storage + ucReconstructX % array = ucStore % array + ucReconstructY % array = vcStore % array + ucReconstructZ % array = wcStore % array + + ! deallocate temporary memory + call mpas_deallocate_scratch_field(ucStore,.True.) + call mpas_deallocate_scratch_field(vcStore,.True.) + call mpas_deallocate_scratch_field(wcStore,.True.) + + end subroutine ocn_second_order_shapiro_filter_ops !}}} + +!*********************************************************************** +! +! routine ocn_multiple_vector_shapiro_filter_ops +! +!> \brief Do Ntimes simple shapiro filtering operations +!> \author Phillip Wolfram +!> \date 08/01/2014 +!> \details +!> Purpose: multiple applications of digital shapiro filter (discrete Laplacian) +!> Input: cell centered data and mesh information +!> Output: filtered cell values +!----------------------------------------------------------------------- + subroutine ocn_multiple_vector_shapiro_filter_ops(Ntimes, meshPool, scratchPool, boundaryVertex, boundaryCell, & + layerThickness, ucReconstructX, ucReconstructY, ucReconstructZ) !{{{ + implicit none + + type (mpas_pool_type), pointer, intent(in) :: meshPool, scratchPool + type (field2DInteger), pointer, intent(in) :: boundaryVertex, boundaryCell + type (field2DReal), pointer, intent(inout) :: ucReconstructX, ucReconstructY, ucReconstructZ ! cell center values + real (kind=RKIND), dimension(:,:), pointer, intent(in) :: layerThickness + integer, intent(in) :: Ntimes ! number of filter applications + + ! local variables + integer atime + + do atime = 1,Ntimes + !call ocn_simple_vector_shapiro_filter(meshPool, scratchPool, boundaryVertex, boundaryCell, & + ! ucReconstructX, ucReconstructY, ucReconstructZ) + call ocn_simple_vector_laplacian_filter(meshPool, scratchPool, boundaryCell % array, layerThickness, ucReconstructX % array) + call ocn_simple_vector_laplacian_filter(meshPool, scratchPool, boundaryCell % array, layerThickness, ucReconstructY % array) + call ocn_simple_vector_laplacian_filter(meshPool, scratchPool, boundaryCell % array, layerThickness, ucReconstructZ % array) + + end do + + end subroutine ocn_multiple_vector_shapiro_filter_ops !}}} + +!*********************************************************************** +! +! routine ocn_simple_vector_laplacian_filter +! +!> \brief Do 1 pass of simple laplacian filter +!> \author Phillip Wolfram +!> \date 08/01/2014 +!> \details +!> Purpose: one pass of digital shapiro filter (discrete Laplacian) +!> Input: cell centered data and mesh information +!> Output: filtered cell values +!----------------------------------------------------------------------- + subroutine ocn_simple_vector_laplacian_filter(meshPool, scratchPool, boundaryCell, layerThickness, ucReconstruct) !{{{ + implicit none + + type (mpas_pool_type), pointer, intent(in) :: meshPool, scratchPool + integer, dimension(:,:), pointer, intent(in) :: boundaryCell + real (kind=RKIND), dimension(:,:), pointer, intent(inout) :: ucReconstruct + real (kind=RKIND), dimension(:,:), pointer, intent(in) :: layerThickness + + ! local variables + type (field2DReal), pointer :: ucTemp + integer :: aCell, aNeigh, aLevel + integer, pointer :: nCellsSolve, nVertLevels + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnCell + real (kind=RKIND), dimension(:), pointer :: areaCell + real (kind=RKIND) :: volSum, cellVol + + ! allocate scratch memory + call mpas_pool_get_field(scratchPool, 'ucTemp', ucTemp) + call mpas_allocate_scratch_field(ucTemp,.True.) + + ! get values from pools + call mpas_pool_get_dimension(meshPool,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(meshPool,'nVertLevels',nVertLevels) + call mpas_pool_get_array(meshPool,'nEdgesOnCell',nEdgesOnCell) + call mpas_pool_get_array(meshPool,'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool,'areaCell',areaCell) + + ucTemp % array = 0.0_RKIND + + ! perform laplacian filtering + do aCell = 1, nCellsSolve + do aLevel = 1, nVertLevels + volSum = nEdgesOnCell(aCell) * layerThickness(aLevel,aCell) * areaCell(aCell) * (1-boundaryCell(aLevel,aCell)) + ucTemp % array(aLevel, aCell) = ucReconstruct(aLevel, aCell) * volSum + if (volSum /= 0 ) then + ! loop over all neighbors + do aNeigh = 1, nEdgesOnCell(aCell) + cellVol = layerThickness(aLevel,cellsOnCell(aNeigh,aCell)) * areaCell(cellsOnCell(aNeigh,aCell)) & + * (1-boundaryCell(aLevel, cellsOnCell(aNeigh,aCell))) + volSum = volSum + cellVol + ucTemp % array(aLevel, aCell) = ucTemp % array(aLevel, aCell) + ucReconstruct(aLevel,cellsOnCell(aNeigh,aCell))* cellVol + end do + ucTemp % array(aLevel, aCell) = ucTemp % array(aLevel, aCell) / volSum + end if + end do + end do + + ! exchange halo values + call mpas_dmpar_exch_halo_field(ucTemp) + + ! replace input values with filtered values + ucReconstruct = ucTemp % array + + ! deallocate scratch memory + call mpas_deallocate_scratch_field(ucTemp , .True.) + + end subroutine ocn_simple_vector_laplacian_filter !}}} + +!*********************************************************************** +! +! routine ocn_simple_vector_shapiro_filter +! +!> \brief Do 1 pass of simple shapiro filter +!> \author Phillip Wolfram +!> \date 08/01/2014 +!> \details +!> Purpose: one pass of digital shapiro filter to vertexes, back to cells +!> Input: cell centered data and mesh information +!> Output: filtered cell values +!----------------------------------------------------------------------- + subroutine ocn_simple_vector_shapiro_filter(meshPool, scratchPool, boundaryVertex, boundaryCell, & + ucReconstructX, ucReconstructY, ucReconstructZ) !{{{ + implicit none + + type (mpas_pool_type), pointer, intent(in) :: meshPool, scratchPool + type (field2DInteger), pointer, intent(in) :: boundaryVertex, boundaryCell + type (field2DReal), pointer, intent(inout) :: ucReconstructX, ucReconstructY, ucReconstructZ ! cell center values + + ! local variables + type (field2DReal), pointer :: uvX , uvY, uvZ ! cell center values + + ! allocate scratch memory + call mpas_pool_get_field(scratchPool, 'uvX', uvX) + call mpas_pool_get_field(scratchPool, 'uvY', uvY) + call mpas_pool_get_field(scratchPool, 'uvZ', uvZ) + call mpas_allocate_scratch_field(uvX,.True.) + call mpas_allocate_scratch_field(uvY,.True.) + call mpas_allocate_scratch_field(uvZ,.True.) + + uvX % array = 0.0_RKIND + uvY % array = 0.0_RKIND + uvZ % array = 0.0_RKIND + + ! perform filtering + + ! CC -> vertices + call ocn_vector_cell_center_to_vertex(meshPool, boundaryVertex % array, boundaryCell % array, & + ucReconstructX % array, ucReconstructY % array, ucReconstructZ % array, & + uvX % array, uvY % array, uvZ % array) + ! do halo exchanges + call mpas_dmpar_exch_halo_field(uvX) + call mpas_dmpar_exch_halo_field(uvY) + call mpas_dmpar_exch_halo_field(uvZ) + ! vertices -> CC + call ocn_vector_vertex_to_cell_center(meshPool, & + uvX % array, uvY % array, uvZ % array, & + ucReconstructX % array, ucReconstructY % array, ucReconstructZ % array) + ! do halo exchanges + call mpas_dmpar_exch_halo_field(ucReconstructX) + call mpas_dmpar_exch_halo_field(ucReconstructY) + call mpas_dmpar_exch_halo_field(ucReconstructZ) + + ! N.B., effect of forgetting halo exchange may be subtle for a single pass + + ! deallocate scratch memory + call mpas_deallocate_scratch_field(uvX , .True.) + call mpas_deallocate_scratch_field(uvY , .True.) + call mpas_deallocate_scratch_field(uvZ , .True.) + + end subroutine ocn_simple_vector_shapiro_filter !}}} + +end module ocn_lagrangian_particle_tracking_interpolations + diff --git a/src/core_ocean/analysis_members/mpas_ocn_particle_list.F b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F new file mode 100644 index 0000000000..cbcb704215 --- /dev/null +++ b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F @@ -0,0 +1,3986 @@ +! Copyright (c) 2014, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_particle_list +! +!> \brief Particle framework +!> \author Phillip Wolfram +!> \date 04/10/2014 +!> \details +!> This module contains a general definition of particles which can be +!> used in implementation of Lagrangian Particles Tracking. +!----------------------------------------------------------------------- + +module ocn_particle_list + + ! declare general packages used +#ifdef _MPI + use mpi +#endif + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_dmpar + use mpas_block_decomp + use mpas_pool_routines + + ! blanket statments to restrict implicit module's scope + implicit none + private + + ! mpi defines +#ifdef _MPI + integer, parameter :: MPI_INTEGERKIND = MPI_INTEGER + integer, parameter :: MPI_2INTEGERKIND = MPI_2INTEGER + +#ifdef SINGLE_PRECISION + integer, parameter :: MPI_REALKIND = MPI_REAL + integer, parameter :: MPI_2REALKIND = MPI_2REAL +#else + integer, parameter :: MPI_REALKIND = MPI_DOUBLE_PRECISION + integer, parameter :: MPI_2REALKIND = MPI_2DOUBLE_PRECISION +#endif +#endif + + ! custom structures defined in mpas_grid_types + + ! define private interfaces + + ! add routines + interface add_halo_data_to_particle_list + !(particlelist, dataName, data) + module procedure add_halo_data_to_particle_list_1Dreal + module procedure add_halo_data_to_particle_list_1Dint + end interface + + interface add_halo_data_to_particle_list_array + module procedure add_halo_data_to_particle_list_1Dreal_array + module procedure add_halo_data_to_particle_list_1Dint_array + end interface + + interface add_nonhalo_data_to_particle_list + !(particlelist, dataName, data) + module procedure add_nonhalo_data_to_particle_list_1Dreal + module procedure add_nonhalo_data_to_particle_list_1Dint + end interface + + interface add_nonhalo_data_to_particle_list_array + module procedure add_nonhalo_data_to_particle_list_1Dreal_array + module procedure add_nonhalo_data_to_particle_list_1Dint_array + end interface + + ! get routines + interface get_halo_data_from_particle_list + !(particlelist, dataName, data) + module procedure get_halo_data_from_particle_list_1Dreal + module procedure get_halo_data_from_particle_list_1Dint + end interface + + interface get_halo_data_from_particle_list_array + module procedure get_halo_data_from_particle_list_1Dreal_array + module procedure get_halo_data_from_particle_list_1Dint_array + end interface + + interface get_nonhalo_data_from_particle_list + !(particlelist, dataName, data) + module procedure get_nonhalo_data_from_particle_list_1Dreal + module procedure get_nonhalo_data_from_particle_list_1Dint + end interface + + interface get_nonhalo_data_from_particle_list_array + !(particlelist, dataName, data) + module procedure get_nonhalo_data_from_particle_list_1Dreal_array + module procedure get_nonhalo_data_from_particle_list_1Dint_array + end interface + + !----------------------------------------------------------------- + ! public routines and interfaces + !----------------------------------------------------------------- + ! define publically accessible subroutines, functions, interfaces + public :: mpas_particle_list_build_and_assign_particle_list + public :: mpas_particle_list_destroy_particle_list, mpas_particle_list_remove_particles_not_on_current_block + public :: mpas_particle_list_build_computation_halos, mpas_particle_list_build_io_halos + public :: mpas_particle_list_update_computational_halos, mpas_particle_list_update_io_halos + public :: mpas_particle_list_transfer_particles_from_block_to_named_block + public :: mpas_particle_list_write_halo_data, mpas_particle_list_write_nonhalo_data + public :: mpas_particle_list_test_neighscalc, mpas_particle_list_test_numparticles_to_neighprocs, mpas_particle_list_test_num_current_particlelist + + ! subroutine / function definition +contains + +!*********************************************************************** +! +! routine mpas_particle_list_build_and_assign_particle_list +! +!> \brief Allocates particles for initialization +!> \author Phillip Wolfram +!> \date 07/01/2014 +!> \details +!> This routine builds and allocates particlces following initalization +! +!----------------------------------------------------------------------- + subroutine mpas_particle_list_build_and_assign_particle_list(domain,err) !{{{ + implicit none + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + err = 0 + ! build / allocate the listPLSend, setting ioProc (currentBlock read in as haloData) + call build_block_particlelists(domain, err) + + + ! read in data from netCDF-injected data structures + ! nonhalo-data is diagnostic + call read_haloData(domain, err) + + ! note that nonhalo data is just initialized with 0 + ! values are not imported from netCDF input file + call read_nonhaloData(domain, err) + +#ifdef MPAS_DEBUG + call mpas_particle_list_test_num_current_particlelist(domain) +#endif + !! test to make sure deallocation is ok before transfer...!{{{ +#ifdef MPAS_DEBUG + write(stderrUnit,*) ' Trying to clear particlelist memory on blocks' + call clear_block_particlelists(domain,err) + call build_block_particlelists(domain, err) + call read_haloData(domain, err) + call read_nonhaloData(domain, err) + call mpas_particle_list_test_num_current_particlelist(domain) + call test_currentBlock(domain) + write(stderrUnit,*) ' Rebuilt data structures-- ok' +#endif + !}}} + end subroutine mpas_particle_list_build_and_assign_particle_list !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_particle_list_destroy_particle_list +! +!> \brief MPAS destroy particlelist +!> \author Phillip Wolfram +!> \date 06/27/2014 +!> \details +!> This routine destroys a particlelist, deallocating its memory +!> including that of all pointers it contains +! +!----------------------------------------------------------------------- +subroutine mpas_particle_list_destroy_particle_list(particlelist) !{{{ + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + type (mpas_particle_list_type), pointer :: pLCurr, pLCurrTemp + + if(associated(particlelist)) then + plCurr => particlelist + do while(associated(plCurr)) + pLCurrTemp => pLCurr + pLCurr => pLCurr % next + ! destroy the particle too + if(associated(pLCurrTemp % particle)) then + call destroy_particle(pLCurrTemp % particle) + end if + deallocate(pLCurrTemp) + end do + end if + +end subroutine mpas_particle_list_destroy_particle_list !}}} + +!*********************************************************************** +! +! routine mpas_particle_list_remove_particles_not_on_current_block +! +!> \brief Remove particles on block % particlelist that are not on currentBlock +!> \author Phillip Wolfram +!> \date 07/03/2014 +!> \details +!> This routine removes particles that were transfered strictly for IO. +!> If the particle's currentBlock is not the same as the current block, +!> the particle is removed. +! +!----------------------------------------------------------------------- + subroutine mpas_particle_list_remove_particles_not_on_current_block(domain, err) !{{{ + implicit none + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_particle_list_type), pointer :: particlelist, particlelisttemp, particlelisttemp2 + integer :: thisBlock + integer, pointer :: particleBlock + integer :: arrayIndex + !type (mpas_pool_type), pointer :: lagrPartTrackPool + type (mpas_particle_type), pointer :: particle + + err = 0 + + block => domain % blocklist + do while(associated(block)) + ! for each particle on each block + particlelist => block % particlelist + do while(associated(particlelist)) + particle => particlelist % particle + call mpas_pool_get_array(particle % haloDataPool, 'currentBlock', particleBlock) + + if(particleBlock /= block % blockID) then + ! REMOVE PARTICLE FROM EXISTING PARTICLELIST + ! remove particle and particle reference from existing particle list + ! 3 cases: head, middle, tail + + call destroy_particle(particle) + + if(associated(particlelist % prev)) then + particlelisttemp => particlelist % prev + if (associated(particlelist % next)) then + ! case of the middle + particlelisttemp % next => particlelist % next + particlelisttemp2 => particlelisttemp + ! want to keep particle memory intact because their pointers were passed previously, + ! so just empty the list, don't destroy it and its contents + particlelisttemp => particlelist % next + particlelisttemp % prev => particlelisttemp2 + ! just need to remove the single link, particle memory needs to stay intact + !deallocate(particlelist % particle) + deallocate(particlelist) + ! get next pointer + particlelist => particlelisttemp + else + ! case of tail + nullify(particlelisttemp % next) + !deallocate(particlelist % particle) + deallocate(particlelist) + ! set back to final + end if + else + if(associated(particlelist % next)) then + ! case of head, set new head (assumes more than one particle) + particlelisttemp => particlelist % next + nullify(particlelisttemp % prev) + block % particlelist => particlelisttemp + !deallocate(particlelist % particle) + deallocate(particlelist) + particlelist => particlelisttemp + else + ! case of single link / particle + !deallocate(particlelist % particle) + deallocate(particlelist) + nullify(block % particlelist) + end if + end if + else + particlelist => particlelist % next + end if + end do + + ! this is done for each block because we want processor - processor communication + block => block % next + end do + + end subroutine mpas_particle_list_remove_particles_not_on_current_block !}}} + +!*********************************************************************** +! +! routine mpas_particle_list_build_computation_halos +! +!> \brief Build up necessary info for communication of particle in +!> halo to neighboring cell during computation step. +!> \author Phillip Wolfram +!> \date 07/02/2014 +!> \details +!> This routine builds g_ProcNeighs which is the neighboring processor +!> list needed to process MPI communication, assuming a list of +!> particlelists is built up corresponding to the processors in this +!> array. The end result is that g_ProcNeighs is populated. +! +!----------------------------------------------------------------------- + subroutine mpas_particle_list_build_computation_halos(domain, err, procNeighs) !{{{ + implicit none + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + integer, dimension(:), pointer :: procNeighs + + err = 0 + + ! compute the cellOwnerBlock for cells + ! owning processor can be obtained from + ! mpas_get_owning_proc in mpas_block_decomp (src/framework) + call compute_cellOwnerBlock(domain, err) + + ! in order to mediate MPI exchanges, need to determine + ! 1. list of blockNeighs (global) + ! stored in block % blockNeighs + ! basically Neighs are processors who own the halo including itself + call compute_blockNeighs(domain, err) + + ! 2. list of procNeighs (extracted from blockNeighs, also global) + ! this information is necessary in order to know where to send data + ! (this is like a block exchange list for particles) + ! stored in block % procNeighs + ! this is just the list of processors who own blockNeighs + call compute_block_procNeighs(domain, err) + + ! need to aggregate procNeighs to be global for the processor (over each block on the + ! processor), total number of neighboring processors to a particular processor + call compute_procNeighs(domain, err, procNeighs) + + end subroutine mpas_particle_list_build_computation_halos !}}} + +!*********************************************************************** +! +! routine mpas_particle_list_build_io_halos +! +!> \brief Build the IO halo information to transmit particles from their +!> initial host IO processor to the appropriate currentBlock +!> processor. +!> \author Phillip Wolfram +!> \date 07/02/2014 +!> \details +!> This routine builds the IO halo information to transmit particles +!> from their initial host IO processor to the appropriate currentBlock +!> processor. The end result is that g_ioProcNeighs is populated. +! +!----------------------------------------------------------------------- + subroutine mpas_particle_list_build_io_halos(domain, err, namedBlock, ioProcNeighs) !{{{ + !{{{ initialization + implicit none + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + character(len=*), intent(in) :: namedBlock + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, dimension(:), pointer, intent(out) :: ioProcNeighs + integer, intent(out) :: err !< Output: error flag + + !}}} + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + integer, dimension(:), pointer :: currentBlocks, tempInt + integer :: i, nBlocks, nTotProcs, mpi_ierr + logical, dimension(:), pointer :: sendNeigh, recvNeigh + + err = 0 + + ! get unique list of currentBlock to determine all currentProcs + ! that the particles must be communicated to + ! determine complete set of ioProcs, which are assigned based on the + ! way that PIO decomposes the nParticle dimension. + ! at this point, processors owning the particle (at read-in) are + ! assumed to be the ioProcessor + call compute_all_particle_values_unique_int(domain, err, namedBlock, currentBlocks) + + nTotProcs = domain % dminfo % nprocs + allocate(sendNeigh(nTotProcs)) + allocate(recvNeigh(nTotProcs)) + sendNeigh = .false. + recvNeigh = .false. + + ! Get processors for currentBlocks. Note, however, this is one-sided because + ! only the IO processors know their send location, the receivers don't know + ! their sending processors + if(associated(currentBlocks)) then + nBlocks = size(currentBlocks) + !write(stderrUnit,*) 'nBlocks = ', nBlocks, ' currentBlocks = ', currentBlocks + allocate(ioProcNeighs(nBlocks)) + do i=1, nBlocks + call mpas_get_owning_proc(domain % dminfo, currentBlocks(i), ioProcNeighs(i)) + end do + + ! note, each ioProc knows where it is sending data. However, those processors + ! do not know they should receive data (their halos are empty). The halos + ! are not symmetric and the communication cannot occur unless this is fixed. + ! this is fixed via an all-to-all communication (only at initialization, otherwise + ! parallelism can be broken) + ! set counter for connectivity + do i=1,size(ioProcNeighs) + sendNeigh(ioProcNeighs(i)+1) = .true. + end do + deallocate(ioProcNeighs) + end if + +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'sendNeigh = ', sendNeigh + write(stderrUnit,*) 'recvNeigh= ', recvNeigh +#endif +#ifdef _MPI + !call MPI_Barrier(domain % dminfo % comm, mpi_ierr) +#endif + ! send with MPI all to update in recvNeigh (should only have to be done once) +#ifdef _MPI + call MPI_Alltoall(sendNeigh, 1, MPI_LOGICAL, recvNeigh, 1, MPI_LOGICAL, domain % dminfo % comm, mpi_ierr) +#endif +#ifdef _MPI + !call MPI_Barrier(domain % dminfo % comm, err) +#endif +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'Finished all to all with mpi_ierr = ', mpi_ierr + write(stderrUnit,*) 'sendNeigh = ', sendNeigh + write(stderrUnit,*) 'recvNeigh= ', recvNeigh + write(stderrUnit,*) 'communicate = ', sendNeigh .or. recvNeigh +#endif + + ! could possibly optimize here by keeping track of send / recv lists separately + ! however, if there is nothing to be sent the only message that is sent + ! is the number of particles to be transferred... + ! update ioProcNeighs from logical lists + ! "add" the lists + recvNeigh = recvNeigh .or. sendNeigh + allocate(tempInt(nTotProcs)) + ! this can artificially create a problem if there isn't a single block to a processor + tempInt = domain % dminfo % my_proc_id + do i=1,nTotProcs + if (recvNeigh(i)) tempInt(i) = i-1 + end do + deallocate(sendNeigh) + deallocate(recvNeigh) + + ! get a complete list of the processors (including itself) + call uniqueIntegerList(tempInt,ioProcNeighs) +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'ioProcNeighs = ', ioProcNeighs +#endif + deallocate(tempInt) + + end subroutine mpas_particle_list_build_io_halos !}}} + +!*********************************************************************** +! +! routine mpas_particle_list_update_io_halos +! +!> \brief Updates halo processor for io communication, noting that +!> the receiving processors must be informed of changes +!> \author Phillip Wolfram +!> \date 07/08/2014 +!> \details +!> This routine transmits a logical list of processors that will +!> transmit data for each ioProc. On the ioProcs, these lists must +!> be aggregated to build out the full list of processors from +!> which data will be received. +! +!----------------------------------------------------------------------- + subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcSendList, ioProcRecvList) !{{{ + implicit none + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + logical, dimension(:,:), intent(in) :: ioProcRecvList !< x: ioProcNeighs for send. y: each receiving processors on x denoted by true + logical, dimension(:), pointer, intent(inout) :: ioProcSendList !< location of true indicates processors to send data to + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + integer, dimension(:), pointer, intent(inout) :: ioProcNeighs !< list of io halo processors + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: i, nioProcNeighs, nProcs + logical, dimension(:), pointer :: completeList, recvList + integer, dimension(:), pointer :: intArray + integer, dimension(:), pointer :: sendRequestID, recvRequestID + integer :: mpi_ierr + logical :: firstTime + + err = 0 + + ! compute send list now that all particles reside on correct block (processor) 'currentBlock' + ! didn't show up with serial IO because all computational processors sent data to proc 0 + call compute_particle_send_list(domain, ioProcSendList) + +#ifdef MPAS_DEBUG + ! need to update IO processors as to the change also so that they know where to get data from!!! + ! should uncomment for testing when multiple ioProcs are utilized (parallel IO) + write(stderrUnit,*) 'ioProcSendList = ', ioProcSendList + write(stderrUnit,*) 'ioProcRecvList = ', ioProcRecvList +#endif + + ! proceed to update the halo + nProcs = domain % dminfo % nprocs + nioProcNeighs = size(ioProcNeighs) + allocate(completeList(nProcs), recvList(nProcs)) + allocate(sendRequestID(nioProcNeighs), recvRequestID(nioProcNeighs)) + + completeList = .False. + ! for each ioProc, send logical array information + do i = 1, nioProcNeighs +#ifdef _MPI + call MPI_ISend(ioProcRecvList(i,:), nProcs, MPI_LOGICAL, ioProcNeighs(i), domain % dminfo % my_proc_id, & + domain % dminfo % comm, sendRequestID(i), mpi_ierr) +#endif + end do + + ! for each ioProc, listen for logical array + do i = 1, nioProcNeighs + ! send the data +#ifdef _MPI + call MPI_IRecv(recvList, nProcs, MPI_LOGICAL, ioProcNeighs(i), ioProcNeighs(i), & + domain % dminfo % comm, recvRequestID(i), mpi_ierr) +#endif + + ! wait until the data is in the buffer +#ifdef _MPI + call MPI_Wait(recvRequestID(i), MPI_STATUS_IGNORE, mpi_ierr) +#endif + + ! aggregate results after wait, making sure that we have the most + ! comprehensive list of ioProcs for receiving + completeList = completeList .or. recvList + !write(stderrUnit,*) 'recvList= ', recvList + !write(stderrUnit,*) 'completeList = ', completeList + end do + + ! wait to make sure (just in case) that all sends have completed +#ifdef _MPI + call MPI_WaitAll(nioProcNeighs, sendRequestID, MPI_STATUSES_IGNORE, mpi_ierr) +#endif + + ! "add" receiving and sending lists into a complete list + completeList = completeList .or. ioProcSendList + !write(stderrUnit,*) 'completeList = ', completeList + + ! convert complete list into a unique list of processor numbers + allocate(intArray(nProcs)) + firstTime = .True. + do i = 1, nProcs + if (completeList(i)) then + if (firstTime) then + intArray = i - 1 + firstTime = .False. + else + intArray(i) = i - 1 + end if + end if + end do + + ! now get the desired integer halo list + deallocate(ioProcNeighs) + call uniqueIntegerList(intArray, ioProcNeighs) + + deallocate(intArray, completeList, sendRequestID, recvRequestID) + + end subroutine mpas_particle_list_update_io_halos !}}} + +!*********************************************************************** +! +! routine mpas_particle_list_transfer_particles_from_block_to_named_block +! +!> \brief Move particles to the appropriate currentBlock +!> \author Phillip Wolfram +!> \date 07/01/2014 +!> \details +!> This routine uses MPI communication to ensure particles end up +!> on their appropriate currentBlock. +! +!----------------------------------------------------------------------- + subroutine mpas_particle_list_transfer_particles_from_block_to_named_block(domain, err, & !{{{ + haloOnly, copyOnly, namedBlock, procNeighs) + implicit none + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + integer, dimension(:), pointer, intent(in) :: procNeighs + character(len=*), intent(in) :: namedBlock + logical, intent(in) :: copyOnly, haloOnly + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + integer, dimension(:), pointer :: nPartSend => NULL(), nPartRecv => NULL() + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: lagrPartTrackPool + type (mpas_list_of_particle_list_type), dimension(:), pointer :: listPLSend => NULL(), listPLRecv => NULL() + + err = 0 + + ! allocate particle list in terms of its communication dimesion to other processors + allocate(listPLSend(size(procNeighs)),listPLRecv(size(procNeighs))) + allocate(nPartSend(size(procNeighs)),nPartRecv(size(procNeighs))) + + ! if statement inside each of the group's subroutines needs removed for parallel IO which + ! assumes a high-level nParticle decomposition which will allocate IO blocks via the + ! decomposition + + + ! this is the communication list and it needs to be a bi-directional graph so that + ! sending processors have their receiving processor listening, even if there is no + ! data transfer required + + ! presently don't distribute particles from each block to correct, owning blocks + !1. communicating from block to block (basically like make_proc_to_proc_particlelists but for blocks) + ! this is all done locally and all it will do is affect the particlelists on each block, forming temporary lists, + ! and then appending particles on these temporary lists back to block % particlelist + !this doesn't have to be tested unless there is more than one block per processor, + !which presently is not how things are done + ! this takes the block % particlelist on the first block and makes sure + ! it is appropriately distributed on other blocks on the same processor + ! call make_block_to_block_particlelists(domain) + + + ! 1. Make temporary particle lists for transfers based on currentBock of cells in halo. + ! These lists live on each block and correspond to other + ! blocks that the list must be moved to. The particle must end up on its currentBlock specified. + ! convention on particles lists is that g_ProcNeighs specifies the processor neighbor numbers + ! corresponding to each index in the particlelists pointer array. Should use linked-list + ! because processor neighbors are typically going to be somewhere less than 10 + ! (perfect partitioning of plane gives hexagons with 6 cell neighbors, for instance). + ! strategy is to make linked list corresponding to each gProcNeigh and then append + ! particles beloning to the list on the list +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'before make_proc_to_proc_particlelists' + call mpas_particle_list_test_numparticles_to_neighprocs(domain % dminfo % my_proc_id, procNeighs, procNeighs) +#endif + call make_proc_to_proc_particlelists(domain, copyOnly, namedBlock, listPLSend, procNeighs, err) +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'after make_proc_to_proc_particlelists' + call mpas_particle_list_test_numparticles_to_neighprocs(domain % dminfo % my_proc_id, procNeighs, procNeighs) +#endif +#ifdef MPAS_DEBUG + write(stderrunit,*) 'finished make_proc_to_proc_particlelists' + call mpas_particle_list_test_num_current_particlelist(domain) + call test_num_particles_on_particlelist(listPLSend, size(procNeighs)) +#endif + + ! now move data from one proc to another, assuming that data is move to 1st block + ! on foreign processor + ! tell other processors how many particles are going to be communicated to them + call get_num_particlelists(listPLSend, size(procNeighs), nPartSend) +#ifdef MPAS_DEBUG + write(stderrunit,*) 'finished get_num_particlelists' + write(stderrunit,*) 'proc id=', domain % dminfo % my_proc_id, ' comm=', domain % dminfo % comm +#endif + call communicate_num_particles_send_recv(domain, procNeighs, nPartSend, nPartRecv) +#ifdef MPAS_DEBUG + write(stderrunit,*) 'finished communicate_num_particles_send_recv' +#endif + + !2. communicating from processor to processor + ! make appropriate list + call allocate_list_particlelists(nPartRecv, listPLRecv) + + ! communicate data (assumes that each processor has knowledge about construction of the pool lagrPartTrackPoolHalo, + ! from the registry. If this changes, this will break this member... It also assumes the code is deterministic + ! and that pools are built and computed the exact same way on each processor. + call communicate_particle_halo_data(domain, procNeighs, nPartSend, nPartRecv, listPLSend, listPLRecv) +#ifdef MPAS_DEBUG + write(stderrunit,*) 'finished communicate_particle_halo_data' +#endif + + if(haloOnly) then + ! need to also allocate the nonHalo data somehow, it just needs initialized so that it can be "filled in" when + ! necessary for output + ! can utilize empty 0'd fields for the nonhalo data portion to initialize the field for all the processors + call allocate_list_nonHalo_data(domain, listPLRecv) + else + call communicate_particle_nonhalo_data(domain, procNeighs, nPartSend, nPartRecv, listPLSend, listPLRecv) + end if + + ! now there should be the complete particles on listPLRecv. These, however, need moved to the blocks of the processor + ! for use in calculations + !3. communicating from block to block + call distribute_particlelist_to_blocks(domain, namedBlock, listPLRecv) + +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'finished distributing particlelist' + write(stderrUnit,*) 'halo procs = ', procNeighs + write(stderrUnit,*) 'nSend = ', nPartSend, ' nRecv = ', nPartRecv +#endif + + ! deallocate listPLSend and listPLRecv + if (copyOnly) then + ! just empty the list without destroying the particle data + !write(stderrUnit,*) 'just emptying the particlelist' + call empty_list_particlelists(listPLSend) + else + ! remove list of particles as well as particle data because it was just sent to the other processors + call destory_list_particlelists(listPLSend) + endif + ! just empty the list without destroying the particle data (because we need particles that were just transferred!) + call empty_list_particlelists(listPLRecv) + + deallocate(nPartSend, nPartRecv) + + !write(stderrUnit,*) 'finished ' + + end subroutine mpas_particle_list_transfer_particles_from_block_to_named_block !}}} + +!*********************************************************************** +! +! routine mpas_particle_list_write_halo_data +! +!> \brief Writes haloData to struct arrays for output +!> \author Phillip Wolfram +!> \date 06/03/2014 +!> \details +!> This routine writes haloData output for this MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + subroutine mpas_particle_list_write_halo_data(domain, err)!{{{ + + implicit none + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_particle_list_type), pointer :: particlelist + type (mpas_pool_type), pointer :: lagrPartTrackPool + type (mpas_pool_iterator_type) :: dimItr + type (field1DReal), pointer :: field1DRealPointer + type (field1DInteger), pointer :: field1DIntPointer + real (kind=RKIND), dimension(:), pointer :: Array1DRealPointer => NULL() + integer, dimension(:), pointer :: Array1DIntPointer => NULL() + integer, dimension(:), pointer :: indexToParticleIDOriginal => NULL(), indexToParticleIDNew => NULL(), orderingVector => NULL() + + err = 0 + + block => domain % blocklist + do while (associated(block)) + ! particle related pointers + particlelist => block % particlelist + ! iterate over each member of the pool and make the relevant assignment + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackHalo', lagrPartTrackPool) + ! need to compute the ordering matrices + call mpas_pool_get_array(lagrPartTrackPool, 'indexToParticleID', indexToParticleIDOriginal) + call get_halo_data_from_particle_list_array(particlelist, 'indexToParticleID', indexToParticleIDNew) + ! note: orderingVector can be a subset of indexToParticleIDNew because this index can include compute as well as IO particles + ! however, it must be of the same size as indexToParticleIDOriginal + call compute_ordering_vector(indexToParticleIDOriginal, indexToParticleIDNew, orderingVector) + + ! iterate over contents of pool and transfer + call mpas_pool_begin_iteration(lagrPartTrackPool) + do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) + ! determine the type of data + if (dimItr % memberType == MPAS_POOL_FIELD) then + if (dimItr % dataType == MPAS_POOL_REAL) then + ! get data and place it in appropriate array + call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DRealPointer) + !{{{ +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'write halo data' + write(stderrUnit,*) 'member name =', trim(dimItr % memberName) + write(stderrUnit,*) 'particlelistSize= ', count_particlelist(particlelist) + write(stderrUnit,*) 'memory arraysize= ', size(field1DRealPointer % array) +#endif + !}}} + allocate(Array1DRealPointer(count_particlelist(particlelist))) + call get_halo_data_from_particle_list_array(particlelist, dimItr % memberName, Array1DRealPointer) + ! reorder + field1DRealPointer % array = Array1DRealPointer(orderingVector) + deallocate(Array1DRealPointer) + elseif (dimItr % dataType == MPAS_POOL_INTEGER) then + ! get data and place it in appropriate array + call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DIntPointer) + allocate(Array1DIntPointer(count_particlelist(particlelist))) + call get_halo_data_from_particle_list_array(particlelist, dimItr % memberName, Array1DIntPointer) + ! reorder + field1DIntPointer % array = Array1DIntPointer(orderingVector) + deallocate(Array1DIntPointer) + else + !write(stderrunit,*) "Different field type than implemented in nonHalo write!" + end if + elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then + ! ignore dimensions for now and have this code so they aren't printed as an error message + else + !write(stderrunit,*) "Different type expected in registry for key ", trim(dimItr % memberName), " in nonHalo data for write, don't know what to do!" + end if + end do + + ! free memory for the next loop + deallocate(indexToParticleIDNew) + deallocate(orderingVector) + + block => block % next + end do + + end subroutine mpas_particle_list_write_halo_data!}}} + +!*********************************************************************** +! +! routine mpas_particle_list_write_nonhalo_data +! +!> \brief Writes nonhaloData to struct arrays for output +!> \author Phillip Wolfram +!> \date 06/03/2014 +!> \details +!> This routine writes nonhaloData output for this MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + subroutine mpas_particle_list_write_nonhalo_data(domain, err)!{{{ + + implicit none + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_particle_list_type), pointer :: particlelist + type (mpas_pool_type), pointer :: lagrPartTrackPool + type (mpas_pool_iterator_type) :: dimItr + type (field1DReal), pointer :: field1DRealPointer + type (field1DInteger), pointer :: field1DIntPointer + real (kind=RKIND), dimension(:), pointer :: Array1DRealPointer => NULL() + integer, dimension(:), pointer :: Array1DIntPointer => NULL() + integer, dimension(:), pointer :: indexToParticleIDOriginal => NULL(), indexToParticleIDNew => NULL(), orderingVector =>NULL() + + err = 0 + + block => domain % blocklist + do while (associated(block)) + ! particle related pointers + particlelist => block % particlelist + ! iterate over each member of the pool and make the relevant assignment + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackHalo', lagrPartTrackPool) + ! need to compute the ordering matrices + call mpas_pool_get_array(lagrPartTrackPool, 'indexToParticleID', indexToParticleIDOriginal) + call get_halo_data_from_particle_list_array(particlelist, 'indexToParticleID', indexToParticleIDNew) + ! note: orderingVector can be a subset of indexToParticleIDNew because this index can include compute as well as IO particles + ! however, it must be of the same size as indexToParticleIDOriginal + call compute_ordering_vector(indexToParticleIDOriginal, indexToParticleIDNew, orderingVector) + + ! iterate over each member of the pool and make the relevant assignment + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackNonHalo', lagrPartTrackPool) + call mpas_pool_begin_iteration(lagrPartTrackPool) + do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) + ! determine the type of data + if (dimItr % memberType == MPAS_POOL_FIELD) then + if (dimItr % dataType == MPAS_POOL_REAL) then + ! get data and place it in appropriate array + call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DRealPointer) + !{{{ +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'write nonhalo data' + write(stderrUnit,*) 'member name =', dimItr % memberName + write(stderrUnit,*) 'particlelistSize= ', count_particlelist(particlelist) + write(stderrUnit,*) 'memory arraysize= ', size(field1DRealPointer % array) +#endif + !}}} + allocate(Array1DRealPointer(count_particlelist(particlelist))) + call get_nonhalo_data_from_particle_list_array(particlelist, dimItr % memberName, Array1DRealPointer) + ! reorder + field1DRealPointer % array = Array1DRealPointer(orderingVector) + deallocate(Array1DRealPointer) + elseif (dimItr % dataType == MPAS_POOL_INTEGER) then + write(stderrunit,*) "Integer type in registry for key ", dimItr % memberName, " in nonHalo data for write, not yet tested!" + ! get data and place it in appropriate array + call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DIntPointer) + allocate(Array1DIntPointer(count_particlelist(particlelist))) + call get_nonhalo_data_from_particle_list_array(particlelist, dimItr % memberName, Array1DIntPointer) + ! reorder + field1DIntPointer % array = Array1DIntPointer(orderingVector) + deallocate(Array1DIntPointer) + else + !write(stderrunit,*) "Different field type than implemented in nonHalo write!" + end if + elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then + ! ignore dimensions for now and have this code so they aren't printed as an error message + else + !write(stderrunit,*) "Different type expected in registry for key ", trim(dimItr % memberName), " in nonHalo data for write, don't know what to do!" + end if + end do + + ! free memory for the next loop + deallocate(indexToParticleIDNew) + deallocate(orderingVector) + + block => block % next + end do + + end subroutine mpas_particle_list_write_nonhalo_data!}}} + +!----------------------------------------------------------------------- +! +! PRIVATE SUBROUTINES +! +!----------------------------------------------------------------------- +!{{{ + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine append_particle_to_particlelist +! +!> \brief MPAS add particle to particlelist, starting new list if +!> not allocated +!> \author Phillip Wolfram +!> \date 06/26/2014 +!> \details +!> This routine takes a particle and places it on an existing particlelist, +!> or in the event of no list, initializes the list with the particle +! +!----------------------------------------------------------------------- +subroutine append_particle_to_particlelist(particle, particlelist)!{{{ + implicit none + type (mpas_particle_type), pointer, intent(in) :: particle + type (mpas_particle_list_type), pointer, intent(inout) :: particlelist + type (mpas_particle_list_type), pointer :: headPL=>NULL(), tempPL=>NULL() + + ! case where particeList needs to be created and populated by particle + if(.not.associated(particlelist)) then + allocate(particlelist) + nullify(particlelist % next) + nullify(particlelist % prev) + particlelist % particle => particle + else + ! case where list exists get the head + headPL => particlelist + if (.not.associated(headPL % particle)) then + ! populate empty link + headPL % particle => particle + else + ! build new link + allocate(tempPL) + tempPL % particle => particle + nullify(tempPL % prev) + tempPL % next => headPL + ! connect to the list + headPL % prev => tempPL + particlelist => tempPL + end if + end if + +end subroutine append_particle_to_particlelist !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_get_halodata_to_particlelist_1Dreal_array +! +!> \brief MPAS get halodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 07/01/2014 +!> \details +!> This routine reads 0D real arrays in each particle of the particlelist +!> and places the data into a 1D real field output. +! +!----------------------------------------------------------------------- +subroutine get_halo_data_from_particle_list_1Dreal_array & !{{{ + (particlelist, dataName, array1DRealPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + real (kind=RKIND), dimension(:), pointer, intent(out) :: array1DRealPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DReal), pointer :: field0DRealPointer + + ! allocate the array if it isn't allocated + if(.not.associated(array1DRealPointer)) then + allocate(array1DRealPointer(count_particlelist(particlelist))) + end if + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a real link + do while(associated(particlelistCurr)) + + call mpas_pool_get_field(particlelistCurr % particle % haloDataPool, dataName, field0DRealPointer) + array1DRealPointer(dataNumber) = field0DRealPointer % scalar + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine get_halo_data_from_particle_list_1Dreal_array !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_get_halodata_to_particlelist_1Dreal +! +!> \brief MPAS get halodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 06/03/2014 +!> \details +!> This routine reads 0D real arrays in each particle of the particlelist +!> and places the data into a 1D real field output. +! +!----------------------------------------------------------------------- +subroutine get_halo_data_from_particle_list_1Dreal & !{{{ + (particlelist, dataName, field1DRealPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + type (field1DReal), pointer, intent(out) :: field1DRealPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DReal), pointer :: field0DRealPointer + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a real link + do while(associated(particlelistCurr)) + + call mpas_pool_get_field(particlelistCurr % particle % haloDataPool, dataName, field0DRealPointer) + field1DRealPointer % array(dataNumber) = field0DRealPointer % scalar + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine get_halo_data_from_particle_list_1Dreal !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_get_nonhalodata_to_particlelist_1Dint +! +!> \brief MPAS get nonhalodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 07/07/2014 +!> \details +! +!----------------------------------------------------------------------- +subroutine get_nonhalo_data_from_particle_list_1Dint& !{{{ + (particlelist, dataName, field1DIntPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + type (field1DInteger), pointer, intent(out) :: field1DIntPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DInteger), pointer :: field0DIntPointer + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a real link + do while(associated(particlelistCurr)) + call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DIntPointer) + field1DIntPointer % array(dataNumber) = field0DIntPointer % scalar + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine get_nonhalo_data_from_particle_list_1Dint !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_get_nonhalodata_to_particlelist_1Dint_array +! +!> \brief MPAS get nonhalodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 07/07/2014 +!> \details +! +!----------------------------------------------------------------------- +subroutine get_nonhalo_data_from_particle_list_1Dint_array & !{{{ + (particlelist, dataName, array1DIntPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + integer, dimension(:), pointer, intent(out) :: array1DIntPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DInteger), pointer :: field0DIntPointer + + ! allocate the array if it isn't allocated + if(.not.associated(array1DIntPointer)) then + allocate(array1DIntPointer(count_particlelist(particlelist))) + end if + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a real link + do while(associated(particlelistCurr)) + call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DIntPointer) + array1DIntPointer(dataNumber) = field0DIntPointer % scalar + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine get_nonhalo_data_from_particle_list_1Dint_array !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_get_nonhalodata_to_particlelist_1Dreal +! +!> \brief MPAS get nonhalodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 06/04/2014 +!> \details +! +!----------------------------------------------------------------------- +subroutine get_nonhalo_data_from_particle_list_1Dreal & !{{{ + (particlelist, dataName, field1DRealPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + type (field1DReal), pointer, intent(out) :: field1DRealPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DReal), pointer :: field0DRealPointer + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a real link + do while(associated(particlelistCurr)) + call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DRealPointer) + field1DRealPointer % array(dataNumber) = field0DRealPointer % scalar + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine get_nonhalo_data_from_particle_list_1Dreal !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_get_nonhalodata_to_particlelist_1Dreal_array +! +!> \brief MPAS get nonhalodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 07/07/2014 +!> \details +! +!----------------------------------------------------------------------- +subroutine get_nonhalo_data_from_particle_list_1Dreal_array & !{{{ + (particlelist, dataName, array1DRealPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + real (kind=RKIND), dimension(:), pointer, intent(out) :: array1DRealPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DReal), pointer :: field0DRealPointer + + ! allocate the array if it isn't allocated + if(.not.associated(array1DRealPointer)) then + allocate(array1DRealPointer(count_particlelist(particlelist))) + end if + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a real link + do while(associated(particlelistCurr)) + call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DRealPointer) + array1DRealPointer(dataNumber) = field0DRealPointer % scalar + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine get_nonhalo_data_from_particle_list_1Dreal_array !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_get_nonhalodata_to_particlelist_2Dreal +! +!> \brief MPAS get nonhalodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 04/10/2014 +!> \details +!> This routine takes a an array of 1D real arrays and places the data into +!> the nonhaloData pool of the particles in the list. It is assumed +!> that the dimensionality of the field is reduced in order by one +!> on each particle. +! +!----------------------------------------------------------------------- +subroutine get_nonhalo_data_from_particle_list_2Dreal & !{{{ + (particlelist, dataName, field2DRealPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + type (field2DReal), pointer, intent(out) :: field2DRealPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field1DReal), pointer :: field1DRealPointer + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a real link + do while(associated(particlelistCurr)) + call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field1DRealPointer) + field2DRealPointer % array(dataNumber, :) = field1DRealPointer % array(:) + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine get_nonhalo_data_from_particle_list_2Dreal !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_get_halodata_to_particlelist_1Dint_array +! +!> \brief MPAS get halodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 04/10/2014 +!> \details +!> This routine takes a an array of 1D int arrays and places the data into +!> the haloData pool of the particles in the list. It is assumed +!> that the dimensionality of the field is reduced in order by one +!> on each particle. +! +!----------------------------------------------------------------------- +subroutine get_halo_data_from_particle_list_1Dint_array & !{{{ + (particlelist, dataName, array1DIntPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + integer, dimension(:), pointer, intent(out) :: array1DIntPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DInteger), pointer :: field0DIntPointer + + ! allocate the array if it isn't allocated + if(.not.associated(array1DIntPointer)) then + allocate(array1DIntPointer(count_particlelist(particlelist))) + end if + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a int link + do while(associated(particlelistCurr)) + call mpas_pool_get_field(particlelistCurr % particle % haloDataPool, dataName, field0DIntPointer) + array1DIntPointer(dataNumber) = field0DIntPointer % scalar + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine get_halo_data_from_particle_list_1Dint_array !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_get_halodata_to_particlelist_1Dint +! +!> \brief MPAS get halodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 04/10/2014 +!> \details +!> This routine takes a an array of 1D int arrays and places the data into +!> the haloData pool of the particles in the list. It is assumed +!> that the dimensionality of the field is reduced in order by one +!> on each particle. +! +!----------------------------------------------------------------------- +subroutine get_halo_data_from_particle_list_1Dint & !{{{ + (particlelist, dataName, field1DIntPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + type (field1DInteger), pointer, intent(out) :: field1DIntPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DInteger), pointer :: field0DIntPointer + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a int link + do while(associated(particlelistCurr)) + call mpas_pool_get_field(particlelistCurr % particle % haloDataPool, dataName, field0DIntPointer) + field1DIntPointer % array(dataNumber) = field0DIntPointer % scalar + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine get_halo_data_from_particle_list_1Dint !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_add_halodata_to_particlelist_1Dreal_array +! +!> \brief MPAS add halodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 07/01/2014 +!> \details +!> This routine takes a an array of real scalars and places the data into +!> the haloData pool of the particles in the list. It is assumed +!> that the dimensionality of the field is reduced in order by one +!> on each particle. +! +!----------------------------------------------------------------------- +subroutine add_halo_data_to_particle_list_1Dreal_array & !{{{ + (particlelist, dataName, array1DRealPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + real (kind=RKIND), dimension(:), pointer, intent(in) :: array1DRealPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DReal), pointer :: field0DRealPointer + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a real link + do while(associated(particlelistCurr)) + + allocate(field0DRealPointer) + field0DRealPointer % scalar = array1DRealPointer(dataNumber) + call mpas_pool_add_field(particlelistCurr % particle % haloDataPool, dataName, field0DRealPointer) + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine add_halo_data_to_particle_list_1Dreal_array !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_add_halodata_to_particlelist_1Dreal +! +!> \brief MPAS add halodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 06/03/2014 +!> \details +!> This routine takes a an array of real scalars and places the data into +!> the haloData pool of the particles in the list. It is assumed +!> that the dimensionality of the field is reduced in order by one +!> on each particle. +! +!----------------------------------------------------------------------- +subroutine add_halo_data_to_particle_list_1Dreal & !{{{ + (particlelist, dataName, field1DRealPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + type (field1DReal), pointer, intent(in) :: field1DRealPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DReal), pointer :: field0DRealPointer + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a real link + do while(associated(particlelistCurr)) + + allocate(field0DRealPointer) + field0DRealPointer % scalar = field1DRealPointer % array(dataNumber) + call mpas_pool_add_field(particlelistCurr % particle % haloDataPool, dataName, field0DRealPointer) + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine add_halo_data_to_particle_list_1Dreal !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_add_nonhalodata_to_particlelist_1Dreal_array +! +!> \brief MPAS add nonhalodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 07/01/2014 +!> \details +!> This routine takes a an array of real scalars and places the data into +!> the nonhaloData pool of the particles in the list. It is assumed +!> that the dimensionality of the field is reduced in order by one +!> on each particle. +! +!----------------------------------------------------------------------- +subroutine add_nonhalo_data_to_particle_list_1Dreal_array & !{{{ + (particlelist, dataName, array1DRealPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + real (kind=RKIND), dimension(:), pointer :: array1DRealPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DReal), pointer :: field0DRealPointer + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a real link + do while(associated(particlelistCurr)) + + allocate(field0DRealPointer) + field0DRealPointer % scalar = array1DRealPointer(dataNumber) + call mpas_pool_add_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DRealPointer) + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine add_nonhalo_data_to_particle_list_1Dreal_array !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_add_nonhalodata_to_particlelist_1Dreal +! +!> \brief MPAS add nonhalodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 06/03/2014 +!> \details +!> This routine takes a an array of real scalars and places the data into +!> the nonhaloData pool of the particles in the list. It is assumed +!> that the dimensionality of the field is reduced in order by one +!> on each particle. +! +!----------------------------------------------------------------------- +subroutine add_nonhalo_data_to_particle_list_1Dreal & !{{{ + (particlelist, dataName, field1DRealPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + type (field1DReal), pointer :: field1DRealPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DReal), pointer :: field0DRealPointer + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a real link + do while(associated(particlelistCurr)) + + allocate(field0DRealPointer) + field0DRealPointer % scalar = field1DRealPointer % array(dataNumber) + call mpas_pool_add_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DRealPointer) + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine add_nonhalo_data_to_particle_list_1Dreal !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_add_halodata_to_particlelist_1Dint_array +! +!> \brief MPAS add halodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 07/01/2014 +!> \details +!> This routine takes a an array of int scalars and places the data into +!> the haloData pool of the particles in the list. It is assumed +!> that the dimensionality of the field is reduced in order by one +!> on each particle. +! +!----------------------------------------------------------------------- +subroutine add_halo_data_to_particle_list_1Dint_array & !{{{ + (particlelist, dataName, array1DIntPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + integer, dimension(:), pointer, intent(in) :: array1DIntPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DInteger), pointer :: field0DIntPointer + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a int link + do while(associated(particlelistCurr)) + + allocate(field0DIntPointer) + field0DIntPointer % scalar = array1DIntPointer(dataNumber) + call mpas_pool_add_field(particlelistCurr % particle % haloDataPool, dataName, field0DIntPointer) + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine add_halo_data_to_particle_list_1Dint_array !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_add_halodata_to_particlelist_1Dint +! +!> \brief MPAS add halodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 06/03/2014 +!> \details +!> This routine takes a an array of int scalars and places the data into +!> the haloData pool of the particles in the list. It is assumed +!> that the dimensionality of the field is reduced in order by one +!> on each particle. +! +!----------------------------------------------------------------------- +subroutine add_halo_data_to_particle_list_1Dint & !{{{ + (particlelist, dataName, field1DIntPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + type (field1DInteger), pointer, intent(in) :: field1DIntPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DInteger), pointer :: field0DIntPointer + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a int link + do while(associated(particlelistCurr)) + + allocate(field0DIntPointer) + field0DIntPointer % scalar = field1DIntPointer % array(dataNumber) + call mpas_pool_add_field(particlelistCurr % particle % haloDataPool, dataName, field0DIntPointer) + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine add_halo_data_to_particle_list_1Dint !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_add_nonhalodata_to_particlelist_1Dint_array +! +!> \brief MPAS add nonhalodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 07/01/2014 +!> \details +!> This routine takes a an array of int scalars and places the data into +!> the nonhaloData pool of the particles in the list. It is assumed +!> that the dimensionality of the field is reduced in order by one +!> on each particle. +! +!----------------------------------------------------------------------- +subroutine add_nonhalo_data_to_particle_list_1Dint_array & !{{{ + (particlelist, dataName, array1DIntPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + integer, dimension(:), pointer, intent(in) :: array1DIntPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DInteger), pointer :: field0DIntPointer + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a int link + do while(associated(particlelistCurr)) + + allocate(field0DIntPointer) + field0DIntPointer % scalar = array1DIntPointer(dataNumber) + call mpas_pool_add_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DIntPointer) + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine add_nonhalo_data_to_particle_list_1Dint_array !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine mpas_add_nonhalodata_to_particlelist_1Dint +! +!> \brief MPAS add nonhalodata to particle contained in a list +!> \author Phillip Wolfram +!> \date 06/03/2014 +!> \details +!> This routine takes a an array of int scalars and places the data into +!> the nonhaloData pool of the particles in the list. It is assumed +!> that the dimensionality of the field is reduced in order by one +!> on each particle. +! +!----------------------------------------------------------------------- +subroutine add_nonhalo_data_to_particle_list_1Dint & !{{{ + (particlelist, dataName, field1DIntPointer) + ! input data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + character(len=*), intent(in) :: dataName + type (field1DInteger), pointer, intent(in) :: field1DIntPointer + + ! subroutine data + integer :: dataNumber + type (mpas_particle_list_type), pointer :: particlelistCurr + type (field0DInteger), pointer :: field0DIntPointer + + ! loop over all elements of the list and insert the data + dataNumber = 1 + particlelistCurr => particlelist + ! while we have a int link + do while(associated(particlelistCurr)) + + allocate(field0DIntPointer) + field0DIntPointer % scalar = field1DIntPointer % array(dataNumber) + call mpas_pool_add_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DIntPointer) + + ! increment for new dataNumber + dataNumber = dataNumber + 1 + ! get next link + particlelistCurr => particlelistCurr % next + end do + +end subroutine add_nonhalo_data_to_particle_list_1Dint !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine count_particlelist_particles +! +!> \brief MPAS count particles in particlelist (must be allocated) +!> \author Phillip Wolfram +!> \date 04/14/2014 +!> \details +!> This routine counts number of particles in particlelist. +! +!----------------------------------------------------------------------- +integer function count_particlelist_particles(particlelist) !{{{ + implicit none + ! input/output data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + + ! subroutine data + type (mpas_particle_list_type), pointer :: ParticleLinkCurr + + count_particlelist_particles = 0 + !write(stderrUnit,*) 'count_particlelist' + !if(.not.associated(particlelist)) then + ! write(stdoutunit,*) 'particleLinkCurr not associated' + ! return + !end if + + ! current link + particleLinkCurr => particlelist + + do while (associated(particleLinkCurr)) + ! increment the list + if (associated(particleLinkCurr % particle)) then + count_particlelist_particles = count_particlelist_particles + 1 + end if + ! get next item on the list + particleLinkCurr => particleLinkCurr % next + end do + + return + +end function count_particlelist_particles !}}} + + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine build_new_particlelist +! +!> \brief MPAS build list of particles +!> \author Phillip Wolfram +!> \date 06/03/2014 +!> \details +!> This routine builds up a list of empty particles ready to be populated. +!> This is just a raw constructor for a particle list. This assumes +!> that a list is more than 1 link, such that nParticles >= 2. +! +!----------------------------------------------------------------------- +subroutine build_new_particlelist(nParticles, particlelist, ioBlock) !{{{ + ! input/output data + ! number of particles + integer, intent(in) :: nParticles + integer, intent(in), optional :: ioBlock + type (field0dInteger), pointer :: ioBlockfield + type (mpas_particle_list_type), pointer, intent(inout) :: particlelist + ! subroutine data + integer aParticle + type (mpas_particle_type), pointer :: particle + type (mpas_particle_list_type), pointer :: newParticleLink + type (mpas_particle_list_type), pointer :: ParticleLinkCurr + + integer :: counter + + if(nParticles == 0) then + return + end if + + ! instantiate a list of empty particles of dimension nParticles + if(.not.associated(particlelist)) then + allocate(particlelist) + end if + + ! allocate memory for the new particle + allocate(particle) + call mpas_pool_create_pool(particle % haloDataPool) + call mpas_pool_create_pool(particle % nonhaloDataPool) + if (present(ioBlock)) then + allocate(ioBlockfield) + ioBlockfield % scalar = ioBlock + call mpas_pool_add_field(particle % haloDataPool, 'ioBlock', ioBlockfield) + end if + + !! allocate start of list link (this must have already been done! + ! assign allocated particle memory to link + particlelist % particle => particle + + ! current link + particleLinkCurr => particlelist + + ! add more links + do aParticle = 2, nParticles + ! allocate memory for the new particle + allocate(particle) + call mpas_pool_create_pool(particle % haloDataPool) + call mpas_pool_create_pool(particle % nonhaloDataPool) + if(present(ioBlock)) then + allocate(ioBlockfield) + ioBlockfield % scalar = ioBlock + call mpas_pool_add_field(particle % haloDataPool, 'ioBlock', ioBlockfield) + end if + ! we already have one link so make a new one + allocate(newParticleLink) + ! place the particle in the list link + newParticleLink % particle => particle + nullify(newParticleLink % next) + ! connect new link to current link + newParticleLink % prev => particleLinkCurr + ! next link is the new link + particleLinkCurr % next => newParticleLink + ! reset link to last link + particleLinkCurr => newParticleLink + end do + +end subroutine build_new_particlelist !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine count_particlelist +! +!> \brief MPAS count particles in particlelist +!> \author Phillip Wolfram +!> \date 04/14/2014 +!> \details +!> This routine counts number of particles in particlelist. +! +!----------------------------------------------------------------------- +integer function count_particlelist(particlelist) !{{{ + implicit none + ! input/output data + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + + ! subroutine data + type (mpas_particle_list_type), pointer :: ParticleLinkCurr + + count_particlelist = 0 + !write(stderrUnit,*) 'count_particlelist' + !if(.not.associated(particlelist)) then + ! write(stdoutunit,*) 'particleLinkCurr not associated' + ! return + !end if + + ! current link + particleLinkCurr => particlelist + + do while (associated(particleLinkCurr)) + ! increment the list + count_particlelist = count_particlelist + 1 + !write(stderrUnit,*) 'count_particlelist = ', count_particlelist + ! get next item on the list + particleLinkCurr => particleLinkCurr % next + end do + + return + +end function count_particlelist !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine destroy_particle +! +!> \brief MPAS destroy particle +!> \author Phillip Wolfram +!> \date 06/03/2014 +!> \details +!> This routine destroys a particle, deallocating its memory +! +!----------------------------------------------------------------------- +subroutine destroy_particle(particle) !{{{ + implicit none + + type (mpas_particle_type), pointer, intent(inout) :: particle + + if(associated(particle)) then + if(associated(particle % haloDataPool)) then + call mpas_pool_destroy_pool(particle % haloDataPool) + end if + if(associated(particle % nonhaloDataPool)) then + call mpas_pool_destroy_pool(particle % nonhaloDataPool) + end if + deallocate(particle) + end if + +end subroutine destroy_particle !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine empty_particlelist +! +!> \brief MPAS empty particlelist +!> \author Phillip Wolfram +!> \date 06/27/2014 +!> \details +!> This routine emptys a particlelist, deallocating its memory +!> but keeping memory of particles it contains intact +! +!----------------------------------------------------------------------- +subroutine empty_particlelist(particlelist) !{{{ + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + type (mpas_particle_list_type), pointer :: pLCurr, pLCurrTemp + + plCurr => particlelist + do while(associated(plCurr)) + pLCurrTemp => pLCurr + pLCurr => pLCurr % next + deallocate(pLCurrTemp) + ! N.B., particle contained in pLCurrTemp is not deallocated!!! + end do + +end subroutine empty_particlelist !}}} + +subroutine destory_list_particlelists(listParticleLists) !{{{ + type (mpas_list_of_particle_list_type), dimension(:), pointer, intent(inout) :: listParticleLists + integer :: i, sizeList + + if(associated(listParticleLists)) then + sizeList = size(listParticleLists) + do i=1,sizeList + call mpas_particle_list_destroy_particle_list(listParticleLists(i) % list) + end do + deallocate(listParticleLists) + end if + +end subroutine destory_list_particlelists !}}} + +subroutine empty_list_particlelists(listParticleLists) !{{{ + type (mpas_list_of_particle_list_type), dimension(:), pointer, intent(inout) :: listParticleLists + integer :: i, sizeList + + if(associated(listParticleLists)) then + sizeList = size(listParticleLists) + do i=1,sizeList + call empty_particlelist(listParticleLists(i) % list) + end do + deallocate(listParticleLists) + end if + +end subroutine empty_list_particlelists!}}} + +!*********************************************************************** +! +! routine compute_cellOwnerBlock(domain, err) +! +!> \brief Compute owner block arrays to specify halo ownership +!> \author Phillip Wolfram +!> \date 06/25/2014 +!> \details +!> This routine computes the cellOwnerBlock for all cells on a block, +!> diagnosing the block which owns each cell. Could potentially be +!> generalized and put in framework (probably need package variables +!> if particles are used). +! +!----------------------------------------------------------------------- + subroutine compute_cellOwnerBlock(domain, err) !{{{ + implicit none + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: lagrPartTrackPool + type (field1DInteger), pointer :: cellOwnerBlock + + err = 0 + + block => domain % blocklist + do while (associated(block)) + ! get pool to access cellOwnerBlock + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackCells', lagrPartTrackPool) + ! prepare cellOwnerBlock for use in determining blockID to + ! be passed from one processor to another + call mpas_pool_get_field(lagrPartTrackPool, 'cellOwnerBlock', cellOwnerBlock) + ! set cellOwnerBlock to be current block + cellOwnerBlock % array(:) = block % blockID + + block => block % next + end do + ! exchange halos + call mpas_dmpar_exch_halo_field(cellOwnerBlock) + + end subroutine compute_cellOwnerBlock !}}} + +!*********************************************************************** +! +! routine compute_blockNeighs(domain, err) +! +!> \brief Compute neighboring blocks from owner block, +!> parsing the halo to get unique values +!> \author Phillip Wolfram +!> \date 06/26/2014 +!> \details +!> This routine computes the neighboring blocks block % blockNeighs +!> for each block. Note that the size of this is not predetermined +!> and depends on the partitioning (typically in graph.info.part.#) +! +!----------------------------------------------------------------------- + subroutine compute_blockNeighs(domain, err) !{{{ + implicit none + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: lagrPartTrackPool + type (field1DInteger), pointer :: cellOwnerBlock + + err = 0 + + block => domain % blocklist + do while (associated(block)) + ! get pool to access cellOwnerBlock + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackCells', lagrPartTrackPool) + ! get cellOwnerBlock + call mpas_pool_get_field(lagrPartTrackPool, 'cellOwnerBlock', cellOwnerBlock) + + ! compute unique list obtained from cellOwnerBlock + call uniqueIntegerList(cellOwnerBlock % array, block % blockNeighs) + + block => block % next + end do + + end subroutine compute_blockNeighs !}}} + +!*********************************************************************** +! +! routine compute_block_procNeighs(domain, err) +! +!> \brief Compute neighboring processors from blockNeighs, +!> getting unique values on a block +!> \author Phillip Wolfram +!> \date 06/26/2014 +!> \details +!> This routine computes the neighboring processors corresponding to +!> block % blockNeighs for each block. +! +!----------------------------------------------------------------------- + subroutine compute_block_procNeighs(domain, err) !{{{ + implicit none + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + type (block_type), pointer :: block + !type (mpas_pool_type), pointer :: lagrPartTrackPool + integer, dimension(:), pointer :: array + integer :: numBlockNeighs, i + + err = 0 + + block => domain % blocklist + do while (associated(block)) + ! convert blockNeighs to procNeighs array + numBlockNeighs = size(block % blockNeighs) + allocate(array(numBlockNeighs)) + do i=1, numBlockNeighs + call mpas_get_owning_proc(domain % dminfo, block % blockNeighs(i), array(i)) + end do + ! compute unique list for processor neighbors + call uniqueIntegerList(array, block % procNeighs) + + ! free up temporary memory + deallocate(array) + + ! get the next block + block => block % next + end do + + end subroutine compute_block_procNeighs !}}} + +!*********************************************************************** +! +! routine compute_procNeighs(domain, err) +! +!> \brief Compute neighboring processors from blockNeighs, +!> getting unique values across all blocks +!> \author Phillip Wolfram +!> \date 06/26/2014 +!> \details +!> This routine computes the neighboring processors corresponding to +!> block % procNeighs for each block. +! +!----------------------------------------------------------------------- + subroutine compute_procNeighs(domain, err, procNeighs) !{{{ + implicit none + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + integer, dimension(:), pointer, intent(out) :: procNeighs + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + type (block_type), pointer :: block + integer, dimension(:), pointer :: tempIntegerArray + integer :: localSize, totalSize, iStart + + err = 0 + + totalSize = 0 + + block => domain % blocklist + do while(associated(block)) + totalSize = totalSize + size(block % procNeighs) + block => block % next + end do + + allocate(tempIntegerArray(totalSize)) + + block => domain % blocklist + iStart = 1 + do while(associated(block)) + localSize = size(block % procNeighs) + tempIntegerArray(iStart:iStart+localSize-1) = block % procNeighs + iStart = iStart + localSize + block => block % next + end do + + ! get unique array for complete list + call uniqueIntegerList(tempIntegerArray, procNeighs) + + deallocate(tempIntegerArray) + + end subroutine compute_procNeighs !}}} + +!*********************************************************************** +! +! routine uniqueIntegerList(array, uniqueList) +! +!> \brief Compute unique entries in array with output in uniqueList +!> \author Phillip Wolfram +!> \date 06/26/2014 +!> \details +!> This routine computes the unique entries in an array using a +!> linked list for dynamic memory storage +! +!----------------------------------------------------------------------- + subroutine uniqueIntegerList(array, uniqueList) !{{{ + implicit none + integer, dimension(:), pointer, intent(out) :: uniqueList + integer, dimension(:), pointer, intent(in) :: array + + type simplelist + type (simplelist), pointer :: next => null() + integer :: num + end type simplelist + + type (simplelist), pointer :: listhead, templist, currlist + + integer :: nlist, i + + ! parse the simple list, looking for unique values + ! algorithm will scale like Nblocks*NCells + + if(.not.associated(array)) then + uniqueList => null() + return + end if + + ! first entry + allocate(listhead) + listhead % num = array(1) + nlist = 1 + + do i = 2, size(array) + currlist => listhead + ! check to see if value is on list + do while(associated(currlist)) + if(currlist % num == array(i)) then + exit + else + if(.not.associated(currlist % next)) then + ! we are on the end of the list, so we should add the entry + allocate(templist) + templist % num = array(i) + nlist = nlist + 1 + currlist % next => templist + end if + currlist => currlist % next + end if + end do + end do + + ! now we have a complete, unique list so store it + if(associated(uniqueList)) write(stderrunit,*) 'Trying to allocate uniqueList, which is already allocated!' + allocate(uniqueList(nlist)) + + currlist => listhead + i = 1 + do while(associated(currlist)) + uniqueList(i) = currlist % num + currlist => currlist % next + i = i + 1 + end do + + ! deallocate linked list + currlist => listhead + do while(associated(currlist)) + templist => currlist % next + deallocate(currlist) + currlist => templist + end do + + end subroutine uniqueIntegerList !}}} + +!*********************************************************************** +! +! routine compute_all_particle_values_unique_int +! +!> \brief Get a unique list of values across particlelists on all blocks +!> \author Phillip Wolfram +!> \date 07/02/2014 +!> \details +!> This routine computes a unique list of values for all the particles +!> on the processor. +! +!----------------------------------------------------------------------- + subroutine compute_all_particle_values_unique_int(domain, err, attrName, attrData) !{{{ + implicit none + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + character(len=*) :: attrName + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + integer, dimension(:), pointer, intent(out) :: attrData + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + type (block_type), pointer :: block + integer, dimension(:), pointer :: tempIntegerArray + integer :: localSize, totalSize, iStart, nPart + + err = 0 + + ! need to get full set of attrData from each processor and form unique list + + totalSize = 0 + + block => domain % blocklist + do while(associated(block)) + nPart = count_particlelist(block % particlelist) + if (nPart > 0) then + allocate(attrData(nPart)) + call get_halo_data_from_particle_list_array(block % particlelist, trim(attrName), attrData) + totalSize = totalSize + size(attrData) + deallocate(attrData) + end if + block => block % next + end do + + if (totalSize > 0) allocate(tempIntegerArray(totalSize)) + + block => domain % blocklist + iStart = 1 + do while(associated(block)) + nPart = count_particlelist(block % particlelist) + if (nPart > 0) then + allocate(attrData(nPart)) + call get_halo_data_from_particle_list_array(block % particlelist, trim(attrName), attrData) + localSize = size(attrData) + tempIntegerArray(iStart:iStart+localSize-1) = attrData + iStart = iStart + localSize + deallocate(attrData) + end if + block => block % next + end do + + ! get unique array for complete list + !if(associated(tempIntegerArray)) write(stderrUnit,*) 'tempIntegerArray = ', tempIntegerArray + call uniqueIntegerList(tempIntegerArray, attrData) + + if (associated(tempIntegerArray)) deallocate(tempIntegerArray) + + end subroutine compute_all_particle_values_unique_int !}}} + +!*********************************************************************** +! +! routine make_proc_to_proc_particlelist(domain, err) +! +!> \brief Compute neighboring processors from blockNeighs, +!> getting unique values across all blocks and forming the lists +!> \author Phillip Wolfram +!> \date 06/26/2014 +!> \details +!> This routine computes the lists of neighboring processors +! +!----------------------------------------------------------------------- + subroutine make_proc_to_proc_particlelists(domain, copyOnly, blockSendToName, interProcPLArray, procNeighs, err) !{{{ + implicit none + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + character(len=*), intent(in) :: blockSendToName + logical, intent(in) :: copyOnly + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(in) :: domain + integer, dimension(:), pointer, intent(in) :: procNeighs + type (mpas_list_of_particle_list_type), dimension(:), & + pointer, intent(inout) :: interProcPLArray + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_particle_list_type), pointer :: particlelist, particlelisttemp, particlelisttemp2 + integer :: thisBlock + integer, pointer :: particleBlock + integer :: particleProc, arrayIndex + !type (mpas_pool_type), pointer :: lagrPartTrackPool + type (mpas_particle_type), pointer :: particle + + err = 0 + +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'make_proc_to_proc_particlelists' +#endif + + block => domain % blocklist + do while(associated(block)) + ! for each particle on each block + particlelist => block % particlelist + do while(associated(particlelist)) +#ifdef MPAS_DEBUG + !write(stderrunit,*) 'link on particlelist ', loc(particlelist) + if(.not.associated(particlelist % particle)) then + write(stderrunit,*) 'particle not associated!' + end if +#endif + particle => particlelist % particle +#ifdef MPAS_DEBUG + if(.not.associated(particle % haloDataPool)) then + write(stderrunit,*) 'particle haloDataPool not associated!' + end if +#endif + call mpas_pool_get_array(particle % haloDataPool, blockSendToName, particleBlock) +#ifdef MPAS_DEBUG + ! For example: + !call mpas_pool_get_array(particle % haloDataPool, 'currentBlock', particleBlock) + + !write(stderrunit,*) 'particleBlock ', particleBlock, ' for ', trim(blockSendToName) + !write(stderrunit,*) 'before mpas call' +#endif + call mpas_get_owning_proc(domain % dminfo, particleBlock, particleProc) +#ifdef MPAS_DEBUG + if(particleBlock /= particleProc) write(stderrunit,*) 'Error if one block per proc: currentBlock = ', & + particleBlock, ' currentProc = ', particleProc + write(stderrunit,*) 'after mpas call' + ! determine whether it belongs on thisBlock + write(stderrUnit,*) 'myproc= ', domain % dminfo % my_proc_id, ' particleProc= ', particleProc +#endif + ! eventual support for multiple blocks + !if(particleBlock /= block % blockID) then + if(particleProc /= domain % dminfo % my_proc_id) then + ! we need to move the particle to a list for export to particleProc + ! get index for array and place particle in list at that index location + !write(stderrUnit,*) 'get array index' + arrayIndex = find_index(procNeighs, particleProc) + if(arrayIndex == -1) write(stderrUnit,*) 'Found processor is not on list of "halo" processors!' +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'ammending particle to processor index ', arrayIndex +#endif + call append_particle_to_particlelist(particle, interProcPLArray(arrayIndex)%list) +#ifdef MPAS_DEBUG + !write(stderrUnit,*) 'added particle ', loc(particle), ' on link ', loc(particlelist), ' to list' +#endif + if (.not.copyOnly) then + ! REMOVE PARTICLE FROM EXISTING PARTICLELIST + ! remove particle reference from existing particle list to prevent bug / hitting null + ! particle if particle is deallocated when interProcPLArray particlelists are destroyed + ! next two lines mean (particlelist % prev) % next => particlelist % next, which + ! fortran doesn't allow even though syntactically this makes perfect sense. + ! 3 cases: head, middle, tail + if(associated(particlelist % prev)) then + !write(stderrUnit,*) 'have previous particlelist link' + particlelisttemp => particlelist % prev + if (associated(particlelist % next)) then +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'in middle of list' +#endif + ! case of the middle + particlelisttemp % next => particlelist % next + particlelisttemp2 => particlelisttemp + ! want to keep particle memory intact because their pointers were passed previously, + ! so just empty the list, don't destroy it and its contents + particlelisttemp => particlelist % next + particlelisttemp % prev => particlelisttemp2 + + particlelisttemp => particlelisttemp % prev + ! just need to remove the single link, particle memory needs to stay intact + !write(stderrunit,*) 'deallocating link ', loc(particlelist) + ! deallocate link and get next link + deallocate(particlelist) + particlelist => particlelisttemp + else +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'in tail of list' +#endif + ! case of tail + nullify(particlelisttemp % next) + !write(stderrunit,*) 'deallocating link ', loc(particlelist) + ! deallocate link and get next link + deallocate(particlelist) + ! no other links to process + end if + else + if(associated(particlelist % next)) then +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'in head of list' +#endif + ! case of head, set new head (assumes more than one particle) + particlelisttemp => particlelist % next + nullify(particlelisttemp % prev) + deallocate(particlelist) + block % particlelist => particlelisttemp + !write(stderrunit,*) 'deallocating link ', loc(particlelist) + ! deallocate link and get next link + particlelist => particlelisttemp + else +#ifdef MPAS_DEBUG + !write(stderrUnit,*) 'single link ', loc(particlelist) + !write(stderrUnit,*) 'block % particlelist', loc(block % particlelist) +#endif + ! case of single link / particle + !write(stderrunit,*) 'deallocating link ', loc(particlelist) + deallocate(particlelist) + nullify(block % particlelist) !deallocate(block % particlelist) + ! there is no other particle in the list (we now have 0!) + end if + end if + else + particlelist => particlelist % next + end if + else + !write(stderrUnit,*) 'just go to the next particle' + particlelist => particlelist % next + end if + end do + + ! this is done for each block because we want processor - processor communication + block => block % next + end do + + end subroutine make_proc_to_proc_particlelists!}}} + + subroutine get_num_particlelists(particlelists, numLists, nPartList) !{{{ + implicit none + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_list_of_particle_list_type), dimension(:), & + pointer, intent(in) :: particlelists + integer, intent(in) :: numLists + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + integer, dimension(:), pointer, intent(inout) :: nPartList + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + integer :: i, allerr=0 + + ! now get number of particles in each list + ! for each entry in list of particlelist + nPartList = -1 + do i=1, numLists + nPartList(i) = count_particlelist(particlelists(i)%list) +#ifdef MPAS_DEBUG + write(stderrunit,*) 'nPartList(i)=', nPartList(i) +#endif + end do + + end subroutine get_num_particlelists !}}} + +!*********************************************************************** +! +! routine communicate_num_particles_send_recv +! +!> \brief Communicate the number of particles to be sent/recv'd +!> from adjacent processors +!> \author Phillip Wolfram +!> \date 06/27/2014 +!> \details +!> This routine transmitts nPartSend to be stored in nPartRecv of +!> adjacent processors in procNeighs. Not that matrix with +!> procNeighs in columns stored in rows for each processor +!> must be symmetric for this to work. +! +!----------------------------------------------------------------------- + subroutine communicate_num_particles_send_recv(domain, procNeighs, nPartSend, nPartRecv) !{{{ + implicit none + + type (domain_type), intent(in) :: domain + integer, dimension(:), pointer, intent(in) :: procNeighs + integer, dimension(:), pointer, intent(in) :: nPartSend + integer, dimension(:), pointer, intent(out) :: nPartRecv + + integer :: i, j, numProcs + integer, dimension(:), pointer :: requestID + integer :: mpi_ierr + + numProcs = size(procNeighs) + + ! set to be -1 for error catching + nPartRecv = -1 + + ! want to send individual values in nPartSend to each entry in procNeighs (paired data) + ! values obtained after communication are to be stored in nPartRecv + + allocate(requestID(2*numProcs)) +#ifdef MPAS_DEBUG +write(stderrUnit,*) 'before 1st barrier' +#ifdef _MPI + call MPI_Barrier(domain % dminfo % comm, mpi_ierr) +#endif +write(stderrUnit,*) 'after 1st barrier' +write(stderrUnit,*) 'receiving data' +write(stderrUnit,*) 'numProcs =', numProcs +#endif + do i=1,numProcs +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'procNeighs=', procNeighs + write(stderrUnit,*) 'sending data i=',i, ' procNeighs(i)=', procNeighs(i), ' nPartSend(i)=', nPartSend(i) +#endif +#ifdef _MPI + call MPI_ISend(nPartSend(i), 1, MPI_INTEGERKIND, procNeighs(i), domain % dminfo % my_proc_id, & + domain % dminfo % comm, requestID(numProcs + i), mpi_ierr) +#endif +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'receiving data i=',i, ' procNeighs(i)=', procNeighs(i) +#endif +#ifdef _MPI + call MPI_IRecv(nPartRecv(i), 1, MPI_INTEGERKIND, procNeighs(i), procNeighs(i), & + domain % dminfo % comm, requestID(i), mpi_ierr) +#endif + end do +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'done with send receive calls' +#endif +#ifdef _MPI + call MPI_WaitAll(2*numProcs, requestID, MPI_STATUSES_IGNORE, mpi_ierr) +#endif +#ifdef MPAS_DEBUG +write(stderrUnit,*) 'before 2nd barrier' +#ifdef _MPI +call MPI_Barrier(domain % dminfo % comm, mpi_ierr) +#endif +write(stderrUnit,*) 'after 2nd barrier' + write(stderrUnit,*) 'done with wait' +#endif + deallocate(requestID) + + end subroutine communicate_num_particles_send_recv !}}} + +!*********************************************************************** +! +! routine compute_particle_send_list +! +!> \brief Update send list +!> \author Phillip Wolfram +!> \date 06/24/2015 +!> \details +!> Compute send list for all particles residing on correct block 'currentBlock' +!----------------------------------------------------------------------- + subroutine compute_particle_send_list(domain, ioProcSendList) !{{{ + implicit none + type (domain_type), intent(in) :: domain + logical, dimension(:), pointer, intent(inout) :: ioProcSendList + + ! local variables + type (block_type), pointer :: block + type (mpas_particle_list_type), pointer :: particlelist + type (mpas_particle_type), pointer :: particle + integer, pointer :: ioBlock + integer :: ioProc + + block => domain % blocklist + do while (associated(block)) !{{{ + particlelist => block % particlelist + do while(associated(particlelist)) !{{{ + particle => particlelist % particle + call mpas_pool_get_array(particle % haloDataPool, 'ioBlock', ioBlock) + call mpas_get_owning_proc(domain % dminfo, ioBlock, ioProc) + ioProcSendList(ioProc+1) = .True. + ! get next particle to process on the list + particlelist => particlelist % next + end do !}}} + ! get next block + block => block % next + end do !}}} + + end subroutine compute_particle_send_list !}}} + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! routine allocate_list_particlelists +! +!> \brief MPAS allocate list of particlelists +!> \author Phillip Wolfram +!> \date 07/01/2014 +!> \details +!> This routine allocates a list of particlelists. Useful in preparation +!> to receive data from MPI communication +! +!----------------------------------------------------------------------- +subroutine allocate_list_particlelists(nPart, listPL) !{{{ + implicit none + + type (mpas_list_of_particle_list_type), dimension(:), intent(inout), pointer :: listPL + integer, dimension(:), pointer, intent(in) :: nPart + + integer :: nProcs, i + + nProcs = size(nPart) + + ! allocate size of particeLists + do i=1,nProcs + call build_new_particlelist(nPart(i), listPL(i)%list) + end do + +end subroutine allocate_list_particlelists !}}} + +!*********************************************************************** +! +! routine distribute_particlelist_to_blocks +! +!> \brief Take a list of particlelists and move them onto the appropriate +!> block on the processor +!> \author Phillip Wolfram +!> \date 07/01/2014 +!> \details +!> This routine places particles in a list of particlelist on the appropriate +!> block (currentBlock) on the processor +! +!----------------------------------------------------------------------- + subroutine distribute_particlelist_to_blocks(domain, blockSendToName, listPL) !{{{ + implicit none + + type (domain_type), intent(in) :: domain + type (mpas_list_of_particle_list_type), dimension(:), pointer, intent(in) :: listPL + character(len=*), intent(in) :: blockSendToName + + integer :: i, numLists + type (block_type), pointer :: block + type (mpas_particle_list_type), pointer :: tempPL + type (mpas_particle_type), pointer :: particle + type (mpas_pool_type), pointer :: lagrPartTrackPool + integer, pointer :: blockNum + + ! need to copy pointers to particles from each entry of the listPL and move the + ! particle to the appropriate block + + ! loop over each part of the particle list + numLists = size(listPL) + do i=1,numLists + ! get a single list of particles + tempPL => listPL(i) % list + ! iterate through the list and assign particles + do while(associated(tempPL)) + ! get the particle blockNum + particle => tempPL % particle + call mpas_pool_get_array(particle % haloDataPool, blockSendToName, blockNum) + + ! determine the block the particle should be moved to + block => domain % blocklist + !write(stderrunit,*) 'blockNum = ' , blockNum + blocksearch: do while(associated(block)) + !write(stderrunit,*) 'blockID = ', block % blockID, 'blockNum = ', blockNum + if (block % blockID == blockNum) then + ! we have the correct block + exit blocksearch + end if + block => block % next + end do blocksearch + + ! check to make sure block is correct + !write(stderrunit,*) 'blockNum = ', blockNum + if (blockNum /= block % blockID) then + write(stderrunit,*) 'block is not correct! for blockNum =', blockNum, ' and blockID = ', block % blockID + end if + + ! move the particle to the block + call append_particle_to_particlelist(particle, block % particlelist) + + ! get the next particle in the list + tempPL => tempPL % next + end do + + end do + + end subroutine distribute_particlelist_to_blocks !}}} + +!*********************************************************************** +! +! routine compute_ordering_vector +! +!> \brief Compute the orderingVector for restructuring of mixed up particles +!> into original order +!> \author Phillip Wolfram +!> \date 07/03/2014 +!> \details +!> This routine ensures that the particles are ordered consistently with +!> the ordering of the original data. +! +!----------------------------------------------------------------------- + subroutine compute_ordering_vector(arrayOrig, arrayNew, orderingVector) !{{{ + implicit none + + integer, dimension(:), pointer, intent(in) :: arrayOrig, arrayNew + integer, dimension(:), pointer, intent(out) :: orderingVector + + integer :: i, idx + + allocate(orderingVector(size(arrayOrig))) + ! allocate to -1 to that if a value isn't found it isn't random data, assuming arrays + ! are all indexed starting from 1 + orderingVector = -1 + ! loop over each element and figure out index + do i=1,size(arrayOrig) + !N.B. should in principle check to make sure index is found + idx = find_index(arrayNew, arrayOrig(i)) +#ifdef MPAS_DEBUG + if ( idx > 0 ) then +#endif + orderingVector(i) = idx +#ifdef MPAS_DEBUG + else + write(stderrunit,*) "ERROR! Didn't find correct ordering index" + end if +#endif + end do + + end subroutine compute_ordering_vector !}}} + +!*********************************************************************** +! +! routine find_index +! +!> \brief find the index corresponding to num in array +!> \author Phillip Wolfram +!> \date 07/03/2014 +!> \details +!> This routine returns the index such that array(find_index) = num. +!> If the index doesn't exist it returns -1. +! +!----------------------------------------------------------------------- + integer function find_index(array, num) !{{{ + implicit none + + integer, dimension(:), pointer, intent(in) :: array + integer, intent(in) :: num + + integer :: i + + ! allocate to negative number to make sure it breaks if + ! an index is not found + + find_index = -1 + ! an error here could be caused by running with different + ! processors (blocks) specified in the input file + ! than run with MPI + do i=1,size(array) + if(num == array(i)) then + find_index = i + return + end if + end do + +#ifdef MPAS_DEBUG + if(find_index == -1) write(stderrunit,*) 'Error: Index number ', num,' not found in array!' +#endif + + end function find_index !}}} + +!*********************************************************************** +! +! routine communicate_particle_nonhalo_data +! +!> \brief Communicate particle nonhalo data to relevant processors +!> based on particlelists +!> \author Phillip Wolfram +!> \date 07/07/2014 +!> \details +!> This routine transmitts nonHaloData from particlelists +! +!----------------------------------------------------------------------- + subroutine communicate_particle_nonhalo_data(domain, procNeighs, nPartSend, nPartRecv, listSend, listRecv) !{{{ + implicit none + + type (domain_type), intent(in) :: domain + integer, dimension(:), pointer, intent(in) :: procNeighs + integer, dimension(:), pointer, intent(in) :: nPartSend + integer, dimension(:), pointer, intent(out) :: nPartRecv + type (mpas_list_of_particle_list_type), dimension(:), pointer :: listSend, listRecv + + integer :: i, j, numProcs, numFields, numRecv, numSends + integer, dimension(:), pointer :: recvRequestID, sendRequestID + integer :: mpi_ierr + type (mpas_pool_type), pointer :: lagrPartTrackPool + type (mpas_pool_iterator_type) :: dimItr + type array1DReal_list + real (kind=RKIND), dimension(:), pointer :: val + end type + type array1DInt_list + integer, dimension(:), pointer :: val + end type + type (array1DInt_list), dimension(:), pointer :: array1DIntSend, array1DIntRecv + type (array1DReal_list), dimension(:), pointer :: array1DRealSend, array1DRealRecv + + ! for each entry in the halo pool, want to send and recv the data + +#ifdef _MPI + !call MPI_Barrier(domain % dminfo % comm) +#endif + + numProcs = size(procNeighs) + allocate(array1DRealSend(numProcs), array1DRealRecv(numProcs)) + allocate(array1DIntSend(numProcs), array1DIntRecv(numProcs)) + + numSends = 0 + do i = 1, numProcs + if (nPartSend(i) > 0) numSends = numSends + 1 + end do + allocate(sendRequestID(numSends)) + + numRecv = 0 + do i = 1, numProcs + if (nPartRecv(i) > 0) numRecv = numRecv + 1 + end do + allocate(recvRequestID(numRecv)) + + !Notes !{{{ + !! get number of items that need transfered from halo pool, numFields which is a constant + !call mpas_pool_get_subpool(domain % blocklist % structs, 'lagrPartTrackHalo', lagrPartTrackPool) + !call mpas_pool_begin_iteration(lagrPartTrackPool) + !numFields = 0 + !do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) + ! ! only need to transfer pool + ! if (dimItr % memberType == MPAS_POOL_FIELD) then + ! numFields = numFields + 1 + ! end if + !end do + !! assume, for now, that this will be constant accross processors. If not, it would need to be sent to other + !! processors too. This also presumes that properties will be fixed accross the processesors. + !}}} + + ! on each list, transmit relevant fields to associated processors (note using the var struct since it has the names + ! required and this information is on each processor, even if the pool's fields are empty their names and types + ! are there from the registry). + call mpas_pool_get_subpool(domain % blocklist % structs, 'lagrPartTrackNonHalo', lagrPartTrackPool) + call mpas_pool_begin_iteration(lagrPartTrackPool) + do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) + if (dimItr % memberType == MPAS_POOL_FIELD) then + !write(stderrUnit,*) 'transfering ', trim(dimItr % memberName) + if (dimItr % dataType == MPAS_POOL_REAL) then + ! recv + j = 1 + do i=1,numProcs + if(nPartRecv(i) > 0) then + allocate(array1DRealRecv(i)%val(nPartRecv(i))) + !write(stderrUnit,*) 'receiving real ', trim(dimItr % memberName), ' from ', procNeighs(i) + ! receive communicated data +#ifdef _MPI + call MPI_IRecv(array1DRealRecv(i)%val, nPartRecv(i), MPI_REALKIND, procNeighs(i), procNeighs(i), & + domain % dminfo % comm, recvRequestID(j), mpi_ierr) +#endif + j = j + 1 + end if + end do + ! send + j = 1 + do i=1,numProcs + if (nPartSend(i) > 0) then + allocate(array1DRealSend(i)%val(nPartSend(i))) + !write(stderrUnit,*) 'sending real ', trim(dimItr % memberName), ' to ', procNeighs(i) + call get_nonhalo_data_from_particle_list_array(listSend(i)%list, dimItr % memberName, & + array1DRealSend(i)%val) +#ifdef _MPI + call MPI_ISend(array1DRealSend(i)%val, nPartSend(i), MPI_REALKIND, procNeighs(i), & + domain % dminfo % my_proc_id, domain % dminfo % comm, sendRequestID(j), mpi_ierr) +#endif + j = j + 1 + end if + end do + +#ifdef _MPI + call MPI_WaitAll(numRecv, recvRequestID, MPI_STATUSES_IGNORE, mpi_ierr) +#endif + if (mpi_ierr /= 0) write(stderrUnit,*) 'recv: mpi_ierr = ', mpi_ierr +#ifdef _MPI + call MPI_WaitAll(numSends, sendRequestID, MPI_STATUSES_IGNORE, mpi_ierr) +#endif + if (mpi_ierr /= 0) write(stderrUnit,*) 'send: mpi_ierr = ', mpi_ierr + + ! store values + j = 1 + do i=1,numProcs + if(nPartRecv(i) > 0) then + ! place it in particle list + call add_nonhalo_data_to_particle_list_array(listRecv(i)%list, dimItr % memberName, & + array1DRealRecv(i)%val) + j = j + 1 + end if + end do + + do i=1,numProcs + if(nPartSend(i) > 0) deallocate(array1DRealSend(i)%val) + end do + do i=1,numProcs + if(nPartRecv(i) > 0) deallocate(array1DRealRecv(i)%val) + end do + !write(stderrUnit,*) 'finished' + + elseif (dimItr % dataType == MPAS_POOL_INTEGER) then + ! recv + j = 1 + do i=1,numProcs + if(nPartRecv(i) > 0) then + allocate(array1DIntRecv(i)%val(nPartRecv(i))) + ! receive communicated data + !write(stderrUnit,*) 'receiving int ', trim(dimItr % memberName), ' from ', procNeighs(i) +#ifdef _MPI + call MPI_IRecv(array1DIntRecv(i)%val, nPartRecv(i), MPI_INTEGERKIND, procNeighs(i), procNeighs(i), & + domain % dminfo % comm, recvRequestID(j), mpi_ierr) +#endif + !if( trim(dimItr % memberName) == 'currentBlock') write(stderrUnit,*) 'currentBlock received ',nPartRecv(i), ' from', procNeighs(i), ' = ', array1DIntRecv(i)%val + j = j + 1 + end if + end do + ! send + j = 1 + do i=1,numProcs + if(nPartSend(i) > 0) then + allocate(array1DIntSend(i)%val(nPartSend(i))) + !write(stderrUnit,*) 'sending int ', trim(dimItr % memberName), ' to ', procNeighs(i) + call get_nonhalo_data_from_particle_list_array(listSend(i)%list, dimItr % memberName, array1DIntSend(i)%val) + !if( trim(dimItr % memberName) == 'currentBlock') write(stderrUnit,*) 'currentBlock sent ',nPartSend(i), ' to ', procNeighs(i), ' = ', array1DIntSend(i)%val +#ifdef _MPI + call MPI_ISend(array1DIntSend(i)%val, nPartSend(i), MPI_INTEGERKIND, procNeighs(i), & + domain % dminfo % my_proc_id, domain % dminfo % comm, sendRequestID(j), mpi_ierr) +#endif + j = j + 1 + end if + end do + +#ifdef _MPI + call MPI_WaitAll(numRecv, recvRequestID, MPI_STATUSES_IGNORE, mpi_ierr) +#endif + if (mpi_ierr /= 0) write(stderrUnit,*) 'mpi_ierr = ', mpi_ierr +#ifdef _MPI + call MPI_WaitAll(numSends, sendRequestID, MPI_STATUSES_IGNORE, mpi_ierr) +#endif + if (mpi_ierr /= 0) write(stderrUnit,*) 'mpi_ierr = ', mpi_ierr + + !do i=1,numProcs + ! if(nPartRecv(i) > 0) write(stderrUnit,*) 'Received ', trim(dimItr % memberName), ' = ', array1DIntRecv(i) % val + !end do + + ! store values + do i=1,numProcs + if(nPartRecv(i) > 0) then + ! place it in particle list + call add_nonhalo_data_to_particle_list_array(listRecv(i)%list, dimItr % memberName, array1DIntRecv(i)%val) + j = j + 1 + end if + end do + + do i=1,numProcs + if(nPartSend(i) > 0) deallocate(array1DIntSend(i)%val) + end do + do i=1,numProcs + if(nPartRecv(i) > 0) deallocate(array1DIntRecv(i)%val) + end do + !write(stderrUnit,*) 'finished' + else + !write(stderrunit,*) "Different field type than implemented during nonHalo communication!" + end if + elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then + ! ignore dimensions for now and have this code so they aren't printed as an error message + else + !write(stderrunit,*) "Different type expected in registry for key ", trim(dimItr % memberName), " in nonHalo data for communication, don't know what to do!" + end if + end do + + deallocate(array1DIntSend, array1DIntRecv, array1DRealSend, array1DRealRecv, recvRequestID, sendRequestID) + !write(stderrunit,*) 'Finished primary MPI communication for nonhalo' + + end subroutine communicate_particle_nonhalo_data!}}} + +!*********************************************************************** +! +! routine communicate_particle_halo_data +! +!> \brief Communicate particle halo data to relevant processors +!> based on particlelists +!> \author Phillip Wolfram +!> \date 07/01/2014 +!> \details +!> This routine transmitts haloData from particlelists +! +!----------------------------------------------------------------------- + subroutine communicate_particle_halo_data(domain, procNeighs, nPartSend, nPartRecv, listSend, listRecv) !{{{ + implicit none + + type (domain_type), intent(in) :: domain + integer, dimension(:), pointer, intent(in) :: procNeighs + integer, dimension(:), pointer, intent(in) :: nPartSend + integer, dimension(:), pointer, intent(out) :: nPartRecv + type (mpas_list_of_particle_list_type), dimension(:), pointer :: listSend, listRecv + + integer :: i, j, numProcs, numFields, numRecv, numSends + integer, dimension(:), pointer :: recvRequestID, sendRequestID + integer :: mpi_ierr + type (mpas_pool_type), pointer :: lagrPartTrackPool + type (mpas_pool_iterator_type) :: dimItr + type array1DReal_list + real (kind=RKIND), dimension(:), pointer :: val + end type + type array1DInt_list + integer, dimension(:), pointer :: val + end type + type (array1DInt_list), dimension(:), pointer :: array1DIntSend, array1DIntRecv + type (array1DReal_list), dimension(:), pointer :: array1DRealSend, array1DRealRecv + + ! for each entry in the halo pool, want to send and recv the data + +#ifdef _MPI + !call MPI_Barrier(domain % dminfo % comm) +#endif + + numProcs = size(procNeighs) + allocate(array1DRealSend(numProcs), array1DRealRecv(numProcs)) + allocate(array1DIntSend(numProcs), array1DIntRecv(numProcs)) + + numSends = 0 + do i = 1, numProcs + if (nPartSend(i) > 0) numSends = numSends + 1 + end do + allocate(sendRequestID(numSends)) + + numRecv = 0 + do i = 1, numProcs + if (nPartRecv(i) > 0) numRecv = numRecv + 1 + end do + allocate(recvRequestID(numRecv)) + + !Notes !{{{ + !! get number of items that need transfered from halo pool, numFields which is a constant + !call mpas_pool_get_subpool(domain % blocklist % structs, 'lagrPartTrackHalo', lagrPartTrackPool) + !call mpas_pool_begin_iteration(lagrPartTrackPool) + !numFields = 0 + !do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) + ! ! only need to transfer pool + ! if (dimItr % memberType == MPAS_POOL_FIELD) then + ! numFields = numFields + 1 + ! end if + !end do + !! assume, for now, that this will be constant accross processors. If not, it would need to be sent to other + !! processors too. This also presumes that properties will be fixed accross the processesors. + !}}} + + ! on each list, transmit relevant fields to associated processors (note using the var struct since it has the names + ! required and this information is on each processor, even if the pool's fields are empty their names and types + ! are there from the registry). + call mpas_pool_get_subpool(domain % blocklist % structs, 'lagrPartTrackHalo', lagrPartTrackPool) + call mpas_pool_begin_iteration(lagrPartTrackPool) + do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) + if (dimItr % memberType == MPAS_POOL_FIELD) then + !write(stderrUnit,*) 'transfering ', trim(dimItr % memberName) + if (dimItr % dataType == MPAS_POOL_REAL) then + ! recv + j = 1 + do i=1,numProcs + if(nPartRecv(i) > 0) then + allocate(array1DRealRecv(i)%val(nPartRecv(i))) + !write(stderrUnit,*) 'receiving real ', trim(dimItr % memberName), ' from ', procNeighs(i) + ! receive communicated data +#ifdef _MPI + call MPI_IRecv(array1DRealRecv(i)%val, nPartRecv(i), MPI_REALKIND, procNeighs(i), procNeighs(i), & + domain % dminfo % comm, recvRequestID(j), mpi_ierr) +#endif + j = j + 1 + end if + end do + ! send + j = 1 + do i=1,numProcs + if (nPartSend(i) > 0) then + allocate(array1DRealSend(i)%val(nPartSend(i))) + !write(stderrUnit,*) 'sending real ', trim(dimItr % memberName), ' to ', procNeighs(i) + call get_halo_data_from_particle_list_array(listSend(i)%list, dimItr % memberName, & + array1DRealSend(i)%val) +#ifdef _MPI + call MPI_ISend(array1DRealSend(i)%val, nPartSend(i), MPI_REALKIND, procNeighs(i), & + domain % dminfo % my_proc_id, domain % dminfo % comm, sendRequestID(j), mpi_ierr) +#endif + j = j + 1 + end if + end do + +#ifdef _MPI + call MPI_WaitAll(numRecv, recvRequestID, MPI_STATUSES_IGNORE, mpi_ierr) +#endif + if (mpi_ierr /= 0) write(stderrUnit,*) 'recv: mpi_ierr = ', mpi_ierr +#ifdef _MPI + call MPI_WaitAll(numSends, sendRequestID, MPI_STATUSES_IGNORE, mpi_ierr) +#endif + if (mpi_ierr /= 0) write(stderrUnit,*) 'send: mpi_ierr = ', mpi_ierr + + ! store values + j = 1 + do i=1,numProcs + if(nPartRecv(i) > 0) then + ! place it in particle list + call add_halo_data_to_particle_list_array(listRecv(i)%list, dimItr % memberName, & + array1DRealRecv(i)%val) + j = j + 1 + end if + end do + + do i=1,numProcs + if(nPartSend(i) > 0) deallocate(array1DRealSend(i)%val) + end do + do i=1,numProcs + if(nPartRecv(i) > 0) deallocate(array1DRealRecv(i)%val) + end do + !write(stderrUnit,*) 'finished' + + elseif (dimItr % dataType == MPAS_POOL_INTEGER) then + ! recv + j = 1 + do i=1,numProcs + if(nPartRecv(i) > 0) then + allocate(array1DIntRecv(i)%val(nPartRecv(i))) + ! receive communicated data + !write(stderrUnit,*) 'receiving int ', trim(dimItr % memberName), ' from ', procNeighs(i) +#ifdef _MPI + call MPI_IRecv(array1DIntRecv(i)%val, nPartRecv(i), MPI_INTEGERKIND, procNeighs(i), procNeighs(i), & + domain % dminfo % comm, recvRequestID(j), mpi_ierr) +#endif + !if( trim(dimItr % memberName) == 'currentBlock') write(stderrUnit,*) 'currentBlock received ',nPartRecv(i), ' from', procNeighs(i), ' = ', array1DIntRecv(i)%val + j = j + 1 + end if + end do + ! send + j = 1 + do i=1,numProcs + if(nPartSend(i) > 0) then + allocate(array1DIntSend(i)%val(nPartSend(i))) + !write(stderrUnit,*) 'sending int ', trim(dimItr % memberName), ' to ', procNeighs(i) + call get_halo_data_from_particle_list_array(listSend(i)%list, dimItr % memberName, array1DIntSend(i)%val) + !if( trim(dimItr % memberName) == 'currentBlock') write(stderrUnit,*) 'currentBlock sent ',nPartSend(i), ' to ', procNeighs(i), ' = ', array1DIntSend(i)%val +#ifdef _MPI + call MPI_ISend(array1DIntSend(i)%val, nPartSend(i), MPI_INTEGERKIND, procNeighs(i), & + domain % dminfo % my_proc_id, domain % dminfo % comm, sendRequestID(j), mpi_ierr) +#endif + j = j + 1 + end if + end do + +#ifdef _MPI + call MPI_WaitAll(numRecv, recvRequestID, MPI_STATUSES_IGNORE, mpi_ierr) +#endif + if (mpi_ierr /= 0) write(stderrUnit,*) 'mpi_ierr = ', mpi_ierr +#ifdef _MPI + call MPI_WaitAll(numSends, sendRequestID, MPI_STATUSES_IGNORE, mpi_ierr) +#endif + if (mpi_ierr /= 0) write(stderrUnit,*) 'mpi_ierr = ', mpi_ierr + + !do i=1,numProcs + ! if(nPartRecv(i) > 0) write(stderrUnit,*) 'Received ', trim(dimItr % memberName), ' = ', array1DIntRecv(i) % val + !end do + + ! store values + do i=1,numProcs + if(nPartRecv(i) > 0) then + ! place it in particle list + call add_halo_data_to_particle_list_array(listRecv(i)%list, dimItr % memberName, array1DIntRecv(i)%val) + j = j + 1 + end if + end do + + do i=1,numProcs + if(nPartSend(i) > 0) deallocate(array1DIntSend(i)%val) + end do + do i=1,numProcs + if(nPartRecv(i) > 0) deallocate(array1DIntRecv(i)%val) + end do + !write(stderrUnit,*) 'finished' + else + !write(stderrunit,*) "Different field type than implemented during halo communication!" + end if + elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then + ! ignore dimensions for now and have this code so they aren't printed as an error message + else + !write(stderrunit,*) "Different type expected in registry for key ", trim(dimItr % memberName), " in halo data for communication, don't know what to do!" + end if + end do + + deallocate(array1DIntSend, array1DIntRecv, array1DRealSend, array1DRealRecv, recvRequestID, sendRequestID) + !write(stderrunit,*) 'Finished primary MPI communication for halo' + + end subroutine communicate_particle_halo_data!}}} + +!*********************************************************************** +! +! routine allocate_nonHalo_data +! +!> \brief Allocate space for nonHalo data for diagnostic output +!> on particlelists +!> \author Phillip Wolfram +!> \date 07/01/2014 +!> \details +!> This routine allocates space for nonHaloData on the particlelist +! +!----------------------------------------------------------------------- + subroutine allocate_nonHalo_data(domain, particlelist) !{{{ + implicit none + + type (domain_type), intent(in) :: domain + type (mpas_particle_list_type), pointer, intent(in) :: particlelist + type (mpas_pool_type), pointer :: lagrPartTrackPool + type (mpas_pool_iterator_type) :: dimItr + + integer :: i, nPart + real (kind=RKIND), dimension(:), pointer :: array1DRealPointer + integer, dimension(:), pointer :: array1DIntPointer + + + ! get number of particle on list + nPart = count_particlelist(particlelist) + + ! allocate zero arrays + allocate(array1DRealPointer(nPart)) + allocate(array1DIntPointer(nPart)) + array1DRealPointer = 0.0_RKIND + array1DIntPointer = 0 + + ! on each list, transmit relevant fields to associated processors + call mpas_pool_get_subpool(domain % blocklist % structs, 'lagrPartTrackNonHalo', lagrPartTrackPool) + call mpas_pool_begin_iteration(lagrPartTrackPool) + do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) + if (dimItr % memberType == MPAS_POOL_FIELD) then + if (dimItr % dataType == MPAS_POOL_REAL) then + call add_nonhalo_data_to_particle_list_array(particlelist, dimItr % memberName, array1DRealPointer) + elseif (dimItr % dataType == MPAS_POOL_INTEGER) then + call add_nonhalo_data_to_particle_list_array(particlelist, dimItr % memberName, array1DIntPointer) + else + !write(stderrunit,*) "Different field type than implemented during halo communication!" + end if + elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then + ! ignore dimensions for now and have this code so they aren't printed as an error message + else + !write(stderrunit,*) "Different type expected in registry for key ", trim(dimItr % memberName), " in halo data for communication, don't know what to do!" + end if + end do + + ! deallocate arrays + deallocate(array1DRealPointer) + deallocate(array1DIntPointer) + + end subroutine allocate_nonHalo_data !}}} + + subroutine allocate_list_nonHalo_data(domain, listPL) !{{{ + implicit none + + type (domain_type), intent(in) :: domain + type (mpas_list_of_particle_list_type), dimension(:), pointer, intent(inout) :: listPL + + integer :: i, numList + + numList = size(listPL) + do i=1, numList + call allocate_nonHalo_data(domain, listPL(i)%list) + end do + + end subroutine allocate_list_nonHalo_data !}}} + +!*********************************************************************** +! +! routine build_block_particlelists +! +!> \brief Allocates empty particlelist +!> \author Phillip Wolfram +!> \date 04/15/2014 +!> \details +!> This routine allocates empty particlelist data structures +! +!----------------------------------------------------------------------- + subroutine build_block_particlelists(domain, err)!{{{ + + implicit none + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: meshPool + type (mpas_particle_list_type), pointer :: particlelist + integer, pointer :: nParticles + + err = 0 + + block => domain % blocklist + do while (associated(block)) + ! allocate pointers + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nParticles', nParticles) + + ! allocate the memory in its location for use +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'in build_block_particlelists: nParticles = ', nParticles + +#endif + if (nParticles > 0) then + allocate(block % particlelist) + particlelist => block % particlelist + + !----------------------------------------------------------------- + ! populate list of particles from input data structures + !----------------------------------------------------------------- + + ! initialize the particlelist for population + call build_new_particlelist(nParticles, particlelist, block % blockID) + end if + + block => block % next + end do + + end subroutine build_block_particlelists!}}} + + subroutine clear_block_particlelists(domain, err) !{{{ + implicit none + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + type (block_type), pointer :: block + + err = 0 + + block => domain % blocklist + do while (associated(block)) + + call mpas_particle_list_destroy_particle_list(block % particlelist) + + block => block % next + end do + + end subroutine clear_block_particlelists !}}} + +!*********************************************************************** +! +! routine read_haloData +! +!> \brief Reads haloData from netCDF-injected struct arrays +!> \author Phillip Wolfram +!> \date 04/15/2014 +!> \details +!> This routine reads haloData input for this MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + subroutine read_haloData(domain, err)!{{{ + + implicit none + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: lagrPartTrackPool + type (mpas_pool_iterator_type) :: dimItr + type (mpas_particle_list_type), pointer :: particlelist + type (field1DReal), pointer :: field1DRealPointer + !type (field2DReal), pointer :: field2DRealPointer + type (field1DInteger), pointer :: field1DIntPointer + integer, dimension(:), pointer :: array1DInt + + err = 0 + + block => domain % blocklist + do while (associated(block)) + ! allocate pointers + particlelist => block % particlelist + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackHalo', lagrPartTrackPool) + + ! iterate over each member of the pool and make the relevant assignment + call mpas_pool_begin_iteration(lagrPartTrackPool) + do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) + ! determine the type of data + if (dimItr % memberType == MPAS_POOL_FIELD) then + if (dimItr % dataType == MPAS_POOL_REAL) then + call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DRealPointer) +#ifdef MPAS_DEBUG + write(stderrunit,*) dimItr % memberName, ' = ' + write(stderrunit,*) field1DRealPointer % array +#endif + call add_halo_data_to_particle_list(particlelist, dimItr % memberName, field1DRealPointer) + elseif (dimItr % dataType == MPAS_POOL_INTEGER) then + call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DIntPointer) + ! assign ioBlock explicitly during initial read + if (dimItr % memberName == 'ioBlock') then +#ifdef MPAS_DEBUG + write(stderrunit,*) 'ioBlock = ', field1DIntPointer % array +#endif + field1DIntPointer % array = domain % dminfo % my_proc_id + end if + call add_halo_data_to_particle_list(particlelist, dimItr % memberName, field1DIntPointer) + else +#ifdef MPAS_DEBUG + write(stderrunit,*) "Different field type than implemented during halo read!" +#endif + end if + elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then + ! ignore dimensions for now and have this code so they aren't printed as an error message + else +#ifdef MPAS_DEBUG + write(stderrunit,*) "Different type expected in registry for key ", trim(dimItr % memberName), " in halo data for read, don't know what to do!" + ! false warning for + !Different type expected in registry for key on_a_sphere in nonHalo data for read, don't know what to do! + !Different type expected in registry for key sphere_radius in nonHalo data for read, don't know what to do! + !Different type expected in registry for key is_periodic in nonHalo data for read, don't know what to do! + !Different type expected in registry for key x_period in nonHalo data for read, don't know what to do! + !Different type expected in registry for key y_period in nonHalo data for read, don't know what to do! +#endif + end if + end do + + block => block % next + end do +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'Finished reading halo data' +#endif + + end subroutine read_haloData!}}} + +!*********************************************************************** +! +! routine read_nonhaloData +! +!> \brief Reads nonhaloData from netCDF-injected struct arrays +!> \author Phillip Wolfram +!> \date 04/15/2014 +!> \details +!> This routine reads nonhaloData input for this MPAS-Ocean analysis member. +! +!----------------------------------------------------------------------- + subroutine read_nonhaloData(domain, err)!{{{ + + implicit none + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(in) :: domain + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: lagrPartTrackPool + type (mpas_pool_iterator_type) :: dimItr + type (mpas_particle_list_type), pointer :: particlelist + type (field1DReal), pointer :: field1DRealPointer + type (field1DInteger), pointer :: field1DIntPointer + + err = 0 + + block => domain % blocklist + do while (associated(block)) + ! allocate pointers + particlelist => block % particlelist + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackNonHalo', lagrPartTrackPool) + + ! iterate over each member of the pool and make the relevant assignment + call mpas_pool_begin_iteration(lagrPartTrackPool) + do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) + ! determine the type of data + if (dimItr % memberType == MPAS_POOL_FIELD) then + if (dimItr % dataType == MPAS_POOL_REAL) then + call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DRealPointer) + call add_nonhalo_data_to_particle_list(particlelist, dimItr % memberName, field1DRealPointer) + elseif (dimItr % dataType == MPAS_POOL_INTEGER) then + call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DIntPointer) + call add_nonhalo_data_to_particle_list(particlelist, dimItr % memberName, field1DIntPointer) + else +#ifdef MPAS_DEBUG + write(stderrunit,*) "Different field type than implemented in nonHalo read!" +#endif + end if + elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then + ! ignore dimensions for now and have this code so they aren't printed as an error message + else +#ifdef MPAS_DEBUG + write(stderrunit,*) "Different type expected in registry for key ", trim(dimItr % memberName), " in nonHalo data for read, don't know what to do!" +#endif + end if + end do + + ! alternatively, could initialize these fields or just make sure that they exist! + + block => block % next + end do +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'Finished reading non-halo data' +#endif + + end subroutine read_nonhaloData!}}} + +!*********************************************************************** +! +! routine mpas_particle_list_update_computational_halos +! +!> \brief Update halo +!> \author Phillip Wolfram +!> \date 06/24/2015 +!> \details +!> This routine updates the halos for particles within the particlelist loop. +!> This constitutes a computational transfer of a particle from one domain +!> to another. Its main goals are to +!> 1. determine if iCell is on halo (just set each particle's +!> currentBlock to the correct currentBlock +!> 2. determine owning block in halo, update particle's currentBlock +!> 3. determine currentBlock ownership of iCell and set cellOwnerBlock +!> to be current block +! +!----------------------------------------------------------------------- + subroutine mpas_particle_list_update_computational_halos(domain, block, particle, poolname, iCell, & + arrayIndex, ioProcRecvList, gioProcNeighs ) !{{{ + implicit none + type (domain_type), intent(inout) :: domain + type (block_type), intent(inout), pointer :: block + type (mpas_particle_type), intent(inout), pointer :: particle + character(len=*), intent(in) :: poolname + integer, intent(inout) :: iCell, arrayIndex + integer, dimension(:), pointer, intent(inout) :: gioProcNeighs + logical, dimension(:,:), pointer, intent(inout) :: ioProcRecvList + + ! local variables + integer :: currentProc, ioProc + type (mpas_pool_type), pointer :: lagrPartTrackCellsPool + integer, pointer :: currentBlock, ioBlock, transfered + integer, dimension(:), pointer :: cellOwnerBlock + + call mpas_pool_get_subpool(block % structs, trim(poolname), lagrPartTrackCellsPool) + call mpas_pool_get_array(lagrPartTrackCellsPool, 'cellOwnerBlock', cellOwnerBlock) + call mpas_pool_get_array(particle % haloDataPool, 'currentBlock', currentBlock) + call mpas_pool_get_array(particle % haloDataPool, 'ioBlock', ioBlock) + if(cellOwnerBlock(iCell) /= currentBlock) then + ! increment transfer counter + call mpas_pool_get_array(particle % haloDataPool, 'transfered', transfered) + transfered = transfered + 1 + ! set new current block + currentBlock = cellOwnerBlock(iCell) + ! reset cell_id to be brute force computed on new block after trasnfer + iCell = -1 + end if + call mpas_get_owning_proc(domain % dminfo, currentBlock, currentProc) + call mpas_get_owning_proc(domain % dminfo, ioBlock, ioProc) + + ! increment data for receiving processors (sum should be total number of particles on processor) +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'g_ioProcNeighs=',gioProcNeighs + write(stderrUnit,*) 'ioProc=',ioProc +#endif + arrayIndex = find_index(gioProcNeighs, ioProc) + ioProcRecvList(arrayIndex, currentProc+1) = .True. + ! must be computed after computational particles are transferred (this was a bug left-over from serial IO) + end subroutine mpas_particle_list_update_computational_halos !}}} + +!}}} + +!----------------------------------------------------------------------- +! +! TESTING SUBROUTINES +! +!----------------------------------------------------------------------- +!{{{ + subroutine mpas_particle_list_test_neighscalc(domain, err) !{{{ + implicit none + + type (domain_type), intent(in) :: domain + integer, intent(out) :: err !< Output: error flag + type (block_type), pointer :: block + + err = 0 + block => domain % blocklist + do while (associated(block)) + + ! write out all blockNeighs and procNeighs + write(stderrUnit,*) 'blockID = ', block % blockID + write(stderrUnit,*) 'blockNeighs = ', block % blockNeighs + write(stderrUnit,*) 'procNeighs = ', block % procNeighs + + block => block % next + end do + + end subroutine mpas_particle_list_test_neighscalc !}}} + + subroutine mpas_particle_list_test_numparticles_to_neighprocs(myproc, procNeighs, ioProcNeighs) !{{{ + implicit none + integer, intent(in) :: myproc + integer, dimension(:), pointer, intent(in) :: procNeighs, ioProcNeighs + + integer :: i, numNeighs + + numNeighs = size(procNeighs) + + write(stderrUnit,*) 'myproc, procNeighs' + do i=1,numNeighs + write(stderrUnit,*) myproc, procNeighs(i) + end do + if(associated(ioProcNeighs)) then + write(stderrUnit,*) 'myproc, ioProcNeighs' + numNeighs = size(ioProcNeighs) + do i=1,numNeighs + write(stderrUnit,*) myproc, ioProcNeighs(i) + end do + end if + + end subroutine mpas_particle_list_test_numparticles_to_neighprocs !}}} + + subroutine mpas_particle_list_test_num_current_particlelist(domain) !{{{ + implicit none + type (domain_type), intent(in) :: domain + type (block_type), pointer :: block + integer :: nPartList, nPartList_particles + + block => domain % blocklist + do while(associated(block)) + ! THIS LINE CAUSED A VERY, VERY, VERY NASTY BUG-- BE CAREFUL ABOUT GETTING THE LOCATION OF POTENTIALLY NULLS! + nPartList = count_particlelist(block % particlelist) + nPartList_particles = count_particlelist_particles(block % particlelist) + write(stderrUnit,*) 'block = ', block % blockID, ' nPartList= ', nPartList, ' nparticles = ', nPartList_particles + if (nPartList > nPartList_particles) then + write(stderrUnit,*) 'Possible error! ', nPartList - nPartList_particles, ' particles on particle list is not allocated!' + end if + + block => block % next + end do + + end subroutine mpas_particle_list_test_num_current_particlelist!}}} + + subroutine test_currentBlock(domain) !{{{ + implicit none + type (domain_type), intent(in) :: domain + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: lagrPartTrackPool + integer, dimension(:), pointer :: field1DInt + integer :: currentBlock, countOnProc, i + countOnProc = 0 + block => domain % blocklist + do while(associated(block)) + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackHalo', lagrPartTrackPool) + call mpas_pool_get_array(lagrPartTrackPool, 'currentBlock', field1DInt) + do i=1,size(field1DInt(:)) + if (field1DInt(i) == block % blockID) countOnProc = countOnProc + 1 + end do + + block => block % next + end do + write(stderrUnit,*) 'number of particles on processor = ', countOnProc + + end subroutine test_currentBlock !}}} + + subroutine test_num_particles_on_particlelist(listPL, nlist) !{{{ + implicit none + integer, intent(in) :: nlist + type (mpas_list_of_particle_list_type), dimension(:), pointer, intent(in) :: listPL + + integer :: i, sumtot, listparticles + + sumtot = 0 + do i = 1, nlist + listparticles = count_particlelist(listPL(i)%list) + write(stderrUnit,*) 'list i=',i,' nparticles=', listparticles + sumtot = sumtot + listparticles + end do + write(stderrunit,*) 'total_on_list=', sumtot + end subroutine test_num_particles_on_particlelist !}}} +!}}} + + +end module ocn_particle_list +! vim: foldmethod=marker From 17ac83bef619c8efe3528037c173708f6733af8b Mon Sep 17 00:00:00 2001 From: Jon Woodring Date: Fri, 2 Oct 2015 12:02:38 -0600 Subject: [PATCH 0291/1724] Put xtime into the stream AFTER we read it (so not to clobber existing xtime.) --- .../mpas_ocn_time_series_stats.F | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index 4b33e5d4ac..e7ec40f12a 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -807,10 +807,6 @@ subroutine modify_stream(domain, instance, series, err)!{{{ call mpas_stream_mgr_set_property(domain % streamManager, & restart_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .false., ierr=err) - ! add xtime to the restart - call mpas_stream_mgr_add_field(domain % streamManager, & - restart_name, TIME_STREAM, ierr=err) - ! create and put the counters in the streams do b = 1, series % number_of_buffers write(buf_identifier, '(I0)') b @@ -887,6 +883,19 @@ subroutine modify_stream(domain, instance, series, err)!{{{ call mpas_stream_mgr_read(domain % streamManager, streamID = restart_name, & ierr=err) + ! add xtime afterwards because we don't want to clobber the existing xtime + ! make restart mutable + call mpas_stream_mgr_set_property(domain % streamManager, & + restart_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .false., ierr=err) + + ! add xtime to the restart + call mpas_stream_mgr_add_field(domain % streamManager, & + restart_name, TIME_STREAM, ierr=err) + + ! make restart immutable + call mpas_stream_mgr_set_property(domain % streamManager, & + restart_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .true., ierr=err) + end subroutine modify_stream!}}} From 9e24e4991c403fdbb5b7d7819857ecb7df2858ef Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Tue, 6 Oct 2015 04:47:01 -0700 Subject: [PATCH 0292/1724] Fix first stream read on restart run A previous PR (#574) added reading of all streams on initializing a forward run. This commit moves this read after the timers for restart and init reading have already been reset, preventing data from the init stream from reading over the restart data. --- src/core_ocean/mode_forward/mpas_ocn_forward_mode.F | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index 4d786de81c..c4370c057e 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -165,14 +165,19 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ call MPAS_stream_mgr_read(domain % streamManager, streamID='input', ierr=err_tmp) end if - call mpas_stream_mgr_read(domain % streamManager, ierr=err_tmp) - ierr = ior(ierr, err_tmp) - call mpas_timer_stop('io_read') call mpas_timer_start('reset_io_alarms', .false.) call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID='input', ierr=err_tmp) call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID='restart', ierr=err_tmp) call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) + call mpas_timer_stop('reset_io_alarms') + + ! Read the remaining input streams + call mpas_timer_start('io_read', .false.) + call mpas_stream_mgr_read(domain % streamManager, ierr=err_tmp) + ierr = ior(ierr, err_tmp) + call mpas_timer_stop('io_read') + call mpas_timer_start('reset_io_alarms', .false.) call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_INPUT, ierr=err_tmp) ierr = ior(ierr, err_tmp) call mpas_timer_stop('reset_io_alarms') From 19b8ee4ddec9f589c3b94633ee15ad7431e7a867 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 24 Sep 2015 11:29:04 -0600 Subject: [PATCH 0293/1724] Fix some issues with XML formatting Specifically, this commit replaces "<=" with "less than or equal" as some XML parsers cannot parse this (even if it's in an attribute, it breaks the parser). Additionally, this commit cleans up whitespace differences to ensure the registry file is formatted the same as other registry files. --- .../Registry_mixed_layer_depths.xml | 87 +++++++++---------- 1 file changed, 42 insertions(+), 45 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml index f19448fdd7..768ae1d00f 100644 --- a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml +++ b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml @@ -1,65 +1,63 @@ + - + - - + - - @@ -67,17 +65,16 @@ - + description="mixed layer depth based on temperature threshold" + /> - From ced86f1739e31ab0cb5166e583c5a35b1d35e8b1 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 24 Sep 2015 11:38:22 -0600 Subject: [PATCH 0294/1724] Adding a missing type specification in EPFT This commit adds a missing type specifiction to a real defined within the EPFT analysis member. Without this type definition, some compilers assume the real is an r4 rather than an r8 and fail to build as the input arguments don't match the interface. --- src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index 69cb02b0ae..0b5d83cc96 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -2899,7 +2899,7 @@ end subroutine mpas_divergence_in_r3_buoyancy!}}} subroutine mpas_vector_R3Cell_to_Edge(vectorCell, meshPool, & vectorEdge) - real, dimension(:,:,:), intent(in) :: vectorCell + real (kind=RKIND), dimension(:,:,:), intent(in) :: vectorCell type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information real (kind=RKIND), dimension(:,:,:), intent(out) :: vectorEdge From e91d56340a96203e3094e7632af99e022ef88c00 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 24 Sep 2015 11:42:01 -0600 Subject: [PATCH 0295/1724] Add missing kind specifications to SOMA This commit adds missing kind specifications to the SOMA init configuration. Without these type specifications, some compilers assume the reals are r4 instead of r8 and the model fails to build since the input arguments don't match the interface. --- src/core_ocean/mode_init/mpas_ocn_init_soma.F | 28 +++++++++---------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_soma.F b/src/core_ocean/mode_init/mpas_ocn_init_soma.F index 8c27e023be..6aee7f16e9 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_soma.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_soma.F @@ -97,20 +97,20 @@ subroutine ocn_init_setup_soma(domain, iErr)!{{{ ! SOMA test case run-time configuration parameters integer, pointer :: config_soma_vert_levels - real, pointer :: config_eos_linear_alpha - real, pointer :: config_soma_surface_salinity - real, pointer :: config_soma_surface_temperature - real, pointer :: config_soma_density_difference_linear - real, pointer :: config_soma_thermocline_depth - real, pointer :: config_soma_center_latitude - real, pointer :: config_soma_center_longitude - real, pointer :: config_soma_domain_width - real, pointer :: config_soma_shelf_width - real, pointer :: config_soma_shelf_depth - real, pointer :: config_soma_bottom_depth - real, pointer :: config_soma_phi - real, pointer :: config_soma_ref_density - real, pointer :: config_soma_density_difference + real (kind=RKIND), pointer :: config_eos_linear_alpha + real (kind=RKIND), pointer :: config_soma_surface_salinity + real (kind=RKIND), pointer :: config_soma_surface_temperature + real (kind=RKIND), pointer :: config_soma_density_difference_linear + real (kind=RKIND), pointer :: config_soma_thermocline_depth + real (kind=RKIND), pointer :: config_soma_center_latitude + real (kind=RKIND), pointer :: config_soma_center_longitude + real (kind=RKIND), pointer :: config_soma_domain_width + real (kind=RKIND), pointer :: config_soma_shelf_width + real (kind=RKIND), pointer :: config_soma_shelf_depth + real (kind=RKIND), pointer :: config_soma_bottom_depth + real (kind=RKIND), pointer :: config_soma_phi + real (kind=RKIND), pointer :: config_soma_ref_density + real (kind=RKIND), pointer :: config_soma_density_difference ! Define dimension pointers integer, pointer :: nVertLevels, nCells, nVertLevelsP1 From 5010b37e65192625f7edea1c71e54eccd6eabbac Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 24 Sep 2015 12:54:41 -0600 Subject: [PATCH 0296/1724] Sync analysis member restart streams with main restart stream This commit updates the output_interval of restart streams for analysis members to ensure they are synchronized with the output_interval of the restart stream, based on a new feature from the lastest MPAS framework. --- src/core_ocean/analysis_members/Registry_eliassen_palm.xml | 2 +- src/core_ocean/analysis_members/Registry_time_filters.xml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index b361fea60d..82106da530 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -651,7 +651,7 @@ filename_template="restarts/eliassenPalm_restart.$Y-$M-$D.nc" filename_interval="01-00-00_00:00:00" input_interval="initial_only" - output_interval="00-00-01_00:00:00" + output_interval="stream:restart:output_interval" packages="eliassenPalmAMPKG" clobber_mode="truncate" runtime_format="single_file"> diff --git a/src/core_ocean/analysis_members/Registry_time_filters.xml b/src/core_ocean/analysis_members/Registry_time_filters.xml index 6fb671b955..078f49b62d 100644 --- a/src/core_ocean/analysis_members/Registry_time_filters.xml +++ b/src/core_ocean/analysis_members/Registry_time_filters.xml @@ -66,7 +66,7 @@ filename_template="restarts/timeFiltersRestart.$Y-$M-$D_$h.nc" filename_interval="01-00-00_00:00:00" input_interval="initial_only" - output_interval="00-00-01_00:00:00" + output_interval="stream:restart:output_interval" packages="timeFiltersAMPKG" clobber_mode="truncate" runtime_format="single_file"> From e8cce140b919fe3404199e1851623fd2b1620b84 Mon Sep 17 00:00:00 2001 From: Luke Van Roekel Date: Fri, 25 Sep 2015 11:11:50 -0600 Subject: [PATCH 0297/1724] This updates the cvmix test case to include differing stratifications in the upper ocean (mixed layer) and lower ocean. Differing mixed layer depths can be set for temperature and salinity. Users can also specify temperature and salinity jumps across the mixed layer. NOTE: for the mixed layer jumps in temperature and salinity positive values reflect an increase in temperature/salinity as you move downward This also adds a KPP_testing stream to Registry.xml and adds necessary forcing information to the forcing stream Finally, a small bug was noticed in the mixed layer depth analysis member (num_tracers was referenced without the need for it) --- src/core_ocean/Registry.xml | 63 ++++- .../mpas_ocn_mixed_layer_depths.F | 4 +- .../mode_init/Registry_cvmix_WSwSBF.xml | 26 +- .../mode_init/mpas_ocn_init_cvmix_WSwSBF.F | 258 ++++++++++++------ 4 files changed, 255 insertions(+), 96 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 761072ff35..34af0ecac6 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -135,7 +135,7 @@ baroclinic_channel_value="baroclinic_channel" cvmix_convection_unit_test_value="cvmix_convection_unit_test" cvmix_shear_unit_test_value="cvmix_shear_unit_test" - cvmx_WSwSBF_value="cvmx_WSwSBF" + cvmix_WSwSBF_value="cvmix_WSwSBF" global_ocean_value="global_ocean" internal_waves_value="internal_waves" lock_exchange_value="lock_exchange" @@ -588,7 +588,7 @@ possible_values="Any positive value" /> - + - + + + + + + + + + + + + @@ -1115,6 +1126,39 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F index 8ab224e116..8a0b3070d8 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F +++ b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F @@ -163,7 +163,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ type (mpas_pool_type), pointer :: mixedLayerDepthsAM ! Here are some example variables which may be needed for your analysis member - integer, pointer :: nVertLevels, nCellsSolve, num_tracers + integer, pointer :: nVertLevels, nCellsSolve integer :: k, iCell, i, refIndex, refLevel(1) integer, pointer :: index_temperature integer, dimension(:), pointer :: maxLevelCell @@ -195,8 +195,6 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ call mpas_pool_get_subpool(domain % blocklist % structs, 'mixedLayerDepthsAM', mixedLayerDepthsAMPool) call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) - call mpas_pool_get_dimension(statePool, 'num_tracers', num_tracers) - call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_Tthreshold', tThresholdFlag) call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_Dthreshold', dThresholdFlag) call mpas_pool_get_config(domain % configs, 'config_AM_mixedLayerDepths_Tgradient', tGradientFlag) diff --git a/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml b/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml index 911371d6ab..9f3143e6fa 100644 --- a/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml +++ b/src/core_ocean/mode_init/Registry_cvmix_WSwSBF.xml @@ -62,7 +62,31 @@ + /> + + + + + + domain % blocklist @@ -177,7 +197,7 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) - + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) @@ -216,6 +236,7 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ call mpas_pool_get_array(forcingPool, 'evaporationFlux', evaporationFlux) call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) + ! Set refBottomDepth and refBottomDepthTopOfCell do k = 1, nVertLevels refBottomDepth(k) = config_cvmix_WSwSBF_bottom_depth * interfaceLocations(k+1) @@ -224,106 +245,167 @@ subroutine ocn_init_setup_cvmix_WSwSBF(domain, iErr)!{{{ ! Set vertCoordMovementWeights vertCoordMovementWeights(:) = 1.0_RKIND - + do iCell = 1, nCellsSolve - ! Set temperature and salinity - do k = 1, nVertLevels - if ( associated(activeTracers) ) then - temperature = config_cvmix_WSwSBF_surface_temperature + refZMid(k) * config_cvmix_WSwSBF_temperature_gradient - activeTracers(index_temperature, k, iCell) = temperature - salinity = config_cvmix_WSwSBF_surface_salinity + refZMid(k) * config_cvmix_WSwSBF_salinity_gradient - activeTracers(index_salinity, k, iCell) = salinity - end if - - if ( associated(debugTracers) ) then - debugTracers(index_tracer1, k, iCell) = 1.0_RKIND - end if - end do - - ! Set layerThickness - do k = 1, nVertLevels - layerThickness(k, iCell) = config_cvmix_WSwSBF_bottom_depth * (interfaceLocations(k+1) - interfaceLocations(k)) - restingThickness(k, iCell) = layerThickness(k, iCell) - end do - - ! Set surface temperature restoring value and rate - ! Value in units of C, piston velocity in units of m/s - if ( associated(activeTracersSurfaceRestoringValue) ) then - activeTracersSurfaceRestoringValue(index_temperature, iCell) = config_cvmix_WSwSBF_surface_restoring_temperature + if(associated(activeTracers) ) then + + ! Loop from surface through surface layer depth + k=1 + + do while (k .le. nVertLevels .and. refZMid(k) > - config_cvmix_WSwSBF_mixed_layer_depth_temperature) + temperature = config_cvmix_WSwSBF_surface_temperature + refZMid(k) * & + config_cvmix_WSwSBF_temperature_gradient_mixed_layer + activeTracers(index_temperature, k, iCell) = temperature + k = k + 1 + enddo + + ! the value of k is now the first layer below the surface layer + if ( k > 1 ) then + temperature = activeTracers(index_temperature, k-1, iCell) + config_cvmix_WSwSBF_mixed_layer_temperature_change + activeTracers(index_temperature, k, iCell) = temperature + BLdepth = refZMid(k) + else + activeTracers(index_temperature, k, iCell) = config_cvmix_WSwSBF_surface_temperature + BLdepth = 0.0 + endif + + ! find the first level below the mixed layer + kML = k + 1 + + ! now loop from the bottom of the mixed layer thru to the bottom of the domain + do k = kML, nVertLevels + temperature = activeTracers(index_temperature, kML-1, iCell) + (refZMid(k) - BLdepth) * & + config_cvmix_WSwSBF_temperature_gradient + activeTracers(index_temperature, k, iCell) = temperature + enddo + + ! + ! next compute the salinity profile + ! + + ! Loop from surface through surface layer depth + k=1 + do while (k .le. nVertLevels .and. refZMid(k) > - config_cvmix_WSwSBF_mixed_layer_depth_salinity) + salinity = config_cvmix_WSwSBF_surface_salinity + refZMid(k) * config_cvmix_WSwSBF_salinity_gradient_mixed_layer + activeTracers(index_salinity, k, iCell) = salinity + k = k + 1 + enddo + + ! the value of k is now the first layer below the surface layer + if ( k > 1 ) then + salinity = activeTracers(index_salinity, k-1, iCell) + config_cvmix_WSwSBF_mixed_layer_salinity_change + activeTracers(index_salinity, k, iCell) = salinity + BLdepth = refZMid(k) + else + activeTracers(index_salinity, k, iCell) = config_cvmix_WSwSBF_surface_salinity + BLdepth = 0.0 + endif + + ! find the first level below the mixed layer + kML = k + 1 + + ! now loop from the bottom of the mixed layer thru to the bottom of the domain + do k = kML, nVertLevels + salinity = activeTracers(index_salinity, kML-1, iCell) + (refZMid(k) - BLdepth) * & + config_cvmix_WSwSBF_salinity_gradient + activeTracers(index_salinity, k, iCell) = salinity + enddo + + endif ! if (associated(activeTracer)) + + ! as a place holder, have some debug tracer in the top few layers and zero below + if ( associated(debugTracers) ) then + debugTracers(index_tracer1, k, iCell) = 0.0_RKIND + do k=1,min(4,nVertLevels) + debugTracers(index_tracer1, k, iCell) = 1.0_RKIND + enddo + endif + + ! Set layerThickness + do k = 1, nVertLevels + layerThickness(k, iCell) = config_cvmix_WSwSBF_bottom_depth * (interfaceLocations(k+1) - interfaceLocations(k)) + restingThickness(k, iCell) = layerThickness(k, iCell) + end do + + ! Set surface temperature restoring value and rate + ! Value in units of C, piston velocity in units of m/s + if ( associated(activeTracersSurfaceRestoringValue) ) then + activeTracersSurfaceRestoringValue(index_temperature, iCell) = config_cvmix_WSwSBF_surface_restoring_temperature + end if + if ( associated(activeTracersPistonVelocity) ) then + activeTracersPistonVelocity(index_temperature, iCell) = config_cvmix_WSwSBF_temperature_piston_velocity + end if + + ! Set surface salinity restoring value and rate + ! Value in units of PSU, piston velocity in units of m/s + if ( associated(activeTracersSurfaceRestoringValue) ) then + activeTracersSurfaceRestoringValue(index_salinity, iCell) = config_cvmix_WSwSBF_surface_restoring_salinity + end if + if ( associated(activeTracersPistonVelocity) ) then + activeTracersPistonVelocity(index_salinity, iCell) = config_cvmix_WSwSBF_salinity_piston_velocity + end if + + ! Set sensible heat flux + sensibleHeatFlux(iCell) = config_cvmix_WSwSBF_sensible_heat_flux + + ! Set latent heat flux + latentHeatFlux(iCell) = config_cvmix_WSwSBF_latent_heat_flux + + ! Set shortwave heat flux + shortWaveHeatFlux(iCell) = config_cvmix_WSwSBF_shortwave_heat_flux + + ! Set precipation and evaporation + rainFlux(iCell) = config_cvmix_WSwSBF_rain_flux + evaporationFlux(iCell) = config_cvmix_WSwSBF_evaporation_flux + + ! Set interior temperature restoring value and rate + do k = 1, nVertLevels + if ( associated(activeTracersInteriorRestoringValue) ) then + activeTracersInteriorRestoringValue(index_temperature, k, iCell) = activeTracers(index_temperature, k, iCell) end if - if ( associated(activeTracersPistonVelocity) ) then - activeTracersPistonVelocity(index_temperature, iCell) = config_cvmix_WSwSBF_temperature_piston_velocity + if ( associated(activeTracersInteriorRestoringRate) ) then + activeTracersInteriorRestoringRate(index_temperature, k, iCell) = config_cvmix_WSwSBF_interior_temperature_restoring_rate end if + enddo - ! Set surface salinity restoring value and rate - ! Value in units of PSU, piston velocity in units of m/s - if ( associated(activeTracersSurfaceRestoringValue) ) then - activeTracersSurfaceRestoringValue(index_salinity, iCell) = config_cvmix_WSwSBF_surface_restoring_salinity + ! Set interior salinity restoring value and rate + do k = 1, nVertLevels + if ( associated(activeTracersInteriorRestoringValue) ) then + activeTracersInteriorRestoringValue(index_salinity, k, iCell) = activeTracers(index_salinity, k, iCell) end if - if ( associated(activeTracersPistonVelocity) ) then - activeTracersPistonVelocity(index_salinity, iCell) = config_cvmix_WSwSBF_salinity_piston_velocity + if ( associated(activeTracersInteriorRestoringRate) ) then + activeTracersInteriorRestoringRate(index_salinity, k, iCell) = config_cvmix_WSwSBF_interior_salinity_restoring_rate end if + enddo - ! Set sensible heat flux - sensibleHeatFlux(iCell) = config_cvmix_WSwSBF_sensible_heat_flux - - ! Set latent heat flux - latentHeatFlux(iCell) = config_cvmix_WSwSBF_latent_heat_flux - - ! Set shortwave heat flux - shortWaveHeatFlux(iCell) = config_cvmix_WSwSBF_shortwave_heat_flux - - ! Set precipation and evaporation - rainFlux(iCell) = config_cvmix_WSwSBF_rain_flux - evaporationFlux(iCell) = config_cvmix_WSwSBF_evaporation_flux - - ! Set interior temperature restoring value and rate - do k = 1, nVertLevels - if ( associated(activeTracersInteriorRestoringValue) ) then - activeTracersInteriorRestoringValue(index_temperature, k, iCell) = activeTracers(index_temperature, k, iCell) - end if - if ( associated(activeTracersInteriorRestoringRate) ) then - activeTracersInteriorRestoringRate(index_temperature, k, iCell) = config_cvmix_WSwSBF_interior_temperature_restoring_rate - end if - enddo + ! Set Coriolis parameter + fCell(iCell) = config_cvmix_WSwSBF_coriolis_parameter - ! Set interior salinity restoring value and rate - do k = 1, nVertLevels - if ( associated(activeTracersInteriorRestoringValue) ) then - activeTracersInteriorRestoringValue(index_salinity, k, iCell) = activeTracers(index_salinity, k, iCell) - end if - if ( associated(activeTracersInteriorRestoringRate) ) then - activeTracersInteriorRestoringRate(index_salinity, k, iCell) = config_cvmix_WSwSBF_interior_salinity_restoring_rate - end if - enddo + ! Set bottomDepth + bottomDepth(iCell) = config_cvmix_WSwSBF_bottom_depth - ! Set Coriolis parameter - fCell(iCell) = config_cvmix_WSwSBF_coriolis_parameter + ! Set maxLevelCell + maxLevelCell(iCell) = nVertLevels - ! Set bottomDepth - bottomDepth(iCell) = config_cvmix_WSwSBF_bottom_depth + end do ! do iCell - ! Set maxLevelCell - maxLevelCell(iCell) = nVertLevels - end do + do iCell = 1, nCellsSolve + windStressZonal(iCell) = config_cvmix_WSwSBF_max_windstress + windStressMeridional(iCell) = 0.0_RKIND + enddo - do iCell = 1, nCellsSolve - windStressZonal(iCell) = config_cvmix_WSwSBF_max_windstress - windStressMeridional(iCell) = 0.0_RKIND - enddo + do iEdge = 1, nEdgesSolve + fEdge(iEdge) = config_cvmix_WSwSBF_coriolis_parameter + end do - do iEdge = 1, nEdgesSolve - fEdge(iEdge) = config_cvmix_WSwSBF_coriolis_parameter - end do - - do iVertex=1, nVerticesSolve - fVertex(iVertex) = config_cvmix_WSwSBF_coriolis_parameter - end do + do iVertex=1, nVerticesSolve + fVertex(iVertex) = config_cvmix_WSwSBF_coriolis_parameter + end do - block_ptr => block_ptr % next - end do + block_ptr => block_ptr % next + end do - deallocate(interfaceLocations) + deallocate(interfaceLocations) !-------------------------------------------------------------------- From 28c45039bf7ef982e25c070d11f280e4f21ce8d2 Mon Sep 17 00:00:00 2001 From: Phillip Wolfram Date: Sun, 27 Sep 2015 23:21:16 -0600 Subject: [PATCH 0298/1724] Tested, compiling ZISO testcase MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ZISO=Zonally periodic Idealized Southern Ocean test case is based off Saenz, Juan A, Chen, Qingshan, & Ringler, Todd. 2015. Prognostic residual- mean flow in an ocean general circulation model and its relation to prognostic Eulerian-mean flow. Journal of Physical Oceanography. Abernathey, Ryan, Marshall, John, & Ferreira, David. 2011. The dependence of Southern Ocean meridional overturning on wind stress. Journal of Physical Oceanography, 41(12), 2261–2278. Stewart, Andrew L, & Thompson, Andrew F. 2013. Connecting Antarctic Cross-Slope Exchange with Southern Ocean Overturning. Journal of Physical Oceanography, 43(7), 1453–1471. Design document can be found in https://github.com/pwolfram/MPAS-Scratch/tree/ZISO --- src/core_ocean/Makefile | 1 + src/core_ocean/Registry.xml | 3 +- src/core_ocean/mode_init/Makefile | 3 +- src/core_ocean/mode_init/Registry.xml | 1 + src/core_ocean/mode_init/Registry_ziso.xml | 106 ++++ .../mode_init/mpas_ocn_init_cell_markers.F | 4 - src/core_ocean/mode_init/mpas_ocn_init_mode.F | 6 +- src/core_ocean/mode_init/mpas_ocn_init_ziso.F | 527 ++++++++++++++++++ 8 files changed, 644 insertions(+), 7 deletions(-) create mode 100644 src/core_ocean/mode_init/Registry_ziso.xml create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_ziso.F diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index 9f0f2d199f..e0c1599b32 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -31,6 +31,7 @@ core_input_gen: (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.cvmix_shear_unit_test mode=init configuration=cvmix_shear_unit_test) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.soma mode=init configuration=soma) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.iso mode=init configuration=iso) + (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.ziso mode=init configuration=ziso) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.global_ocean mode=init configuration=global_ocean) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean stream_list.ocean. mutable ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.forward stream_list.ocean.forward. mutable mode=forward ) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 34af0ecac6..f82dcf2729 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -142,6 +142,7 @@ overflow_value="overflow" soma_value="soma" iso_value="iso" + ziso_value="ziso" /> - + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_cell_markers.F b/src/core_ocean/mode_init/mpas_ocn_init_cell_markers.F index c23eae1aad..341eee6a6f 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_cell_markers.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_cell_markers.F @@ -83,7 +83,6 @@ subroutine ocn_mark_north_boundary(meshPool, yMax, edgeMin, iErr)!{{{ integer, pointer :: nCells integer :: iCell - integer :: count iErr = 0 @@ -95,13 +94,10 @@ subroutine ocn_mark_north_boundary(meshPool, yMax, edgeMin, iErr)!{{{ call mpas_pool_get_array(meshPool, 'cullCell', cullCell) call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - count = 0 - if ( associated(cullCell) ) then do iCell = 1, nCells if ( yCell(iCell) > yMax - 0.8_RKIND * edgeMin ) then cullCell(iCell) = 1 - count = count + 1 end if end do end if diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 276c7b6fca..98bed5190f 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -46,6 +46,7 @@ module ocn_init_mode use ocn_init_cvmix_WSwSBF use ocn_init_iso use ocn_init_soma + use ocn_init_ziso implicit none private @@ -253,6 +254,7 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call ocn_init_setup_cvmix_WSwSBF(domain, ierr) call ocn_init_setup_iso(domain, ierr) call ocn_init_setup_soma(domain, ierr) + call ocn_init_setup_ziso(domain, ierr) !call ocn_init_setup_TEMPLATE(domain, ierr) write(stderrUnit, *) ' Completed setup of: ' // trim(config_init_configuration) @@ -342,7 +344,9 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, ioconte iErr = ior(iErr, err_tmp) call ocn_init_validate_soma(configPool, packagePool, iocontext, iErr=err_tmp) iErr = ior(iErr, err_tmp) - ! call ocn_config_TEMPLATE_validate(configPool, packagePool, iocontext, iErr=err_tmp) + call ocn_init_validate_ziso(configPool, packagePool, iErr=err_tmp) + iErr = ior(iErr, err_tmp) + ! call ocn_config_TEMPLATE_validate(configPool, packagePool, iErr=err_tmp) ! iErr = ior(iErr, err_tmp) end subroutine ocn_init_mode_validate_configuration!}}} diff --git a/src/core_ocean/mode_init/mpas_ocn_init_ziso.F b/src/core_ocean/mode_init/mpas_ocn_init_ziso.F new file mode 100644 index 0000000000..6fa1837d85 --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_ziso.F @@ -0,0 +1,527 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_ziso +! +!> \brief MPAS ocean initialize case -- Zonally periodic Idealized Southern Ocean (ZISO) +!> \author Phillip J. Wolfram, Luke Van Roekel, Todd Ringler +!> \date 09/14/2015 +!> \details +!> This module contains the routines for initializing the +!> ZISO initial condition. +! +!----------------------------------------------------------------------- + +module ocn_init_ziso + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + use mpas_stream_manager + + use ocn_constants + use ocn_init_vertical_grids + use ocn_init_cell_markers + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_ziso, & + ocn_init_validate_ziso + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_ziso +! +!> \brief Setup for this initial condition +!> \author Phillip J. Wolfram, Luke Van Roekel, Todd Ringler +!> \date 09/14/2015 +!> \details +!> This routine sets up the initial conditions for the ZISO configuration. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_ziso(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + ! local work variables + type (block_type), pointer :: block_ptr + type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool, forcingPool, tracersPool + type (mpas_pool_type), pointer :: tracersSurfaceRestoringFieldsPool, tracersInteriorRestoringFieldsPool + + integer :: iCell, iEdge, iVertex, k, idx + real (kind=RKIND), dimension(:), pointer :: interfaceLocations + + ! Define config variable pointers + character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid + logical, pointer :: config_write_cull_cell_mask + + ! ZISO test case run-time configuration parameters + logical, pointer :: config_ziso_use_slopping_bathymetry + real (kind=RKIND), pointer :: config_ziso_meridional_extent + real (kind=RKIND), pointer :: config_ziso_bottom_depth + real (kind=RKIND), pointer :: config_ziso_wind_stress_max + real (kind=RKIND), pointer :: config_ziso_reference_coriolis + real (kind=RKIND), pointer :: config_ziso_coriolis_gradient + real (kind=RKIND), pointer :: config_ziso_shelf_depth + real (kind=RKIND), pointer :: config_ziso_slope_center_position + real (kind=RKIND), pointer :: config_ziso_slope_half_width + real (kind=RKIND), pointer :: config_ziso_initial_temp_t1 + real (kind=RKIND), pointer :: config_ziso_initial_temp_t2 + real (kind=RKIND), pointer :: config_ziso_initial_temp_h1 + real (kind=RKIND), pointer :: config_ziso_initial_temp_mt + real (kind=RKIND), pointer :: config_ziso_mean_restoring_temp + real (kind=RKIND), pointer :: config_ziso_restoring_temp_dev_ta + real (kind=RKIND), pointer :: config_ziso_restoring_temp_dev_tb + real (kind=RKIND), pointer :: config_ziso_restoring_temp_piston_vel + real (kind=RKIND), pointer :: config_ziso_restoring_sponge_l + real (kind=RKIND), pointer :: config_ziso_restoring_temp_tau + real (kind=RKIND), pointer :: config_ziso_restoring_temp_ts + real (kind=RKIND), pointer :: config_ziso_restoring_temp_ze + real (kind=RKIND), pointer :: config_ziso_wind_transition_position + real (kind=RKIND), pointer :: config_ziso_antarctic_shelf_front_width + real (kind=RKIND), pointer :: config_ziso_wind_stress_shelf_front_max + logical, pointer :: config_ziso_add_easterly_wind_stress_ASF + + integer, pointer :: config_ziso_vert_levels + + + ! Define dimension pointers + integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, nVertLevelsP1 + integer, pointer :: index_temperature, index_salinity + + ! Define variable pointers + logical, pointer :: on_a_sphere + integer, dimension(:), pointer :: maxLevelCell + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, xEdge, yEdge, xVertex, yVertex, refBottomDepth, refZMid, & + vertCoordMovementWeights, bottomDepth, & + fCell, fEdge, fVertex, dcEdge + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers + real (kind=RKIND), dimension(:, :), pointer :: activeTracersPistonVelocity, activeTracersSurfaceRestoringValue + real (kind=RKIND), dimension(:, :, :), pointer :: activeTracersInteriorRestoringValue, activeTracersInteriorRestoringRate + real (kind=RKIND), dimension(:), pointer :: windStressZonal, windStressMeridional + + real (kind=RKIND) :: yMin, yMax, xMin, xMax, dcEdgeMin, dcEdgeMinGlobal + real (kind=RKIND) :: yMinGlobal, yMaxGlobal, yMidGlobal, xMinGlobal, xMaxGlobal + real(kind=RKIND), pointer :: y_period + character (len=StrKIND) :: streamID + integer :: directionProperty + + ! assume no error + iErr = 0 + + + ! test if ZISO is the desired configuration + call mpas_pool_get_config(ocnConfigs, 'config_init_configuration', config_init_configuration) + if(config_init_configuration .ne. trim('ziso')) return + + write(stderrUnit,*) 'Starting initialization of Zonally periodic Idealized Southern Ocean (ZISO)' + + ! get config variables !{{{ + call mpas_pool_get_config(domain % configs, 'config_write_cull_cell_mask', config_write_cull_cell_mask) + call mpas_pool_get_config(domain % configs, 'config_ziso_use_slopping_bathymetry', config_ziso_use_slopping_bathymetry) + call mpas_pool_get_config(domain % configs, 'config_ziso_bottom_depth', config_ziso_bottom_depth) + call mpas_pool_get_config(domain % configs, 'config_ziso_meridional_extent', config_ziso_meridional_extent) + call mpas_pool_get_config(domain % configs, 'config_ziso_reference_coriolis', config_ziso_reference_coriolis) + call mpas_pool_get_config(domain % configs, 'config_ziso_coriolis_gradient', config_ziso_coriolis_gradient) + call mpas_pool_get_config(domain % configs, 'config_ziso_vert_levels', config_ziso_vert_levels) + call mpas_pool_get_config(domain % configs, 'config_ziso_wind_stress_max', config_ziso_wind_stress_max) + call mpas_pool_get_config(domain % configs, 'config_ziso_slope_half_width', config_ziso_slope_half_width) + call mpas_pool_get_config(domain % configs, 'config_ziso_shelf_depth', config_ziso_shelf_depth) + call mpas_pool_get_config(domain % configs, 'config_ziso_slope_center_position', config_ziso_slope_center_position) + call mpas_pool_get_config(domain % configs, 'config_ziso_initial_temp_t1', config_ziso_initial_temp_t1) + call mpas_pool_get_config(domain % configs, 'config_ziso_initial_temp_t2', config_ziso_initial_temp_t2) + call mpas_pool_get_config(domain % configs, 'config_ziso_initial_temp_h1', config_ziso_initial_temp_h1) + call mpas_pool_get_config(domain % configs, 'config_ziso_initial_temp_mt', config_ziso_initial_temp_mt) + call mpas_pool_get_config(domain % configs, 'config_ziso_mean_restoring_temp', config_ziso_mean_restoring_temp) + call mpas_pool_get_config(domain % configs, 'config_ziso_restoring_temp_dev_ta', config_ziso_restoring_temp_dev_ta) + call mpas_pool_get_config(domain % configs, 'config_ziso_restoring_temp_dev_tb', config_ziso_restoring_temp_dev_tb) + call mpas_pool_get_config(domain % configs, 'config_ziso_restoring_temp_piston_vel', config_ziso_restoring_temp_piston_vel) + call mpas_pool_get_config(domain % configs, 'config_ziso_restoring_sponge_l', config_ziso_restoring_sponge_l) + call mpas_pool_get_config(domain % configs, 'config_ziso_restoring_temp_tau', config_ziso_restoring_temp_tau) + call mpas_pool_get_config(domain % configs, 'config_ziso_restoring_temp_ts', config_ziso_restoring_temp_ts) + call mpas_pool_get_config(domain % configs, 'config_ziso_restoring_temp_ze', config_ziso_restoring_temp_ze) + call mpas_pool_get_config(domain % configs, 'config_vertical_grid', config_vertical_grid) + call mpas_pool_get_config(domain % configs, 'config_ziso_add_easterly_wind_stress_ASF', config_ziso_add_easterly_wind_stress_ASF) + call mpas_pool_get_config(domain % configs, 'config_ziso_wind_transition_position', config_ziso_wind_transition_position) + call mpas_pool_get_config(domain % configs, 'config_ziso_antarctic_shelf_front_width', config_ziso_antarctic_shelf_front_width) + call mpas_pool_get_config(domain % configs, 'config_ziso_wind_stress_shelf_front_max', config_ziso_wind_stress_shelf_front_max) + !}}} + + ! Determine vertical grid for configuration + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nVertLevelsP1', nVertLevelsP1) + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + + ! test if configure settings are invalid + if ( on_a_sphere ) call mpas_dmpar_global_abort('IERROR: The ZISO configuration can only be applied to a planar mesh. Exiting...') + + ! Define interface locations + allocate(interfaceLocations(nVertLevelsP1)) + call ocn_generate_vertical_grid( config_vertical_grid, interfaceLocations ) + + ! assign config variables + nVertLevels = config_ziso_vert_levels + nVertLevelsP1 = nVertLevels + 1 + + ! keep all cells on planar, periodic mesh (no culling) + + !-------------------------------------------------------------------- + ! Use this section to find min/max of grid to allow culling + !-------------------------------------------------------------------- + + ! Initalize min/max values to large positive and negative values + yMin = 1.0E10_RKIND + yMax = -1.0E10_RKIND + xMin = 1.0E10_RKIND + xMax = -1.0E10_RKIND + dcEdgeMin = 1.0E10_RKIND + + ! Determine local min and max values. + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + + yMin = min( yMin, minval(yCell(1:nCellsSolve))) + yMax = max( yMax, maxval(yCell(1:nCellsSolve))) + xMin = min( xMin, minval(xCell(1:nCellsSolve))) + xMax = max( xMax, maxval(xCell(1:nCellsSolve))) + dcEdgeMin = min( dcEdgeMin, minval(dcEdge(1:nEdgesSolve))) + + block_ptr => block_ptr % next + end do ! do while(associated(block_ptr)) + + + !-------------------------------------------------------------------- + ! Use this section to set initial values + !-------------------------------------------------------------------- + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nVerticesSolve', nVerticesSolve) + + call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_salinity) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'xEdge', xEdge) + call mpas_pool_get_array(meshPool, 'yEdge', yEdge) + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'fCell', fCell) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + call mpas_pool_get_array(meshPool, 'fVertex', fVertex) + + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + call mpas_pool_get_array(forcingPool, 'windStressZonal', windStressZonal) + call mpas_pool_get_array(forcingPool, 'windStressMeridional', windStressMeridional) + ! tests to make sure these are allocated + if (.not. associated(windStressZonal) .or. .not. associated(windStressMeridional)) then + call mpas_dmpar_global_abort("windStressZonal and / or windStressMeridional are not allocated") + end if + + call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceRestoringFields', tracersSurfaceRestoringFieldsPool) + if (.not. associated(tracersSurfaceRestoringFieldsPool)) then + call mpas_dmpar_global_abort("tracersSurfaceRestoringFieldsPool not allocated.") + end if + call mpas_pool_get_subpool(forcingPool, 'tracersInteriorRestoringFields', tracersInteriorRestoringFieldsPool) + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, 'activeTracersPistonVelocity', activeTracersPistonVelocity, 1) + if (.not. associated(activeTracersPistonVelocity)) then + call mpas_dmpar_global_abort("activeTracersPistonVelocity not allocated.") + end if + call mpas_pool_get_array(tracersSurfaceRestoringFieldsPool, & + 'activeTracersSurfaceRestoringValue', activeTracersSurfaceRestoringValue, 1) + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, & + 'activeTracersInteriorRestoringRate', activeTracersInteriorRestoringRate, 1) + call mpas_pool_get_array(tracersInteriorRestoringFieldsPool, & + 'activeTracersInteriorRestoringValue', activeTracersInteriorRestoringValue, 1) + + ! Determine global min and max values. + call mpas_dmpar_min_real(domain % dminfo, yMin, yMinGlobal) + call mpas_dmpar_max_real(domain % dminfo, yMax, yMaxGlobal) + call mpas_dmpar_min_real(domain % dminfo, xMin, xMinGlobal) + call mpas_dmpar_max_real(domain % dminfo, xMax, xMaxGlobal) + call mpas_dmpar_min_real(domain % dminfo, dcEdgeMin, dcEdgeMinGlobal) + + ! mark north / south boundaries + if(config_write_cull_cell_mask) then + call ocn_mark_north_boundary(meshPool, yMaxGlobal, dcEdgeMinGlobal, iErr) + call ocn_mark_south_boundary(meshPool, yMinGlobal, dcEdgeMinGlobal, iErr) + call mpas_pool_get_config(meshPool, 'y_period', y_period) + y_period = 0.0_RKIND + endif + call mpas_stream_mgr_begin_iteration(domain % streamManager) + do while (mpas_stream_mgr_get_next_stream(domain % streamManager, streamID, directionProperty)) + if ( directionProperty == MPAS_STREAM_OUTPUT .or. directionProperty == MPAS_STREAM_INPUT_OUTPUT ) then + call mpas_stream_mgr_add_att(domain % streamManager, 'y_period', 0.0_RKIND, streamID) + end if + end do + + activeTracersInteriorRestoringRate(:,:,:) = 0.0_RKIND + activeTracersInteriorRestoringValue(:,:,:) = 0.0_RKIND + activeTracersPistonVelocity(:,:) = 0.0_RKIND + activeTracersSurfaceRestoringValue(:,:) = 0.0_RKIND + + + ! Set refBottomDepth and refZMid + do k = 1, nVertLevels + refBottomDepth(k) = config_ziso_bottom_depth * interfaceLocations(k+1) + refZMid(k) = - 0.5_RKIND * (interfaceLocations(k+1) + interfaceLocations(k)) * config_ziso_bottom_depth + end do + + ! set bottomDepth and maxLevelCell !{{{{ + bottomDepth(:) = 0.0_RKIND + do iCell = 1, nCellsSolve + + if (config_ziso_use_slopping_bathymetry) then + ! bottom depth function to be applied + bottomDepth(iCell) = config_ziso_shelf_depth + & + 0.5_RKIND*(config_ziso_bottom_depth - config_ziso_shelf_depth) * & + (1.0_RKIND + tanh((yCell(iCell) - config_ziso_slope_center_position)/config_ziso_slope_half_width)) + else + bottomDepth(iCell) = config_ziso_bottom_depth + end if + + ! Determine maxLevelCell based on bottomDepth and refBottomDepth + ! Also set botomDepth based on refBottomDepth, since + ! above bottomDepth was set with continuous analytical functions, + ! and needs to be discrete + maxLevelCell(iCell) = nVertLevels + if (nVertLevels > 1) then + do k = 1, nVertLevels + if (bottomDepth(iCell) < refBottomDepth(k)) then + maxLevelCell(iCell) = k-1 + bottomDepth(iCell) = refBottomDepth(k-1) + exit + end if + end do + end if + + enddo ! Looping through with iCell !}}} + + ! Set vertCoordMovementWeights + vertCoordMovementWeights(:) = 1.0_RKIND + + do iCell = 1, nCellsSolve + + ! Set initial temperature + idx = index_temperature + do k = 1, nVertLevels + activeTracers(idx, k, iCell) = config_ziso_initial_temp_t1 + & + config_ziso_initial_temp_t2*tanh(refZMid(k)/config_ziso_initial_temp_h1) + config_ziso_initial_temp_mt*refZMid(k) + end do + + ! Set initial salinity + idx = index_salinity + do k = 1, nVertLevels + activeTracers(idx, k, iCell) = 34.0_RKIND + end do + + ! Set layerThickness and restingThickness + ! Uniform layer thickness + do k = 1, nVertLevels + layerThickness(k, iCell) = config_ziso_bottom_depth * ( interfaceLocations(k+1) - interfaceLocations(k) ) + restingThickness(k, iCell) = layerThickness(k, iCell) + end do + + ! Set bottomDepth (above) + + ! Set maxLevelCell (above) + + ! set windstress + if (config_ziso_add_easterly_wind_stress_ASF) then + if(yCell(iCell) .ge. config_ziso_wind_transition_position) then + windStressZonal(iCell) = config_ziso_wind_stress_max*sin((pii*(yCell(iCell) - & + config_ziso_wind_transition_position) / & + (config_ziso_meridional_extent - config_ziso_wind_transition_position)))**2 + elseif(yCell(iCell) .ge. config_ziso_wind_transition_position - config_ziso_antarctic_shelf_front_width) then + windStressZonal(iCell) = 0.0_RKIND + if(yCell(iCell) .lt. config_ziso_wind_transition_position) then + windStressZonal(iCell) = config_ziso_wind_stress_shelf_front_max * & + sin((pii*(config_ziso_wind_transition_position & + - yCell(iCell)))/config_ziso_antarctic_shelf_front_width)**2 + endif + endif + else + windStressZonal(iCell) = config_ziso_wind_stress_max * exp(-((yCell(iCell) - & + config_ziso_meridional_extent/2.0_RKIND) / & + (config_ziso_meridional_extent/2.0_RKIND))**2.0_RKIND)*cos(pii/2.0_RKIND*(yCell(iCell) - & + config_ziso_meridional_extent/2.0_RKIND)/(config_ziso_meridional_extent/2.0_RKIND)) + endif + windStressMeridional(iCell) = 0.0_RKIND + + ! surface restoring + idx = index_temperature + activeTracersSurfaceRestoringValue(idx,iCell) = config_ziso_mean_restoring_temp & + + config_ziso_restoring_temp_dev_ta * & + tanh(2.0_RKIND*(yCell(iCell)-config_ziso_meridional_extent/2.0_RKIND)/(config_ziso_meridional_extent/2.0_RKIND)) & + + config_ziso_restoring_temp_dev_tb * & + (yCell(iCell)-config_ziso_meridional_extent/2.0_RKIND)/(config_ziso_meridional_extent/2.0_RKIND) + activeTracersPistonVelocity(idx,iCell) = config_ziso_restoring_temp_piston_vel + idx = index_salinity + activeTracersSurfaceRestoringValue(idx,iCell) = 34.0_RKIND + activeTracersPistonVelocity(idx,iCell) = 0.0_RKIND + + ! set restoring at equatorward (north) boundary + do k = 1, nVertLevels + !Interior restoring along northern wall + if(config_ziso_meridional_extent-yCell(iCell) <= 1.5_RKIND*config_ziso_restoring_sponge_l) then + idx = index_temperature + activeTracersInteriorRestoringValue(idx, k, iCell) = activeTracersSurfaceRestoringValue(idx,iCell) & + * exp(refZMid(k)/config_ziso_restoring_temp_ze) + activeTracersInteriorRestoringRate(idx, k, iCell) = & + exp(-(config_ziso_meridional_extent-yCell(iCell))/config_ziso_restoring_sponge_l) & + * ( 1.0_RKIND / (config_ziso_restoring_temp_tau*86400.0_RKIND)) + idx = index_salinity + activeTracersInteriorRestoringValue(idx, k, iCell) = 34.0_RKIND + activeTracersInteriorRestoringRate(idx, k, iCell) = 0.0_RKIND + end if + end do + + + ! set restoring at poleward (south) boundary + do k = 1, nVertLevels + !Interior restoring along southern wall + if(yCell(iCell) <= 2.0_RKIND*config_ziso_restoring_sponge_l) then + idx = index_temperature + activeTracersInteriorRestoringValue(idx, k, iCell) = activeTracersSurfaceRestoringValue(idx,iCell) + activeTracersInteriorRestoringRate(idx, k, iCell) = exp(-yCell(iCell)/config_ziso_restoring_sponge_l) & + * ( 1.0_RKIND / (config_ziso_restoring_temp_tau*86400.0_RKIND)) + idx = index_salinity + activeTracersInteriorRestoringValue(idx, k, iCell) = 34.0_RKIND + activeTracersInteriorRestoringRate(idx, k, iCell) = 0.0_RKIND + end if + enddo + + end do ! do iCell + + ! Set Coriolis parameters, if other than zero + do iCell = 1, nCellsSolve + fCell(iCell) = config_ziso_reference_coriolis + yCell(iCell) * config_ziso_coriolis_gradient + end do + do iEdge = 1, nEdgesSolve + fEdge(iEdge) = config_ziso_reference_coriolis + yEdge(iEdge) * config_ziso_coriolis_gradient + end do + do iVertex = 1, nVerticesSolve + fVertex(iVertex) = config_ziso_reference_coriolis + yVertex(iVertex) * config_ziso_reference_coriolis + end do + + block_ptr => block_ptr % next + end do ! do while(associated(block_ptr)) + + write(stderrUnit,*) 'Finishing initialization of Zonally periodic Idealized Southern Ocean (ZISO)' + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_ziso!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_ziso +! +!> \brief Validation for this initial condition +!> \author Phillip J. Wolfram, Luke Van Roekel, Todd Ringler +!> \date 09/14/2015 +!> \details +!> This routine validates the configuration options for this case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_ziso(configPool, packagePool, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: configPool, packagePool + integer, intent(out) :: iErr + + character (len=StrKIND), pointer :: config_init_configuration + integer, pointer :: config_vert_levels, config_ziso_vert_levels + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + if(config_init_configuration .ne. trim('ziso')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_ziso_vert_levels', config_ziso_vert_levels) + + if(config_vert_levels <= 0 .and. config_ziso_vert_levels > 0) then + config_vert_levels = config_ziso_vert_levels + else if (config_vert_levels <= 0) then + write(stderrUnit,*) 'ERROR: Validation failed for ziso. Not given a usable value for vertical levels.' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_ziso!}}} + + +!*********************************************************************** + +end module ocn_init_ziso + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker From d7d5f9df77bb867fbe5b4385d765435cd99f566d Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Fri, 2 Oct 2015 08:43:06 -0700 Subject: [PATCH 0299/1724] Combine land-ice flags into config_land_ice_flux_mode The new character string config_land_ice_flux_mode has four possible modes: 'off', 'pressure_only', 'standalone' and 'coupled'. 'off' - there is no landIcePressure and no fluxes are computed 'pressure_only' - used for spin-up with no land-ice fluxes but with landIcePressure 'standalone' - landIcePressure is used and land-ice fluxes are computed in MPAS-O 'coupled' - landIcePressure is used and land-ice fluxes are computed in the coupler A missing standaloneOn flag has been added to ocn_surface_land_ice_fluxes, and land-ice flux arrays are computed in MPAS-O only if in 'standalone' mode --- src/core_ocean/Registry.xml | 12 ++++-------- src/core_ocean/driver/mpas_ocn_core_interface.F | 9 ++++++--- src/core_ocean/shared/mpas_ocn_diagnostics.F | 12 +++++++----- .../shared/mpas_ocn_surface_land_ice_fluxes.F | 14 ++++++++------ 4 files changed, 25 insertions(+), 22 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 34af0ecac6..d65cbdf88d 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -619,14 +619,10 @@ /> - - + Date: Thu, 8 Oct 2015 11:59:11 -0600 Subject: [PATCH 0300/1724] Fixing whitespace and syntax formatting of registry files This commit fixes formatting issues within analysis member registry files, but additionally it removes '>', '<', '<=', and '>=' characters, as they are not valid within attributes of XML tags (i.e. they close or open XML tags). --- .../Registry_mixed_layer_depths.xml | 2 +- .../Registry_time_filters.xml | 156 +++++----- .../Registry_time_series_stats.xml | 293 +++++++++--------- 3 files changed, 227 insertions(+), 224 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml index 768ae1d00f..e31f1abd55 100644 --- a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml +++ b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml @@ -37,7 +37,7 @@ /> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/Registry_time_series_stats.xml b/src/core_ocean/analysis_members/Registry_time_series_stats.xml index fce5d80e31..c7ef329bc5 100644 --- a/src/core_ocean/analysis_members/Registry_time_series_stats.xml +++ b/src/core_ocean/analysis_members/Registry_time_series_stats.xml @@ -1,154 +1,157 @@ - - - - - - - + + + + + + + - - + + - - - - + + + + - + - - - + + + - - - - - + + + + + - - + + - - - - - - - - - - - - - + + + + + + + + + + + + + - + - + From 2efdf1064d356337b09dee834f4d02ac252d9f14 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 8 Oct 2015 13:55:37 -0600 Subject: [PATCH 0301/1724] Convert stream_name namelist options to output_stream This commit changes analysis member namelist options from *_stream_name to *_output_stream. This more clearly identifies that the namelist value should be the name of the output stream for the analysis member. Additionally, analysis members that had a *_restart_name namelist option were updated to have *_restart_stream instead. --- .../analysis_members/Registry_TEMPLATE.xml | 2 +- .../Registry_eliassen_palm.xml | 2 +- .../Registry_global_stats.xml | 2 +- .../Registry_high_frequency_output.xml | 2 +- .../Registry_lagrangian_particle_tracking.xml | 2 +- ...egistry_layer_volume_weighted_averages.xml | 2 +- .../Registry_meridional_heat_transport.xml | 2 +- .../Registry_mixed_layer_depths.xml | 2 +- .../analysis_members/Registry_okubo_weiss.xml | 2 +- ...egistry_surface_area_weighted_averages.xml | 2 +- .../Registry_test_compute_interval.xml | 2 +- .../Registry_time_filters.xml | 2 +- .../Registry_time_series_stats.xml | 4 +- .../Registry_water_mass_census.xml | 2 +- .../analysis_members/Registry_zonal_mean.xml | 2 +- .../mpas_ocn_analysis_driver.F | 48 +++++++------- .../mpas_ocn_time_series_stats.F | 62 +++++++++---------- 17 files changed, 71 insertions(+), 71 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_TEMPLATE.xml b/src/core_ocean/analysis_members/Registry_TEMPLATE.xml index 7781514365..b2b15cbda1 100644 --- a/src/core_ocean/analysis_members/Registry_TEMPLATE.xml +++ b/src/core_ocean/analysis_members/Registry_TEMPLATE.xml @@ -16,7 +16,7 @@ description="Timestamp determining how often analysis member computation should be performed." possible_values="Any valid time stamp, 'dt', or 'output_interval'" /> - diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index 82106da530..fe66ed93df 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -7,7 +7,7 @@ description="Timestamp determining how often analysis member computation should be performed." possible_values="Any valid time stamp, 'dt', or 'output_interval'" /> - diff --git a/src/core_ocean/analysis_members/Registry_global_stats.xml b/src/core_ocean/analysis_members/Registry_global_stats.xml index 2332939a3a..f256ed788b 100644 --- a/src/core_ocean/analysis_members/Registry_global_stats.xml +++ b/src/core_ocean/analysis_members/Registry_global_stats.xml @@ -23,7 +23,7 @@ description="subdirectory to write eddy census text files" possible_values="any valid directory name" /> - diff --git a/src/core_ocean/analysis_members/Registry_high_frequency_output.xml b/src/core_ocean/analysis_members/Registry_high_frequency_output.xml index 40c678a410..2d34c49c4c 100644 --- a/src/core_ocean/analysis_members/Registry_high_frequency_output.xml +++ b/src/core_ocean/analysis_members/Registry_high_frequency_output.xml @@ -7,7 +7,7 @@ description="Timestamp determining how often analysis member computation should be performed." possible_values="Any valid time stamp, 'dt', or 'output_interval'" /> - diff --git a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml index 7cba75fa56..f5b26968fa 100644 --- a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml +++ b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml @@ -11,7 +11,7 @@ description="Logical flag determining if an analysis member computation occurs on start-up." possible_values=".true. or .false." /> - diff --git a/src/core_ocean/analysis_members/Registry_layer_volume_weighted_averages.xml b/src/core_ocean/analysis_members/Registry_layer_volume_weighted_averages.xml index 4163b8772d..9ea44bdddf 100644 --- a/src/core_ocean/analysis_members/Registry_layer_volume_weighted_averages.xml +++ b/src/core_ocean/analysis_members/Registry_layer_volume_weighted_averages.xml @@ -23,7 +23,7 @@ description="Logical flag determining if an analysis member output write occurs on start-up." possible_values=".true. or .false." /> - diff --git a/src/core_ocean/analysis_members/Registry_meridional_heat_transport.xml b/src/core_ocean/analysis_members/Registry_meridional_heat_transport.xml index 2acf98b0dd..7c2f61926a 100644 --- a/src/core_ocean/analysis_members/Registry_meridional_heat_transport.xml +++ b/src/core_ocean/analysis_members/Registry_meridional_heat_transport.xml @@ -15,7 +15,7 @@ description="Logical flag determining if an analysis member output occurs on start-up." possible_values=".true. or .false." /> - diff --git a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml index e31f1abd55..4c85306284 100644 --- a/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml +++ b/src/core_ocean/analysis_members/Registry_mixed_layer_depths.xml @@ -7,7 +7,7 @@ description="Timestamp determining how often analysis member computation should be performed." possible_values="Any valid time stamp, 'dt', or 'output_interval'" /> - diff --git a/src/core_ocean/analysis_members/Registry_okubo_weiss.xml b/src/core_ocean/analysis_members/Registry_okubo_weiss.xml index fdb5565224..e0819dda81 100644 --- a/src/core_ocean/analysis_members/Registry_okubo_weiss.xml +++ b/src/core_ocean/analysis_members/Registry_okubo_weiss.xml @@ -27,7 +27,7 @@ description="Time stamp for frequency of computation of the okubo weiss analysis member." possible_values="Any time stamp, 'dt', or 'output_interval'" /> - - diff --git a/src/core_ocean/analysis_members/Registry_test_compute_interval.xml b/src/core_ocean/analysis_members/Registry_test_compute_interval.xml index c11a0734cb..10e257e5f6 100644 --- a/src/core_ocean/analysis_members/Registry_test_compute_interval.xml +++ b/src/core_ocean/analysis_members/Registry_test_compute_interval.xml @@ -15,7 +15,7 @@ description="Logical flag determining if an analysis member write occurs on start-up." possible_values=".true. or .false." /> - diff --git a/src/core_ocean/analysis_members/Registry_time_filters.xml b/src/core_ocean/analysis_members/Registry_time_filters.xml index 1ce543e423..a721fd76bf 100644 --- a/src/core_ocean/analysis_members/Registry_time_filters.xml +++ b/src/core_ocean/analysis_members/Registry_time_filters.xml @@ -7,7 +7,7 @@ description="Timestamp determining how often analysis member computation should be performed." possible_values="'dt' because filtering should be performed at each time step." /> - diff --git a/src/core_ocean/analysis_members/Registry_time_series_stats.xml b/src/core_ocean/analysis_members/Registry_time_series_stats.xml index c7ef329bc5..d56f3b87d3 100644 --- a/src/core_ocean/analysis_members/Registry_time_series_stats.xml +++ b/src/core_ocean/analysis_members/Registry_time_series_stats.xml @@ -27,14 +27,14 @@ description="Interval that determines frequency of computation for the time series stats analysis member." possible_values="Any valid time stamp or 'dt'. This must also be less than or requal to output_interval / 2 (at least two samples in a series)." /> - - - diff --git a/src/core_ocean/analysis_members/Registry_zonal_mean.xml b/src/core_ocean/analysis_members/Registry_zonal_mean.xml index 8bb0dc3538..bc688f8546 100644 --- a/src/core_ocean/analysis_members/Registry_zonal_mean.xml +++ b/src/core_ocean/analysis_members/Registry_zonal_mean.xml @@ -15,7 +15,7 @@ description="Interval that determines frequency of computation for the zonal mean analysis member." possible_values="Any valid time stamp, 'dt', or 'output_interval'" /> - diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F index 18252c0015..e73952f7d9 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -224,7 +224,7 @@ subroutine ocn_analysis_init(domain, err)!{{{ character (len=StrKIND) :: configName, alarmName, streamName, timerName logical, pointer :: config_AM_enable - character (len=StrKIND), pointer :: config_AM_compute_interval, config_AM_stream_name + character (len=StrKIND), pointer :: config_AM_compute_interval, config_AM_output_stream integer :: nameLength type (mpas_pool_iterator_type) :: poolItr @@ -252,8 +252,8 @@ subroutine ocn_analysis_init(domain, err)!{{{ configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_compute_interval' call mpas_pool_get_config(domain % configs, configName, config_AM_compute_interval) - configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_stream_name' - call mpas_pool_get_config(domain % configs, configName, config_AM_stream_name) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_output_stream' + call mpas_pool_get_config(domain % configs, configName, config_AM_output_stream) if ( config_AM_compute_interval == 'dt' ) then alarmTimeStep = mpas_get_clock_timestep(domain % clock, err_tmp) @@ -261,26 +261,26 @@ subroutine ocn_analysis_init(domain, err)!{{{ end if ! Verify stream exists before trying to use output_interval - if ( config_AM_stream_name /= 'none' ) then + if ( config_AM_output_stream /= 'none' ) then streamFound = .false. call mpas_stream_mgr_begin_iteration(domain % streamManager) do while ( mpas_stream_mgr_get_next_stream(domain % streamManager, streamName) ) - if ( trim(streamName) == trim(config_AM_stream_name) ) then + if ( trim(streamName) == trim(config_AM_output_stream) ) then streamFound = .true. end if end do if ( .not. streamFound ) then - call mpas_dmpar_global_abort('ERROR: Stream ' // trim(config_AM_stream_name) // ' does not exist. Exiting...') + call mpas_dmpar_global_abort('ERROR: Stream ' // trim(config_AM_output_stream) // ' does not exist. Exiting...') end if end if - if ( config_AM_compute_interval /= 'output_interval' .and. config_AM_stream_name /= 'none') then + if ( config_AM_compute_interval /= 'output_interval' .and. config_AM_output_stream /= 'none') then alarmName = poolItr % memberName(1:nameLength) // computeAlarmSuffix call mpas_set_timeInterval(alarmTimeStep, timeString=config_AM_compute_interval, ierr=err_tmp) - call MPAS_stream_mgr_get_property(domain % streamManager, config_AM_stream_name, MPAS_STREAM_PROPERTY_REF_TIME, referenceTimeString, err_tmp) + call MPAS_stream_mgr_get_property(domain % streamManager, config_AM_output_stream, MPAS_STREAM_PROPERTY_REF_TIME, referenceTimeString, err_tmp) call mpas_set_time(referenceTime, dateTimeString=referenceTimeString, ierr=err_tmp) call mpas_add_clock_alarm(domain % clock, alarmName, referenceTime, alarmTimeStep, ierr=err_tmp) call mpas_reset_clock_alarm(domain % clock, alarmName, ierr=err_tmp) @@ -339,7 +339,7 @@ subroutine ocn_analysis_compute_startup(domain, err)!{{{ integer :: timeLevel, err_tmp character (len=StrKIND) :: configName, timerName - character (len=StrKIND), pointer :: config_AM_stream_name + character (len=StrKIND), pointer :: config_AM_output_stream logical, pointer :: config_AM_enable, config_AM_write_on_startup, config_AM_compute_on_startup type (mpas_pool_iterator_type) :: poolItr integer :: nameLength @@ -371,10 +371,10 @@ subroutine ocn_analysis_compute_startup(domain, err)!{{{ end if if ( config_AM_write_on_startup ) then - configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_stream_name' - call mpas_pool_get_config(domain % configs, configName, config_AM_stream_name) - if ( config_AM_stream_name /= 'none' ) then - call mpas_stream_mgr_write(domain % streamManager, streamID=config_AM_stream_name, forceWriteNow=.true., ierr=err_tmp) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_output_stream' + call mpas_pool_get_config(domain % configs, configName, config_AM_output_stream) + if ( config_AM_output_stream /= 'none' ) then + call mpas_stream_mgr_write(domain % streamManager, streamID=config_AM_output_stream, forceWriteNow=.true., ierr=err_tmp) end if if (.not. config_AM_compute_on_startup) then write(stderrUnit, *) ' *** WARNING: write_on_startup called without compute_on_startup for analysis member: ' & @@ -434,7 +434,7 @@ subroutine ocn_analysis_compute(domain, err)!{{{ integer :: timeLevel, err_tmp character (len=StrKIND) :: configName, alarmName, timerName - character (len=StrKIND), pointer :: config_AM_stream_name, config_AM_compute_interval + character (len=StrKIND), pointer :: config_AM_output_stream, config_AM_compute_interval logical, pointer :: config_AM_enable type (mpas_pool_iterator_type) :: poolItr integer :: nameLength @@ -454,16 +454,16 @@ subroutine ocn_analysis_compute(domain, err)!{{{ if ( config_AM_enable ) then configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_compute_interval' call mpas_pool_get_config(domain % configs, configName, config_AM_compute_interval) - configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_stream_name' - call mpas_pool_get_config(domain % configs, configName, config_AM_stream_name) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_output_stream' + call mpas_pool_get_config(domain % configs, configName, config_AM_output_stream) ! Build name of alarm for analysis member alarmName = poolItr % memberName(1:nameLength) // computeAlarmSuffix timerName = trim(computeTimerPrefix) // poolItr % memberName(1:nameLength) ! Compute analysis member just before output - if ( config_AM_compute_interval == 'output_interval' .and. config_AM_stream_name /= 'none') then - if ( mpas_stream_mgr_ringing_alarms(domain % streamManager, streamID=config_AM_stream_name, direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) ) then + if ( config_AM_compute_interval == 'output_interval' .and. config_AM_output_stream /= 'none') then + if ( mpas_stream_mgr_ringing_alarms(domain % streamManager, streamID=config_AM_output_stream, direction=MPAS_STREAM_OUTPUT, ierr=err_tmp) ) then call mpas_timer_start(timerName, .false.) call ocn_compute_analysis_members(domain, timeLevel, poolItr % memberName, err_tmp) call mpas_timer_stop(timerName) @@ -602,7 +602,7 @@ subroutine ocn_analysis_write(domain, err)!{{{ integer :: err_tmp character (len=StrKIND) :: configName, timerName - character (len=StrKIND), pointer :: config_AM_stream_name + character (len=StrKIND), pointer :: config_AM_output_stream logical, pointer :: config_AM_enable type (mpas_pool_iterator_type) :: poolItr integer :: nameLength @@ -618,16 +618,16 @@ subroutine ocn_analysis_write(domain, err)!{{{ call mpas_pool_get_config(domain % configs, configName, config_AM_enable) if ( config_AM_enable ) then - configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_stream_name' - call mpas_pool_get_config(domain % configs, configName, config_AM_stream_name) - if ( config_AM_stream_name /= 'none' ) then + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_output_stream' + call mpas_pool_get_config(domain % configs, configName, config_AM_output_stream) + if ( config_AM_output_stream /= 'none' ) then timerName = trim(writeTimerPrefix) // poolItr % memberName(1:nameLength) call mpas_timer_start(timerName, .false.) - call mpas_stream_mgr_write(domain % streamManager, streamID=config_AM_stream_name, ierr=err_tmp) + call mpas_stream_mgr_write(domain % streamManager, streamID=config_AM_output_stream, ierr=err_tmp) call mpas_timer_stop(timerName) timerName = trim(alarmTimerPrefix) // poolItr % memberName(1:nameLength) call mpas_timer_start(timerName, .false.) - call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID=config_AM_stream_name, ierr=err_tmp) + call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID=config_AM_output_stream, ierr=err_tmp) call mpas_timer_stop(timerName) end if end if diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index e7ec40f12a..1e136629bc 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -106,8 +106,8 @@ module ocn_time_series_stats 'config_AM_timeSeriesStats' character (len=StrKIND), parameter :: FRAMEWORK_PREFIX = 'timeSeriesStats' - character (len=StrKIND), parameter :: STREAM_NAME_SUFFIX = '_stream_name' - character (len=StrKIND), parameter :: RESTART_NAME_SUFFIX = '_restart_name' + character (len=StrKIND), parameter :: OUTPUT_STREAM_SUFFIX = '_output_stream' + character (len=StrKIND), parameter :: RESTART_STREAM_SUFFIX = '_restart_stream' character (len=StrKIND), parameter :: OPERATION_SUFFIX = '_operation' character (len=StrKIND), parameter :: ADD_MESH_SUFFIX = '_add_mesh' @@ -500,7 +500,7 @@ subroutine start_init(domain, instance, series, err) integer, intent(out) :: err !< Output: error flag ! local variables - character (len=StrKIND), pointer :: config_results, stream_name + character (len=StrKIND), pointer :: config_results, output_stream_name character (len=StrKIND) :: config, namelist_prefix, storage_prefix, & var_identifier, buf_identifier, var_prefix, buf_prefix integer :: b, v @@ -555,20 +555,20 @@ subroutine start_init(domain, instance, series, err) ! ! get the stream name - config = trim(namelist_prefix) // trim(STREAM_NAME_SUFFIX) - call mpas_pool_get_config(domain % configs, config, stream_name) + config = trim(namelist_prefix) // trim(OUTPUT_STREAM_SUFFIX) + call mpas_pool_get_config(domain % configs, config, output_stream_name) - if (stream_name == 'none') then + if (output_stream_name == 'none') then call mpas_dmpar_global_abort('Error: stream cannot be "none" ' // & 'for time series stats.') end if ! count the number of variables call mpas_stream_mgr_begin_iteration(domain % streamManager, & - stream_name, err) + output_stream_name, err) series % number_of_variables = 0 do while (mpas_stream_mgr_get_next_field(domain % streamManager, & - stream_name, config)) + output_stream_name, config)) series % number_of_variables = series % number_of_variables + 1 end do @@ -735,7 +735,7 @@ subroutine modify_stream(domain, instance, series, err)!{{{ ! local variables integer :: v, b - character (len=StrKIND), pointer :: stream_name, restart_name + character (len=StrKIND), pointer :: output_stream_name, restart_stream_name type (field0DReal), pointer :: srcReal, dstReal logical, pointer :: copy_mesh character (len=StrKIND) :: field_name, config, op_name @@ -749,13 +749,13 @@ subroutine modify_stream(domain, instance, series, err)!{{{ namelist_prefix = trim(CONFIG_PREFIX) // trim(instance) storage_prefix = trim(FRAMEWORK_PREFIX) // trim(instance) - ! get the stream name - config = trim(namelist_prefix) // trim(STREAM_NAME_SUFFIX) - call mpas_pool_get_config(domain % configs, config, stream_name) + ! get the output stream name + config = trim(namelist_prefix) // trim(OUTPUT_STREAM_SUFFIX) + call mpas_pool_get_config(domain % configs, config, output_stream_name) - ! get restart stream - config = trim(namelist_prefix) // trim(RESTART_NAME_SUFFIX) - call mpas_pool_get_config(domain % configs, config, restart_name) + ! get restart stream name + config = trim(namelist_prefix) // trim(RESTART_STREAM_SUFFIX) + call mpas_pool_get_config(domain % configs, config, restart_stream_name) ! operator if (series % operation == AVG_OP) then @@ -768,10 +768,10 @@ subroutine modify_stream(domain, instance, series, err)!{{{ ! get the old field names call mpas_stream_mgr_begin_iteration(domain % streamManager, & - stream_name, err) + output_stream_name, err) v = 1 do while (mpas_stream_mgr_get_next_field(domain % streamManager, & - stream_name, field_name)) + output_stream_name, field_name)) series % variables(v) % input_name = field_name v = v + 1 end do @@ -779,7 +779,7 @@ subroutine modify_stream(domain, instance, series, err)!{{{ ! remove the old ones from the stream do v = 1, series % number_of_variables call mpas_stream_mgr_remove_field(domain % streamManager, & - stream_name, series % variables(v) % input_name) + output_stream_name, series % variables(v) % input_name) end do ! @@ -788,7 +788,7 @@ subroutine modify_stream(domain, instance, series, err)!{{{ ! add xtime to the stream call mpas_stream_mgr_add_field(domain % streamManager, & - stream_name, TIME_STREAM, ierr=err) + output_stream_name, TIME_STREAM, ierr=err) ! optionally add mesh to stream config = trim(namelist_prefix) // trim(ADD_MESH_SUFFIX) @@ -799,13 +799,13 @@ subroutine modify_stream(domain, instance, series, err)!{{{ do while (mpas_stream_mgr_get_next_field(domain % streamManager, & MESH_STREAM, field_name)) call mpas_stream_mgr_add_field(domain % streamManager, & - stream_name, field_name, ierr=err) + output_stream_name, field_name, ierr=err) end do end if ! make restart mutable call mpas_stream_mgr_set_property(domain % streamManager, & - restart_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .false., ierr=err) + restart_stream_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .false., ierr=err) ! create and put the counters in the streams do b = 1, series % number_of_buffers @@ -825,16 +825,16 @@ subroutine modify_stream(domain, instance, series, err)!{{{ ! put it in the output stream call mpas_stream_mgr_add_field(domain % streamManager, & - stream_name, dstReal % fieldName, ierr=err) + output_stream_name, dstReal % fieldName, ierr=err) ! put it in the restart stream call mpas_stream_mgr_add_field(domain % streamManager, & - restart_name, dstReal % fieldName, ierr=err) + restart_stream_name, dstReal % fieldName, ierr=err) end do ! set up the variables call mpas_stream_mgr_begin_iteration(domain % streamManager, & - stream_name, err) + output_stream_name, err) do v = 1, series % number_of_variables ! get the info of the field call mpas_pool_get_field_info(domain % blocklist % allFields, & @@ -867,34 +867,34 @@ subroutine modify_stream(domain, instance, series, err)!{{{ ! add the field to the stream call mpas_stream_mgr_add_field(domain % streamManager, & - stream_name, series % variables(v) % output_names(b), ierr=err) + output_stream_name, series % variables(v) % output_names(b), ierr=err) ! put it in the restart stream call mpas_stream_mgr_add_field(domain % streamManager, & - restart_name, series % variables(v) % output_names(b), ierr=err) + restart_stream_name, series % variables(v) % output_names(b), ierr=err) end do end do ! number_of_variables ! make restart immutable call mpas_stream_mgr_set_property(domain % streamManager, & - restart_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .true., ierr=err) + restart_stream_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .true., ierr=err) ! read the restart stream - call mpas_stream_mgr_read(domain % streamManager, streamID = restart_name, & + call mpas_stream_mgr_read(domain % streamManager, streamID = restart_stream_name, & ierr=err) ! add xtime afterwards because we don't want to clobber the existing xtime ! make restart mutable call mpas_stream_mgr_set_property(domain % streamManager, & - restart_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .false., ierr=err) + restart_stream_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .false., ierr=err) ! add xtime to the restart call mpas_stream_mgr_add_field(domain % streamManager, & - restart_name, TIME_STREAM, ierr=err) + restart_stream_name, TIME_STREAM, ierr=err) ! make restart immutable call mpas_stream_mgr_set_property(domain % streamManager, & - restart_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .true., ierr=err) + restart_stream_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .true., ierr=err) end subroutine modify_stream!}}} From 9e208e6cc138a0d38b38e4a1aef66d4d99087da0 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 8 Oct 2015 14:18:17 -0600 Subject: [PATCH 0302/1724] Adding a routine to read restarts / inputs for analysis members This commit adds a routine that is not called yet to handle reading of input / restart streams for analysis members that have one or more of these. --- .../mpas_ocn_analysis_driver.F | 142 ++++++++++++++++++ 1 file changed, 142 insertions(+) diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F index e73952f7d9..6b21d8a480 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -59,6 +59,7 @@ module ocn_analysis_driver !-------------------------------------------------------------------- public :: ocn_analysis_setup_packages, & + ocn_analysis_read_init_streams, & ocn_analysis_init, & ocn_analysis_compute_startup, & ocn_analysis_compute, & @@ -73,6 +74,7 @@ module ocn_analysis_driver !-------------------------------------------------------------------- + character (len=*), parameter :: initReadTimerPrefix = 'init_read_' character (len=*), parameter :: initTimerPrefix = 'init_' character (len=*), parameter :: computeTimerPrefix = 'compute_' character (len=*), parameter :: computeStartupTimerPrefix = 'compute_startup_' @@ -177,6 +179,146 @@ subroutine ocn_analysis_setup_packages(configPool, packagePool, iocontext, err)! end subroutine ocn_analysis_setup_packages!}}} +!*********************************************************************** +! +! routine ocn_analysis_read_init_streams +! +!> \brief Setup packages for MPAS-Ocean analysis driver +!> \author Doug Jacobsen +!> \date 10/08/2015 +!> \details +!> This routine will read either a restart or an input stream for each analysis member. +!> The stream names that will be read are controlled via the analysis member's +!> - config_AM_${AM}_restart_stream +!> - config_AM_${AM}_input_stream +!> namelist options. +!> +!> If the AM doesn't specify either of these, it will be ignored. If the AM +!> specifies only the restart stream, it will only be read if the config_do_restart flag +!> for the model is set to true. If the AM specifies both, the restart_stream will be read if +!> config_do_restart is true, and the input_stream will be read if config_do_restart is false. +!> +!> After this call, alarms on both streams are reset. +! +!----------------------------------------------------------------------- + + subroutine ocn_analysis_read_init_streams(domain, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: err_tmp + + character (len=StrKIND) :: configName, alarmName, restartStreamName, inputStreamName, timerName + logical, pointer :: config_AM_enable, config_do_restart + character (len=StrKIND), pointer :: config_AM_restart_stream, config_AM_input_stream + integer :: nameLength + type (mpas_pool_iterator_type) :: poolItr + + logical :: streamFound + character (len=StrKIND) :: referenceTimeString, outputIntervalString + type (MPAS_Time_Type) :: referenceTime + type (MPAS_TimeInterval_type) :: alarmTimeStep + + integer :: poolErrorLevel + + err = 0 + + poolErrorLevel = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + + call mpas_timer_start('analysis_read_init_streams', .false.) + + call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) + + call mpas_pool_begin_iteration(analysisMemberList) + do while ( mpas_pool_get_next_member(analysisMemberList, poolItr) ) + nameLength = len_trim(poolItr % memberName) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_enable' + call mpas_pool_get_config(domain % configs, configName, config_AM_enable) + + if ( config_AM_enable ) then + timerName = trim(initReadTimerPrefix) // poolItr % memberName(1:nameLength) + call mpas_timer_start(timerName, .false.) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_restart_stream' + call mpas_pool_get_config(domain % configs, configName, config_AM_restart_stream) + + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_input_stream' + call mpas_pool_get_config(domain % configs, configName, config_AM_input_stream) + + ! Verify the restart stream exists + if ( associated(config_AM_restart_stream) ) then + if ( .not. mpas_stream_mgr_stream_exists(domain % streamManager, config_AM_restart_stream) ) then + call mpas_dmpar_global_abort('ERROR: Stream named ''' // trim(config_AM_restart_stream) // & + ''' does not exist in config for analysis member ''' // & + trim(poolItr % memberName(1:nameLength)) // '''') + end if + end if + + ! Verify the input stream exists + if ( associated(config_AM_input_stream) ) then + if ( .not. mpas_stream_mgr_stream_exists(domain % streamManager, config_AM_input_stream) ) then + call mpas_dmpar_global_abort('ERROR: Stream named ''' // trim(config_AM_input_stream) // & + ''' does not exist in config for analysis member ''' // & + trim(poolItr % memberName(1:nameLength)) // '''') + end if + end if + + ! Handle reading of streams that exist. + if ( associated(config_AM_restart_stream) .and. associated(config_AM_input_stream) ) then + if ( config_do_restart ) then + call mpas_stream_mgr_read(domain % streamManager, streamID=config_AM_restart_stream, ierr=err) + else + call mpas_stream_mgr_read(domain % streamManager, streamID=config_AM_input_stream, ierr=err) + end if + call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID=config_AM_restart_stream, direction=MPAS_STREAM_INPUT, ierr=err) + call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID=config_AM_input_stream, direction=MPAS_STREAM_INPUT, ierr=err) + else if ( associated(config_AM_restart_stream) ) then + if ( config_do_restart ) then + call mpas_stream_mgr_read(domain % streamManager, streamID=config_AM_restart_stream, ierr=err) + end if + call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID=config_AM_restart_stream, direction=MPAS_STREAM_INPUT, ierr=err) + else if ( associated(config_AM_input_stream) ) then + if ( .not. config_do_restart ) then + call mpas_stream_mgr_read(domain % streamManager, streamID=config_AM_input_stream, ierr=err) + end if + call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID=config_AM_input_stream, direction=MPAS_STREAM_INPUT, ierr=err) + end if + call mpas_timer_stop(timerName) + end if + end do + + call mpas_timer_stop('analysis_read_init_streams') + + call mpas_pool_set_error_level(poolErrorLevel) + + end subroutine ocn_analysis_read_init_streams!}}} + !*********************************************************************** ! ! routine ocn_analysis_init From 039e07505341039c1449aa43c810c52fc0646225 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 8 Oct 2015 14:38:59 -0600 Subject: [PATCH 0303/1724] Adding a call to read analysis member restart / input streams This commit adds a call to read the analysis member restart / input streams in the forward mode of the ocean core. --- src/core_ocean/mode_forward/mpas_ocn_forward_mode.F | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index c4370c057e..b69acc314b 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -165,6 +165,8 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ call MPAS_stream_mgr_read(domain % streamManager, streamID='input', ierr=err_tmp) end if + call ocn_analysis_read_init_streams(domain, err=err_tmp) + call mpas_timer_stop('io_read') call mpas_timer_start('reset_io_alarms', .false.) call mpas_stream_mgr_reset_alarms(domain % streamManager, streamID='input', ierr=err_tmp) From 6bf8d9faf01987f5632ec0dfb3fedfedc6fcb1f5 Mon Sep 17 00:00:00 2001 From: toddringler Date: Thu, 8 Oct 2015 15:06:15 -0600 Subject: [PATCH 0304/1724] added new module for the computatation of frazil processes --- src/core_ocean/shared/mpas_ocn_frazil.F | 362 ++++++++++++++++++++++++ 1 file changed, 362 insertions(+) create mode 100644 src/core_ocean/shared/mpas_ocn_frazil.F diff --git a/src/core_ocean/shared/mpas_ocn_frazil.F b/src/core_ocean/shared/mpas_ocn_frazil.F new file mode 100644 index 0000000000..efd4766922 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_frazil.F @@ -0,0 +1,362 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_frazil +! +!> \brief MPAS ocean frazil formation module +!> \author Todd Ringler +!> \date 10/19/2015 +!> \details +!> This module contains routines for the formation of frazil ice. +! +!----------------------------------------------------------------------- + +module ocn_frazil + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use mpas_timekeeping + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_frazil_formation, & + ocn_frazil_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + integer :: verticalLevelCap + logical :: frazilFormationOn + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_frazil_formation +! +!> \brief Performs the formation of frazil within the ocean. +!> \author Todd Ringler +!> \date 10/19/2015 +!> \details +!> ocn_frazil_formation compute the tendencies to layer thickness, temperature and salinity +!> due to the creation and possible melting of frazil ice +!> +!> these tendencies can be retrieved at any point by calling into ocn_frazil_*_tendency routines +!> where * is layerThickness, temperature or salinity +!> +!> the pressure exerted by the frazil on the ocean "surface" can be retrieved by calling into +!> ocn_frazil_surface_pressure +! +!----------------------------------------------------------------------- + + subroutine ocn_frazil_formation(meshPool, indexTemperature, indexSalinity, layerThickness, tracers, seaIceEnergy, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + + integer :: indexTemperature !< Input: Index in tracers array for temperature + integer :: indexSalinity !< Input: Index in tracers array for salinity + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(inout) :: seaIceEnergy !< Input/Output: Accumulated energy for sea ice formation + real (kind=RKIND), dimension(:,:,:), intent(inout) :: tracers !< Input/Output: Array of tracers + real (kind=RKIND), dimension(:,:), intent(inout) :: layerThickness !< Input/Output: Thickness of each layer + integer, intent(inout) :: err !< Error flag + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: maxLevel, nTracers + integer :: iCell, k, iTracer + integer, pointer :: nCells, nVertLevels, nCellsSolve + + integer, dimension(:), pointer :: maxLevelCell + + real (kind=RKIND) :: temperatureTendency, thicknessTendency, salinityTendency + + + real (kind=RKIND) :: netEnergyChange, availableEnergyChange, energyChange + real (kind=RKIND) :: temperatureTendency, thicknessTendency, salinityTendency + + real (kind=RKIND) :: referenceSalinity, iceSalinity + real (kind=RKIND) :: freezingTemp, density_ice + real (kind=RKIND), dimension(:), allocatable :: iceTracer + + if(.not. frazilFormationOn) return + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + + do iCell = 1, nCellsSolve + + columnTemperatureMin = min(tracers(indexTemperature,:,iCell)) + freezingTemp = ocn_freezing_temperature(tracers(indexSalinity, 1, iCell)) + + if (columnTemperatureMin < freezingTemp) then + + do k=1,nVertLevels + deltaTemperature = freezingTemp - tracers(indexTemperature,k,iCell) + energyPotential = cp_sw * density(k,iCell) * deltaTemperature + fractionalFreezePotential(k) = max(0.0_RKIND, energyPotential / (energyPotential + density_ice * latent_heat_fusion_mks)) + fractionalMeltPotential(k) = max(0.0_RKIND, -energyPotential / energyPotential + density_ice * latent_heat_fusion_mks) + enddo + + ! set all accumulators to zero + frazilThickness = 0.0_RKIND + frazilMass = 0.0_RKIND + + do k=maxLevelCell(iCell),1,-1 + + ! test to see if frazil is created in this layer + if (fractionalFreezePotential(k).gt.0.0_RKIND) then + thicknessFreeze = min(fractionalFreezePotential(k), fractionalFrazilLimiter)*layerThickness(k,iCell) + thickessLiquid = frazilReferenceSalinity * thicknessFreeze / (tracers(indexSalinity,k,iCell)-frazilReferenceSalinity) + frazilThicknessTend(k,iCell) = -(thicknessFreeze+thickessLiquid) / dt + frazilSalinityTend(k,iCell) = -thickessLiquid*tracers(indexSalinity,k,iCell) / dt + frazilTemperatureTend(k,iCell) = latent_heat_fusion_mks * thicknessFreeze / cp_sw / dt + frazilThickness = frazilThickness + thicknessFreeze + thickessLiquid + frazilMass = frazilMass + (thicknessFreeze + thickessLiquid) * density(k,iCell) + else + if (frazilThickness.gt.0.0_RKIND) then + thicknessMelt = min(frazilThickness, fractionalMeltPotential(k)*layerThickness(k,iCell), fractionalFrazilLimiter*layerThickness(k,iCell)) + frazilThicknessTend(k,iCell) = thicknessMelt / dt + frazilSalinityTend(k,iCell) = thicknessMelt * frazilReferenceSalinity / dt + frazilTemperatureTend(k,iCell) = -latent_heat_fusion_mks * thicknessFreeze / cp_sw / dt + frazilThickness = frazilThickness - thicknessMelt + frazilMass = frazilMass - thicknessMelt * density_ice + endif + endif ! (fractionalFreezePotential(k).gt.0.0_RKIND) + + enddo ! do k=maxLevelCell(iCell),1,-1 + + frazilSurfacePressure(newTime) = frazilSurfacePressure(oldTime) + frazilMass*gravity + + endif + + enddo + + + + + + endif ! (columnTemperatureMin < freezingTemp) + + + + + + maxLevel = min(maxLevelCell(iCell), verticalLevelCap) + netEnergyChange = 0.0_RKIND + + ! Loop over vertical levels, starting from the bottom of a column + do k = maxLevel, 1, -1 + freezingTemp = ocn_freezing_temperature(tracers(indexSalinity, k, iCell)) + ! availableEnergyChange is: + ! positive when frazil ice is formed + ! negative when frazil ice can be melted + availableEnergyChange = rho_sw * cp_sw * layerThickness(k, iCell) & + * (freezingTemp - tracers(indexTemperature, k, iCell)) + + ! energyChange is capped when negative. + ! melting energy can't be greater than the amount of energy + ! available in formed ice. + energyChange = max(availableEnergyChange, -netEnergyChange) + + ! Compute temperature change in ocean cell due to energy change + temperatureChange = energyChange / ( rho_sw * cp_sw * layerThickness(k, iCell) ) + ! Compute thickness change in ocean cell due to energy change + thicknessChange = energyChange / ( rho_sw * latent_heat_fusion_mks ) + ! Compute thickness change in sea ice due to energy change + iceThicknessChange = energyChange / ( density_ice * latent_heat_fusion_mks ) + + ! Update all tracers based on the thickness change + do iTracer = 1, nTracers + if(iTracer /= indexTemperature) then + ! computed as: + ! \rho_{ocn} h_{ocn}^{pre} \theta_{ocn}^{pre} = + ! \rho_{ocn}^{new} h_{ocn}^{new} \theta_{ocn}^{new} = \rho_{si} h_{si} \theta_{si} + tracers(iTracer, k, iCell) = ( rho_sw * layerThickness(k,iCell) * tracers(iTracer, k, iCell) & + - density_ice * iceThicknessChange * iceTracer(iTracer)) / & + (rho_sw * (layerThickness(k,iCell) + thicknessChange)) + end if + end do + + ! Adjust Temperature + tracers(indexTemperature, k, iCell) = tracers(indexTemperature, k, iCell) + temperatureChange + ! Adjust Thickness + layerThickness(k,iCell) = layerThickness(k,iCell) + thicknessChange + + ! Add energyChange to netEnergyChange. + ! netEnergyChange should always be >= 0.0 + netEnergyChange = netEnergychange + energyChange + end do + + ! Add netEnergyChange to the cell's energy. + ! seaIceEnergy should always be >= 0.0 + seaIceEnergy(iCell) = seaIceEnergy(iCell) + netEnergyChange + + ! Adjust top layer one more time, based on energy availabe in seaIceEnergy(iCell) + ! This really only allows melting of previously formed ice to occur. + if(maxLevelCell(iCell) >= 1 .and. seaIceEnergy(iCell) > 0.0_RKIND) then + k = 1 + + netEnergychange = 0.0_RKIND + freezingTemp = ocn_freezing_temperature(tracers(indexSalinity, k, iCell)) + ! availableEnergyChange is: + ! positive when frazil ice is formed + ! negative when frazil ice can be melted + availableEnergyChange = rho_sw * cp_sw * layerThickness(k, iCell) & + * (freezingTemp - tracers(indexTemperature, k, iCell)) + + ! energyChange is capped when negative. + ! melting energy can't be greater than the amount of energy + ! available in formed ice. + ! compared with seaIceEnergy in this case, rather than netEnergyChange + energyChange = max(availableEnergyChange, -seaIceEnergy(iCell)) + + ! Compute temperature change in ocean cell due to energy change + temperatureChange = energyChange / ( rho_sw * cp_sw * layerThickness(k, iCell) ) + ! Compute thickness change in ocean cell due to energy change + thicknessChange = energyChange / ( rho_sw * latent_heat_fusion_mks ) + ! Compute thickness change in sea ice due to energy change + iceThicknessChange = energyChange / ( density_ice * latent_heat_fusion_mks ) + + ! Update all tracers based on the thickness change + do iTracer = 1, nTracers + if(iTracer /= indexTemperature) then + ! computed as: + ! \rho_{ocn} h_{ocn}^{pre} \theta_{ocn}^{pre} = + ! \rho_{ocn}^{new} h_{ocn}^{new} \theta_{ocn}^{new} = \rho_{si} h_{si} \theta_{si} + tracers(iTracer, k, iCell) = ( rho_sw * layerThickness(k,iCell) * tracers(iTracer, k, iCell) & + - density_ice * iceThicknessChange * iceTracer(iTracer)) / & + (rho_sw * (layerThickness(k,iCell) + thicknessChange)) + end if + end do + + ! Adjust Temperature + tracers(indexTemperature, k, iCell) = tracers(indexTemperature, k, iCell) + temperatureChange + ! Adjust Thickness + layerThickness(k,iCell) = layerThickness(k,iCell) + thicknessChange + + ! Add energyChange to netEnergyChange. + ! netEnergyChange should always be >= 0.0 + seaIceEnergy(iCell) = seaIceEnergy(iCell) + energyChange + end if + end do + + deallocate(iceTracer) + + end subroutine ocn_frazil_formation!}}} + +!*********************************************************************** +! +! function ocn_freezing_temperature +! +!> \brief Computes the freezing temperature of the ocean. +!> \author Todd Ringler +!> \date 10/29/2015 +!> \details +!> This routine computes the freezing temperature of the ocean at a given +!> salinity value. +! +!----------------------------------------------------------------------- + real (kind=RKIND) function ocn_freezing_temperature(salinity)!{{{ + real (kind=RKIND) :: salinity !< Input: Salinity value of water for freezing temperature + ocn_freezing_temperature = -1.8 + end function ocn_freezing_temperature!}}} + + +!*********************************************************************** +! +! routine ocn_frazil_init +! +!> \brief Initializes ocean frazil ice module. +!> \author Todd Ringler +!> \date 10/19/2015 +!> \details +!> This routine initializes the ocean frazil ice module and variables.. +! +!----------------------------------------------------------------------- + + subroutine ocn_frazil_init(nVertLevels, err)!{{{ + + integer, intent(in) :: nVertLevels !< Input: Number of vertical levels suggested for level cap + integer, intent(out) :: err !< Output: error flag + + logical, pointer :: config_frazil_ice_formation, config_monotonic + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_frazil_ice_formation', config_frazil_ice_formation) + call mpas_pool_get_config(ocnConfigs, 'config_monotonic', config_monotonic) + + frazilFormationOn = .false. + + if(config_frazil_ice_formation) then + frazilFormationOn = .true. + end if + + if(.not. config_monotonic) then + verticalLevelCap = 1 + else + verticalLevelCap = nVertLevels + end if + + end subroutine ocn_frazil_init!}}} + +!*********************************************************************** + +end module ocn_sea_ice + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker From 233c66fe3617d963f6d58308e87dfb78ff1c44dd Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Fri, 9 Oct 2015 08:28:51 -0600 Subject: [PATCH 0305/1724] Remove extraneous comma from write statement that XLF fails on --- src/core_landice/shared/mpas_li_setup.F | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/core_landice/shared/mpas_li_setup.F b/src/core_landice/shared/mpas_li_setup.F index 9578e1843e..36c07ec317 100644 --- a/src/core_landice/shared/mpas_li_setup.F +++ b/src/core_landice/shared/mpas_li_setup.F @@ -179,8 +179,7 @@ subroutine li_setup_vertical_grid(meshPool, geometryPool, err) write(stderrUnit,*) 'Error: The sum of layerThicknessFractions is different from 1.0 by more than 0.001.' err = 1 end if - write (stdoutUnit,*), 'Adjusting upper layerThicknessFrac by small amount because sum of layerThicknessFractions is slightly different from 1.0.' - ! TODO - distribute the residual amongst all layers (and then put the residual of that in a single layer + write (stdoutUnit,*) 'Adjusting upper layerThicknessFrac by small amount because sum of layerThicknessFractions is slightly different from 1.0.' layerThicknessFractions(1) = layerThicknessFractions(1) - (fractionTotal - 1.0_RKIND) endif From 741c361cfff8092b4d74659a05233901c25167ea Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Fri, 2 Oct 2015 06:03:13 -0700 Subject: [PATCH 0306/1724] Adding time-averaged fields for land-ice coupling The averaged fields are updated in ocn_time_average_coupled Some tracer fields related to land-ice fluxes have been grouped into arrays for convenience and consistencey with other time averaging Adding effective density in ice shelves: Needed for land-ice coupling to compute ice draft = sea-surface height using Arhcimedes' principle. Effective density is computed using Achimedes' principle where there is more than 50% land-ice cover. Elsewhere, the value is extrapolated through averaging nearest neighbors at each time step. The effective density requires a halo update after each time step. Moved seaSurfacePressure and surfaceStress to forcing input/output instead of init/restart/output, since it is in the forcing pool. Cleaning up white space in the registry: Many of the spaces instead of tabs were introduced by PR #544, which I have attempted to clean up here. --- src/core_ocean/Registry.xml | 459 ++++++++++-------- .../driver/mpas_ocn_core_interface.F | 11 +- .../mpas_ocn_time_integration_rk4.F | 20 +- .../mpas_ocn_time_integration_split.F | 19 +- src/core_ocean/shared/Makefile | 4 +- src/core_ocean/shared/mpas_ocn_diagnostics.F | 62 ++- .../mpas_ocn_effective_density_in_land_ice.F | 181 +++++++ .../shared/mpas_ocn_surface_land_ice_fluxes.F | 90 ++-- .../shared/mpas_ocn_time_average_coupled.F | 45 +- 9 files changed, 600 insertions(+), 291 deletions(-) create mode 100644 src/core_ocean/shared/mpas_ocn_effective_density_in_land_ice.F diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index d65cbdf88d..36c554da56 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -618,72 +618,72 @@ possible_values=".true. or .false." /> - + - + - - - - - - - - - - - - - + + + + + + + + + + + + + - + + @@ -1012,8 +1013,6 @@ - - @@ -1022,6 +1021,7 @@ + + + @@ -1039,19 +1041,19 @@ - + - - - - - - - - - - - + + + + + + + + + + + @@ -1120,38 +1122,38 @@ - + - - + - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + @@ -1176,12 +1178,12 @@ - + + @@ -1232,19 +1235,19 @@ - + - - - - - - - - - - - + + + + + + + + + + + @@ -1327,6 +1330,9 @@ + + + + + + + + + + + + + - - - - - - - - + + + + + + + + + + + + - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + - - - - - - - - + + + + + + + + + diff --git a/src/core_ocean/driver/mpas_ocn_core_interface.F b/src/core_ocean/driver/mpas_ocn_core_interface.F index 0753ffb25f..c4e4de9dcd 100644 --- a/src/core_ocean/driver/mpas_ocn_core_interface.F +++ b/src/core_ocean/driver/mpas_ocn_core_interface.F @@ -112,6 +112,7 @@ function ocn_setup_packages(configPool, packagePool, iocontext) result(ierr)!{{{ logical, pointer :: splitTimeIntegratorActive logical, pointer :: windStressBulkPKGActive logical, pointer :: landIceFluxesPKGActive + logical, pointer :: landIceCouplingPKGActive logical, pointer :: thicknessBulkPKGActive logical, pointer :: frazilIceActive logical, pointer :: inSituEOSActive @@ -211,14 +212,16 @@ function ocn_setup_packages(configPool, packagePool, iocontext) result(ierr)!{{{ ! ! test for land ice fluxes, landIceFluxesPKG - ! test for land ice pressure, landIcePressurePKG + ! test for land ice coupling, landIceCouplingPKG ! call mpas_pool_get_package(packagePool, 'landIceFluxesPKGActive', landIceFluxesPKGActive) - call mpas_pool_get_package(packagePool, 'landIcePressurePKGActive', landIcePressurePKGActive) + call mpas_pool_get_package(packagePool, 'landIceCouplingPKGActive', landIceCouplingPKGActive) call mpas_pool_get_config(configPool, 'config_land_ice_flux_mode', config_land_ice_flux_mode) - if ( (trim(config_land_ice_flux_mode) == 'standalone') & - .or. (trim(config_land_ice_flux_mode) == 'coupled') ) then + if ( trim(config_land_ice_flux_mode) == 'standalone' ) then landIceFluxesPKGActive = .true. + else if ( trim(config_land_ice_flux_mode) == 'coupled' ) then + landIceFluxesPKGActive = .true. + landIceCouplingPKGActive = .true. end if ! diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F index 1f361219af..71876a9865 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F @@ -38,6 +38,8 @@ module ocn_time_integration_rk4 use ocn_time_average_coupled use ocn_sea_ice + use ocn_effective_density_in_land_ice + implicit none private save @@ -124,6 +126,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ logical, pointer :: config_use_cvmix_kpp logical, pointer :: config_use_tracerGroup real (kind=RKIND), pointer :: config_mom_del4 + character (len=StrKIND), pointer :: config_land_ice_flux_mode ! State indices integer, pointer :: indexTemperature @@ -170,7 +173,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ real (kind=RKIND), dimension(:), pointer :: seaIceEnergy ! Diagnostics Field Pointers - type (field1DReal), pointer :: boundaryLayerDepthField + type (field1DReal), pointer :: boundaryLayerDepthField, effectiveDensityField type (field2DReal), pointer :: normalizedRelativeVorticityEdgeField, divergenceField, relativeVorticityField ! State/Tend Field Pointers @@ -191,6 +194,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_config(domain % configs, 'config_use_freq_filtered_thickness', config_use_freq_filtered_thickness) call mpas_pool_get_config(domain % configs, 'config_use_standardGM', config_use_standardGM) call mpas_pool_get_config(domain % configs, 'config_use_cvmix_kpp', config_use_cvmix_kpp) + call mpas_pool_get_config(domain % configs, 'config_land_ice_flux_mode', config_land_ice_flux_mode) ! ! Initialize time_levs(2) with state at current time @@ -831,6 +835,9 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) + ! Update the effective desnity in land ice if we're coupling to land ice + call ocn_effective_density_in_land_ice_update(meshPool, forcingPool, statePool, scratchPool, err) + ! ------------------------------------------------------------------ ! Accumulating various parameterizations of the transport velocity ! ------------------------------------------------------------------ @@ -865,7 +872,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ SSHGradient(indexSSHGradientMeridional, :) = gradSSHMeridional(1, :) call ocn_time_average_accumulate(averagePool, statePool, diagnosticsPool, 2) - call ocn_time_average_coupled_accumulate(diagnosticsPool, forcingPool) + call ocn_time_average_coupled_accumulate(diagnosticsPool, statePool, forcingPool, 2) if (config_use_standardGM) then call ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) @@ -873,6 +880,15 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ block => block % next end do + + if (trim(config_land_ice_flux_mode) == 'coupled') then + call mpas_timer_start("RK4-effective density halo") + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_field(statePool, 'effectiveDensityInLandIce', effectiveDensityField, 2) + call mpas_dmpar_exch_halo_field(effectiveDensityField) + call mpas_timer_stop("RK4-effective density halo") + end if + call mpas_timer_stop("RK4-cleaup phase") block => domain % blocklist diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F index 58230e7392..af5f7c3fe2 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F @@ -40,6 +40,8 @@ module ocn_time_integration_split use ocn_sea_ice + use ocn_effective_density_in_land_ice + implicit none private save @@ -132,6 +134,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ logical, pointer :: config_vel_correction, config_prescribe_velocity, config_prescribe_thickness logical, pointer :: config_use_cvmix_kpp logical, pointer :: config_use_tracerGroup + character (len=StrKIND), pointer :: config_land_ice_flux_mode real (kind=RKIND), pointer :: config_mom_del4, config_btr_gam1_velWt1, config_btr_gam2_SSHWt1 real (kind=RKIND), pointer :: config_btr_gam3_velWt2 @@ -186,7 +189,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! Diagnostics Field Pointers type (field2DReal), pointer :: normalizedRelativeVorticityEdgeField, divergenceField, relativeVorticityField - type (field1DReal), pointer :: barotropicThicknessFluxField, boundaryLayerDepthField + type (field1DReal), pointer :: barotropicThicknessFluxField, boundaryLayerDepthField, effectiveDensityField ! State/Tend Field Pointers type (field1DReal), pointer :: normalBarotropicVelocitySubcycleField, sshSubcycleField @@ -228,6 +231,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_config(domain % configs, 'config_use_standardGM', config_use_standardGM) call mpas_pool_get_config(domain % configs, 'config_use_cvmix_kpp', config_use_cvmix_kpp) + call mpas_pool_get_config(domain % configs, 'config_land_ice_flux_mode', config_land_ice_flux_mode) allocate(n_bcl_iter(config_n_ts_iter)) @@ -1595,6 +1599,9 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) + ! Update the effective desnity in land ice if we're coupling to land ice + call ocn_effective_density_in_land_ice_update(meshPool, forcingPool, statePool, scratchPool, err) + ! Compute normalGMBolusVelocity; it will be added to normalVelocity in Stage 2 of the next cycle. if (config_use_standardGM) then call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) @@ -1617,7 +1624,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ SSHGradient(indexSSHGradientMeridional, :) = gradSSHMeridional(1, :) call ocn_time_average_accumulate(averagePool, statePool, diagnosticsPool, 2) - call ocn_time_average_coupled_accumulate(diagnosticsPool, forcingPool) + call ocn_time_average_coupled_accumulate(diagnosticsPool, statePool, forcingPool, 2) if (config_use_standardGM) then call ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) @@ -1626,6 +1633,14 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ block => block % next end do + if (trim(config_land_ice_flux_mode) == 'coupled') then + call mpas_timer_start("se effective density halo") + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_field(statePool, 'effectiveDensityInLandIce', effectiveDensityField, 2) + call mpas_dmpar_exch_halo_field(effectiveDensityField) + call mpas_timer_stop("se effective density halo") + end if + call mpas_timer_stop("se timestep", timer_main) deallocate(n_bcl_iter) diff --git a/src/core_ocean/shared/Makefile b/src/core_ocean/shared/Makefile index 91f3d78a4c..b770fedcf6 100644 --- a/src/core_ocean/shared/Makefile +++ b/src/core_ocean/shared/Makefile @@ -49,6 +49,7 @@ OBJS = mpas_ocn_init_routines.o \ mpas_ocn_forcing.o \ mpas_ocn_surface_bulk_forcing.o \ mpas_ocn_surface_land_ice_fluxes.o \ + mpas_ocn_effective_density_in_land_ice.o \ mpas_ocn_forcing_restoring.o \ mpas_ocn_time_average.o \ mpas_ocn_time_average_coupled.o \ @@ -150,11 +151,12 @@ mpas_ocn_surface_bulk_forcing.o: mpas_ocn_surface_land_ice_fluxes.o: mpas_ocn_constants.o +mpas_ocn_effective_density_in_land_ice.o: mpas_ocn_constants.o + mpas_ocn_forcing_restoring.o: mpas_ocn_constants.o mpas_ocn_sea_ice.o: mpas_ocn_constants.o - clean: $(RM) *.o *.i *.mod *.f90 diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index 0415424f68..cc14bb2a6d 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -1329,11 +1329,11 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & integer :: iCell, iEdge, cell1, cell2, iLevel, i integer, pointer :: nCells, nEdges - integer, dimension(:,:), pointer :: cellsOnCell, cellsOnEdge + integer, dimension(:,:), pointer :: cellsOnCell, cellsOnEdge, cellMask integer, dimension(:), pointer :: maxLevelCell, nEdgesOnCell - integer, pointer :: indexT, indexS + integer, pointer :: indexT, indexS, indexBLT, indexBLS, indexHeatTrans, indexSaltTrans character (len=StrKIND), pointer :: config_land_ice_flux_formulation, config_land_ice_flux_mode @@ -1345,21 +1345,18 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & config_land_ice_flux_jenkins_salt_transfer_coefficient, & config_land_ice_flux_attenuation_coefficient - real (kind=RKIND) :: blThickness, dz, blWeightSum, h_nu, Gamma_turb, landIceEdgeFraction, velocityMagnitude + real (kind=RKIND) :: blThickness, dz, weightSum, h_nu, Gamma_turb, landIceEdgeFraction, velocityMagnitude real (kind=RKIND), dimension(:), pointer :: landIceFraction, & landIceFrictionVelocity, & - landIceBoundaryLayerTemperature, & - landIceBoundaryLayerSalinity, & - landIceHeatTransferVelocity, & - landIceSaltTransferVelocity, & topDrag, & topDragMagnitude, & fCell, & blTempScratch, blSaltScratch, & surfaceFluxAttenuationCoefficient - real (kind=RKIND), dimension(:,:), pointer :: kineticEnergyCell, layerThickness, normalVelocity + real (kind=RKIND), dimension(:,:), pointer :: kineticEnergyCell, layerThickness, normalVelocity, & + landIceBoundaryLayerTracers, landIceTracerTransferVelocities real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers type (field1DReal), pointer :: boundaryLayerTemperatureField, boundaryLayerSalinityField @@ -1375,8 +1372,7 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_mode', config_land_ice_flux_mode) - if ( (trim(config_land_ice_flux_mode) .ne. 'standalone') & - .and. (trim(config_land_ice_flux_mode) .ne. 'coupled') ) then + if ( trim(config_land_ice_flux_mode) == 'off') then return end if @@ -1408,6 +1404,7 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'cellMask', cellMask) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, timeLevel) @@ -1421,13 +1418,17 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & call mpas_pool_get_array(diagnosticsPool, 'kineticEnergyCell', kineticEnergyCell) call mpas_pool_get_array(diagnosticsPool, 'landIceFrictionVelocity', landIceFrictionVelocity) - call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerTemperature', landIceBoundaryLayerTemperature) - call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerSalinity', landIceBoundaryLayerSalinity) call mpas_pool_get_array(diagnosticsPool, 'topDrag', topDrag) call mpas_pool_get_array(diagnosticsPool, 'topDragMagnitude', topDragMagnitude) + + call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerTracers', landIceBoundaryLayerTracers) + call mpas_pool_get_dimension(diagnosticsPool, 'index_landIceBoundaryLayerTemperature', indexBLT) + call mpas_pool_get_dimension(diagnosticsPool, 'index_landIceBoundaryLayerSalinity', indexBLS) + if(jenkinsOn .or. hollandJenkinsOn) then - call mpas_pool_get_array(diagnosticsPool, 'landIceHeatTransferVelocity', landIceHeatTransferVelocity) - call mpas_pool_get_array(diagnosticsPool, 'landIceSaltTransferVelocity', landIceSaltTransferVelocity) + call mpas_pool_get_array(diagnosticsPool, 'landIceTracerTransferVelocities', landIceTracerTransferVelocities) + call mpas_pool_get_dimension(diagnosticsPool, 'index_landIceHeatTransferVelocity', indexHeatTrans) + call mpas_pool_get_dimension(diagnosticsPool, 'index_landIceSaltTransferVelocity', indexSaltTrans) end if call mpas_pool_get_array(diagnosticsPool, 'surfaceFluxAttenuationCoefficient', surfaceFluxAttenuationCoefficient) @@ -1437,6 +1438,7 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & call mpas_allocate_scratch_field(boundaryLayerSalinityField, .true.) blTempScratch => boundaryLayerTemperatureField % array blSaltScratch => boundaryLayerSalinityField % array + if(hollandJenkinsOn) then call mpas_pool_get_array(meshPool, 'fCell', fCell) end if @@ -1486,32 +1488,28 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & end if end do do iCell = 1, nCells - landIceBoundaryLayerTemperature(iCell) = blTempScratch(iCell) - landIceBoundaryLayerSalinity(iCell) = blSaltScratch(iCell) + landIceBoundaryLayerTracers(indexBLT, iCell) = blTempScratch(iCell) + landIceBoundaryLayerTracers(indexBLS, iCell) = blSaltScratch(iCell) if(config_land_ice_flux_boundaryLayerNeighborWeight > 0.0_RKIND) then - blWeightSum = 1.0_RKIND + weightSum = 1.0_RKIND do i = 1, nEdgesOnCell(iCell) cell2 = cellsOnCell(i,iCell) - if(cell2 <= 0 .or. cell2 > nCells) cycle - landIceBoundaryLayerTemperature(iCell) = landIceBoundaryLayerTemperature(iCell) & - + config_land_ice_flux_boundaryLayerNeighborWeight*blTempScratch(cell2) - landIceBoundaryLayerSalinity(iCell) = landIceBoundaryLayerSalinity(iCell) & - + config_land_ice_flux_boundaryLayerNeighborWeight*blSaltScratch(cell2) - blWeightSum = blWeightSum + config_land_ice_flux_boundaryLayerNeighborWeight + landIceBoundaryLayerTracers(indexBLT, iCell) = landIceBoundaryLayerTracers(indexBLT, iCell) & + + cellMask(1,cell2)*config_land_ice_flux_boundaryLayerNeighborWeight*blTempScratch(cell2) + landIceBoundaryLayerTracers(indexBLS, iCell) = landIceBoundaryLayerTracers(indexBLS, iCell) & + + cellMask(1,cell2)*config_land_ice_flux_boundaryLayerNeighborWeight*blSaltScratch(cell2) + weightSum = weightSum + cellMask(1,cell2)*config_land_ice_flux_boundaryLayerNeighborWeight end do - if(blWeightSum > 0.0_RKIND) then - landIceBoundaryLayerTemperature(iCell) = landIceBoundaryLayerTemperature(iCell)/blWeightSum - landIceBoundaryLayerSalinity(iCell) = landIceBoundaryLayerSalinity(iCell)/blWeightSum - end if + landIceBoundaryLayerTracers(:, iCell) = landIceBoundaryLayerTracers(:, iCell)/weightSum end if end do if(jenkinsOn) then do iCell = 1, nCells ! transfer coefficients from namelist - landIceHeatTransferVelocity(iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_heat_transfer_coefficient - landIceSaltTransferVelocity(iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_salt_transfer_coefficient + landIceTracerTransferVelocities(indexHeatTrans, iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_heat_transfer_coefficient + landIceTracerTransferVelocities(indexSaltTrans, iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_salt_transfer_coefficient end do else if(hollandJenkinsOn) then do iCell = 1, nCells @@ -1525,8 +1523,8 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & *xiN/(abs(fCell(iCell))*h_nu)) end if - landIceHeatTransferVelocity(iCell) = 1.0_RKIND/(Gamma_turb + 12.5_RKIND*Pr**(2.0_RKIND/3.0_RKIND) - 6.0_RKIND) - landIceSaltTransferVelocity(iCell) = 1.0_RKIND/(Gamma_turb + 12.5_RKIND*Sc**(2.0_RKIND/3.0_RKIND) - 6.0_RKIND) + landIceTracerTransferVelocities(indexHeatTrans, iCell) = 1.0_RKIND/(Gamma_turb + 12.5_RKIND*Pr**(2.0_RKIND/3.0_RKIND) - 6.0_RKIND) + landIceTracerTransferVelocities(indexSaltTrans, iCell) = 1.0_RKIND/(Gamma_turb + 12.5_RKIND*Sc**(2.0_RKIND/3.0_RKIND) - 6.0_RKIND) end do end if @@ -1535,7 +1533,7 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & ! recompute the spatially-varying attenuation coefficient based on landIceFraction do iCell = 1, nCells - surfaceFluxAttenuationCoefficient(iCell) = landIceFraction(iCell)*config_land_ice_flux_attenuation_coefficient & + surfaceFluxAttenuationCoefficient(iCell) = landIceFraction(iCell)*config_land_ice_flux_attenuation_coefficient & + (1.0_RKIND - landIceFraction(iCell))*surfaceFluxAttenuationCoefficient(iCell) end do diff --git a/src/core_ocean/shared/mpas_ocn_effective_density_in_land_ice.F b/src/core_ocean/shared/mpas_ocn_effective_density_in_land_ice.F new file mode 100644 index 0000000000..44f582bf43 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_effective_density_in_land_ice.F @@ -0,0 +1,181 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_effective_density_in_land_ice +! +!> \brief MPAS ocean effective density in land ice +!> \author Xylar Asay-Davis +!> \date 10/03/2015 +!> \details +!> This module contains routines for computing the effective seawater +!> density in land ice using Arhimedes' principle. +! +!----------------------------------------------------------------------- + +module ocn_effective_density_in_land_ice + + use mpas_constants + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_effective_density_in_land_ice_update + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_effective_density_in_land_ice_update +! +!> \brief updates effective density in land ice +!> \author Xylar Asay-Davis +!> \date 10/03/2015 +!> \details +!> This routine updates the value of the effective seawater density +!> displaced by land ice, based on Archimedes' principle. The effective +!> density is smoothed and extrapolated by averaging with nearest neighbors +!> (cellsOnCell). +! +!----------------------------------------------------------------------- + + subroutine ocn_effective_density_in_land_ice_update(meshPool, forcingPool, statePool, scratchPool, ierr)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: statePool !< Input/Output: state information + type (mpas_pool_type), intent(inout) :: scratchPool !< Input/Output: scratch information + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: ierr !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + character (len=StrKIND), pointer :: config_land_ice_flux_mode + + real (kind=RKIND), dimension(:), pointer :: landIceFraction, & + seaSurfacePressure, ssh, & + effectiveDensityCur, & + effectiveDensityNew, & + effectiveDensityScratch + + type (field1DReal), pointer :: effectiveDensityField + + real (kind=RKIND) :: weightSum + + integer :: iCell, cell2, i + integer, pointer :: nCells, nEdges + + integer, dimension(:,:), pointer :: cellsOnCell, cellMask + + integer, dimension(:), pointer :: nEdgesOnCell + + ierr = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_mode', config_land_ice_flux_mode) + if ( (trim(config_land_ice_flux_mode) .ne. 'coupled') ) then + return + end if + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'cellMask', cellMask) + + call mpas_pool_get_array(forcingPool, 'landIceFraction', landIceFraction) + call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) + call mpas_pool_get_array(statePool, 'ssh', ssh, 2) + call mpas_pool_get_array(statePool, 'effectiveDensityInLandIce', effectiveDensityCur, 1) + call mpas_pool_get_array(statePool, 'effectiveDensityInLandIce', effectiveDensityNew, 2) + + call mpas_pool_get_field(scratchPool, 'effectiveDensityScratch', effectiveDensityField) + call mpas_allocate_scratch_field(effectiveDensityField, .true.) + effectiveDensityScratch => effectiveDensityField % array + + do iCell = 1, nCells + ! TODO: should only apply to floating land ice, once wetting/drying is supported + if(landIceFraction(iCell) >= 0.5) then + ! there is sufficient land ice to update the effective density + effectiveDensityScratch(iCell) = -seaSurfacePressure(iCell)/(ssh(iCell)*gravity) + else + ! we copy the previous effective density + effectiveDensityScratch(iCell) = effectiveDensityCur(iCell) + end if + end do + do iCell = 1, nCells + ! smooth/extrapolate by averaging with nearest neighbors + weightSum = 1.0_RKIND + effectiveDensityNew(iCell) = effectiveDensityScratch(iCell) + do i = 1, nEdgesOnCell(iCell) + cell2 = cellsOnCell(i,iCell) + effectiveDensityNew(iCell) = effectiveDensityNew(iCell) & + + cellMask(1,cell2)*effectiveDensityScratch(cell2) + weightSum = weightSum + cellMask(1,cell2) + end do + effectiveDensityNew(iCell) = effectiveDensityNew(iCell)/weightSum + end do + call mpas_deallocate_scratch_field(effectiveDensityField, .true.) + + !-------------------------------------------------------------------- + + end subroutine ocn_effective_density_in_land_ice_update !}}} + +!*********************************************************************** + +end module ocn_effective_density_in_land_ice + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F index 2baf766f4c..d6c7a019ec 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F +++ b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F @@ -382,19 +382,18 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & real (kind=RKIND), dimension(:), pointer :: seaSurfacePressure, landIceFraction, & landIceSurfaceTemperature, & - landIceInterfaceTemperature, & - landIceInterfaceSalinity, landIceFrictionVelocity, & - landIceBoundaryLayerTemperature, & - landIceBoundaryLayerSalinity, & + landIceFrictionVelocity, & landIceFreshwaterFlux, & landIceHeatFlux, heatFluxToLandIce, & - landIceHeatTransferVelocity, & - landIceSaltTransferVelocity, & freezeInterfaceSalinity, freezeInterfaceTemperature, & freezeFreshwaterFlux, freezeHeatFlux, & freezeIceHeatFlux - real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers + real (kind=RKIND), dimension(:,:), pointer :: landIceBoundaryLayerTracers, & + landIceInterfaceTracers, & + landIceTracerTransferVelocities + integer, pointer :: indexBLT, indexBLS, indexIT, indexIS, indexHeatTrans, indexSaltTrans + type (field1DReal), pointer :: boundaryLayerTemperatureField, boundaryLayerSalinityField, & freezeInterfaceSalinityField, freezeInterfaceTemperatureField, & freezeFreshwaterFluxField, freezeHeatFluxField, & @@ -409,20 +408,28 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerTemperature', landIceBoundaryLayerTemperature) - call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerSalinity', landIceBoundaryLayerSalinity) - call mpas_pool_get_array(diagnosticsPool, 'landIceHeatTransferVelocity', landIceHeatTransferVelocity) - call mpas_pool_get_array(diagnosticsPool, 'landIceSaltTransferVelocity', landIceSaltTransferVelocity) call mpas_pool_get_array(diagnosticsPool, 'landIceFrictionVelocity', landIceFrictionVelocity) call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) + call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerTracers', landIceBoundaryLayerTracers) + call mpas_pool_get_dimension(diagnosticsPool, 'index_landIceBoundaryLayerTemperature', indexBLT) + call mpas_pool_get_dimension(diagnosticsPool, 'index_landIceBoundaryLayerSalinity', indexBLS) + + if(jenkinsOn .or. hollandJenkinsOn) then + call mpas_pool_get_array(diagnosticsPool, 'landIceTracerTransferVelocities', landIceTracerTransferVelocities) + call mpas_pool_get_dimension(diagnosticsPool, 'index_landIceHeatTransferVelocity', indexHeatTrans) + call mpas_pool_get_dimension(diagnosticsPool, 'index_landIceSaltTransferVelocity', indexSaltTrans) + end if + call mpas_pool_get_array(forcingPool, 'landIceFraction', landIceFraction) call mpas_pool_get_array(forcingPool, 'landIceFreshwaterFlux', landIceFreshwaterFlux) call mpas_pool_get_array(forcingPool, 'landIceHeatFlux', landIceHeatFlux) call mpas_pool_get_array(forcingPool, 'heatFluxToLandIce', heatFluxToLandIce) - call mpas_pool_get_array(forcingPool, 'landIceInterfaceTemperature', landIceInterfaceTemperature) - call mpas_pool_get_array(forcingPool, 'landIceInterfaceSalinity', landIceInterfaceSalinity) + + call mpas_pool_get_array(forcingPool, 'landIceInterfaceTracers', landIceInterfaceTracers) + call mpas_pool_get_dimension(forcingPool, 'index_landIceInterfaceTemperature', indexIT) + call mpas_pool_get_dimension(forcingPool, 'index_landIceInterfaceSalinity', indexIS) if(config_land_ice_flux_useHollandJenkinsAdvDiff) then call mpas_pool_get_array(forcingPool, 'landIceSurfaceTemperature', landIceSurfaceTemperature) @@ -447,8 +454,8 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & if(isomipOn) then do iCell = 1, nCellsSolve ! linearized equaiton for the S and p dependent potential freezing temperature - landIceInterfaceTemperature(iCell) = Tf0 & - + dTf_dS*landIceBoundaryLayerSalinity(iCell) & + landIceInterfaceTracers(indexIT,iCell) = Tf0 & + + dTf_dS*landIceBoundaryLayerTracers(indexBLT,iCell) & + dTf_dp*seaSurfacePressure(iCell) ! using (3) and (4) from Hunter (2006) @@ -456,15 +463,15 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & ! and no heat flux into ice ! freshwater flux = density * melt rate is in kg/m^2/s freshwaterFlux = -rho_sw * config_land_ice_flux_ISOMIP_gammaT * (cp_sw/latent_heat_fusion_mks) & - * (landIceInterfaceTemperature(iCell)-landIceBoundaryLayerTemperature(iCell)) + * (landIceInterfaceTracers(indexIT,iCell)-landIceBoundaryLayerTracers(indexBLT,iCell)) landIceFreshwaterFlux(iCell) = landIceFraction(iCell)*freshwaterFlux ! Using (13) from Jenkins et al. (2001) ! heat flux is in W/s - heatFlux = cp_sw*(freshwaterFlux*landIceInterfaceTemperature(iCell) & + heatFlux = cp_sw*(freshwaterFlux*landIceInterfaceTracers(indexIT,iCell) & + rho_sw*config_land_ice_flux_ISOMIP_gammaT & - * (landIceInterfaceTemperature(iCell)-landIceBoundaryLayerTemperature(iCell))) + * (landIceInterfaceTracers(indexIT,iCell)-landIceBoundaryLayerTracers(indexBLT,iCell))) landIceHeatFlux(iCell) = landIceFraction(iCell)*heatFlux heatFluxToLandIce(iCell) = 0.0_RKIND @@ -476,14 +483,14 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & if(config_land_ice_flux_useHollandJenkinsAdvDiff) then ! melting solution call compute_HJ99_melt_fluxes( & - landIceBoundaryLayerTemperature, & - landIceBoundaryLayerSalinity, & - landIceHeatTransferVelocity, & - landIceSaltTransferVelocity, & + landIceBoundaryLayerTracers(indexBLT,:), & + landIceBoundaryLayerTracers(indexBLS,:), & + landIceTracerTransferVelocities(indexHeatTrans,:), & + landIceTracerTransferVelocities(indexSaltTrans,:), & landIceSurfaceTemperature, & seaSurfacePressure, & - landIceInterfaceSalinity, & - landIceInterfaceTemperature, & + landIceInterfaceTracers(indexIT,:), & + landIceInterfaceTracers(indexIS,:), & landIceFreshwaterFlux, & landIceHeatFlux, & heatFluxToLandIce, & @@ -495,13 +502,13 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & ! freezing solution call compute_melt_fluxes( & - landIceBoundaryLayerTemperature, & - landIceBoundaryLayerSalinity, & - landIceHeatTransferVelocity, & - landIceSaltTransferVelocity, & + landIceBoundaryLayerTracers(indexBLT,:), & + landIceBoundaryLayerTracers(indexBLS,:), & + landIceTracerTransferVelocities(indexHeatTrans,:), & + landIceTracerTransferVelocities(indexSaltTrans,:), & seaSurfacePressure, & - freezeInterfaceSalinity, & freezeInterfaceTemperature, & + freezeInterfaceSalinity, & freezeFreshwaterFlux, & freezeHeatFlux, & freezeIceHeatFlux, & @@ -512,21 +519,21 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & end if where(landIceFreshwaterFlux < 0.0_RKIND) - landIceInterfaceSalinity = freezeInterfaceSalinity - landIceInterfaceTemperature = freezeInterfaceTemperature + landIceInterfaceTracers(indexIS,:) = freezeInterfaceSalinity + landIceInterfaceTracers(indexIT,:) = freezeInterfaceTemperature landIceFreshwaterFlux = freezeFreshwaterFlux landIceHeatFlux = freezeHeatFlux heatFluxToLandIce = freezeIceHeatFlux end where else ! not using Holland and Jenkins advection/diffusion call compute_melt_fluxes( & - landIceBoundaryLayerTemperature, & - landIceBoundaryLayerSalinity, & - landIceHeatTransferVelocity, & - landIceSaltTransferVelocity, & + landIceBoundaryLayerTracers(indexBLT,:), & + landIceBoundaryLayerTracers(indexBLS,:), & + landIceTracerTransferVelocities(indexHeatTrans,:), & + landIceTracerTransferVelocities(indexSaltTrans,:), & seaSurfacePressure, & - landIceInterfaceSalinity, & - landIceInterfaceTemperature, & + landIceInterfaceTracers(indexIT,:), & + landIceInterfaceTracers(indexIS,:), & landIceFreshwaterFlux, & landIceHeatFlux, & heatFluxToLandIce, & @@ -655,8 +662,8 @@ subroutine compute_melt_fluxes( & oceanHeatTransferVelocity, & oceanSaltTransferVelocity, & interfacePressure, & - outInterfaceSalinity, & outInterfaceTemperature, & + outInterfaceSalinity, & outFreshwaterFlux, & outOceanHeatFlux, & outIceHeatFlux, & @@ -695,8 +702,8 @@ subroutine compute_melt_fluxes( & !----------------------------------------------------------------- real (kind=RKIND), dimension(:), intent(out) :: & - outInterfaceSalinity, & !< Output: ocean salinity at the interface outInterfaceTemperature, & !< Output: ice/ocean temperature at the interface + outInterfaceSalinity, & !< Output: ocean salinity at the interface outFreshwaterFlux, & !< Output: ocean thickness flux (melt rate) outOceanHeatFlux, & !< Output: the temperature flux into the ocean outIceHeatFlux !< Output: the temperature flux into the ice @@ -739,6 +746,7 @@ subroutine compute_melt_fluxes( & ! The positive root is the one we want (salinity is strictly positive) outInterfaceSalinity(iCell) = (-b + sqrt(b**2 - 4.0_RKIND*a*c*oceanSalinity(iCell)))/(2.0_RKIND*a) if (outInterfaceSalinity(iCell) .le. 0.0_RKIND) then + write(stderrUnit, *) "ERROR: interfaceSalinity <= 0", outInterfaceSalinity(iCell), oceanSalinity(iCell), a, b, c err = 1 return end if @@ -805,8 +813,8 @@ subroutine compute_HJ99_melt_fluxes( & oceanSaltTransferVelocity, & iceTemperature, & interfacePressure, & - outInterfaceSalinity, & outInterfaceTemperature, & + outInterfaceSalinity, & outFreshwaterFlux, & outOceanHeatFlux, & outIceHeatFlux, & @@ -842,8 +850,8 @@ subroutine compute_HJ99_melt_fluxes( & !----------------------------------------------------------------- real (kind=RKIND), dimension(:), intent(out) :: & - outInterfaceSalinity, & !< Output: ocean salinity at the interface outInterfaceTemperature, & !< Output: ice/ocean temperature at the interface + outInterfaceSalinity, & !< Output: ocean salinity at the interface outFreshwaterFlux, & !< Output: ocean thickness flux (melt rate) outOceanHeatFlux, & !< Output: the temperature flux into the ocean outIceHeatFlux !< Output: the temperature flux into the ice diff --git a/src/core_ocean/shared/mpas_ocn_time_average_coupled.F b/src/core_ocean/shared/mpas_ocn_time_average_coupled.F index 6df6612234..2ec389bab4 100644 --- a/src/core_ocean/shared/mpas_ocn_time_average_coupled.F +++ b/src/core_ocean/shared/mpas_ocn_time_average_coupled.F @@ -45,7 +45,11 @@ module ocn_time_average_coupled subroutine ocn_time_average_coupled_init(forcingPool)!{{{ type (mpas_pool_type), intent(inout) :: forcingPool - real (kind=RKIND), dimension(:,:), pointer :: avgTracersSurfaceValue, avgSurfaceVelocity, avgSSHGradient + real (kind=RKIND), dimension(:,:), pointer :: avgTracersSurfaceValue, avgSurfaceVelocity, avgSSHGradient, & + avgLandIceBoundaryLayerTracers, avgLandIceTracerTransferVelocities + + real (kind=RKIND), dimension(:), pointer :: avgEffectiveDensityInLandIce + character (len=StrKIND), pointer :: config_land_ice_flux_mode integer, pointer :: nAccumulatedCoupled @@ -58,6 +62,17 @@ subroutine ocn_time_average_coupled_init(forcingPool)!{{{ avgSurfaceVelocity(:,:) = 0.0_RKIND avgSSHGradient(:,:) = 0.0_RKIND + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_mode', config_land_ice_flux_mode) + if(trim(config_land_ice_flux_mode) == 'coupled') then + call mpas_pool_get_array(forcingPool, 'avgLandIceBoundaryLayerTracers', avgLandIceBoundaryLayerTracers) + call mpas_pool_get_array(forcingPool, 'avgLandIceTracerTransferVelocities', avgLandIceTracerTransferVelocities) + call mpas_pool_get_array(forcingPool, 'avgEffectiveDensityInLandIce', avgEffectiveDensityInLandIce) + + avgLandIceBoundaryLayerTracers(:,:) = 0.0_RKIND + avgLandIceTracerTransferVelocities(:,:) = 0.0_RKIND + avgEffectiveDensityInLandIce(:) = 0.0_RKIND + end if + nAccumulatedCoupled = 0 end subroutine ocn_time_average_coupled_init!}}} @@ -73,15 +88,21 @@ end subroutine ocn_time_average_coupled_init!}}} !> This routine accumulated the coupled time averaging fields ! !----------------------------------------------------------------------- - subroutine ocn_time_average_coupled_accumulate(diagnosticsPool, forcingPool)!{{{ + subroutine ocn_time_average_coupled_accumulate(diagnosticsPool, statePool, forcingPool, timeLevel)!{{{ type (mpas_pool_type), intent(in) :: diagnosticsPool + type (mpas_pool_type), intent(in) :: statePool type (mpas_pool_type), intent(inout) :: forcingPool + integer, intent(in) :: timeLevel real (kind=RKIND), dimension(:,:), pointer :: surfaceVelocity, avgSurfaceVelocity real (kind=RKIND), dimension(:,:), pointer :: tracersSurfaceValue, avgTracersSurfaceValue real (kind=RKIND), dimension(:,:), pointer :: avgSSHGradient real (kind=RKIND), dimension(:,:), pointer :: gradSSHZonal, gradSSHMeridional integer, pointer :: index_temperature, index_SSHzonal, index_SSHmeridional, nAccumulatedCoupled + real (kind=RKIND), dimension(:,:), pointer :: landIceBoundaryLayerTracers, landIceTracerTransferVelocities, & + avgLandIceBoundaryLayerTracers, avgLandIceTracerTransferVelocities + real (kind=RKIND), dimension(:), pointer :: effectiveDensityInLandIce, avgEffectiveDensityInLandIce + character (len=StrKIND), pointer :: config_land_ice_flux_mode call mpas_pool_get_array(diagnosticsPool, 'tracersSurfaceValue', tracersSurfaceValue) call mpas_pool_get_array(diagnosticsPool, 'surfaceVelocity', surfaceVelocity) @@ -98,6 +119,8 @@ subroutine ocn_time_average_coupled_accumulate(diagnosticsPool, forcingPool)!{{{ call mpas_pool_get_array(forcingPool, 'nAccumulatedCoupled', nAccumulatedCoupled) + + avgTracersSurfaceValue(:,:) = avgTracersSurfaceValue(:,:) * nAccumulatedCoupled + tracersSurfaceValue(:,:) avgTracersSurfaceValue(index_temperature,:) = avgTracersSurfaceValue(index_temperature,:) + T0_Kelvin avgTracersSurfaceValue(:,:) = avgTracersSurfaceValue(:,:) / ( nAccumulatedCoupled + 1 ) @@ -107,6 +130,24 @@ subroutine ocn_time_average_coupled_accumulate(diagnosticsPool, forcingPool)!{{{ avgSSHGradient(index_SSHzonal,:) = ( avgSSHGradient(index_SSHzonal,:) * nAccumulatedCoupled + gradSSHZonal(1,:) ) / ( nAccumulatedCoupled + 1 ) avgSSHGradient(index_SSHmeridional,:) = ( avgSSHGradient(index_SSHmeridional,:) * nAccumulatedCoupled + gradSSHMeridional(1,:) ) / ( nAccumulatedCoupled + 1 ) + call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_mode', config_land_ice_flux_mode) + if(trim(config_land_ice_flux_mode) == 'coupled') then + call mpas_pool_get_array(diagnosticsPool, 'landIceBoundaryLayerTracers', landIceBoundaryLayerTracers) + call mpas_pool_get_array(diagnosticsPool, 'landIceTracerTransferVelocities', landIceTracerTransferVelocities) + call mpas_pool_get_array(statePool, 'effectiveDensityInLandIce', effectiveDensityInLandIce, timeLevel) + + call mpas_pool_get_array(forcingPool, 'avgLandIceBoundaryLayerTracers', avgLandIceBoundaryLayerTracers) + call mpas_pool_get_array(forcingPool, 'avgLandIceTracerTransferVelocities', avgLandIceTracerTransferVelocities) + call mpas_pool_get_array(forcingPool, 'avgEffectiveDensityInLandIce', avgEffectiveDensityInLandIce) + + avgLandIceBoundaryLayerTracers(:,:) = ( avgLandIceBoundaryLayerTracers(:,:) * nAccumulatedCoupled & + + landIceBoundaryLayerTracers(:,:) ) / ( nAccumulatedCoupled + 1 ) + avgLandIceTracerTransferVelocities(:,:) = ( avgLandIceTracerTransferVelocities(:,:) * nAccumulatedCoupled & + + landIceTracerTransferVelocities(:,:) ) / ( nAccumulatedCoupled + 1) + avgEffectiveDensityInLandIce(:) = ( avgEffectiveDensityInLandIce(:) * nAccumulatedCoupled & + + effectiveDensityInLandIce(:) ) / ( nAccumulatedCoupled + 1) + end if + nAccumulatedCoupled = nAccumulatedCoupled + 1 end subroutine ocn_time_average_coupled_accumulate!}}} From 1ae0b86d6a9b6775146b674b3b85de6f185f1037 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Tue, 6 Oct 2015 04:47:01 -0700 Subject: [PATCH 0307/1724] Fix first stream read on restart run A previous PR (#574) added reading of all streams on initializing a forward run. This commit moves this read after the timers for restart and init reading have already been reset, preventing data from the init stream from reading over the restart data. fixing a small bug, cleaning up some extra calls and moving the computation of average surface buoyancy and shear into mpas_ocn_vmix_cvmix.F removed turbscales, for diagnosis only fixed two errors in the velocity averaging routine in the cvmix interface added two missing deallocate statements added a few comments added _RKIND to a constant --- src/core_ocean/Registry.xml | 5 +- .../mode_forward/mpas_ocn_forward_mode.F | 11 ++- src/core_ocean/shared/mpas_ocn_diagnostics.F | 32 +------ src/core_ocean/shared/mpas_ocn_vmix_cvmix.F | 85 ++++++++++++------- 4 files changed, 68 insertions(+), 65 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 34af0ecac6..f672627daa 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1143,7 +1143,8 @@ - + + @@ -2047,7 +2048,7 @@ + /> RiSmoothed ! fill BVF - BVFSmoothed(1:nVertLevels) = BruntVaisalaFreqTop(1:nVertLevels,iCell) - BVFSmoothed(nVertLevels+1) = BVFSmoothed(nVertLevels) + BVFSmoothed(1:nVertLevels) = max(0.0_RKIND,BruntVaisalaFreqTop(1:nVertLevels,iCell)) + BVFSmoothed(nVertLevels+1) = max(0.0_RKIND,BVFSmoothed(nVertLevels)) cvmix_variables%SqrBuoyancyFreq_iface => BVFSmoothed ! fill the intent(in) KPP @@ -342,6 +350,10 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, if (config_use_cvmix_fixed_boundary_layer) then cvmix_variables % BoundaryLayerDepth = config_cvmix_kpp_boundary_layer_depth + cvmix_variables % kOBL_depth = cvmix_kpp_compute_kOBL_depth( & + zw_iface = cvmix_variables%zw_iface(1:nVertLevels+1), & + zt_cntr = cvmix_variables%zt_cntr(1:nVertLevels), & + OBL_depth = cvmix_variables % BoundaryLayerDepth ) else @@ -355,14 +367,12 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, ! compute bulk Richardson number ! assume boundary layer depth is at bottom of every kIndexOBL cell bulkRichardsonNumberStop = config_cvmix_kpp_stop_OBL_search * config_cvmix_kpp_criticalBulkRichardsonNumber - bulkRichardsonNumber(:,iCell) = bulkRichardsonNumberStop - 1.0 - kIndexOBL=1 + bulkRichardsonNumber(:,iCell) = bulkRichardsonNumberStop - 1.0_RKIND bulkRichardsonFlag = .false. do kIndexOBL = 1, maxLevelCell(iCell) - ! set OBL at bottome of kIndexOBL cell for computation of bulk Richardson number - cvmix_variables % BoundaryLayerDepth = cvmix_variables % zw_iface(kIndexOBL+1) - + ! set OBL at bottom of kIndexOBL cell for computation of bulk Richardson number + cvmix_variables % BoundaryLayerDepth = abs(cvmix_variables % zw_iface(kIndexOBL+1)) sigma = -cvmix_variables % zt_cntr(kIndexOBL) / cvmix_variables % BoundaryLayerDepth ! compute the turbulent scales in order to compute the bulk Richardson number @@ -373,8 +383,33 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, surf_fric_vel = cvmix_variables % SurfaceFriction, & w_s = turbulentScalarVelocityScale(kIndexOBL)) - enddo ! do kIndexOBL + ! averaging over a surface layer assuming that BLdepth is cell bottom + + ! move progressively downward to find the bottom most layer within the surface layer + sfc_layer_depth = cvmix_variables % BoundaryLayerDepth * config_cvmix_kpp_surface_layer_extent + do kav=1,kIndexOBL + if(cvmix_variables%zw_iface(kav+1) < -sfc_layer_depth) exit + enddo + + !compute shear contribution assuming BLdepth is cell bottom + + invAreaCell = 1.0 / areaCell(iCell) + deltaVelocitySquared = 0.0_RKIND + do iEdge=1,nEdgesOnCell(iCell) + normalVelocityAv = sum(normalVelocity(1:kav,iEdge))/float(kav) + + iEdgeVal = edgesOnCell(iEdge,iCell) + factor = 0.5 * dcEdge(iEdgeVal) * dvEdge(iEdgeVal) * invAreaCell + delU2 = (normalVelocityAv - normalVelocity(kIndexOBL,iEdgeVal))**2 + deltaVelocitySquared = deltaVelocitySquared + factor * delU2 + enddo + bulkRichardsonNumberShear(kIndexOBL,iCell) = max(deltaVelocitySquared, 1.0e-15_RKIND) + + bulkRichardsonNumberBuoy(kIndexOBL,iCell) = gravity * (density(kIndexOBL,iCell) - & + sum(density(1:kav,iCell))/float(kav)) / rho_sw + + enddo ! do kIndexOBL cvmix_variables % bulkRichardson_cntr(:) = cvmix_kpp_compute_bulk_Richardson( & zt_cntr = cvmix_variables % zt_cntr(1:nVertLevels), & delta_buoy_cntr = bulkRichardsonNumberBuoy(1:nVertLevels,iCell), & @@ -384,18 +419,13 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, ! each level of bulk Richardson is computed as if OBL resided at bottom of that level - unresolvedShear(:,iCell) = cvmix_kpp_compute_unresolved_shear( & - zt_cntr = cvmix_variables % zt_cntr(1:nVertLevels), & - ws_cntr = turbulentScalarVelocityScale(1:nVertLevels), & - Nsqr_iface = Nsqr_iface(1:nVertLevels+1)) - call cvmix_kpp_compute_OBL_depth( & Ri_bulk = bulkRichardsonNumber(1:nVertLevels,iCell), & zw_iface = cvmix_variables % zw_iface(1:nVertLevels+1), & OBL_depth = cvmix_variables % BoundaryLayerDepth, & kOBL_depth = cvmix_variables % kOBL_depth, & zt_cntr = cvmix_variables % zt_cntr(1:nVertLevels), & - surf_fric = cvmix_variables % SurfaceFriction, & + surf_fric = cvmix_variables % SurfaceFriction, & surf_buoy = cvmix_variables % SurfaceBuoyancyForcing, & Coriolis = cvmix_variables % Coriolis) @@ -411,11 +441,6 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, cvmix_variables % BoundaryLayerDepth = abs(cvmix_variables%zt_cntr(maxLevelCell(iCell))) endif - cvmix_variables % kOBL_depth = cvmix_kpp_compute_kOBL_depth( & - zw_iface = cvmix_variables%zw_iface(1:nVertLevels+1), & - zt_cntr = cvmix_variables%zt_cntr(1:nVertLevels), & - OBL_depth = cvmix_variables % BoundaryLayerDepth ) - call cvmix_coeffs_kpp( & Mdiff_out = cvmix_variables % Mdiff_iface(1:nVertLevels+1), & Tdiff_out = cvmix_variables % Tdiff_iface(1:nVertLevels+1), & @@ -525,11 +550,13 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, ! dellocate cmvix variables deallocate(cvmix_variables % Mdiff_iface) deallocate(cvmix_variables % Tdiff_iface) + deallocate(cvmix_variables % Sdiff_iface) deallocate(cvmix_variables % zw_iface) deallocate(cvmix_variables % dzw) deallocate(cvmix_variables % zt_cntr) deallocate(cvmix_variables % dzt) deallocate(cvmix_variables % kpp_Tnonlocal_iface) + deallocate(cvmix_variables % kpp_Snonlocal_iface) deallocate(Nsqr_iface) deallocate(turbulentScalarVelocityScale) From 2184ffeb03ceef62308bcee723c66683ce56ff1d Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Fri, 25 Sep 2015 15:24:50 -0600 Subject: [PATCH 0308/1724] Add pbc alteration directly to ocn_init_setup_global_ocean_interpolate_topo This was tested and produces the correct bottomDepth array. --- src/core_ocean/Registry.xml | 3 +- .../mode_init/mpas_ocn_init_global_ocean.F | 110 +++++++++++++++++- 2 files changed, 108 insertions(+), 5 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 761072ff35..8235cd3fe1 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -240,7 +240,7 @@ possible_values="any positive real" /> - + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F index 7d441b0aa4..fb4bf8f5d2 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F @@ -265,14 +265,15 @@ subroutine ocn_init_setup_global_ocean_interpolate_topo(domain, iErr)!{{{ type (block_type), pointer :: block_ptr - type (mpas_pool_type), pointer :: meshPool, scratchPool, statePool, verticalMeshPool + type (mpas_pool_type), pointer :: meshPool, scratchPool, statePool, verticalMeshPool, diagnosticsPool real (kind=RKIND) :: currentLat, currentLon real (kind=RKIND) :: dist, minDist real (kind=RKIND) :: alpha, beta, depthLat1, depthLat2, proposedDepth - real (kind=RKIND), dimension(:), pointer :: latCell, lonCell, bottomDepth, bottomDepthObserved, refBottomDepth - real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell, bottomDepth, bottomDepthObserved, & + refBottomDepth, refLayerThickness, refZMid + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness, zMid integer, pointer :: nCells, nCellsSolve, nVertLevels @@ -286,6 +287,15 @@ subroutine ocn_init_setup_global_ocean_interpolate_topo(domain, iErr)!{{{ logical, pointer :: config_global_ocean_smooth_topography real (kind=RKIND), pointer :: config_global_ocean_minimum_depth +! mrp note: move to subroutine and different name list later. change pbc to vertical_cell + logical, pointer :: config_alter_ICs_for_pbcs + real (kind=RKIND), dimension(:), allocatable :: minBottomDepth, minBottomDepthMid + real (kind=RKIND), pointer :: config_min_pbc_fraction + character (len=StrKIND), pointer :: config_pbc_alteration_type + call mpas_pool_get_config(domain % configs, 'config_alter_ICs_for_pbcs', config_alter_ICs_for_pbcs) + call mpas_pool_get_config(domain % configs, 'config_pbc_alteration_type', config_pbc_alteration_type) + call mpas_pool_get_config(domain % configs, 'config_min_pbc_fraction', config_min_pbc_fraction) +! mrp note end: move to subroutine and different name list later. change pbc to vertical_cell iErr = 0 @@ -410,6 +420,7 @@ subroutine ocn_init_setup_global_ocean_interpolate_topo(domain, iErr)!{{{ block_ptr => domain % blocklist do while(associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) @@ -420,12 +431,100 @@ subroutine ocn_init_setup_global_ocean_interpolate_topo(domain, iErr)!{{{ call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + call mpas_pool_get_array(verticalMeshPool, 'refLayerThickness', refLayerThickness) + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + +! move this to subroutine later + ! TopOfCell needed where zero depth for the very top may be referenced. + refLayerThickness(1) = refBottomDepth(1) + refZMid(1) = refBottomDepth(1)/2.0 + do k = 2, nVertLevels + refLayerThickness(k) = refBottomDepth(k) - refBottomDepth(k-1) + refZMid(k) = - refBottomDepth(k-1) - refLayerThickness(k)/2.0 + end do + +! initialize minBottomDepth, MinBottomDepthMid +print *, 'config_alter_ICs_for_pbcs',config_alter_ICs_for_pbcs,config_pbc_alteration_type, config_min_pbc_fraction + allocate(minBottomDepth(nVertLevels),minBottomDepthMid(nVertLevels)) + + ! min_pbc_fraction restricts pbcs from being too small. + ! A typical value is 10%, so pbcs must occupy at least 10% of the cell thickness. + ! If min_pbc_fraction = 0.0, bottomDepth gives the actual depth for that cell. + ! If min_pbc_fraction = 1.0, bottomDepth reverts to discrete z-level depths, same + ! as partial_bottom_cells = .false. + + minBottomDepth(1) = (1.0-config_min_pbc_fraction)*refBottomDepth(1) + minBottomDepthMid(1) = 0.5*minBottomDepth(1) + do k = 2, nVertLevels + minBottomDepth(k) = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*(refBottomDepth(k) - refBottomDepth(k-1)) + minBottomDepthMid(k) = 0.5*(minBottomDepth(k) + refBottomDepth(k-1)) + end do +! end: initialize minBottomDepth, MinBottomDepthMid do iCell = 1, nCellsSolve if (maxLevelCell(iCell) > 0) then +! substitute with a subroutine call later: +! call ocn_initialize_z_level_vertical_coord( & +! bottomDepthObserved(iCell), refBottomDepth, ssh, & ! inputs +! alteredBottomDepth(iCell), maxLevelCell(iCell), layerThickness(:,iCell), zMid(:,iCell) ) ! outputs + + if (config_alter_ICs_for_pbcs) then + +!!!!!!!!!!!!! this would be in a subroutine +! subroutine ocn_initialize_z_level_vertical_coord +! if (not.config_alter_ICs_for_pbcs) return ! but change flag name + + if (config_pbc_alteration_type .eq. 'partial_cell') then + ! Change value of maxLevelCell for partial bottom cells + k = maxLevelCell(iCell) + if (bottomDepth(iCell) .lt. minBottomDepthMid(k)) then + ! Round up to cell above + maxLevelCell(iCell) = maxLevelCell(iCell) - 1 + bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) + else if (bottomDepth(iCell) .lt. minBottomDepth(k)) then + ! Round down cell to the min_pbc_fraction. + bottomDepth(iCell) = minBottomDepth(k) + end if + ! reset k to new value of maxLevelCell + k = maxLevelCell(iCell) + + elseif (config_pbc_alteration_type .eq. 'full_cell') then + + bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) + + else + + write (stderrUnit,*) ' Incorrect choice of config_pbc_alteration_type.' + call mpas_dmpar_abort(domain % dminfo) + + endif + + ! Initialize layerThickness + if (maxLevelCell(iCell)==1) then + layerThickness(1,iCell) = bottomDepth(iCell) + else + layerThickness(1, iCell) = refBottomDepth(1) + do k = 2, maxLevelCell(iCell)-1 + layerThickness(k, iCell) = refBottomDepth(k) - refBottomDepth(k-1) + end do + ! Alter thickness of bottom level to account for PBC + k = maxLevelCell(iCell) + layerThickness(k,iCell) = bottomDepth(iCell) - refBottomDepth(k-1) + layerThickness(k+1:nVertLevels,iCell) = 0.0_RKIND + endif + + ! Initialize zMid + zMid(1,iCell) = layerThickness(1,iCell)/2.0 + do k = 2, maxLevelCell(iCell) + zMid(k,iCell) = - refBottomDepth(k-1) - layerThickness(k,iCell)/2.0 + end do + +!!!!!!!!!!!!! this would be in a subroutine: end + else !if (config_alter_ICs_for_pbcs) then ! By going to maxLevelCell, this loop sets the layer Thickness as the full cell at the bottom. layerThickness(1, iCell) = refBottomDepth(1) do k = 2, maxLevelCell(iCell) @@ -436,6 +535,8 @@ subroutine ocn_init_setup_global_ocean_interpolate_topo(domain, iErr)!{{{ ! In version 3.0, one may alter the IC for partial bottom cells on start-up in MPAS. !k = maxLevelCell(iCell) !layerThickness(k, iCell) = bottomDepth(iCell) - refBottomDepth(k-1) + endif !if (config_alter_ICs_for_pbcs) then + restingThickness(:, iCell) = layerThickness(:, iCell) end if @@ -444,6 +545,9 @@ subroutine ocn_init_setup_global_ocean_interpolate_topo(domain, iErr)!{{{ block_ptr => block_ptr % next end do +!!! this is temp: + deallocate(minBottomDepth,minBottomDepthMid) + end subroutine ocn_init_setup_global_ocean_interpolate_topo!}}} !*********************************************************************** From 7f2f881038022dc4158e99a4d4361c5f18587eb6 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Sun, 11 Oct 2015 10:45:02 -0600 Subject: [PATCH 0309/1724] Adding the 10km baroclinic channel test case This commit adds the configuration files to setup / run the baroclinic channel test case using the new ocean testing infrastructure. --- .../10km/config_forward.xml | 57 ++++++++++++++++ .../baroclinic_channel/10km/config_init1.xml | 67 +++++++++++++++++++ .../baroclinic_channel/10km/config_init2.xml | 55 +++++++++++++++ 3 files changed, 179 insertions(+) create mode 100644 test_cases/ocean/ocean/baroclinic_channel/10km/config_forward.xml create mode 100644 test_cases/ocean/ocean/baroclinic_channel/10km/config_init1.xml create mode 100644 test_cases/ocean/ocean/baroclinic_channel/10km/config_init2.xml diff --git a/test_cases/ocean/ocean/baroclinic_channel/10km/config_forward.xml b/test_cases/ocean/ocean/baroclinic_channel/10km/config_forward.xml new file mode 100644 index 0000000000..e64aac3f01 --- /dev/null +++ b/test_cases/ocean/ocean/baroclinic_channel/10km/config_forward.xml @@ -0,0 +1,57 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + init.nc + + + init.nc + + + output + output.nc + 0000_00:00:01 + truncate + + + + + + + + + + + + + 4 + + + 4 + ./ocean_model + namelist.ocean + streams.ocean + + + diff --git a/test_cases/ocean/ocean/baroclinic_channel/10km/config_init1.xml b/test_cases/ocean/ocean/baroclinic_channel/10km/config_init1.xml new file mode 100644 index 0000000000..d40d51a276 --- /dev/null +++ b/test_cases/ocean/ocean/baroclinic_channel/10km/config_init1.xml @@ -0,0 +1,67 @@ + + + + + + + + + + + + + + + + + + + + + + mesh.nc + + + output + 0000_00:00:01 + truncate + ocean.nc + + + + + + + + + + + + + + + + + + + + + + + + base_mesh.nc + mesh.nc + + + + 1 + ./ocean_model + namelist.ocean + streams.ocean + + + + ocean.nc + + + diff --git a/test_cases/ocean/ocean/baroclinic_channel/10km/config_init2.xml b/test_cases/ocean/ocean/baroclinic_channel/10km/config_init2.xml new file mode 100644 index 0000000000..dba9d4e3db --- /dev/null +++ b/test_cases/ocean/ocean/baroclinic_channel/10km/config_init2.xml @@ -0,0 +1,55 @@ + + + + + + + + + + + + + + + + + + init.nc + + + output + 0000_00:00:01 + truncate + ocean.nc + + + + + + + + + + + + + + + + + + + + + + + + 1 + ./ocean_model + namelist.ocean + streams.ocean + + + + From c7bc0ce252f2bf9f6fa1e47a3e1ad5814a7da6f3 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Thu, 15 Oct 2015 15:59:52 -0600 Subject: [PATCH 0310/1724] Add tracer alteration in PBCs. I can get a match between: old method: PBCs on start-up of forward run new method: PBCs in init mode, then start foward run see t14[h-x] --- .../mode_init/mpas_ocn_init_global_ocean.F | 70 ++++++++++++++++++- 1 file changed, 68 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F index fb4bf8f5d2..1ca4b3a15b 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F @@ -1070,11 +1070,12 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ real (kind=RKIND) :: currentLat, currentLon, counter real (kind=RKIND) :: minDist, dist real (kind=RKIND) :: x, x1, x2, y, y1, y2, coef, coef11, coef12, coef21, coef22 + real (kind=RKIND) :: zMidPBC integer :: iLat, iLon, iSmooth, j, coc integer :: latSearch, lonSearch - integer :: iCell, k + integer :: iCell, k, km1 integer :: xInd1, xInd2, yInd1, yInd2 - integer, pointer :: idxSalinity, idxTemperature, nCells, nCellsSolve, idxTracer1 + integer, pointer :: idxSalinity, idxTemperature, nCells, nVertLevels, nCellsSolve, idxTracer1 type (field2DReal), pointer :: smoothedTemperatureField, smoothedSalinityField type (field3DReal), pointer :: activeTracersField @@ -1093,6 +1094,15 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ real (kind=RKIND), pointer :: config_global_ocean_piston_velocity real (kind=RKIND), pointer :: config_global_ocean_interior_restore_rate + ! These variables needed to interpolate tracers for partial bottom cells. + ! Might remove once we interpolate to an arbitrary vertical grid. + logical, pointer :: config_alter_ICs_for_pbcs + character (len=StrKIND), pointer :: config_pbc_alteration_type + type (mpas_pool_iterator_type) :: groupItr + real (kind=RKIND), dimension(:), pointer :: bottomDepth, refBottomDepth + real (kind=RKIND), dimension(:,:,:), pointer :: tracersGroup + real (kind=RKIND), dimension(:), allocatable :: zMidZLevel + iErr = 0 call mpas_pool_get_config(domain % configs, 'config_global_ocean_tracer_method', config_global_ocean_tracer_method) @@ -1344,6 +1354,62 @@ subroutine ocn_init_setup_global_ocean_interpolate_tracers(domain, iErr)!{{{ call mpas_deallocate_scratch_field(smoothedSalinityField, .false.) endif + ! Interpolate tracers for partial bottom cells. + ! This can be removed once we interpolate to an arbitrary vertical grid. + call mpas_pool_get_config(domain % configs, 'config_alter_ICs_for_pbcs', config_alter_ICs_for_pbcs) + call mpas_pool_get_config(domain % configs, 'config_pbc_alteration_type', config_pbc_alteration_type) + if (config_alter_ICs_for_pbcs.and.config_pbc_alteration_type .eq. 'partial_cell') then + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + + allocate(zMidZLevel(nVertLevels)) + zMidZLevel(1) = - 0.5*(refBottomDepth(1)) ! could add SSH here + do k = 2, nVertLevels + zMidZLevel(k) = - 0.5*(refBottomDepth(k) + refBottomDepth(k-1)) + end do + + call mpas_pool_begin_iteration(tracersPool) + do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) + if ( groupItr % memberType == MPAS_POOL_FIELD ) then + call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroup, 1) + + + if ( associated(tracersGroup) ) then + do iCell = 1, nCells + ! Linearly interpolate the initial tracers for new location of bottom cell for PBCs + k = maxLevelCell(iCell) + if (k>1) then + zMidPBC = -0.5_RKIND * (bottomDepth(iCell) + refBottomDepth(k-1)) + km1 = max(k-1,1) + tracersGroup(:, k, iCell) = tracersGroup(:, k, iCell) & + + (tracersGroup(:, km1, iCell) - tracersGroup(:, k, iCell)) & + /(zMidZLevel(km1) - zMidZLevel(k) + 1.0e-16_RKIND) & + *(zMidPBC - zMidZLevel(k)) + endif + end do + end if + end if + end do + + deallocate(zMidZLevel) + block_ptr => block_ptr % next + end do + endif + ! end: Interpolate tracers for partial bottom cells. + block_ptr => domain % blocklist do while(associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) From effed4293970f934c43ad09b41c720e173c97d4d Mon Sep 17 00:00:00 2001 From: Luke Van Roekel Date: Thu, 15 Oct 2015 22:26:15 -0600 Subject: [PATCH 0311/1724] This fixes a small error in the cvmix interface that was throwing a bounds error in debug mode. If the CVMIX BL depth is greater than the bottom depth it was reset to the depth of the bottom. However the vertical index of the boundary layer was not reset. I have added the appropriate calls to reset this index. --- src/core_ocean/shared/mpas_ocn_vmix_cvmix.F | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F b/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F index 9f20e0be31..89a448cbad 100644 --- a/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F +++ b/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F @@ -434,11 +434,20 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, ! apply minimum limit to OBL if(cvmix_variables % BoundaryLayerDepth .lt. layerThickness(1,iCell)/2.0) then cvmix_variables % BoundaryLayerDepth = layerThickness(1,iCell)/2.0 + cvmix_variables % kOBL_depth = cvmix_kpp_compute_kOBL_depth( & + zw_iface = cvmix_variables%zw_iface(1:nVertLevels+1),& + zt_cntr = cvmix_variables%zt_cntr(1:nVertLevels), & + OBL_depth = cvmix_variables % BoundaryLayerDepth ) endif ! apply maximum limit to OBL if(cvmix_variables % BoundaryLayerDepth .gt. abs(cvmix_variables%zt_cntr(maxLevelCell(iCell)))) then cvmix_variables % BoundaryLayerDepth = abs(cvmix_variables%zt_cntr(maxLevelCell(iCell))) + cvmix_variables % kOBL_depth = cvmix_kpp_compute_kOBL_depth( & + zw_iface = cvmix_variables%zw_iface(1:nVertLevels+1), & + zt_cntr = cvmix_variables%zt_cntr(1:nVertLevels), & + OBL_depth = cvmix_variables % BoundaryLayerDepth ) + endif call cvmix_coeffs_kpp( & From de1651161d69a6fd9edd4b2d87ac5d8a47f38185 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Sat, 17 Oct 2015 07:31:46 -0600 Subject: [PATCH 0312/1724] Update initialization of layerThickness and zMid. --- .../mode_init/mpas_ocn_init_global_ocean.F | 134 ++++++------------ 1 file changed, 46 insertions(+), 88 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F index 1ca4b3a15b..e77514c6c9 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F @@ -115,7 +115,7 @@ subroutine ocn_init_setup_global_ocean(domain, iErr)!{{{ write(stderrUnit,*) 'Reading topography data.' call ocn_init_setup_global_ocean_read_topo(domain, iErr) write(stderrUnit,*) 'Interpolating topography data.' - call ocn_init_setup_global_ocean_interpolate_topo(domain, iErr) + call ocn_init_setup_global_ocean_create_model_topo(domain, iErr) write(stderrUnit,*) 'Cleaning up topography IC fields' call ocn_init_global_ocean_destroy_topo_fields() @@ -248,7 +248,7 @@ end subroutine ocn_init_setup_global_ocean_read_topo!}}} !*********************************************************************** ! -! routine ocn_init_setup_global_ocean_interpolate_topo +! routine ocn_init_setup_global_ocean_create_model_topo ! !> \brief Interpolate the topography IC to MPAS mesh !> \author Doug Jacobsen @@ -259,7 +259,7 @@ end subroutine ocn_init_setup_global_ocean_read_topo!}}} ! !----------------------------------------------------------------------- - subroutine ocn_init_setup_global_ocean_interpolate_topo(domain, iErr)!{{{ + subroutine ocn_init_setup_global_ocean_create_model_topo(domain, iErr)!{{{ type (domain_type), intent(inout) :: domain integer, intent(out) :: iErr @@ -289,7 +289,7 @@ subroutine ocn_init_setup_global_ocean_interpolate_topo(domain, iErr)!{{{ real (kind=RKIND), pointer :: config_global_ocean_minimum_depth ! mrp note: move to subroutine and different name list later. change pbc to vertical_cell logical, pointer :: config_alter_ICs_for_pbcs - real (kind=RKIND), dimension(:), allocatable :: minBottomDepth, minBottomDepthMid + real (kind=RKIND) :: minBottomDepth, minBottomDepthMid real (kind=RKIND), pointer :: config_min_pbc_fraction character (len=StrKIND), pointer :: config_pbc_alteration_type call mpas_pool_get_config(domain % configs, 'config_alter_ICs_for_pbcs', config_alter_ICs_for_pbcs) @@ -438,7 +438,7 @@ subroutine ocn_init_setup_global_ocean_interpolate_topo(domain, iErr)!{{{ call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) ! move this to subroutine later - ! TopOfCell needed where zero depth for the very top may be referenced. +! call ocn_compute_layerThickness_zMid_from_bottomDepth refLayerThickness(1) = refBottomDepth(1) refZMid(1) = refBottomDepth(1)/2.0 do k = 2, nVertLevels @@ -446,97 +446,55 @@ subroutine ocn_init_setup_global_ocean_interpolate_topo(domain, iErr)!{{{ refZMid(k) = - refBottomDepth(k-1) - refLayerThickness(k)/2.0 end do -! initialize minBottomDepth, MinBottomDepthMid -print *, 'config_alter_ICs_for_pbcs',config_alter_ICs_for_pbcs,config_pbc_alteration_type, config_min_pbc_fraction - allocate(minBottomDepth(nVertLevels),minBottomDepthMid(nVertLevels)) - - ! min_pbc_fraction restricts pbcs from being too small. - ! A typical value is 10%, so pbcs must occupy at least 10% of the cell thickness. - ! If min_pbc_fraction = 0.0, bottomDepth gives the actual depth for that cell. - ! If min_pbc_fraction = 1.0, bottomDepth reverts to discrete z-level depths, same - ! as partial_bottom_cells = .false. - - minBottomDepth(1) = (1.0-config_min_pbc_fraction)*refBottomDepth(1) - minBottomDepthMid(1) = 0.5*minBottomDepth(1) - do k = 2, nVertLevels - minBottomDepth(k) = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*(refBottomDepth(k) - refBottomDepth(k-1)) - minBottomDepthMid(k) = 0.5*(minBottomDepth(k) + refBottomDepth(k-1)) - end do -! end: initialize minBottomDepth, MinBottomDepthMid - do iCell = 1, nCellsSolve if (maxLevelCell(iCell) > 0) then -! substitute with a subroutine call later: -! call ocn_initialize_z_level_vertical_coord( & -! bottomDepthObserved(iCell), refBottomDepth, ssh, & ! inputs -! alteredBottomDepth(iCell), maxLevelCell(iCell), layerThickness(:,iCell), zMid(:,iCell) ) ! outputs + ! substitute with a subroutine call later: + ! call ocn_alter_bottomDepth_for_pbcs( & + ! bottomDepthObserved(iCell), refBottomDepth, ssh, & ! inputs + ! alteredBottomDepth(iCell), maxLevelCell(iCell), layerThickness(:,iCell), zMid(:,iCell) ) ! outputs - if (config_alter_ICs_for_pbcs) then + if (config_alter_ICs_for_pbcs) then !!!!!!!!!!!!! this would be in a subroutine -! subroutine ocn_initialize_z_level_vertical_coord -! if (not.config_alter_ICs_for_pbcs) return ! but change flag name - - if (config_pbc_alteration_type .eq. 'partial_cell') then - ! Change value of maxLevelCell for partial bottom cells - k = maxLevelCell(iCell) - if (bottomDepth(iCell) .lt. minBottomDepthMid(k)) then - ! Round up to cell above - maxLevelCell(iCell) = maxLevelCell(iCell) - 1 - bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) - else if (bottomDepth(iCell) .lt. minBottomDepth(k)) then - ! Round down cell to the min_pbc_fraction. - bottomDepth(iCell) = minBottomDepth(k) - end if - ! reset k to new value of maxLevelCell - k = maxLevelCell(iCell) - - elseif (config_pbc_alteration_type .eq. 'full_cell') then - - bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) - - else - - write (stderrUnit,*) ' Incorrect choice of config_pbc_alteration_type.' - call mpas_dmpar_abort(domain % dminfo) - - endif - - ! Initialize layerThickness - if (maxLevelCell(iCell)==1) then - layerThickness(1,iCell) = bottomDepth(iCell) - else - layerThickness(1, iCell) = refBottomDepth(1) - do k = 2, maxLevelCell(iCell)-1 - layerThickness(k, iCell) = refBottomDepth(k) - refBottomDepth(k-1) - end do - ! Alter thickness of bottom level to account for PBC - k = maxLevelCell(iCell) - layerThickness(k,iCell) = bottomDepth(iCell) - refBottomDepth(k-1) - layerThickness(k+1:nVertLevels,iCell) = 0.0_RKIND - endif - - ! Initialize zMid - zMid(1,iCell) = layerThickness(1,iCell)/2.0 - do k = 2, maxLevelCell(iCell) - zMid(k,iCell) = - refBottomDepth(k-1) - layerThickness(k,iCell)/2.0 - end do + ! subroutine ocn_initialize_z_level_vertical_coord + ! if (not.config_alter_ICs_for_pbcs) return ! but change flag name + + if (config_pbc_alteration_type .eq. 'partial_cell') then + ! Change value of maxLevelCell for partial bottom cells + k = maxLevelCell(iCell) + minBottomDepth = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*(refBottomDepth(k) - refBottomDepth(k-1)) + minBottomDepthMid = 0.5*(minBottomDepth + refBottomDepth(k-1)) + if (bottomDepth(iCell) .lt. minBottomDepthMid) then + ! Round up to cell above + maxLevelCell(iCell) = maxLevelCell(iCell) - 1 + bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) + else if (bottomDepth(iCell) .lt. minBottomDepth) then + ! Round down cell to the min_pbc_fraction. + bottomDepth(iCell) = minBottomDepth + end if + ! reset k to new value of maxLevelCell + k = maxLevelCell(iCell) + + elseif (config_pbc_alteration_type .eq. 'full_cell') then + bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) + else + write (stderrUnit,*) ' Incorrect choice of config_pbc_alteration_type.' + call mpas_dmpar_abort(domain % dminfo) + endif !!!!!!!!!!!!! this would be in a subroutine: end - else !if (config_alter_ICs_for_pbcs) then - ! By going to maxLevelCell, this loop sets the layer Thickness as the full cell at the bottom. - layerThickness(1, iCell) = refBottomDepth(1) - do k = 2, maxLevelCell(iCell) - layerThickness(k, iCell) = refBottomDepth(k) - refBottomDepth(k-1) - end do + endif !if (config_alter_ICs_for_pbcs) then - ! The following lines could be used for partial bottom cells, but only if the temperature is interpolated in the vertical as well. - ! In version 3.0, one may alter the IC for partial bottom cells on start-up in MPAS. - !k = maxLevelCell(iCell) - !layerThickness(k, iCell) = bottomDepth(iCell) - refBottomDepth(k-1) - endif !if (config_alter_ICs_for_pbcs) then + k = maxLevelCell(iCell) + layerThickness(1:k-1,iCell) = refLayerThickness(1:k-1) + zMid(1:k-1,iCell) = refZMid(1:k-1) + layerThickness(k,iCell) = bottomDepth(iCell) - refBottomDepth(k-1) + zMid(k,iCell) = - refBottomDepth(k-1) - layerThickness(k,iCell)/2.0 + + layerThickness(k+1:nVertLevels,iCell) = 0.0_RKIND + zMid(k+1:nVertLevels,iCell) = 0.0_RKIND restingThickness(:, iCell) = layerThickness(:, iCell) end if @@ -546,9 +504,9 @@ subroutine ocn_init_setup_global_ocean_interpolate_topo(domain, iErr)!{{{ end do !!! this is temp: - deallocate(minBottomDepth,minBottomDepthMid) +! deallocate(minBottomDepth,minBottomDepthMid) - end subroutine ocn_init_setup_global_ocean_interpolate_topo!}}} + end subroutine ocn_init_setup_global_ocean_create_model_topo!}}} !*********************************************************************** ! From 32809222337f83f0e0d22c8b99d9849f5ef509b3 Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Sun, 18 Oct 2015 10:24:32 -0600 Subject: [PATCH 0313/1724] new frazil algorithm coded ... no yet compiling. --- src/core_ocean/shared/mpas_ocn_frazil.F | 352 +++++++++++------------- 1 file changed, 155 insertions(+), 197 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_frazil.F b/src/core_ocean/shared/mpas_ocn_frazil.F index efd4766922..0245bba2f9 100644 --- a/src/core_ocean/shared/mpas_ocn_frazil.F +++ b/src/core_ocean/shared/mpas_ocn_frazil.F @@ -50,7 +50,6 @@ module ocn_frazil ! !-------------------------------------------------------------------- - integer :: verticalLevelCap logical :: frazilFormationOn !*********************************************************************** @@ -65,7 +64,7 @@ module ocn_frazil !> \author Todd Ringler !> \date 10/19/2015 !> \details -!> ocn_frazil_formation compute the tendencies to layer thickness, temperature and salinity +!> ocn_frazil_formation computes the tendencies to layer thickness, temperature and salinity !> due to the creation and possible melting of frazil ice !> !> these tendencies can be retrieved at any point by calling into ocn_frazil_*_tendency routines @@ -73,10 +72,16 @@ module ocn_frazil !> !> the pressure exerted by the frazil on the ocean "surface" can be retrieved by calling into !> ocn_frazil_surface_pressure +!> +!> this routine should be call at the beginning of whatever time stepping method is utilized +!> and the tendencies should be retieved when building up the RHS of the thickess, temperature +!> and salinity equations. +!> +!> this routine is only applicable to the thickness and active tracer fields ! !----------------------------------------------------------------------- - subroutine ocn_frazil_formation(meshPool, indexTemperature, indexSalinity, layerThickness, tracers, seaIceEnergy, err)!{{{ + subroutine ocn_frazil_formation(meshPool, statePool, tendPool, tracers, err)!{{{ !----------------------------------------------------------------- ! @@ -85,19 +90,14 @@ subroutine ocn_frazil_formation(meshPool, indexTemperature, indexSalinity, layer !----------------------------------------------------------------- type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information - - integer :: indexTemperature !< Input: Index in tracers array for temperature - integer :: indexSalinity !< Input: Index in tracers array for salinity + type (mpas_pool_type), intent(in) :: statePool !< Input: State information !----------------------------------------------------------------- ! ! input/output variables ! !----------------------------------------------------------------- - - real (kind=RKIND), dimension(:), intent(inout) :: seaIceEnergy !< Input/Output: Accumulated energy for sea ice formation - real (kind=RKIND), dimension(:,:,:), intent(inout) :: tracers !< Input/Output: Array of tracers - real (kind=RKIND), dimension(:,:), intent(inout) :: layerThickness !< Input/Output: Thickness of each layer + type (mpas_pool_type), intent(out) :: tendPool !< Output: Tendency information integer, intent(inout) :: err !< Error flag !----------------------------------------------------------------- @@ -111,191 +111,158 @@ subroutine ocn_frazil_formation(meshPool, indexTemperature, indexSalinity, layer ! local variables ! !----------------------------------------------------------------- + integer :: iCell, k, kBottomFrazil + integer, pointer :: nCells, nVertLevels - integer :: maxLevel, nTracers - integer :: iCell, k, iTracer - integer, pointer :: nCells, nVertLevels, nCellsSolve +config_frazil_heat_of_fusion +config_frazil_sea_ice_density +config_frazil_fractional_thickness_limit - integer, dimension(:), pointer :: maxLevelCell - real (kind=RKIND) :: temperatureTendency, thicknessTendency, salinityTendency +real (kind=RKIND) :: newFrazilIceThickness +real (kind=RKIND) :: meltedFrazilIceThickness + + type (mpas_pool_type) :: tracerPool + + real (kind=RKIND), pointer, dimension(:) :: accumulatedFrazilIceThickness + real (kind=RKIND), pointer, dimension(:) :: accumulatedFrazilIceMass + real (kind=RKIND), pointer, dimension(:,:) :: zMid + real (kind=RKIND), pointer, dimension(:,:) :: density + real (kind=RKIND), pointer, dimension(:,:) :: layerThickness - real (kind=RKIND) :: netEnergyChange, availableEnergyChange, energyChange - real (kind=RKIND) :: temperatureTendency, thicknessTendency, salinityTendency +layerTendencyFrazil +temperatureTendencyFrazil +salinityTendencyFrazil +surfacePressureTendencyFrazil - real (kind=RKIND) :: referenceSalinity, iceSalinity - real (kind=RKIND) :: freezingTemp, density_ice - real (kind=RKIND), dimension(:), allocatable :: iceTracer + integer, dimension(:), pointer :: maxLevelCell + integer :: indexTemperature !< Input: Index in tracers array for temperature + integer :: indexSalinity !< Input: Index in tracers array for salinity + real (kind=RKIND) :: kBottomFrazil ! k index where testing for frazil begins + real (kind=RKIND) :: potential ! scalar holding freezing/melt potential + real (kind=RKIND) :: freezingEnergy ! energy available for freezing, positive definite + real (kind=RKIND) :: meltingEnergy ! energy available for melting, positive definite + + + ! if frazil is not enabled, return if(.not. frazilFormationOn) return - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + do block ----- + + ! get dimensions + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + + ! get configure parameters + config_frazil_maximum_depth + + ! get mesh fields + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + ! get state fields + layerThickness + activeTracers + temperature index + salinity index + + ! get diagnostic fields + zMid + density + accumulatedFrazilIceThickness + + ! get tendency fields from pool + + + ! loop over all columns + do iCell=1,nCells + + ! reset frazil thickness and mass to be zero for each column + accumulatedFrazilIceThickness(iCell) = 0.0_RKIND + accumulatedFrazilIceMass(iCell) = 0.0_RKIND + + ! find deepest level where frazil can be created + do k=maxLevelCell(iCell), 1, -1 + if(-zMid(k,iCell).lt.config_frazil_maximum_depth) then + kBottomFrazil=k + exit + endif + enddo + + ! loop from maximum depth of frazil creation to surface + do k = kBottomFrazil, 1, -1 + + potential = layerThickness(k,iCell) * config_specific_heat_sea_water & + * density(k,iCell) * (temperature(k,iCell) - oceanFreezingTemperature) + freezingEnergy = max(0.0_RKIND, -potential) + meltingEnergy = max(0.0_RKIND, potential) + + if (freezingEnergy < 0) then + + ! new frazil ice formation measured in meters + newFrazilIceThickness = freezingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) + + ! limit the frazil formed appropriately + newFrazilIceThickness = min(newFrazilIceThickness, layerThickness(k,iCell) * config_frazil_fractional_thickness_limit) + + ! compute increments to thickness, temperature and salinity + ! layerTendencyFrazil is scaled so that mass of ice created == mass of ocean water removed + layerTendencyFrazil(k,iCell) = -newFrazilIceThickness * config_frazil_sea_ice_density / density(k,iCell) + saltTendencyFrazil(k,iCell) = -newFrazilIceThickness * config_frazil_iceReferenceSalinity + temperatureTendencyFrazil(k,iCell) = (newFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density) & + / (config_specific_heat_sea_water * density(k,iCell)) + + ! accumulate frazil + accumulatedFrazilIceThickness(iCell) = accumulatedFrazilIceThickness(iCell) + newFrazilIceThickness + accumulatedFrazilIceMass(iCell) = accumulatedFrazilIceMass(iCell) + newFrazilIceThickness*config_frazil_sea_ice_density + + else + + ! ocean water is warm enough to melt frazil + + ! test to see if there is frazil to be melted + if (accumulatedFrazilIceThickness(iCell) > 0) then + + ! Frazil melting + meltedFrazilIceThickness = meltingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) + + ! limit melting by what there is to melt + meltedFrazilIceThickness = min(meltedFrazilIceThickness, accumulatedFrazilIceThickness(iCell)) + + ! limit melting by fraction of layer thickness + meltedFrazilIceThickness = min(meltedFrazilIceThickness, layerThickness(k,iCell)*config_frazil_fractional_thickness_limit) + + ! compute increments to thickness, temperature and salinity + layerTendencyFrazil(k,iCell) = meltedFrazilIceThickness + saltTendencyFrazil(k,iCell) = meltedFrazilIceThickness * config_frazil_sea_ice_reference_salinity + temperatureTendencyFrazil(k,iCell) = -(meltedFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density) & + / (config_specific_heat_sea_water * density(k,iCell)) + + ! deaccumulate frazil + accumulatedFrazilIceThickness(iCell) = accumulatedFrazilIceThickness(iCell) - meltedFrazilThickness + accumulatedFrazilIceMass(iCell) = accumulatedFrazilIceMass(iCell) - meltedFrazilIceThickness*config_frazil_sea_ice_density + + endif ! if (freezingEnergy < 0) + + ! convert tendencies to rates + ! each of these tendencies can be access through public subroutines below + layerTendencyFrazil(k,iCell) = layerTendencyFrazil(k,iCell) / dt + saltTendencyFrazil(k,iCell) = saltTendencyFrazil(k,iCell) / dt + temperatureTendencyFrazil(k,iCell) = temperatureTendencyFrazil(k,iCell) / dt + + enddo ! do k=kBottom,1-1 + + ! sea surface pressure tendency from frazil ice + ! note: surfacePressureFrazil should incrememented by surfacePressureTendencyFrazil * dt + ! note: surfacePressureFrazil should be reset to zero after sending to coupler + surfacePressureTendencyFrazil(iCell) = accumulatedFrazilIceMass(iCell) * gravity / dt + + enddo ! do iCell = 1, nCells + + enddo ! iBlock - do iCell = 1, nCellsSolve - - columnTemperatureMin = min(tracers(indexTemperature,:,iCell)) - freezingTemp = ocn_freezing_temperature(tracers(indexSalinity, 1, iCell)) - - if (columnTemperatureMin < freezingTemp) then - - do k=1,nVertLevels - deltaTemperature = freezingTemp - tracers(indexTemperature,k,iCell) - energyPotential = cp_sw * density(k,iCell) * deltaTemperature - fractionalFreezePotential(k) = max(0.0_RKIND, energyPotential / (energyPotential + density_ice * latent_heat_fusion_mks)) - fractionalMeltPotential(k) = max(0.0_RKIND, -energyPotential / energyPotential + density_ice * latent_heat_fusion_mks) - enddo - - ! set all accumulators to zero - frazilThickness = 0.0_RKIND - frazilMass = 0.0_RKIND - - do k=maxLevelCell(iCell),1,-1 - - ! test to see if frazil is created in this layer - if (fractionalFreezePotential(k).gt.0.0_RKIND) then - thicknessFreeze = min(fractionalFreezePotential(k), fractionalFrazilLimiter)*layerThickness(k,iCell) - thickessLiquid = frazilReferenceSalinity * thicknessFreeze / (tracers(indexSalinity,k,iCell)-frazilReferenceSalinity) - frazilThicknessTend(k,iCell) = -(thicknessFreeze+thickessLiquid) / dt - frazilSalinityTend(k,iCell) = -thickessLiquid*tracers(indexSalinity,k,iCell) / dt - frazilTemperatureTend(k,iCell) = latent_heat_fusion_mks * thicknessFreeze / cp_sw / dt - frazilThickness = frazilThickness + thicknessFreeze + thickessLiquid - frazilMass = frazilMass + (thicknessFreeze + thickessLiquid) * density(k,iCell) - else - if (frazilThickness.gt.0.0_RKIND) then - thicknessMelt = min(frazilThickness, fractionalMeltPotential(k)*layerThickness(k,iCell), fractionalFrazilLimiter*layerThickness(k,iCell)) - frazilThicknessTend(k,iCell) = thicknessMelt / dt - frazilSalinityTend(k,iCell) = thicknessMelt * frazilReferenceSalinity / dt - frazilTemperatureTend(k,iCell) = -latent_heat_fusion_mks * thicknessFreeze / cp_sw / dt - frazilThickness = frazilThickness - thicknessMelt - frazilMass = frazilMass - thicknessMelt * density_ice - endif - endif ! (fractionalFreezePotential(k).gt.0.0_RKIND) - - enddo ! do k=maxLevelCell(iCell),1,-1 - - frazilSurfacePressure(newTime) = frazilSurfacePressure(oldTime) + frazilMass*gravity - - endif - - enddo - - - - - - endif ! (columnTemperatureMin < freezingTemp) - - - - - - maxLevel = min(maxLevelCell(iCell), verticalLevelCap) - netEnergyChange = 0.0_RKIND - - ! Loop over vertical levels, starting from the bottom of a column - do k = maxLevel, 1, -1 - freezingTemp = ocn_freezing_temperature(tracers(indexSalinity, k, iCell)) - ! availableEnergyChange is: - ! positive when frazil ice is formed - ! negative when frazil ice can be melted - availableEnergyChange = rho_sw * cp_sw * layerThickness(k, iCell) & - * (freezingTemp - tracers(indexTemperature, k, iCell)) - - ! energyChange is capped when negative. - ! melting energy can't be greater than the amount of energy - ! available in formed ice. - energyChange = max(availableEnergyChange, -netEnergyChange) - - ! Compute temperature change in ocean cell due to energy change - temperatureChange = energyChange / ( rho_sw * cp_sw * layerThickness(k, iCell) ) - ! Compute thickness change in ocean cell due to energy change - thicknessChange = energyChange / ( rho_sw * latent_heat_fusion_mks ) - ! Compute thickness change in sea ice due to energy change - iceThicknessChange = energyChange / ( density_ice * latent_heat_fusion_mks ) - - ! Update all tracers based on the thickness change - do iTracer = 1, nTracers - if(iTracer /= indexTemperature) then - ! computed as: - ! \rho_{ocn} h_{ocn}^{pre} \theta_{ocn}^{pre} = - ! \rho_{ocn}^{new} h_{ocn}^{new} \theta_{ocn}^{new} = \rho_{si} h_{si} \theta_{si} - tracers(iTracer, k, iCell) = ( rho_sw * layerThickness(k,iCell) * tracers(iTracer, k, iCell) & - - density_ice * iceThicknessChange * iceTracer(iTracer)) / & - (rho_sw * (layerThickness(k,iCell) + thicknessChange)) - end if - end do - - ! Adjust Temperature - tracers(indexTemperature, k, iCell) = tracers(indexTemperature, k, iCell) + temperatureChange - ! Adjust Thickness - layerThickness(k,iCell) = layerThickness(k,iCell) + thicknessChange - - ! Add energyChange to netEnergyChange. - ! netEnergyChange should always be >= 0.0 - netEnergyChange = netEnergychange + energyChange - end do - - ! Add netEnergyChange to the cell's energy. - ! seaIceEnergy should always be >= 0.0 - seaIceEnergy(iCell) = seaIceEnergy(iCell) + netEnergyChange - - ! Adjust top layer one more time, based on energy availabe in seaIceEnergy(iCell) - ! This really only allows melting of previously formed ice to occur. - if(maxLevelCell(iCell) >= 1 .and. seaIceEnergy(iCell) > 0.0_RKIND) then - k = 1 - - netEnergychange = 0.0_RKIND - freezingTemp = ocn_freezing_temperature(tracers(indexSalinity, k, iCell)) - ! availableEnergyChange is: - ! positive when frazil ice is formed - ! negative when frazil ice can be melted - availableEnergyChange = rho_sw * cp_sw * layerThickness(k, iCell) & - * (freezingTemp - tracers(indexTemperature, k, iCell)) - - ! energyChange is capped when negative. - ! melting energy can't be greater than the amount of energy - ! available in formed ice. - ! compared with seaIceEnergy in this case, rather than netEnergyChange - energyChange = max(availableEnergyChange, -seaIceEnergy(iCell)) - - ! Compute temperature change in ocean cell due to energy change - temperatureChange = energyChange / ( rho_sw * cp_sw * layerThickness(k, iCell) ) - ! Compute thickness change in ocean cell due to energy change - thicknessChange = energyChange / ( rho_sw * latent_heat_fusion_mks ) - ! Compute thickness change in sea ice due to energy change - iceThicknessChange = energyChange / ( density_ice * latent_heat_fusion_mks ) - - ! Update all tracers based on the thickness change - do iTracer = 1, nTracers - if(iTracer /= indexTemperature) then - ! computed as: - ! \rho_{ocn} h_{ocn}^{pre} \theta_{ocn}^{pre} = - ! \rho_{ocn}^{new} h_{ocn}^{new} \theta_{ocn}^{new} = \rho_{si} h_{si} \theta_{si} - tracers(iTracer, k, iCell) = ( rho_sw * layerThickness(k,iCell) * tracers(iTracer, k, iCell) & - - density_ice * iceThicknessChange * iceTracer(iTracer)) / & - (rho_sw * (layerThickness(k,iCell) + thicknessChange)) - end if - end do - - ! Adjust Temperature - tracers(indexTemperature, k, iCell) = tracers(indexTemperature, k, iCell) + temperatureChange - ! Adjust Thickness - layerThickness(k,iCell) = layerThickness(k,iCell) + thicknessChange - - ! Add energyChange to netEnergyChange. - ! netEnergyChange should always be >= 0.0 - seaIceEnergy(iCell) = seaIceEnergy(iCell) + energyChange - end if - end do - - deallocate(iceTracer) - end subroutine ocn_frazil_formation!}}} !*********************************************************************** @@ -328,30 +295,21 @@ end function ocn_freezing_temperature!}}} ! !----------------------------------------------------------------------- - subroutine ocn_frazil_init(nVertLevels, err)!{{{ + subroutine ocn_frazil_init(err)!{{{ - integer, intent(in) :: nVertLevels !< Input: Number of vertical levels suggested for level cap integer, intent(out) :: err !< Output: error flag - - logical, pointer :: config_frazil_ice_formation, config_monotonic + logical, pointer :: config_use_frazil_ice_formation err = 0 - call mpas_pool_get_config(ocnConfigs, 'config_frazil_ice_formation', config_frazil_ice_formation) - call mpas_pool_get_config(ocnConfigs, 'config_monotonic', config_monotonic) + call mpas_pool_get_config(ocnConfigs, 'config_use_frazil_ice_formation', config_use_frazil_ice_formation) frazilFormationOn = .false. - if(config_frazil_ice_formation) then + if(config_use_frazil_ice_formation) then frazilFormationOn = .true. end if - if(.not. config_monotonic) then - verticalLevelCap = 1 - else - verticalLevelCap = nVertLevels - end if - end subroutine ocn_frazil_init!}}} !*********************************************************************** From 8f99b08dfcd3e8e027cf531da21b76b4b2e1b57e Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Mon, 19 Oct 2015 07:08:31 -0600 Subject: [PATCH 0314/1724] add subroutine: compute_layerThickness_zMid_from_bottomDepth --- .../mode_init/mpas_ocn_init_global_ocean.F | 57 +++++++++++++++---- 1 file changed, 45 insertions(+), 12 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F index e77514c6c9..ba91b4005e 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F @@ -246,6 +246,37 @@ subroutine ocn_init_setup_global_ocean_read_topo(domain, iErr)!{{{ end subroutine ocn_init_setup_global_ocean_read_topo!}}} + +!*********************************************************************** +! +! routine ocn_compute_layerThickness_zMid_from_bottomDepth +! +!> \brief Compute auxiliary z-variables from bottomDepth +!> \author Mark Petersen +!> \date 10/17/2015 +!> \details +!> This routine computes auxiliary z-variables from bottomDepth +! +!----------------------------------------------------------------------- + + subroutine ocn_compute_layerThickness_zMid_from_bottomDepth(LayerThicknessCol,ZMidCol,BottomDepthCol,kMax,iErr)!{{{ + real (kind=RKIND), dimension(kMax), intent(out) :: LayerThicknessCol, ZMidCol + real (kind=RKIND), dimension(kMax), intent(in) :: BottomDepthCol + integer, intent(in) :: kMax + integer, intent(out) :: iErr + integer :: k + + iErr = 0 + + LayerThicknessCol(1) = BottomDepthCol(1) + ZMidCol(1) = BottomDepthCol(1)/2.0 + do k = 2, kMax + LayerThicknessCol(k) = BottomDepthCol(k) - BottomDepthCol(k-1) + ZMidCol(k) = - BottomDepthCol(k-1) - LayerThicknessCol(k)/2.0 + end do + + end subroutine ocn_compute_layerThickness_zMid_from_bottomDepth !}}} + !*********************************************************************** ! ! routine ocn_init_setup_global_ocean_create_model_topo @@ -438,20 +469,20 @@ subroutine ocn_init_setup_global_ocean_create_model_topo(domain, iErr)!{{{ call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) ! move this to subroutine later -! call ocn_compute_layerThickness_zMid_from_bottomDepth - refLayerThickness(1) = refBottomDepth(1) - refZMid(1) = refBottomDepth(1)/2.0 - do k = 2, nVertLevels - refLayerThickness(k) = refBottomDepth(k) - refBottomDepth(k-1) - refZMid(k) = - refBottomDepth(k-1) - refLayerThickness(k)/2.0 - end do + call ocn_compute_layerThickness_zMid_from_bottomDepth(refLayerThickness,refZMid,refBottomDepth,nVertLevels,iErr) +! refLayerThickness(1) = refBottomDepth(1) +! refZMid(1) = refBottomDepth(1)/2.0 +! do k = 2, nVertLevels +! refLayerThickness(k) = refBottomDepth(k) - refBottomDepth(k-1) +! refZMid(k) = - refBottomDepth(k-1) - refLayerThickness(k)/2.0 +! end do do iCell = 1, nCellsSolve if (maxLevelCell(iCell) > 0) then ! substitute with a subroutine call later: ! call ocn_alter_bottomDepth_for_pbcs( & - ! bottomDepthObserved(iCell), refBottomDepth, ssh, & ! inputs + ! bottomDepth(iCell), refBottomDepth, ssh, & ! inputs ! alteredBottomDepth(iCell), maxLevelCell(iCell), layerThickness(:,iCell), zMid(:,iCell) ) ! outputs if (config_alter_ICs_for_pbcs) then @@ -487,11 +518,13 @@ subroutine ocn_init_setup_global_ocean_create_model_topo(domain, iErr)!{{{ endif !if (config_alter_ICs_for_pbcs) then k = maxLevelCell(iCell) - layerThickness(1:k-1,iCell) = refLayerThickness(1:k-1) - zMid(1:k-1,iCell) = refZMid(1:k-1) + layerThickness(1:k,iCell) = refLayerThickness(1:k) + zMid(1:k,iCell) = refZMid(1:k) - layerThickness(k,iCell) = bottomDepth(iCell) - refBottomDepth(k-1) - zMid(k,iCell) = - refBottomDepth(k-1) - layerThickness(k,iCell)/2.0 + if (config_alter_ICs_for_pbcs.and.config_pbc_alteration_type .eq. 'partial_cell') then + layerThickness(k,iCell) = bottomDepth(iCell) - refBottomDepth(k-1) + zMid(k,iCell) = - refBottomDepth(k-1) - layerThickness(k,iCell)/2.0 + end if layerThickness(k+1:nVertLevels,iCell) = 0.0_RKIND zMid(k+1:nVertLevels,iCell) = 0.0_RKIND From be7b730c1fd786f460d00d30dba27978ab1a4ffc Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Mon, 19 Oct 2015 07:40:18 -0600 Subject: [PATCH 0315/1724] Add subroutine ocn_alter_bottomDepth_for_pbcs --- .../mode_init/mpas_ocn_init_global_ocean.F | 143 +++++++++++++----- 1 file changed, 104 insertions(+), 39 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F index ba91b4005e..76fc660b5a 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F @@ -29,6 +29,7 @@ module ocn_init_global_ocean use mpas_io_streams use mpas_dmpar + use ocn_constants use ocn_init_cell_markers implicit none @@ -277,6 +278,68 @@ subroutine ocn_compute_layerThickness_zMid_from_bottomDepth(LayerThicknessCol,ZM end subroutine ocn_compute_layerThickness_zMid_from_bottomDepth !}}} +!*********************************************************************** +! +! routine ocn_alter_bottomDepth_for_pbcs +! +!> \brief Interpolate the topography IC to MPAS mesh +!> \author Mark Petersen +!> \date 10/17/2015 +!> \details +!> This routine alters the bottom depth in a single column based on pbc settings +! +!----------------------------------------------------------------------- + subroutine ocn_alter_bottomDepth_for_pbcs(bottomDepth, refBottomDepth, maxLevelCell, iErr) + + real (kind=RKIND), intent(inout) :: bottomDepth + integer, intent(inout) :: maxLevelCell + real (kind=RKIND), dimension(maxLevelCell), intent(in) :: refBottomDepth + integer, intent(out) :: iErr + integer :: k + + ! mrp note: move to subroutine and different name list later. change pbc to vertical_cell + logical, pointer :: config_alter_ICs_for_pbcs + real (kind=RKIND) :: minBottomDepth, minBottomDepthMid + real (kind=RKIND), pointer :: config_min_pbc_fraction + character (len=StrKIND), pointer :: config_pbc_alteration_type + call mpas_pool_get_config(ocnConfigs, 'config_alter_ICs_for_pbcs', config_alter_ICs_for_pbcs) + call mpas_pool_get_config(ocnConfigs, 'config_pbc_alteration_type', config_pbc_alteration_type) + call mpas_pool_get_config(ocnConfigs, 'config_min_pbc_fraction', config_min_pbc_fraction) + ! mrp note end: move to subroutine and different name list later. change pbc to vertical_cell + + iErr = 0 + + if (maxLevelCell > 0) then + if (config_alter_ICs_for_pbcs) then + + if (config_pbc_alteration_type .eq. 'partial_cell') then + ! Change value of maxLevelCell for partial bottom cells + k = maxLevelCell + minBottomDepth = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*(refBottomDepth(k) - refBottomDepth(k-1)) + minBottomDepthMid = 0.5*(minBottomDepth + refBottomDepth(k-1)) + if (bottomDepth .lt. minBottomDepthMid) then + ! Round up to cell above + maxLevelCell = maxLevelCell - 1 + bottomDepth = refBottomDepth(maxLevelCell) + else if (bottomDepth .lt. minBottomDepth) then + ! Round down cell to the min_pbc_fraction. + bottomDepth = minBottomDepth + end if + ! reset k to new value of maxLevelCell + k = maxLevelCell + + elseif (config_pbc_alteration_type .eq. 'full_cell') then + bottomDepth = refBottomDepth(maxLevelCell) + else + write (stderrUnit,*) ' Error: Incorrect choice of config_pbc_alteration_type: ', config_pbc_alteration_type + iErr = 1 + ! call mpas_dmpar_abort(domain % dminfo) + endif + endif + endif + + end subroutine ocn_alter_bottomDepth_for_pbcs + !*********************************************************************** ! ! routine ocn_init_setup_global_ocean_create_model_topo @@ -478,44 +541,46 @@ subroutine ocn_init_setup_global_ocean_create_model_topo(domain, iErr)!{{{ ! end do do iCell = 1, nCellsSolve - if (maxLevelCell(iCell) > 0) then - - ! substitute with a subroutine call later: - ! call ocn_alter_bottomDepth_for_pbcs( & - ! bottomDepth(iCell), refBottomDepth, ssh, & ! inputs - ! alteredBottomDepth(iCell), maxLevelCell(iCell), layerThickness(:,iCell), zMid(:,iCell) ) ! outputs - - if (config_alter_ICs_for_pbcs) then - -!!!!!!!!!!!!! this would be in a subroutine - ! subroutine ocn_initialize_z_level_vertical_coord - ! if (not.config_alter_ICs_for_pbcs) return ! but change flag name - - if (config_pbc_alteration_type .eq. 'partial_cell') then - ! Change value of maxLevelCell for partial bottom cells - k = maxLevelCell(iCell) - minBottomDepth = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*(refBottomDepth(k) - refBottomDepth(k-1)) - minBottomDepthMid = 0.5*(minBottomDepth + refBottomDepth(k-1)) - if (bottomDepth(iCell) .lt. minBottomDepthMid) then - ! Round up to cell above - maxLevelCell(iCell) = maxLevelCell(iCell) - 1 - bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) - else if (bottomDepth(iCell) .lt. minBottomDepth) then - ! Round down cell to the min_pbc_fraction. - bottomDepth(iCell) = minBottomDepth - end if - ! reset k to new value of maxLevelCell - k = maxLevelCell(iCell) - - elseif (config_pbc_alteration_type .eq. 'full_cell') then - bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) - else - write (stderrUnit,*) ' Incorrect choice of config_pbc_alteration_type.' - call mpas_dmpar_abort(domain % dminfo) - endif - -!!!!!!!!!!!!! this would be in a subroutine: end - endif !if (config_alter_ICs_for_pbcs) then + call ocn_alter_bottomDepth_for_pbcs(bottomDepth(iCell), refBottomDepth, maxLevelCell(iCell), iErr) + +! if (maxLevelCell(iCell) > 0) then + +! ! substitute with a subroutine call later: +! ! call ocn_alter_bottomDepth_for_pbcs( & +! ! bottomDepth(iCell), refBottomDepth, ssh, & ! inputs +! ! alteredBottomDepth(iCell), maxLevelCell(iCell), layerThickness(:,iCell), zMid(:,iCell) ) ! outputs + +! if (config_alter_ICs_for_pbcs) then + +! !!!!!!!!!!!!! this would be in a subroutine +! ! subroutine ocn_initialize_z_level_vertical_coord +! ! if (not.config_alter_ICs_for_pbcs) return ! but change flag name + +! if (config_pbc_alteration_type .eq. 'partial_cell') then +! ! Change value of maxLevelCell for partial bottom cells +! k = maxLevelCell(iCell) +! minBottomDepth = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*(refBottomDepth(k) - refBottomDepth(k-1)) +! minBottomDepthMid = 0.5*(minBottomDepth + refBottomDepth(k-1)) +! if (bottomDepth(iCell) .lt. minBottomDepthMid) then +! ! Round up to cell above +! maxLevelCell(iCell) = maxLevelCell(iCell) - 1 +! bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) +! else if (bottomDepth(iCell) .lt. minBottomDepth) then +! ! Round down cell to the min_pbc_fraction. +! bottomDepth(iCell) = minBottomDepth +! end if +! ! reset k to new value of maxLevelCell +! k = maxLevelCell(iCell) + +! elseif (config_pbc_alteration_type .eq. 'full_cell') then +! bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) +! else +! write (stderrUnit,*) ' Incorrect choice of config_pbc_alteration_type.' +! call mpas_dmpar_abort(domain % dminfo) +! endif + +! !!!!!!!!!!!!! this would be in a subroutine: end +! endif !if (config_alter_ICs_for_pbcs) then k = maxLevelCell(iCell) layerThickness(1:k,iCell) = refLayerThickness(1:k) @@ -530,7 +595,7 @@ subroutine ocn_init_setup_global_ocean_create_model_topo(domain, iErr)!{{{ zMid(k+1:nVertLevels,iCell) = 0.0_RKIND restingThickness(:, iCell) = layerThickness(:, iCell) - end if +! end if end do block_ptr => block_ptr % next From d6e5f6712d1f823cdffc3b10d649e3d46a3363e8 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Mon, 19 Oct 2015 09:08:52 -0600 Subject: [PATCH 0316/1724] Clean up, remove old code. --- .../mode_init/mpas_ocn_init_global_ocean.F | 138 ++++++------------ 1 file changed, 43 insertions(+), 95 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F index 76fc660b5a..3f81fbeaa2 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F @@ -247,7 +247,6 @@ subroutine ocn_init_setup_global_ocean_read_topo(domain, iErr)!{{{ end subroutine ocn_init_setup_global_ocean_read_topo!}}} - !*********************************************************************** ! ! routine ocn_compute_layerThickness_zMid_from_bottomDepth @@ -260,21 +259,39 @@ end subroutine ocn_init_setup_global_ocean_read_topo!}}} ! !----------------------------------------------------------------------- - subroutine ocn_compute_layerThickness_zMid_from_bottomDepth(LayerThicknessCol,ZMidCol,BottomDepthCol,kMax,iErr)!{{{ - real (kind=RKIND), dimension(kMax), intent(out) :: LayerThicknessCol, ZMidCol - real (kind=RKIND), dimension(kMax), intent(in) :: BottomDepthCol - integer, intent(in) :: kMax + subroutine ocn_compute_layerThickness_zMid_from_bottomDepth(layerThickness,zMid,refBottomDepth,bottomDepth,maxLevelCell,nVertLevels,iErr)!{{{ + real (kind=RKIND), dimension(nVertLevels), intent(out) :: layerThickness, zMid + real (kind=RKIND), dimension(nVertLevels), intent(in) :: refBottomDepth + real (kind=RKIND), intent(in) :: bottomDepth + integer, intent(in) :: maxLevelCell, nVertLevels integer, intent(out) :: iErr integer :: k iErr = 0 - LayerThicknessCol(1) = BottomDepthCol(1) - ZMidCol(1) = BottomDepthCol(1)/2.0 - do k = 2, kMax - LayerThicknessCol(k) = BottomDepthCol(k) - BottomDepthCol(k-1) - ZMidCol(k) = - BottomDepthCol(k-1) - LayerThicknessCol(k)/2.0 - end do + if (maxLevelCell<=0) then + return + elseif (maxLevelCell==1) then + layerThickness(1) = bottomDepth + zMid(1) = - refBottomDepth(1)/2.0 + else + layerThickness(1) = refBottomDepth(1) + zMid(1) = - refBottomDepth(1)/2.0 + + do k = 2, maxLevelCell-1 + layerThickness(k) = refBottomDepth(k) - refBottomDepth(k-1) + zMid(k) = - refBottomDepth(k-1) - layerThickness(k)/2.0 + end do + + k = maxLevelCell + layerThickness(k) = bottomDepth - refBottomDepth(k-1) + zMid(k) = - refBottomDepth(k-1) - layerThickness(k)/2.0 + + do k = maxLevelCell+1, nVertLevels + layerThickness(k) = 0.0_RKIND + zMid(k) = 0.0_RKIND + end do + endif end subroutine ocn_compute_layerThickness_zMid_from_bottomDepth !}}} @@ -282,9 +299,9 @@ end subroutine ocn_compute_layerThickness_zMid_from_bottomDepth !}}} ! ! routine ocn_alter_bottomDepth_for_pbcs ! -!> \brief Interpolate the topography IC to MPAS mesh +!> \brief Alter bottom depth for partial bottom cells !> \author Mark Petersen -!> \date 10/17/2015 +!> \date 10/19/2015 !> \details !> This routine alters the bottom depth in a single column based on pbc settings ! @@ -297,7 +314,6 @@ subroutine ocn_alter_bottomDepth_for_pbcs(bottomDepth, refBottomDepth, maxLevelC integer, intent(out) :: iErr integer :: k - ! mrp note: move to subroutine and different name list later. change pbc to vertical_cell logical, pointer :: config_alter_ICs_for_pbcs real (kind=RKIND) :: minBottomDepth, minBottomDepthMid real (kind=RKIND), pointer :: config_min_pbc_fraction @@ -305,11 +321,10 @@ subroutine ocn_alter_bottomDepth_for_pbcs(bottomDepth, refBottomDepth, maxLevelC call mpas_pool_get_config(ocnConfigs, 'config_alter_ICs_for_pbcs', config_alter_ICs_for_pbcs) call mpas_pool_get_config(ocnConfigs, 'config_pbc_alteration_type', config_pbc_alteration_type) call mpas_pool_get_config(ocnConfigs, 'config_min_pbc_fraction', config_min_pbc_fraction) - ! mrp note end: move to subroutine and different name list later. change pbc to vertical_cell iErr = 0 - if (maxLevelCell > 0) then + if (maxLevelCell > 1) then if (config_alter_ICs_for_pbcs) then if (config_pbc_alteration_type .eq. 'partial_cell') then @@ -325,15 +340,11 @@ subroutine ocn_alter_bottomDepth_for_pbcs(bottomDepth, refBottomDepth, maxLevelC ! Round down cell to the min_pbc_fraction. bottomDepth = minBottomDepth end if - ! reset k to new value of maxLevelCell - k = maxLevelCell - elseif (config_pbc_alteration_type .eq. 'full_cell') then bottomDepth = refBottomDepth(maxLevelCell) else write (stderrUnit,*) ' Error: Incorrect choice of config_pbc_alteration_type: ', config_pbc_alteration_type iErr = 1 - ! call mpas_dmpar_abort(domain % dminfo) endif endif endif @@ -381,15 +392,6 @@ subroutine ocn_init_setup_global_ocean_create_model_topo(domain, iErr)!{{{ logical, pointer :: config_global_ocean_smooth_topography real (kind=RKIND), pointer :: config_global_ocean_minimum_depth -! mrp note: move to subroutine and different name list later. change pbc to vertical_cell - logical, pointer :: config_alter_ICs_for_pbcs - real (kind=RKIND) :: minBottomDepth, minBottomDepthMid - real (kind=RKIND), pointer :: config_min_pbc_fraction - character (len=StrKIND), pointer :: config_pbc_alteration_type - call mpas_pool_get_config(domain % configs, 'config_alter_ICs_for_pbcs', config_alter_ICs_for_pbcs) - call mpas_pool_get_config(domain % configs, 'config_pbc_alteration_type', config_pbc_alteration_type) - call mpas_pool_get_config(domain % configs, 'config_min_pbc_fraction', config_min_pbc_fraction) -! mrp note end: move to subroutine and different name list later. change pbc to vertical_cell iErr = 0 @@ -510,7 +512,6 @@ subroutine ocn_init_setup_global_ocean_create_model_topo(domain, iErr)!{{{ call mpas_pool_get_field(meshPool, 'maxLevelCell', maxLevelCellField) call mpas_dmpar_exch_halo_field(maxLevelCellField) - ! Set layerThickness based on refBottomDepth and bottomDepth block_ptr => domain % blocklist do while(associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) @@ -531,79 +532,26 @@ subroutine ocn_init_setup_global_ocean_create_model_topo(domain, iErr)!{{{ call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) -! move this to subroutine later - call ocn_compute_layerThickness_zMid_from_bottomDepth(refLayerThickness,refZMid,refBottomDepth,nVertLevels,iErr) -! refLayerThickness(1) = refBottomDepth(1) -! refZMid(1) = refBottomDepth(1)/2.0 -! do k = 2, nVertLevels -! refLayerThickness(k) = refBottomDepth(k) - refBottomDepth(k-1) -! refZMid(k) = - refBottomDepth(k-1) - refLayerThickness(k)/2.0 -! end do + ! Compute refLayerThickness and refZMid + call ocn_compute_layerThickness_zMid_from_bottomDepth(refLayerThickness,refZMid, & + refBottomDepth,refBottomDepth(nVertLevels), & + nVertLevels,nVertLevels,iErr) do iCell = 1, nCellsSolve - call ocn_alter_bottomDepth_for_pbcs(bottomDepth(iCell), refBottomDepth, maxLevelCell(iCell), iErr) - -! if (maxLevelCell(iCell) > 0) then - -! ! substitute with a subroutine call later: -! ! call ocn_alter_bottomDepth_for_pbcs( & -! ! bottomDepth(iCell), refBottomDepth, ssh, & ! inputs -! ! alteredBottomDepth(iCell), maxLevelCell(iCell), layerThickness(:,iCell), zMid(:,iCell) ) ! outputs - -! if (config_alter_ICs_for_pbcs) then - -! !!!!!!!!!!!!! this would be in a subroutine -! ! subroutine ocn_initialize_z_level_vertical_coord -! ! if (not.config_alter_ICs_for_pbcs) return ! but change flag name - -! if (config_pbc_alteration_type .eq. 'partial_cell') then -! ! Change value of maxLevelCell for partial bottom cells -! k = maxLevelCell(iCell) -! minBottomDepth = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*(refBottomDepth(k) - refBottomDepth(k-1)) -! minBottomDepthMid = 0.5*(minBottomDepth + refBottomDepth(k-1)) -! if (bottomDepth(iCell) .lt. minBottomDepthMid) then -! ! Round up to cell above -! maxLevelCell(iCell) = maxLevelCell(iCell) - 1 -! bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) -! else if (bottomDepth(iCell) .lt. minBottomDepth) then -! ! Round down cell to the min_pbc_fraction. -! bottomDepth(iCell) = minBottomDepth -! end if -! ! reset k to new value of maxLevelCell -! k = maxLevelCell(iCell) - -! elseif (config_pbc_alteration_type .eq. 'full_cell') then -! bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) -! else -! write (stderrUnit,*) ' Incorrect choice of config_pbc_alteration_type.' -! call mpas_dmpar_abort(domain % dminfo) -! endif - -! !!!!!!!!!!!!! this would be in a subroutine: end -! endif !if (config_alter_ICs_for_pbcs) then - - k = maxLevelCell(iCell) - layerThickness(1:k,iCell) = refLayerThickness(1:k) - zMid(1:k,iCell) = refZMid(1:k) - - if (config_alter_ICs_for_pbcs.and.config_pbc_alteration_type .eq. 'partial_cell') then - layerThickness(k,iCell) = bottomDepth(iCell) - refBottomDepth(k-1) - zMid(k,iCell) = - refBottomDepth(k-1) - layerThickness(k,iCell)/2.0 - end if - - layerThickness(k+1:nVertLevels,iCell) = 0.0_RKIND - zMid(k+1:nVertLevels,iCell) = 0.0_RKIND + call ocn_alter_bottomDepth_for_pbcs(bottomDepth(iCell), refBottomDepth, maxLevelCell(iCell), iErr) - restingThickness(:, iCell) = layerThickness(:, iCell) -! end if + ! Compute LayerThickness and zMid + call ocn_compute_layerThickness_zMid_from_bottomDepth(layerThickness(:,iCell),zMid(:,iCell), & + refBottomDepth,bottomDepth(iCell), & + maxLevelCell(iCell),nVertLevels,iErr) + + ! Compute restingThickness + restingThickness(:, iCell) = layerThickness(:, iCell) end do block_ptr => block_ptr % next end do -!!! this is temp: -! deallocate(minBottomDepth,minBottomDepthMid) - end subroutine ocn_init_setup_global_ocean_create_model_topo!}}} !*********************************************************************** From 0894eb01c7a76062bfbeb0773dd5548b879c357a Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Mon, 19 Oct 2015 12:36:44 -0600 Subject: [PATCH 0317/1724] Move general initialization routines to init_vertical_grids --- .../mode_init/mpas_ocn_init_global_ocean.F | 105 +---------------- .../mode_init/mpas_ocn_init_vertical_grids.F | 109 +++++++++++++++++- 2 files changed, 109 insertions(+), 105 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F index 3f81fbeaa2..4693e89228 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_global_ocean.F @@ -31,6 +31,7 @@ module ocn_init_global_ocean use ocn_constants use ocn_init_cell_markers + use ocn_init_vertical_grids implicit none private @@ -247,110 +248,6 @@ subroutine ocn_init_setup_global_ocean_read_topo(domain, iErr)!{{{ end subroutine ocn_init_setup_global_ocean_read_topo!}}} -!*********************************************************************** -! -! routine ocn_compute_layerThickness_zMid_from_bottomDepth -! -!> \brief Compute auxiliary z-variables from bottomDepth -!> \author Mark Petersen -!> \date 10/17/2015 -!> \details -!> This routine computes auxiliary z-variables from bottomDepth -! -!----------------------------------------------------------------------- - - subroutine ocn_compute_layerThickness_zMid_from_bottomDepth(layerThickness,zMid,refBottomDepth,bottomDepth,maxLevelCell,nVertLevels,iErr)!{{{ - real (kind=RKIND), dimension(nVertLevels), intent(out) :: layerThickness, zMid - real (kind=RKIND), dimension(nVertLevels), intent(in) :: refBottomDepth - real (kind=RKIND), intent(in) :: bottomDepth - integer, intent(in) :: maxLevelCell, nVertLevels - integer, intent(out) :: iErr - integer :: k - - iErr = 0 - - if (maxLevelCell<=0) then - return - elseif (maxLevelCell==1) then - layerThickness(1) = bottomDepth - zMid(1) = - refBottomDepth(1)/2.0 - else - layerThickness(1) = refBottomDepth(1) - zMid(1) = - refBottomDepth(1)/2.0 - - do k = 2, maxLevelCell-1 - layerThickness(k) = refBottomDepth(k) - refBottomDepth(k-1) - zMid(k) = - refBottomDepth(k-1) - layerThickness(k)/2.0 - end do - - k = maxLevelCell - layerThickness(k) = bottomDepth - refBottomDepth(k-1) - zMid(k) = - refBottomDepth(k-1) - layerThickness(k)/2.0 - - do k = maxLevelCell+1, nVertLevels - layerThickness(k) = 0.0_RKIND - zMid(k) = 0.0_RKIND - end do - endif - - end subroutine ocn_compute_layerThickness_zMid_from_bottomDepth !}}} - -!*********************************************************************** -! -! routine ocn_alter_bottomDepth_for_pbcs -! -!> \brief Alter bottom depth for partial bottom cells -!> \author Mark Petersen -!> \date 10/19/2015 -!> \details -!> This routine alters the bottom depth in a single column based on pbc settings -! -!----------------------------------------------------------------------- - subroutine ocn_alter_bottomDepth_for_pbcs(bottomDepth, refBottomDepth, maxLevelCell, iErr) - - real (kind=RKIND), intent(inout) :: bottomDepth - integer, intent(inout) :: maxLevelCell - real (kind=RKIND), dimension(maxLevelCell), intent(in) :: refBottomDepth - integer, intent(out) :: iErr - integer :: k - - logical, pointer :: config_alter_ICs_for_pbcs - real (kind=RKIND) :: minBottomDepth, minBottomDepthMid - real (kind=RKIND), pointer :: config_min_pbc_fraction - character (len=StrKIND), pointer :: config_pbc_alteration_type - call mpas_pool_get_config(ocnConfigs, 'config_alter_ICs_for_pbcs', config_alter_ICs_for_pbcs) - call mpas_pool_get_config(ocnConfigs, 'config_pbc_alteration_type', config_pbc_alteration_type) - call mpas_pool_get_config(ocnConfigs, 'config_min_pbc_fraction', config_min_pbc_fraction) - - iErr = 0 - - if (maxLevelCell > 1) then - if (config_alter_ICs_for_pbcs) then - - if (config_pbc_alteration_type .eq. 'partial_cell') then - ! Change value of maxLevelCell for partial bottom cells - k = maxLevelCell - minBottomDepth = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*(refBottomDepth(k) - refBottomDepth(k-1)) - minBottomDepthMid = 0.5*(minBottomDepth + refBottomDepth(k-1)) - if (bottomDepth .lt. minBottomDepthMid) then - ! Round up to cell above - maxLevelCell = maxLevelCell - 1 - bottomDepth = refBottomDepth(maxLevelCell) - else if (bottomDepth .lt. minBottomDepth) then - ! Round down cell to the min_pbc_fraction. - bottomDepth = minBottomDepth - end if - elseif (config_pbc_alteration_type .eq. 'full_cell') then - bottomDepth = refBottomDepth(maxLevelCell) - else - write (stderrUnit,*) ' Error: Incorrect choice of config_pbc_alteration_type: ', config_pbc_alteration_type - iErr = 1 - endif - endif - endif - - end subroutine ocn_alter_bottomDepth_for_pbcs - !*********************************************************************** ! ! routine ocn_init_setup_global_ocean_create_model_topo diff --git a/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F index 2440cf6222..fa6829c5cf 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F @@ -43,7 +43,9 @@ module ocn_init_vertical_grids ! !-------------------------------------------------------------------- - public :: ocn_generate_vertical_grid + public :: ocn_generate_vertical_grid, & + ocn_compute_layerThickness_zMid_from_bottomDepth, & + ocn_alter_bottomDepth_for_pbcs !-------------------------------------------------------------------- ! @@ -490,6 +492,111 @@ subroutine ocn_generate_1dCVT_vertical_grid(configPool, interfaceLocations)!{{{ end subroutine ocn_generate_1dCVT_vertical_grid!}}} + +!*********************************************************************** +! +! routine ocn_compute_layerThickness_zMid_from_bottomDepth +! +!> \brief Compute auxiliary z-variables from bottomDepth +!> \author Mark Petersen +!> \date 10/17/2015 +!> \details +!> This routine computes auxiliary z-variables from bottomDepth +! +!----------------------------------------------------------------------- + + subroutine ocn_compute_layerThickness_zMid_from_bottomDepth(layerThickness,zMid,refBottomDepth,bottomDepth,maxLevelCell,nVertLevels,iErr)!{{{ + real (kind=RKIND), dimension(nVertLevels), intent(out) :: layerThickness, zMid + real (kind=RKIND), dimension(nVertLevels), intent(in) :: refBottomDepth + real (kind=RKIND), intent(in) :: bottomDepth + integer, intent(in) :: maxLevelCell, nVertLevels + integer, intent(out) :: iErr + integer :: k + + iErr = 0 + + if (maxLevelCell<=0) then + return + elseif (maxLevelCell==1) then + layerThickness(1) = bottomDepth + zMid(1) = - refBottomDepth(1)/2.0 + else + layerThickness(1) = refBottomDepth(1) + zMid(1) = - refBottomDepth(1)/2.0 + + do k = 2, maxLevelCell-1 + layerThickness(k) = refBottomDepth(k) - refBottomDepth(k-1) + zMid(k) = - refBottomDepth(k-1) - layerThickness(k)/2.0 + end do + + k = maxLevelCell + layerThickness(k) = bottomDepth - refBottomDepth(k-1) + zMid(k) = - refBottomDepth(k-1) - layerThickness(k)/2.0 + + do k = maxLevelCell+1, nVertLevels + layerThickness(k) = 0.0_RKIND + zMid(k) = 0.0_RKIND + end do + endif + + end subroutine ocn_compute_layerThickness_zMid_from_bottomDepth !}}} + +!*********************************************************************** +! +! routine ocn_alter_bottomDepth_for_pbcs +! +!> \brief Alter bottom depth for partial bottom cells +!> \author Mark Petersen +!> \date 10/19/2015 +!> \details +!> This routine alters the bottom depth in a single column based on pbc settings +! +!----------------------------------------------------------------------- + subroutine ocn_alter_bottomDepth_for_pbcs(bottomDepth, refBottomDepth, maxLevelCell, iErr) + + real (kind=RKIND), intent(inout) :: bottomDepth + integer, intent(inout) :: maxLevelCell + real (kind=RKIND), dimension(maxLevelCell), intent(in) :: refBottomDepth + integer, intent(out) :: iErr + integer :: k + + logical, pointer :: config_alter_ICs_for_pbcs + real (kind=RKIND) :: minBottomDepth, minBottomDepthMid + real (kind=RKIND), pointer :: config_min_pbc_fraction + character (len=StrKIND), pointer :: config_pbc_alteration_type + call mpas_pool_get_config(ocnConfigs, 'config_alter_ICs_for_pbcs', config_alter_ICs_for_pbcs) + call mpas_pool_get_config(ocnConfigs, 'config_pbc_alteration_type', config_pbc_alteration_type) + call mpas_pool_get_config(ocnConfigs, 'config_min_pbc_fraction', config_min_pbc_fraction) + + iErr = 0 + + if (maxLevelCell > 1) then + if (config_alter_ICs_for_pbcs) then + + if (config_pbc_alteration_type .eq. 'partial_cell') then + ! Change value of maxLevelCell for partial bottom cells + k = maxLevelCell + minBottomDepth = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*(refBottomDepth(k) - refBottomDepth(k-1)) + minBottomDepthMid = 0.5*(minBottomDepth + refBottomDepth(k-1)) + if (bottomDepth .lt. minBottomDepthMid) then + ! Round up to cell above + maxLevelCell = maxLevelCell - 1 + bottomDepth = refBottomDepth(maxLevelCell) + else if (bottomDepth .lt. minBottomDepth) then + ! Round down cell to the min_pbc_fraction. + bottomDepth = minBottomDepth + end if + elseif (config_pbc_alteration_type .eq. 'full_cell') then + bottomDepth = refBottomDepth(maxLevelCell) + else + write (stderrUnit,*) ' Error: Incorrect choice of config_pbc_alteration_type: ', config_pbc_alteration_type + iErr = 1 + endif + endif + endif + + end subroutine ocn_alter_bottomDepth_for_pbcs + !*********************************************************************** end module ocn_init_vertical_grids From 28f46bfa2c4b101f0eae5c8b1be4807c5e31d137 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Mon, 19 Oct 2015 14:39:56 -0600 Subject: [PATCH 0318/1724] Fix typo on zMid --- src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F index fa6829c5cf..bb8aa729c8 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F @@ -519,7 +519,7 @@ subroutine ocn_compute_layerThickness_zMid_from_bottomDepth(layerThickness,zMid, return elseif (maxLevelCell==1) then layerThickness(1) = bottomDepth - zMid(1) = - refBottomDepth(1)/2.0 + zMid(1) = - bottomDepth/2.0 else layerThickness(1) = refBottomDepth(1) zMid(1) = - refBottomDepth(1)/2.0 From 6fef08c774bbbb6ae14827f62eae066b2060bc2a Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 19 Oct 2015 19:17:12 -0600 Subject: [PATCH 0319/1724] Add option to disable name mangling in interface Currently the Fortran to C++ interface for external velocity solvers uses a series of preprocessor #define's to deal with the different way that Fortran and C++ use underscores in routine/function names. However, on some machine configurations it may be required to NOT do this, namely, on Mira where the Fortran and C++ compilers that must be used are from different vendors. This commit adds "#ifndef MPASLI_EXTERNAL_INTERFACE_DISABLE_MANGLING" around the #define's to provide the possibility for avoiding this. Currently this variable is only set within ACME and is not used at all in standalone MPAS. --- src/core_landice/mode_forward/Interface_velocity_solver.hpp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.hpp b/src/core_landice/mode_forward/Interface_velocity_solver.hpp index 5441d31302..b9bc36f7b7 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.hpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.hpp @@ -35,6 +35,7 @@ #include #include +#ifndef MPASLI_EXTERNAL_INTERFACE_DISABLE_MANGLING #define velocity_solver_init_mpi velocity_solver_init_mpi_ #define velocity_solver_finalize velocity_solver_finalize_ #define velocity_solver_init_l1l2 velocity_solver_init_l1l2_ @@ -50,6 +51,7 @@ #define velocity_solver_export_2d_data velocity_solver_export_2d_data_ #define velocity_solver_export_fo_velocity velocity_solver_export_fo_velocity_ #define velocity_solver_estimate_SS_SMB velocity_solver_estimate_ss_smb_ +#endif //#include //#include From 193a6dd911cd176bd1cae724bc33301240e7f1db Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 17 Aug 2015 09:39:48 -0600 Subject: [PATCH 0320/1724] Add betaSolve variable to be used by velo solver This commit makes it so there are two beta fields in the model when a HO dycore is being used. 'beta' is still the field that is input by the user. 'betaSolve' is a copy of 'beta' that is updated on each time step to be 0 where the ice is floating. This allows for grounding line movement while retaining a beta field that can cover the entire domain. --- src/core_landice/Registry.xml | 4 ++++ .../mode_forward/mpas_li_diagnostic_vars.F | 13 ++++++++++++- .../mode_forward/mpas_li_velocity_external.F | 12 ++++++------ 3 files changed, 22 insertions(+), 7 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index b273b2a387..9f3983b6e5 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -689,6 +689,10 @@ is the value of that variable from the *previous* time level! description="higher-order basal traction parameter" packages="higherOrderVelocity" /> + block % next end do - ! This information is only needed by external dycores. + ! This halo update is only needed by external dycores. if (config_velocity_solver /= 'sia') then ! Update halos on masks - the outermost cells/edges/vertices may be wrong for mask components that need neighbor information call mpas_timer_start("halo updates") @@ -645,6 +646,16 @@ subroutine diagnostic_solve_before_velocity(domain, err)!{{{ ! Determine if any blocks on this processor had a change to the vertex mask procDirichletMaskChanged = max(procDirichletMaskChanged, blockDirichletMaskChanged) + ! -- Set beta to 0 under floating ice -- + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(velocityPool, 'beta', beta) + call mpas_pool_get_array(velocityPool, 'betaSolve', betaSolve) + where (li_mask_is_floating_ice(cellMask)) + betaSolve = 0.0_RKIND + elsewhere + betaSolve = beta + end where + block => block % next end do diff --git a/src/core_landice/mode_forward/mpas_li_velocity_external.F b/src/core_landice/mode_forward/mpas_li_velocity_external.F index a1a8194add..2415582c8f 100644 --- a/src/core_landice/mode_forward/mpas_li_velocity_external.F +++ b/src/core_landice/mode_forward/mpas_li_velocity_external.F @@ -392,7 +392,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc !----------------------------------------------------------------- integer, pointer :: index_temperature real (kind=RKIND), dimension(:), pointer :: & - thickness, lowerSurface, upperSurface, layerThicknessFractions, beta, sfcMassBal + thickness, lowerSurface, upperSurface, layerThicknessFractions, betaSolve, sfcMassBal real (kind=RKIND), dimension(:,:), pointer :: & normalVelocity, uReconstructX, uReconstructY, uReconstructZ real (kind=RKIND), dimension(:,:,:), pointer :: & @@ -435,7 +435,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX) call mpas_pool_get_array(velocityPool, 'uReconstructY', uReconstructY) call mpas_pool_get_array(velocityPool, 'uReconstructZ', uReconstructZ) - call mpas_pool_get_array(velocityPool, 'beta', beta) + call mpas_pool_get_array(velocityPool, 'betaSolve', betaSolve) call mpas_pool_get_array(velocityPool, 'anyDynamicVertexMaskChanged', anyDynamicVertexMaskChanged) call mpas_pool_get_array(velocityPool, 'dirichletMaskChanged', dirichletMaskChanged) call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel = 1) @@ -475,7 +475,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc case ('L1L2') ! =============================================== #ifdef USE_EXTERNAL_L1L2 call mpas_timer_start("velocity_solver_solve_L1L2") - call velocity_solver_solve_L1L2(lowerSurface, thickness, beta, tracers(index_temperature,:,:), & + call velocity_solver_solve_L1L2(lowerSurface, thickness, betaSolve, tracers(index_temperature,:,:), & uReconstructX, uReconstructY, & ! Dirichlet boundary values to apply where dirichletVelocityMask=1 normalVelocity, uReconstructX, uReconstructY) ! return values ! call velocity_solver_estimate_SS_SMB(normalVelocity, mesh % sfcMassBal % array) @@ -484,7 +484,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc if (config_output_external_velocity_solver_data) then ! Optional calls to have LifeV output data files call mpas_timer_start("velocity_solver export") - call velocity_solver_export_2d_data(lowerSurface, thickness, beta) + call velocity_solver_export_2d_data(lowerSurface, thickness, betaSolve) call velocity_solver_export_L1L2_velocity(); call mpas_timer_stop("velocity_solver export") endif @@ -497,7 +497,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc case ('FO') ! =============================================== #ifdef USE_EXTERNAL_FIRSTORDER call mpas_timer_start("velocity_solver_solve_FO") - call velocity_solver_solve_FO(lowerSurface, thickness, beta, sfcMassBal, tracers(index_temperature,:,:), & + call velocity_solver_solve_FO(lowerSurface, thickness, betaSolve, sfcMassBal, tracers(index_temperature,:,:), & uReconstructX, uReconstructY, & ! Dirichlet boundary values to apply where dirichletVelocityMask=1 normalVelocity, uReconstructX, uReconstructY, deltat) ! return values ! call velocity_solver_estimate_SS_SMB(normalVelocity, mesh % sfcMassBal % array) ! this was used only for some ice2sea experiments, and is not a general routine to use @@ -517,7 +517,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc case ('Stokes') ! =============================================== #ifdef USE_EXTERNAL_STOKES call mpas_timer_start("velocity_solver_solve_stokes") - call velocity_solver_solve_stokes(lowerSurface, thickness, beta, tracers(index_temperature,:,:), & + call velocity_solver_solve_stokes(lowerSurface, thickness, betaSolve, tracers(index_temperature,:,:), & uReconstructX, uReconstructY, & ! Dirichlet boundary values to apply where dirichletVelocityMask=1 normalVelocity, uReconstructX, uReconstructY, uReconstructZ) ! return values uReconstructZ = uReconstructZ / (365.0*24.0*3600.0) ! convert from m/yr to m/s From 08428469db7b709c18c6c56f82371121ffb9ceb0 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 17 Aug 2015 13:37:10 -0600 Subject: [PATCH 0321/1724] Add in basal mass balance to geometry evolution There are two components to basal mass balance: groundedBasalMassBal - to be calculated internally by heat balance once it is added floatingBasalMassBal - input to the model from file or climate model These two fields are combined on each time step into the field basalMassBal which is what is actually used during evolution. Therefore basalMassBal is a useful output field but it is not an input field. --- src/core_landice/Registry.xml | 12 +++- .../mode_forward/mpas_li_tendency.F | 58 +++++++++---------- 2 files changed, 38 insertions(+), 32 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 9f3983b6e5..7fcbcadb80 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -332,6 +332,7 @@ + @@ -406,7 +407,6 @@ - @@ -629,8 +629,14 @@ is the value of that variable from the *previous* time level! description="Surface mass balance" /> + description="Basal mass balance applied" + /> + + mesh % marineBasalMassBal % array -!!! iceArea => state % iceArea % array -!!! areaCell => mesh % areaCell % array call mpas_pool_get_config(liConfigs, 'config_thickness_advection', config_thickness_advection) call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) @@ -204,36 +206,34 @@ subroutine li_tendency_thickness(meshPool, velocityPool, geometryPool, layerThic case ('None') !=================================================== ! Do nothing - don't add the MB case default -! Commenting BMB out for now. -!!! ! Make some potential adjustments to BMB before applying them. -!!! ! It's ok to overwrite the values with 0's here, because each time step -!!! ! we get a fresh copy of the array from the annual_forcing subroutine. -!!! ! 1. make adjustments for where the ice is grounded and floating. -!!! ! TODO: more complicated treatment at GL? -!!! where ( li_mask_is_grounded_ice(cellMask) ) -!!! ! Apply marineBasalMassBal to floating ice only. -!!! marineBasalMassBal = 0.0_RKIND -!!! elsewhere ( li_mask_is_floating_ice(cellMask) ) -!!! ! Currently, floating and grounded ice are mutually exclusive. -!!! ! This could change if the GL is parameterized, in which case this logic may need adjustment. -!!! ! Grounded BMB should come from the temperature solver. -!!! ! < PLACEHOLDER > -!!! elsewhere ( .not. (li_mask_is_ice(cellMask) ) -!!! ! We don't allow a positive BMB where ice is not already present. -!!! mesh % marineBasalMassBal % array = 0.0_RKIND -!!! end where + + ! Combine various basal mass balnce fields based on mask + ! 1. make adjustments for where the ice is grounded and floating. + ! TODO: more complicated treatment at GL? + where ( li_mask_is_grounded_ice(cellMask) ) + ! Apply marineBasalMassBal to floating ice only. + basalMassBal = groundedBasalMassBal + elsewhere ( li_mask_is_floating_ice(cellMask) ) + ! Currently, floating and grounded ice are mutually exclusive. + ! This could change if the GL is parameterized, in which case this logic may need adjustment. + ! Grounded BMB should come from the temperature solver. + basalMassBal = floatingBasalMassBal + elsewhere ( .not. (li_mask_is_ice(cellMask) ) ) + ! We don't allow a positive BMB where ice is not already present. + basalMassBal = 0.0_RKIND + end where ! Add surface mass balance to tendency ! TODO: Need to decide how to deal with negative SMB that eliminates top layer or all ice (check for negative thickness?) layerThickness_tend(1,:) = layerThickness_tend(1,:) + sfcMassBal / config_ice_density ! (tendency in meters per year) ! TODO THIS MIGHT RESULT IN NEGATIVE LAYER THICKNESS! -!!! ! Add basal mass balance to tendency -!!! ! TODO: Need to decide how to deal with negative BMB that eliminates top layer or all ice (check for negative thickness?) -!!! layerThickness_tend(nVertLevels,:) = layerThickness_tend(nVertLevels,:) & -!!! + mesh % marineBasalMassBal % array ! (tendency in meters per year) -!!! ! TODO Add in grounded ice basal mass balance once temperature diffusion is calculated -!!! ! TODO THIS MIGHT RESULT IN NEGATIVE LAYER THICKNESS! + ! Add basal mass balance to tendency + ! TODO: Need to decide how to deal with negative BMB that eliminates top layer or all ice (check for negative thickness?) + layerThickness_tend(nVertLevels,:) = layerThickness_tend(nVertLevels,:) & + + basalMassBal / config_ice_density ! (tendency in meters per year) + ! TODO THIS MIGHT RESULT IN NEGATIVE LAYER THICKNESS! + end select ! === error check From e026d0d8832cbdf01f454827af6a4243c47a92f0 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 17 Aug 2015 13:45:48 -0600 Subject: [PATCH 0322/1724] Add packages to HO input/restart variables This way those fields will only be attempted to be read if a HO dycore is being used. This commit also adds dirichletVelocityMask as a restart field so that time-evolving runs with Dirichlet b.c. will work correctly (e.g. MISMIP). Note that this means that this extra field will be present in all HO restart files even if they don't use Dirichlet b.c. --- src/core_landice/Registry.xml | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 7fcbcadb80..857c521ec6 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -335,10 +335,10 @@ - - - - + + + + - - - - - + + + + + + + From 0c386b0ece16bb0333c2db292421a2e96001ab81 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 1 Sep 2015 09:38:14 -0600 Subject: [PATCH 0323/1724] Check for valid triangles when setting vertexMask With this change vertices are only considered 'valid' if they have three valid neighboring cells (i.e., the cells exist in the mesh). This allows external dycores to use the vertexMask to get information about triangles in the Delaunay triangulation. This is done in a way which does not assume vertexMask==3, but the triangular dual mesh is the intended purpose for this. --- src/core_landice/shared/mpas_li_mask.F | 27 +++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/src/core_landice/shared/mpas_li_mask.F b/src/core_landice/shared/mpas_li_mask.F index d85d65333b..cf8cca8a05 100644 --- a/src/core_landice/shared/mpas_li_mask.F +++ b/src/core_landice/shared/mpas_li_mask.F @@ -251,7 +251,8 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) logical :: isMargin logical :: aCellOnVertexHasIce, aCellOnVertexHasNoIce, aCellOnVertexHasDynamicIce, aCellOnVertexHasNoDynamicIce, aCellOnVertexIsFloating logical :: aCellOnEdgeHasIce, aCellOnEdgeHasNoIce, aCellOnEdgeHasDynamicIce, aCellOnEdgeHasNoDynamicIce, aCellOnEdgeIsFloating - + integer :: numCellsOnVertex + logical :: validVertex err = 0 @@ -350,6 +351,10 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) ! Bit: Floating vertices have at least one neighboring cell floating ! Bit: Vertices on margin are vertices with at least one neighboring cell with ice and at least one neighboring cell without ice ! Bit: Vertices on dynamic margin are vertices with at least one neighboring cell with dynamic ice and at least one neighboring cell without dynamic ice + ! NOTE: Vertices are only considered 'valid' if they have three valid neighboring + ! cells (i.e., the cells exist in the mesh). This allows external dycores to use the + ! vertexMask to get information about triangles in the Delaunay triangulation. + ! (This is done in a way which does not assume vertexMask==3.) vertexMask = 0 do i = 1,nVertices aCellOnVertexHasIce = .false. @@ -357,27 +362,35 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) aCellOnVertexHasDynamicIce = .false. aCellOnVertexHasNoDynamicIce = .false. aCellOnVertexIsFloating = .false. + numCellsOnVertex = 0 + validVertex = .false. do j = 1, vertexDegree ! vertexDegree is usually 3 (e.g. CVT mesh) but could be something else (e.g. 4 for quad mesh) iCell = cellsOnVertex(j,i) + if (iCell < nCells+1) then + numCellsOnVertex = numCellsOnVertex + 1 + endif aCellOnVertexHasIce = (aCellOnVertexHasIce .or. li_mask_is_ice(cellMask(iCell))) aCellOnVertexHasNoIce = (aCellOnVertexHasNoIce .or. (.not. li_mask_is_ice(cellMask(iCell)))) aCellOnVertexHasDynamicIce = (aCellOnVertexHasDynamicIce .or. li_mask_is_dynamic_ice(cellMask(iCell))) aCellOnVertexHasNoDynamicIce = (aCellOnVertexHasNoDynamicIce .or. (.not. (li_mask_is_dynamic_ice(cellMask(iCell))))) aCellOnVertexIsFloating = (aCellOnVertexIsFloating .or. li_mask_is_floating_ice(cellMask(iCell))) - end do - if (aCellOnVertexHasIce) then + end do + if (numCellsOnVertex == vertexDegree) then + validVertex = .true. + endif + if (aCellOnVertexHasIce .and. validVertex) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueIce) endif - if (aCellOnVertexHasDynamicIce) then + if (aCellOnVertexHasDynamicIce .and. validVertex) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueDynamicIce) endif - if (aCellOnVertexIsFloating) then + if (aCellOnVertexIsFloating .and. validVertex) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueFloating) endif - if (aCellOnVertexHasIce .and. aCellOnVertexHasNoIce) then + if (aCellOnVertexHasIce .and. aCellOnVertexHasNoIce .and. validVertex) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueMargin) ! vertex with both 1+ ice cell and 1+ non-ice cell as neighbors endif - if (aCellOnVertexHasDynamicIce .and. aCellOnVertexHasNoDynamicIce) then + if (aCellOnVertexHasDynamicIce .and. aCellOnVertexHasNoDynamicIce .and. validVertex) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueDynamicMargin) ! vertex with both 1+ dynamic ice cell(s) and 1+ non-dynamic cell(s) as neighbors endif end do From 1a63c80d282bdc1f0b9fffc07b36d8fa92c5d710 Mon Sep 17 00:00:00 2001 From: Mauro Perego Date: Thu, 27 Aug 2015 16:10:20 -0600 Subject: [PATCH 0324/1724] Change way scalar fields are extended at floating boundaries in Interface Change implementation of fields (elevation, thickness, basal friction, etc.) extensions at floating boundaries. We now extend the fields only on floating boundary cells that do not have ice, looking at adjacent cells that have ice. Among adjacent cells with ice we pick the one with smallest elevation and copy the fields from that cell to the boundary one. In order to do that we need to pass the cellMask to the velocity solver interface. We do not check whether the cell mask changes in time or not, assuming for now that it changes only when the vertexMask changes. --- .../Interface_velocity_solver.cpp | 19 +++++++++++-------- .../Interface_velocity_solver.hpp | 2 +- .../mode_forward/mpas_li_velocity_external.F | 11 ++++++----- src/core_landice/shared/mpas_li_mask.F | 11 ++++++++--- 4 files changed, 26 insertions(+), 17 deletions(-) diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.cpp b/src/core_landice/mode_forward/Interface_velocity_solver.cpp index ef1dff7b55..7fb55eb670 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.cpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.cpp @@ -29,7 +29,7 @@ int nVertices, nEdges, nTriangles, nGlobalVertices, nGlobalEdges, int maxNEdgesOnCell_F; int const *cellsOnEdge_F, *cellsOnVertex_F, *verticesOnCell_F, *verticesOnEdge_F, *edgesOnCell_F, *indexToCellID_F, *nEdgesOnCells_F, - *dirichletCellsMask_F, *floatingEdgesMask_F, *verticesMask_F; + *cellsMask_F, *dirichletCellsMask_F, *floatingEdgesMask_F, *verticesMask_F; std::vector layersRatio, levelsNormalizedThickness; int nLayers; double const *xCell_F, *yCell_F, *zCell_F, *xVertex_F, *yVertex_F, *zVertex_F, *areaTriangle_F; @@ -495,9 +495,10 @@ void velocity_solver_finalize() { * */ -void velocity_solver_compute_2d_grid(int const* _verticesMask_F, int const* _dirichletCellsMask_F, int const* _floatingEdgesMask_F) { +void velocity_solver_compute_2d_grid(int const* _verticesMask_F, int const* _cellsMask_F, int const* _dirichletCellsMask_F, int const* _floatingEdgesMask_F) { int numProcs, me; + cellsMask_F = _cellsMask_F; verticesMask_F = _verticesMask_F; dirichletCellsMask_F = _dirichletCellsMask_F; floatingEdgesMask_F = _floatingEdgesMask_F; @@ -1301,9 +1302,9 @@ void import2DFields(double const * lowerSurface_F, double const * thickness_F, std::set::const_iterator iter; for (int iV = 0; iV < nVertices; iV++) { - if (isVertexBoundary[iV]) { + int fCell = vertexToFCell[iV]; + if (isVertexBoundary[iV] && !(cellsMask_F[fCell] & ice_present_bit_value)) { int c; - int fCell = vertexToFCell[iV]; int nEdg = nEdgesOnCells_F[fCell]; bool isFloating = false; for (int j = 0; (j < nEdg)&&(!isFloating); j++) { @@ -1311,17 +1312,19 @@ void import2DFields(double const * lowerSurface_F, double const * thickness_F, isFloating = (floatingEdgesMask_F[fEdge] != 0); } if(!isFloating) continue; + double elevTemp =1e10; for (int j = 0; j < nEdg; j++) { int fEdge = edgesOnCell_F[maxNEdgesOnCell_F * fCell + j] - 1; - bool keep = (mask[verticesOnEdge_F[2 * fEdge] - 1] & dynamic_ice_bit_value) - && (mask[verticesOnEdge_F[2 * fEdge + 1] - 1] & dynamic_ice_bit_value); - if (!keep) - continue; + // bool keep = (mask[verticesOnEdge_F[2 * fEdge] - 1] & dynamic_ice_bit_value) + // && (mask[verticesOnEdge_F[2 * fEdge + 1] - 1] & dynamic_ice_bit_value); + // if (!keep) + // continue; int c0 = cellsOnEdge_F[2 * fEdge] - 1; int c1 = cellsOnEdge_F[2 * fEdge + 1] - 1; c = (fCellToVertex[c0] == iV) ? c1 : c0; + if(!(cellsMask_F[c] & ice_present_bit_value)) continue; double elev = thickness_F[c] + lowerSurface_F[c]; // - 1e-8*std::sqrt(pow(xCell_F[c0],2)+std::pow(yCell_F[c0],2)); if (elevTemp > elev) { diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.hpp b/src/core_landice/mode_forward/Interface_velocity_solver.hpp index 5441d31302..915b4e7050 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.hpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.hpp @@ -101,7 +101,7 @@ void velocity_solver_solve_fo(double const* lowerSurface_F, double* xVelocityOnCell = 0, double* yVelocityOnCell = 0, double const * deltat = 0); -void velocity_solver_compute_2d_grid(int const* verticesMask_F, int const* dirichletNodesMask_F, int const* floatingEdgeMask_F); +void velocity_solver_compute_2d_grid(int const* verticesMask_F, int const* _cellsMask_F, int const* dirichletNodesMask_F, int const* floatingEdgeMask_F); void velocity_solver_set_grid_data(int const* _nCells_F, int const* _nEdges_F, int const* _nVertices_F, int const* _nLayers, int const* _nCellsSolve_F, diff --git a/src/core_landice/mode_forward/mpas_li_velocity_external.F b/src/core_landice/mode_forward/mpas_li_velocity_external.F index 2415582c8f..8c86edc97f 100644 --- a/src/core_landice/mode_forward/mpas_li_velocity_external.F +++ b/src/core_landice/mode_forward/mpas_li_velocity_external.F @@ -398,7 +398,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc real (kind=RKIND), dimension(:,:,:), pointer :: & tracers real (kind=RKIND), pointer :: deltat - integer, dimension(:), pointer :: vertexMask, edgeMask, floatingEdges + integer, dimension(:), pointer :: vertexMask, cellMask, edgeMask, floatingEdges integer, dimension(:,:), pointer :: dirichletVelocityMask character (len=StrKIND), pointer :: config_velocity_solver logical, pointer :: config_always_compute_fem_grid @@ -423,6 +423,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc call mpas_pool_get_array(geometryPool, 'lowerSurface', lowerSurface) call mpas_pool_get_array(geometryPool, 'upperSurface', upperSurface) call mpas_pool_get_array(geometryPool, 'vertexMask', vertexMask, timeLevel = 1) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) call mpas_pool_get_array(geometryPool, 'edgeMask', edgeMask) call mpas_pool_get_array(geometryPool, 'sfcMassBal', sfcMassBal) @@ -453,7 +454,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc write(stdoutUnit,*) "Generating new external velocity solver FEM grid." flush(stdoutUnit) ! Flush log files before handing control to C++ flush(stderrUnit) - call generate_fem_grid(config_velocity_solver, vertexMask, dirichletVelocityMask, & + call generate_fem_grid(config_velocity_solver, vertexMask, cellMask, dirichletVelocityMask, & floatingEdges, layerThicknessFractions, lowerSurface, thickness, err) endif @@ -676,14 +677,14 @@ end subroutine interface_stokes_init ! !----------------------------------------------------------------------- - subroutine generate_fem_grid(config_velocity_solver, vertexMask, dirichletVelocityMask, floatingEdges, & + subroutine generate_fem_grid(config_velocity_solver, vertexMask, cellMask, dirichletVelocityMask, floatingEdges, & layerThicknessFractions, lowerSurface, thickness, err) !----------------------------------------------------------------- ! input variables !----------------------------------------------------------------- character (len=StrKIND), pointer :: config_velocity_solver - integer, pointer, dimension(:), intent(in) :: vertexMask, floatingEdges + integer, pointer, dimension(:), intent(in) :: vertexMask, cellMask, floatingEdges integer, pointer, dimension(:,:), intent(in) :: dirichletVelocityMask real(kind=RKIND), pointer, dimension(:), intent(in) :: layerThicknessFractions, & lowerSurface, thickness @@ -706,7 +707,7 @@ subroutine generate_fem_grid(config_velocity_solver, vertexMask, dirichletVeloci #if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) call mpas_timer_start("velocity_solver_compute_2d_grid") - call velocity_solver_compute_2d_grid(vertexMask, dirichletVelocityMask, floatingEdges) + call velocity_solver_compute_2d_grid(vertexMask, cellMask, dirichletVelocityMask, floatingEdges) call mpas_timer_stop("velocity_solver_compute_2d_grid") #else write(stderrUnit,*) "Error: To run with an external velocity solver you must compile MPAS with one." diff --git a/src/core_landice/shared/mpas_li_mask.F b/src/core_landice/shared/mpas_li_mask.F index cf8cca8a05..7439cad6d9 100644 --- a/src/core_landice/shared/mpas_li_mask.F +++ b/src/core_landice/shared/mpas_li_mask.F @@ -240,6 +240,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) ! !----------------------------------------------------------------- integer, pointer :: nCells, nVertices, nEdges, vertexDegree + integer, pointer :: nVertInterfaces real(KIND=RKIND), dimension(:), pointer :: thickness, bedTopography integer, dimension(:), pointer :: nEdgesOnCell, cellMask, vertexMask, edgeMask integer, dimension(:,:), pointer :: cellsOnCell, cellsOnVertex, cellsOnEdge, dirichletVelocityMask @@ -261,6 +262,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) call mpas_pool_get_dimension(meshPool, 'nVertices', nVertices) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) call mpas_pool_get_dimension(meshPool, 'vertexDegree', vertexDegree) + call mpas_pool_get_dimension(meshPool, 'nVertInterfaces', nVertInterfaces) call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) @@ -279,6 +281,10 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + if ( .not. ((trim(config_velocity_solver) == 'sia') .or. (trim(config_velocity_solver) == 'none')) ) then + call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel = 1) + endif + ! ==== ! Calculate cellMask values=========================== ! ==== @@ -294,15 +300,14 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) end where ! Identify cells where the ice is above the ice dynamics thickness limit - if (config_velocity_solver == 'sia') then + if ( (trim(config_velocity_solver) == 'sia') .or. (trim(config_velocity_solver) == 'none') ) then where ( thickness > config_dynamic_thickness ) cellMask = ior(cellMask, li_mask_ValueDynamicIce) end where else ! HO external FEM dycore - call mpas_pool_get_array(velocityPool, 'dirichletVelocityMask', dirichletVelocityMask, timeLevel = 1) ! Identify cells where the ice is above the ice dynamics thickness limit but not with a dirichletVelocity condition set where ( (thickness > config_dynamic_thickness) .and. & ! same as for SIA case - (dirichletVelocityMask(1,:) == 0) ) ! but exclude dirichletVelocityMask locations set as lateral b.c. To ignore dirichlet b.c. on the basal boundary, just check the surface level + (maxval(dirichletVelocityMask(1:nVertInterfaces-1, :), dim=1) == 0) ) ! but exclude dirichletVelocityMask locations set as lateral b.c. We don't want to consider dirichlet b.c. on the basal boundary, so we ignore the basal level cellMask = ior(cellMask, li_mask_ValueDynamicIce) end where endif From d70ebe6aeee8ed43c5efa8b9b67fdc83a7c8e707 Mon Sep 17 00:00:00 2001 From: Mauro Perego Date: Sat, 29 Aug 2015 15:40:06 -0600 Subject: [PATCH 0325/1724] Check verticesMask when interpolating velocity to edges in Interface When computing normal velocity, we need to make sure that the vertex (triangle in the dual Delaunay mesh) we use for the interpolation belongs to the verticesMask. For interior edges this is never an issue, but in some situations we may be interpolating velocity to edges on the boundary of the FEM mesh, in which case we need to make sure we are using a valid FEM triangle! --- .../mode_forward/Interface_velocity_solver.cpp | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.cpp b/src/core_landice/mode_forward/Interface_velocity_solver.cpp index 7fb55eb670..c9d8ed8757 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.cpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.cpp @@ -29,7 +29,7 @@ int nVertices, nEdges, nTriangles, nGlobalVertices, nGlobalEdges, int maxNEdgesOnCell_F; int const *cellsOnEdge_F, *cellsOnVertex_F, *verticesOnCell_F, *verticesOnEdge_F, *edgesOnCell_F, *indexToCellID_F, *nEdgesOnCells_F, - *cellsMask_F, *dirichletCellsMask_F, *floatingEdgesMask_F, *verticesMask_F; + *verticesMask_F, *cellsMask_F, *dirichletCellsMask_F, *floatingEdgesMask_F; std::vector layersRatio, levelsNormalizedThickness; int nLayers; double const *xCell_F, *yCell_F, *zCell_F, *xVertex_F, *yVertex_F, *zVertex_F, *areaTriangle_F; @@ -498,6 +498,7 @@ void velocity_solver_finalize() { void velocity_solver_compute_2d_grid(int const* _verticesMask_F, int const* _cellsMask_F, int const* _dirichletCellsMask_F, int const* _floatingEdgesMask_F) { int numProcs, me; + verticesMask_F = _verticesMask_F; cellsMask_F = _cellsMask_F; verticesMask_F = _verticesMask_F; dirichletCellsMask_F = _dirichletCellsMask_F; @@ -982,11 +983,11 @@ void get_prism_velocity_on_FEdges(double * uNormal, e_mid[0] = 0.5*(xVertex_F[fVertex0] + xVertex_F[fVertex1]); e_mid[1] = 0.5*(yVertex_F[fVertex0] + yVertex_F[fVertex1]); - if(belongToTria(e_mid, t0, bcoords)) { + if((verticesMask_F[fVertex0] & dynamic_ice_bit_value) && belongToTria(e_mid, t0, bcoords)) { for (int j = 0; j < 3; j++) iCells[j] = cellsOnVertex_F[3 * fVertex0 + j] - 1; } - else if(belongToTria(e_mid, t1, bcoords)) { + else if((verticesMask_F[fVertex1] & dynamic_ice_bit_value) && belongToTria(e_mid, t1, bcoords)) { for (int j = 0; j < 3; j++) iCells[j] = cellsOnVertex_F[3 * fVertex1 + j] - 1; } From 918ef707b948b067389d82f570475947bfd63251 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Fri, 16 Oct 2015 12:14:28 -0600 Subject: [PATCH 0326/1724] Add new mask bit for active albany locations Albany's requirements for active/inactive cells, vertices, and edges were getting so complicated that it made more sense to make a special bit in the bitmasks for what Albany considered active rather than trying to use the masks defined from the MPAS perspective. --- .../mode_forward/mpas_li_velocity_external.F | 2 +- src/core_landice/shared/mpas_li_mask.F | 17 +++++++++++------ 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/src/core_landice/mode_forward/mpas_li_velocity_external.F b/src/core_landice/mode_forward/mpas_li_velocity_external.F index 8c86edc97f..6da2301851 100644 --- a/src/core_landice/mode_forward/mpas_li_velocity_external.F +++ b/src/core_landice/mode_forward/mpas_li_velocity_external.F @@ -323,7 +323,7 @@ subroutine li_velocity_external_block_init(block, err) ! Set physical parameters needed on the other side call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) #if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) - call velocity_solver_set_parameters(config_ice_density, li_mask_ValueDynamicIce, li_mask_ValueIce) + call velocity_solver_set_parameters(config_ice_density, li_mask_ValueAlbanyActive, li_mask_ValueIce) #endif ! === error check diff --git a/src/core_landice/shared/mpas_li_mask.F b/src/core_landice/shared/mpas_li_mask.F index 7439cad6d9..399ed61295 100644 --- a/src/core_landice/shared/mpas_li_mask.F +++ b/src/core_landice/shared/mpas_li_mask.F @@ -39,6 +39,7 @@ module li_mask integer, parameter :: li_mask_ValueMargin = 8 ! This is the last cell with ice. integer, parameter :: li_mask_ValueDynamicMargin = 16 ! This is the last dynamically active cell with ice integer, parameter :: li_mask_ValueInitialIceExtent = 1 + integer, parameter :: li_mask_ValueAlbanyActive = 64 ! These are locations that Albany includes in its solution !-------------------------------------------------------------------- ! @@ -300,15 +301,17 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) end where ! Identify cells where the ice is above the ice dynamics thickness limit - if ( (trim(config_velocity_solver) == 'sia') .or. (trim(config_velocity_solver) == 'none') ) then - where ( thickness > config_dynamic_thickness ) - cellMask = ior(cellMask, li_mask_ValueDynamicIce) - end where - else ! HO external FEM dycore + where ( thickness > config_dynamic_thickness ) + cellMask = ior(cellMask, li_mask_ValueDynamicIce) + end where + + ! Identify cells that Albany would consider as active + if ( .not. ((trim(config_velocity_solver) == 'sia') .or. (trim(config_velocity_solver) == 'none')) ) then + ! HO external FEM dycore ! Identify cells where the ice is above the ice dynamics thickness limit but not with a dirichletVelocity condition set where ( (thickness > config_dynamic_thickness) .and. & ! same as for SIA case (maxval(dirichletVelocityMask(1:nVertInterfaces-1, :), dim=1) == 0) ) ! but exclude dirichletVelocityMask locations set as lateral b.c. We don't want to consider dirichlet b.c. on the basal boundary, so we ignore the basal level - cellMask = ior(cellMask, li_mask_ValueDynamicIce) + cellMask = ior(cellMask, li_mask_ValueAlbanyActive) end where endif @@ -388,6 +391,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) endif if (aCellOnVertexHasDynamicIce .and. validVertex) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueDynamicIce) + vertexMask(i) = ior(vertexMask(i), li_mask_ValueAlbanyActive) ! Albany should include all dynamic vertices, despite how it defines dynamic cells endif if (aCellOnVertexIsFloating .and. validVertex) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueFloating) @@ -429,6 +433,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) endif if (aCellOnEdgeHasDynamicIce) then edgeMask(i) = ior(edgeMask(i), li_mask_ValueDynamicIce) + edgeMask(i) = ior(edgeMask(i), li_mask_ValueAlbanyActive) endif if (aCellOnEdgeIsFloating) then edgeMask(i) = ior(edgeMask(i), li_mask_ValueFloating) From e47e5205a2c39dc1eeec2cb58b2de95ade118000 Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Mon, 19 Oct 2015 21:11:15 -0600 Subject: [PATCH 0327/1724] a fairly complete fleshing out of the frazil algorithm --- src/core_ocean/Registry.xml | 34 +- .../shared/mpas_ocn_frazil_forcing.F | 553 ++++++++++++++++++ 2 files changed, 582 insertions(+), 5 deletions(-) create mode 100644 src/core_ocean/shared/mpas_ocn_frazil_forcing.F diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index e07ce67901..3070ebc28f 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -689,6 +689,11 @@ possible_values="Any positive real number" /> + + - + @@ -1493,6 +1498,12 @@ description="baroclinic velocity, used in split-explicit time-stepping" packages="splitTimeIntegrator" /> + + + - + + + + + \brief MPAS ocean frazil formation module +!> \author Todd Ringler +!> \date 10/19/2015 +!> \details +!> This module contains routines for the formation of frazil ice. +! +!----------------------------------------------------------------------- + +module ocn_frazil_forcing + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use mpas_timekeeping + use ocn_constants + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_frazil_forcing_build_arrays, & + ocn_frazil_forcing_tracers, & + ocn_frazil_forcing_thickness, & + ocn_frazil_forcing_surface_pressure, & + ocn_frazil_forcing_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + logical :: frazilFormationOn + type (timer_node), pointer :: timer_frazil + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_frazil_forcing_tracers +! +!> \brief Determines the tracer tendency due to frazil +!> \author Todd Ringler +!> \date 18 October 2015 +!> \details +!> This routine adds to the tracer tendency arrays +!> used to compute tracer at n+1. +! +!----------------------------------------------------------------------- + + subroutine ocn_frazil_forcing_tracers(meshPool, groupName, forcingPool, tracersTendPool, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: forcingPool !< Input: forcing pool holding frazil-induced tendencies + type (mpas_pool_type), intent(in) :: tracersTendPool !< Input: tracer tendency pool used to time step tracer fields + character (len=*) :: groupName !< Input: Name of tracer group + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + if ( .not. frazilFormationOn ) return + + if ( trim(groupName) == 'activeTracers' ) then + call ocn_frazil_forcing_active_tracers(meshPool, forcingPool, tracersTendPool, err) + end if + + end subroutine ocn_frazil_forcing_tracers!}}} + +!*********************************************************************** +! +! routine ocn_frazil_forcing_thickness +! +!> \brief Add tendency due to frazil processes +!> \author Todd Ringler +!> \date 18 October 2015 +!> \details +!> This routine adds a tendency to layer thickness due to frazil formation +! +!----------------------------------------------------------------------- + + subroutine ocn_frazil_forcing_thickness(meshPool, forcingPool, tendPool, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information + type (mpas_pool_type), intent(inout) :: tendPool !< Input: Tendency information + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell, k + integer, pointer :: nCells + integer, dimension(:), pointer :: maxLevelCell + real (kind=RKIND), dimension(:,:), pointer :: layerThicknessTend + + err = 0 + + if ( .not. frazilFormationOn ) return + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_array(forcingPool, 'frazilLayerThicknessTendency', frazilLayerThicknessTendency) + call mpas_pool_get_array(tendPool, 'layerThicknessTend', layerThicknessTend) + + ! Build surface fluxes at cell centers + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + layerThicknessTend(k,iCell) = layerThicknessTend(k,iCell) + frazilLayerThicknessTendency(k,iCell) + end do + + end subroutine ocn_frazil_forcing_layer_thickness!}}} + +!*********************************************************************** +! +! routine ocn_frazil_forcing_active_tracers +! +!> \brief Adds the active tracers forcing due to frazil +!> \author Todd Ringler +!> \date 18 October 2015 +!> \details +!> This routine adds the active tracers forcing due to frazil +!> from which tracer tendencies are computed later. +! +!----------------------------------------------------------------------- + + subroutine ocn_frazil_forcing_active_tracers(meshPool, forcingPool, tracerTendPool, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information + type (mpas_pool_type), intent(inout) :: tracerTendPool !< Input: tendency pool + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell, k + integer, pointer :: nCells + integer, pointer :: indexTemperature, indexSalinity + integer, pointer, dimension(:) :: maxLevelCell + + real (kind=RKIND), dimension(:,:), pointer :: frazilTemperatureTendency + real (kind=RKIND), dimension(:,:), pointer :: frazilSalinityTendency + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracerTend + + err = 0 + + if ( .not. frazilFormationOn ) return + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(tracersTendPool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(tracersTendPool, 'index_salinity', indexSalinity) + + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(tracersTendPool, 'activeTracersTend', activeTracersTend) + call mpas_pool_get_array(forcingPool, 'frazilTemperatureTendency', frazilTemperatureTendency) + call mpas_pool_get_array(forcingPool, 'frazilSalinityTendency', frazilSalinityTendency) + + ! add to surface fluxes at cell centers + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + activeTracersTend(indexTemperature,k,iCell) = activeTracersTend(indexTemperature,k,iCell) + frazilTemperatureTendency(k,iCell) + activeTracersTend(indexSalinity,k,iCell) = activeTracersTend(indexSalinity,k,iCell) + frazilSalinityTendency(k,iCell) + end do + end do + + end subroutine ocn_frazil_forcing_active_tracers!}}} + + +!*********************************************************************** +! +! routine ocn_frazil_forcing_build_arrays +! +!> \brief Performs the formation of frazil within the ocean. +!> \author Todd Ringler +!> \date 10/19/2015 +!> \details +!> ocn_frazil_forcing_build_arrays computes the tendencies to layer thickness, temperature and salinity +!> due to the creation and possible melting of frazil ice +!> +!> these tendencies can be retrieved at any point by calling into ocn_frazil_forcing_{tracers, thickness} routines +!> +!> the pressure exerted by the frazil on the ocean "surface" can be retrieved by calling into +!> ocn_frazil_forcing_surface_pressure +!> +!> this routine should be call at the beginning of whatever time stepping method is utilized +!> and the tendencies should be retieved when building up the RHS of the thickess, temperature +!> and salinity equations. +!> +!> this routine is only applicable to the surface pressure, thickness and active tracer fields +! +!----------------------------------------------------------------------- + + subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPool, statePool, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer, intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), pointer, intent(in) :: forcingPool !< Input: Forcing information + type (mpas_pool_type), pointer, intent(in) :: statePool !< Input: State information + type (mpas_pool_type), pointer, intent(in) :: diagnosticsPool !< Input: Diagnostic information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), pointer, intent(in) :: forcingPool !< Input: Forcing information + integer, intent(inout) :: err !< Error flag + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + type (block_type), pointer :: block + type (mpas_pool_type) :: tracerPool + + real (kind=RKIND), dimension(:,:), pointer :: frazilLayerThicknessTendency + real (kind=RKIND), dimension(:,:), pointer :: frazilTemperatureTendency + real (kind=RKIND), dimension(:,:), pointer :: frazilSalinityTendency + real (kind=RKIND), dimension(:), pointer :: frazilSurfacePressure + + integer :: iCell, k, kBottomFrazil + integer, pointer :: nCells, nVertLevels + + real (kind=RKIND), pointer :: config_frazil_heat_of_fusion + real (kind=RKIND), pointer :: config_frazil_sea_ice_density + real (kind=RKIND), pointer :: config_frazil_fractional_thickness_limit + + real (kind=RKIND) :: newFrazilIceThickness + real (kind=RKIND) :: sumNewFrazilIceThickness + real (kind=RKIND) :: meltedFrazilIceThickness + real (kind=RKIND) :: oceanFreezingTemperature + + real (kind=RKIND), pointer, dimension(:) :: accumulatedFrazilIceMassNew + real (kind=RKIND), pointer, dimension(:) :: accumulatedFrazilIceMassOld + real (kind=RKIND), pointer, dimension(:,:) :: zMid + real (kind=RKIND), pointer, dimension(:,:) :: density + real (kind=RKIND), pointer, dimension(:,:) :: layerThickness + + integer, dimension(:), pointer :: maxLevelCell + integer :: indexTemperature !< index in tracers array for temperature + integer :: indexSalinity !< index in tracers array for salinity + + real (kind=RKIND) :: kBottomFrazil ! k index where testing for frazil begins + real (kind=RKIND) :: potential ! scalar holding freezing/melt potential + real (kind=RKIND) :: freezingEnergy ! energy available for freezing, positive definite + real (kind=RKIND) :: meltingEnergy ! energy available for melting, positive definite + + ! if frazil is not enabled, return + if(.not. frazilFormationOn) return + + call mpas_timer_start("fazil", .false., timer_frazil) + block => domain % blocklist + do while (associated(block)) + + ! get pool pointers + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + + ! get dimensions + call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) + + ! get mesh information + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + ! get arrays + ! note: state information is used to produce tendencies, so always grab "new" time level + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 2) + call mpas_pool_get_array(statePool, 'accumulatedFrazilIceMass', accumulatedFrazilIceMassNew, 2) + call mpas_pool_get_array(statePool, 'accumulatedFrazilIceMass', accumulatedFrazilIceMassOld, 1) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 2) + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + call mpas_pool_get_array(diagnosticsPool, 'density', density) + call mpas_pool_get_array(forcingPool, 'frazilTemperatureTendency', frazilTemperatureTendency) + call mpas_pool_get_array(forcingPool,'frazilSalinityTendency', frazilSalinityTendency) + call mpas_pool_get_array(forcingPool,'frazilThicknessTendency', frazilThicknessTendency) + call mpas_pool_get_array(forcingPool,'frazilSurfacePressure', frazilSurfacePressure) + + ! get configure parameters + call mpas_pool_get_config(domain % configs, 'config_frazil_maximum_depth', config_frazil_maximum_depth) + call mpas_pool_get_config(domain % configs, 'config_frazil_fractional_thickness_limit', config_frazil_fractional_thickness_limit) + call mpas_pool_get_config(domain % configs, 'config_specific_heat_sea_water', config_specific_heat_sea_water) + call mpas_pool_get_config(domain % configs, 'config_frazil_heat_of_fusion', config_frazil_heat_of_fusion) + call mpas_pool_get_config(domain % configs, 'config_frazil_sea_ice_density', config_frazil_sea_ice_density) + + ! initialize frazil tendency fields + frazilTemperatureTendency = 0.0_RKIND + frazilSalinityTendency = 0.0_RKIND + frazilThicknessTendency = 0.0_RKIND + + ! loop over all columns + do iCell=1,nCells + + ! find deepest level where frazil can be created + do k=maxLevelCell(iCell), 1, -1 + if(-zMid(k,iCell).lt.config_frazil_maximum_depth) then + kBottomFrazil=k + exit + endif + enddo + + ! zero the sum of new frazil ice created + sumNewFrazilIceThickness = 0.0_RKIND + + ! loop from maximum depth of frazil creation to surface + do k = kBottomFrazil, 1, -1 + + ! get freezing temperature + oceanFreezingTemperature = ocn_freezing_temperature(activeTracers(indexSalinity,k,iCell)) + + potential = layerThickness(k,iCell) * config_specific_heat_sea_water & + * density(k,iCell) * (activeTracers(indexTemperature,k,iCell) - oceanFreezingTemperature) + freezingEnergy = max(0.0_RKIND, -potential) + meltingEnergy = max(0.0_RKIND, potential) + + if (freezingEnergy < 0) then + + ! new frazil ice formation measured in meters + newFrazilIceThickness = freezingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) + + ! limit the frazil formed appropriately + newFrazilIceThickness = min(newFrazilIceThickness, layerThickness(k,iCell) * config_frazil_fractional_thickness_limit) + + ! compute tendency to thickness, temperature and salinity + ! layerTendency is scaled so that mass of ice created == mass of ocean water removed + + ! layer thickness decreased due to creation of frazil + frazilThicknessTendency(k,iCell) = - newFrazilIceThickness * config_frazil_sea_ice_density / density(k,iCell) / dt + + ! salt is extracted with the frazil + frazilSalinityTendency(k,iCell) = - newFrazilIceThickness * config_frazil_iceReferenceSalinity / dt + + ! ocean fluid temperature is warmed due to creation of frazil + frazilTemperatureTendency(k,iCell) = & + + ( newFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density ) & + / (config_specific_heat_sea_water * density(k,iCell)) / dt + + ! accumulate frazil mass to column total + ! note: accumulatedFrazilIceMass (at both time levels) is reset to zero after being sent to the coupler + accumulatedFrazilIceMassNew(iCell) = accumulatedFrazilIceMassOld(iCell) + newFrazilIceThickness*config_frazil_sea_ice_density + + ! keep track of sum of frazil ice + sumNewFrazilIceThickness = sumNewFrazilIceThickness + newFrazilIceThickness + + else + + ! ocean water is warm enough to melt frazil + + ! test to see if there is frazil to be melted + if (sumNewFrazilIceThickness > 0.0_RKIND) then + + ! Frazil melting + meltedFrazilIceThickness = meltingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) + + ! limit melting by what there is to melt + meltedFrazilIceThickness = min(meltedFrazilIceThickness, sumNewFrazilIceThickness) + + ! limit melting by fraction of layer thickness + meltedFrazilIceThickness = min(meltedFrazilIceThickness, layerThickness(k,iCell)*config_frazil_fractional_thickness_limit) + + ! compute tendency to thickness, temperature and salinity + + ! layer thickness increases due to melting of frazil + frazilThicknessTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_sea_ice_density / density(k,iCell) / dt + + ! salt is released into ocean with the melting frazil + frazilSalinityTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_iceReferenceSalinity / dt + + ! ocean fluid temperature is cooled due to melting of frazil + frazilTemperatureTendency(k,iCell) = & + - ( meltedFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density ) & + / (config_specific_heat_sea_water * density(k,iCell)) / dt + + ! deaccumulate frazil + accumulatedFrazilIceMassNew(iCell) = accumulatedFrazilIceMassOld(iCell) - meltedFrazilIceThickness*config_frazil_sea_ice_density + + ! keep track of new frazil ice + sumNewFrazilIceThickness = sumNewFrazilIceThickness - meltedFrazilIceThickness + + endif ! if (freezingEnergy < 0) + + enddo ! do k=kBottom,1-1 + + ! sea surface pressure due to the net production of frazil ice + frazilSurfacePressure(iCell) = accumulatedFrazilIceMass(iCell) * gravity / dt + + enddo ! do iCell = 1, nCells + + enddo ! iBlock + call mpas_timer_stop("frazil", timer_frazil) + + end subroutine ocn_frazil_forcing_build_arrays!}}} + +!*********************************************************************** +! +! function ocn_freezing_temperature +! +!> \brief Computes the freezing temperature of the ocean. +!> \author Todd Ringler +!> \date 10/29/2015 +!> \details +!> This routine computes the freezing temperature of the ocean at a given +!> salinity value. +! +!----------------------------------------------------------------------- + real (kind=RKIND) function ocn_freezing_temperature(salinity)!{{{ + real (kind=RKIND) :: salinity !< Input: Salinity value of water for freezing temperature + ocn_freezing_temperature = -1.8 + end function ocn_freezing_temperature!}}} + + +!*********************************************************************** +! +! routine ocn_frazil_forcing_init +! +!> \brief Initializes ocean frazil ice module. +!> \author Todd Ringler +!> \date 10/19/2015 +!> \details +!> This routine initializes the ocean frazil ice module and variables.. +! +!----------------------------------------------------------------------- + + subroutine ocn_frazil_forcing_init(err)!{{{ + + integer, intent(out) :: err !< Output: error flag + logical, pointer :: config_use_frazil_ice_formation + + err = 0 + + call mpas_pool_get_config(ocnConfigs, 'config_use_frazil_ice_formation', config_use_frazil_ice_formation) + + frazilFormationOn = .false. + + if(config_use_frazil_ice_formation) then + frazilFormationOn = .true. + end if + + end subroutine ocn_frazil_forcing_init!}}} + +!*********************************************************************** + +end module ocn_sea_ice + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker From f69da6a4ea0d337d343e144ee1af03ddde6a1473 Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Mon, 19 Oct 2015 21:11:56 -0600 Subject: [PATCH 0328/1724] placeholder for where call into frazil ice build arrays should occur --- src/core_ocean/mode_forward/mpas_ocn_forward_mode.F | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index c4370c057e..dd0af04696 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -487,6 +487,11 @@ function ocn_forward_mode_run(domain) result(ierr)!{{{ call ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & forcingPool, scratchPool, err) call mpas_timer_stop("land_ice_build_arrays") + + !! TDR + call ocn_frazil_build_arrays( ) + !! TDR + block_ptr => block_ptr % next end do From 72f927266640f5d1d4a3471752b64618d520b469 Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Mon, 19 Oct 2015 21:12:28 -0600 Subject: [PATCH 0329/1724] changed name, so file deleted --- src/core_ocean/shared/mpas_ocn_frazil.F | 320 ------------------------ 1 file changed, 320 deletions(-) delete mode 100644 src/core_ocean/shared/mpas_ocn_frazil.F diff --git a/src/core_ocean/shared/mpas_ocn_frazil.F b/src/core_ocean/shared/mpas_ocn_frazil.F deleted file mode 100644 index 0245bba2f9..0000000000 --- a/src/core_ocean/shared/mpas_ocn_frazil.F +++ /dev/null @@ -1,320 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! -! ocn_frazil -! -!> \brief MPAS ocean frazil formation module -!> \author Todd Ringler -!> \date 10/19/2015 -!> \details -!> This module contains routines for the formation of frazil ice. -! -!----------------------------------------------------------------------- - -module ocn_frazil - - use mpas_kind_types - use mpas_derived_types - use mpas_pool_routines - use mpas_timekeeping - use ocn_constants - - implicit none - private - save - - !-------------------------------------------------------------------- - ! - ! Public parameters - ! - !-------------------------------------------------------------------- - - !-------------------------------------------------------------------- - ! - ! Public member functions - ! - !-------------------------------------------------------------------- - - public :: ocn_frazil_formation, & - ocn_frazil_init - - !-------------------------------------------------------------------- - ! - ! Private module variables - ! - !-------------------------------------------------------------------- - - logical :: frazilFormationOn - -!*********************************************************************** - -contains - -!*********************************************************************** -! -! routine ocn_frazil_formation -! -!> \brief Performs the formation of frazil within the ocean. -!> \author Todd Ringler -!> \date 10/19/2015 -!> \details -!> ocn_frazil_formation computes the tendencies to layer thickness, temperature and salinity -!> due to the creation and possible melting of frazil ice -!> -!> these tendencies can be retrieved at any point by calling into ocn_frazil_*_tendency routines -!> where * is layerThickness, temperature or salinity -!> -!> the pressure exerted by the frazil on the ocean "surface" can be retrieved by calling into -!> ocn_frazil_surface_pressure -!> -!> this routine should be call at the beginning of whatever time stepping method is utilized -!> and the tendencies should be retieved when building up the RHS of the thickess, temperature -!> and salinity equations. -!> -!> this routine is only applicable to the thickness and active tracer fields -! -!----------------------------------------------------------------------- - - subroutine ocn_frazil_formation(meshPool, statePool, tendPool, tracers, err)!{{{ - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - - type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information - type (mpas_pool_type), intent(in) :: statePool !< Input: State information - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - type (mpas_pool_type), intent(out) :: tendPool !< Output: Tendency information - integer, intent(inout) :: err !< Error flag - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - integer :: iCell, k, kBottomFrazil - integer, pointer :: nCells, nVertLevels - -config_frazil_heat_of_fusion -config_frazil_sea_ice_density -config_frazil_fractional_thickness_limit - - -real (kind=RKIND) :: newFrazilIceThickness -real (kind=RKIND) :: meltedFrazilIceThickness - - type (mpas_pool_type) :: tracerPool - - real (kind=RKIND), pointer, dimension(:) :: accumulatedFrazilIceThickness - real (kind=RKIND), pointer, dimension(:) :: accumulatedFrazilIceMass - real (kind=RKIND), pointer, dimension(:,:) :: zMid - real (kind=RKIND), pointer, dimension(:,:) :: density - real (kind=RKIND), pointer, dimension(:,:) :: layerThickness - - -layerTendencyFrazil -temperatureTendencyFrazil -salinityTendencyFrazil -surfacePressureTendencyFrazil - - integer, dimension(:), pointer :: maxLevelCell - integer :: indexTemperature !< Input: Index in tracers array for temperature - integer :: indexSalinity !< Input: Index in tracers array for salinity - - real (kind=RKIND) :: kBottomFrazil ! k index where testing for frazil begins - real (kind=RKIND) :: potential ! scalar holding freezing/melt potential - real (kind=RKIND) :: freezingEnergy ! energy available for freezing, positive definite - real (kind=RKIND) :: meltingEnergy ! energy available for melting, positive definite - - - ! if frazil is not enabled, return - if(.not. frazilFormationOn) return - - - do block ----- - - ! get dimensions - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) - - ! get configure parameters - config_frazil_maximum_depth - - ! get mesh fields - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - - ! get state fields - layerThickness - activeTracers - temperature index - salinity index - - ! get diagnostic fields - zMid - density - accumulatedFrazilIceThickness - - ! get tendency fields from pool - - - ! loop over all columns - do iCell=1,nCells - - ! reset frazil thickness and mass to be zero for each column - accumulatedFrazilIceThickness(iCell) = 0.0_RKIND - accumulatedFrazilIceMass(iCell) = 0.0_RKIND - - ! find deepest level where frazil can be created - do k=maxLevelCell(iCell), 1, -1 - if(-zMid(k,iCell).lt.config_frazil_maximum_depth) then - kBottomFrazil=k - exit - endif - enddo - - ! loop from maximum depth of frazil creation to surface - do k = kBottomFrazil, 1, -1 - - potential = layerThickness(k,iCell) * config_specific_heat_sea_water & - * density(k,iCell) * (temperature(k,iCell) - oceanFreezingTemperature) - freezingEnergy = max(0.0_RKIND, -potential) - meltingEnergy = max(0.0_RKIND, potential) - - if (freezingEnergy < 0) then - - ! new frazil ice formation measured in meters - newFrazilIceThickness = freezingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) - - ! limit the frazil formed appropriately - newFrazilIceThickness = min(newFrazilIceThickness, layerThickness(k,iCell) * config_frazil_fractional_thickness_limit) - - ! compute increments to thickness, temperature and salinity - ! layerTendencyFrazil is scaled so that mass of ice created == mass of ocean water removed - layerTendencyFrazil(k,iCell) = -newFrazilIceThickness * config_frazil_sea_ice_density / density(k,iCell) - saltTendencyFrazil(k,iCell) = -newFrazilIceThickness * config_frazil_iceReferenceSalinity - temperatureTendencyFrazil(k,iCell) = (newFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density) & - / (config_specific_heat_sea_water * density(k,iCell)) - - ! accumulate frazil - accumulatedFrazilIceThickness(iCell) = accumulatedFrazilIceThickness(iCell) + newFrazilIceThickness - accumulatedFrazilIceMass(iCell) = accumulatedFrazilIceMass(iCell) + newFrazilIceThickness*config_frazil_sea_ice_density - - else - - ! ocean water is warm enough to melt frazil - - ! test to see if there is frazil to be melted - if (accumulatedFrazilIceThickness(iCell) > 0) then - - ! Frazil melting - meltedFrazilIceThickness = meltingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) - - ! limit melting by what there is to melt - meltedFrazilIceThickness = min(meltedFrazilIceThickness, accumulatedFrazilIceThickness(iCell)) - - ! limit melting by fraction of layer thickness - meltedFrazilIceThickness = min(meltedFrazilIceThickness, layerThickness(k,iCell)*config_frazil_fractional_thickness_limit) - - ! compute increments to thickness, temperature and salinity - layerTendencyFrazil(k,iCell) = meltedFrazilIceThickness - saltTendencyFrazil(k,iCell) = meltedFrazilIceThickness * config_frazil_sea_ice_reference_salinity - temperatureTendencyFrazil(k,iCell) = -(meltedFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density) & - / (config_specific_heat_sea_water * density(k,iCell)) - - ! deaccumulate frazil - accumulatedFrazilIceThickness(iCell) = accumulatedFrazilIceThickness(iCell) - meltedFrazilThickness - accumulatedFrazilIceMass(iCell) = accumulatedFrazilIceMass(iCell) - meltedFrazilIceThickness*config_frazil_sea_ice_density - - endif ! if (freezingEnergy < 0) - - ! convert tendencies to rates - ! each of these tendencies can be access through public subroutines below - layerTendencyFrazil(k,iCell) = layerTendencyFrazil(k,iCell) / dt - saltTendencyFrazil(k,iCell) = saltTendencyFrazil(k,iCell) / dt - temperatureTendencyFrazil(k,iCell) = temperatureTendencyFrazil(k,iCell) / dt - - enddo ! do k=kBottom,1-1 - - ! sea surface pressure tendency from frazil ice - ! note: surfacePressureFrazil should incrememented by surfacePressureTendencyFrazil * dt - ! note: surfacePressureFrazil should be reset to zero after sending to coupler - surfacePressureTendencyFrazil(iCell) = accumulatedFrazilIceMass(iCell) * gravity / dt - - enddo ! do iCell = 1, nCells - - enddo ! iBlock - - end subroutine ocn_frazil_formation!}}} - -!*********************************************************************** -! -! function ocn_freezing_temperature -! -!> \brief Computes the freezing temperature of the ocean. -!> \author Todd Ringler -!> \date 10/29/2015 -!> \details -!> This routine computes the freezing temperature of the ocean at a given -!> salinity value. -! -!----------------------------------------------------------------------- - real (kind=RKIND) function ocn_freezing_temperature(salinity)!{{{ - real (kind=RKIND) :: salinity !< Input: Salinity value of water for freezing temperature - ocn_freezing_temperature = -1.8 - end function ocn_freezing_temperature!}}} - - -!*********************************************************************** -! -! routine ocn_frazil_init -! -!> \brief Initializes ocean frazil ice module. -!> \author Todd Ringler -!> \date 10/19/2015 -!> \details -!> This routine initializes the ocean frazil ice module and variables.. -! -!----------------------------------------------------------------------- - - subroutine ocn_frazil_init(err)!{{{ - - integer, intent(out) :: err !< Output: error flag - logical, pointer :: config_use_frazil_ice_formation - - err = 0 - - call mpas_pool_get_config(ocnConfigs, 'config_use_frazil_ice_formation', config_use_frazil_ice_formation) - - frazilFormationOn = .false. - - if(config_use_frazil_ice_formation) then - frazilFormationOn = .true. - end if - - end subroutine ocn_frazil_init!}}} - -!*********************************************************************** - -end module ocn_sea_ice - -!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| -! vim: foldmethod=marker From 70293c07498a8a0893d500de2fc7bb53e718ee44 Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Mon, 19 Oct 2015 21:13:29 -0600 Subject: [PATCH 0330/1724] add "use" for frazil ice forcing --- src/core_ocean/shared/mpas_ocn_tendency.F | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index 5e02242e0a..83319eecaa 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -29,6 +29,7 @@ module ocn_tendency use ocn_surface_bulk_forcing use ocn_surface_land_ice_fluxes + use ocn_frazil_forcing use ocn_tracer_hmix use ocn_high_freq_thickness_hmix_del2 From f46e67c4ffd33ea9bc124f46f8b3e0fbe760ac69 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Fri, 16 Oct 2015 13:55:23 -0600 Subject: [PATCH 0331/1724] Add mask for cells albany will extend to, add special case for albany vertex in MISMIP This is needed to properly calculate which vertices (triangles) should be used by Albany. In particular, there is a special case of 1 Dirichlet dynamic cell, 1 Dirichlet nondynamic cell, and 1 extended cell that should be made an active vertex (triangle) for MISMIP test case to work correctly. This commit also adds the logic to check for that situation. --- src/core_landice/shared/mpas_li_mask.F | 102 +++++++++++++++++++++++-- 1 file changed, 96 insertions(+), 6 deletions(-) diff --git a/src/core_landice/shared/mpas_li_mask.F b/src/core_landice/shared/mpas_li_mask.F index 399ed61295..153adb553b 100644 --- a/src/core_landice/shared/mpas_li_mask.F +++ b/src/core_landice/shared/mpas_li_mask.F @@ -40,6 +40,7 @@ module li_mask integer, parameter :: li_mask_ValueDynamicMargin = 16 ! This is the last dynamically active cell with ice integer, parameter :: li_mask_ValueInitialIceExtent = 1 integer, parameter :: li_mask_ValueAlbanyActive = 64 ! These are locations that Albany includes in its solution + integer, parameter :: li_mask_ValueAlbanyMarginNeighbor = 128 ! This the first cell beyond the last active albany cell !-------------------------------------------------------------------- ! @@ -71,6 +72,12 @@ module li_mask end interface + interface li_mask_is_albany_active + module procedure li_mask_is_albany_active_logout_1d + module procedure li_mask_is_albany_active_logout_0d + end interface + + interface li_mask_is_dynamic_ice_int module procedure li_mask_is_dynamic_ice_intout_1d module procedure li_mask_is_dynamic_ice_intout_0d @@ -89,6 +96,12 @@ module li_mask end interface + interface li_mask_is_albany_margin_neighbor + module procedure li_mask_is_albany_margin_neighbor_logout_1d + module procedure li_mask_is_albany_margin_neighbor_logout_0d + end interface + + interface li_mask_is_floating_ice module procedure li_mask_is_floating_ice_logout_1d module procedure li_mask_is_floating_ice_logout_0d @@ -251,9 +264,11 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) integer :: i, j, iCell logical :: isMargin - logical :: aCellOnVertexHasIce, aCellOnVertexHasNoIce, aCellOnVertexHasDynamicIce, aCellOnVertexHasNoDynamicIce, aCellOnVertexIsFloating + logical :: isAlbanyMarginNeighbor + logical :: aCellOnVertexHasIce, aCellOnVertexHasNoIce, aCellOnVertexHasDynamicIce, aCellOnVertexHasNoDynamicIce, aCellOnVertexIsFloating, aCellOnVertexIsAlbanyActive logical :: aCellOnEdgeHasIce, aCellOnEdgeHasNoIce, aCellOnEdgeHasDynamicIce, aCellOnEdgeHasNoDynamicIce, aCellOnEdgeIsFloating integer :: numCellsOnVertex + integer :: numDiriDynamicCells, numDiriNondynamicCells, numExtendedCells logical :: validVertex err = 0 @@ -350,6 +365,20 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) endif enddo + ! Identify first cell outside of active albany extent + if ( .not. ((trim(config_velocity_solver) == 'sia') .or. (trim(config_velocity_solver) == 'none')) ) then + do i=1,nCells + if ( (.not. li_mask_is_albany_active(cellMask(i)))) then ! check non albany cells only + isAlbanyMarginNeighbor = .false. + do j=1,nEdgesOnCell(i) ! Check if any neighbors are dynamic-ice + isAlbanyMarginNeighbor = ( isAlbanyMarginNeighbor .or. (li_mask_is_albany_active(cellMask(cellsOnCell(j,i)))) ) + enddo + if (isAlbanyMarginNeighbor) then + cellMask(i) = ior(cellMask(i), li_mask_ValueAlbanyMarginNeighbor) + endif + endif + enddo + endif ! ==== ! Calculate vertexMask values based on cellMask values=========================== @@ -370,8 +399,12 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) aCellOnVertexHasDynamicIce = .false. aCellOnVertexHasNoDynamicIce = .false. aCellOnVertexIsFloating = .false. + aCellOnVertexIsAlbanyActive = .false. numCellsOnVertex = 0 validVertex = .false. + numDiriDynamicCells = 0 + numDiriNondynamicCells = 0 + numExtendedCells = 0 do j = 1, vertexDegree ! vertexDegree is usually 3 (e.g. CVT mesh) but could be something else (e.g. 4 for quad mesh) iCell = cellsOnVertex(j,i) if (iCell < nCells+1) then @@ -382,6 +415,19 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) aCellOnVertexHasDynamicIce = (aCellOnVertexHasDynamicIce .or. li_mask_is_dynamic_ice(cellMask(iCell))) aCellOnVertexHasNoDynamicIce = (aCellOnVertexHasNoDynamicIce .or. (.not. (li_mask_is_dynamic_ice(cellMask(iCell))))) aCellOnVertexIsFloating = (aCellOnVertexIsFloating .or. li_mask_is_floating_ice(cellMask(iCell))) + aCellOnVertexIsAlbanyActive = (aCellOnVertexIsAlbanyActive .or. li_mask_is_albany_active(cellMask(iCell))) + if ( .not. ((trim(config_velocity_solver) == 'sia') .or. (trim(config_velocity_solver) == 'none')) ) then + !if (li_mask_is_dynamic_ice(cellMask(iCell)) .and. .not. li_mask_is_albany_active(cellMask(iCell))) then ! this finds diri cells + if ( (maxval(dirichletVelocityMask(1:nVertInterfaces-1, iCell)) > 0) .and. & + (li_mask_is_dynamic_ice(cellMask(iCell)) ) ) then + numDiriDynamicCells = numDiriDynamicCells + 1 + elseif ( (maxval(dirichletVelocityMask(1:nVertInterfaces-1, iCell)) > 0) .and. & + (.not. li_mask_is_dynamic_ice(cellMask(iCell)) ) ) then + numDiriNondynamicCells = numDiriNondynamicCells + 1 + elseif (li_mask_is_albany_margin_neighbor(cellMask(iCell))) then + numExtendedCells = numExtendedCells + 1 + endif + endif end do if (numCellsOnVertex == vertexDegree) then validVertex = .true. @@ -391,7 +437,15 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) endif if (aCellOnVertexHasDynamicIce .and. validVertex) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueDynamicIce) - vertexMask(i) = ior(vertexMask(i), li_mask_ValueAlbanyActive) ! Albany should include all dynamic vertices, despite how it defines dynamic cells + endif + if (aCellOnVertexIsAlbanyActive .and. validVertex) then + vertexMask(i) = ior(vertexMask(i), li_mask_ValueAlbanyActive) + endif + if ( (numDiriDynamicCells == 1) .and. (numDiriNondynamicCells == 1) .and. & + (numExtendedCells == 1) .and. validVertex) then + ! This is a special case needed for MISMIP + vertexMask(i) = ior(vertexMask(i), li_mask_ValueAlbanyActive) + vertexMask(i) = ior(vertexMask(i), li_mask_ValueAlbanyMarginNeighbor) endif if (aCellOnVertexIsFloating .and. validVertex) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueFloating) @@ -433,7 +487,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) endif if (aCellOnEdgeHasDynamicIce) then edgeMask(i) = ior(edgeMask(i), li_mask_ValueDynamicIce) - edgeMask(i) = ior(edgeMask(i), li_mask_ValueAlbanyActive) + edgeMask(i) = ior(edgeMask(i), li_mask_ValueAlbanyActive) ! Note: Albany does not use edgeMask, but setting this anyway. endif if (aCellOnEdgeIsFloating) then edgeMask(i) = ior(edgeMask(i), li_mask_ValueFloating) @@ -485,12 +539,13 @@ subroutine li_calculate_extrapolate_floating_edgemask(meshPool, vertexMask, floa !----------------------------------------------------------------- type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information - integer, dimension(:) :: & - vertexMask !< Input: vertexMask !----------------------------------------------------------------- ! input/output variables !----------------------------------------------------------------- - integer, dimension(:) :: & + integer, dimension(:), intent(inout) :: & + vertexMask !< Input/Output: vertexMask + + integer, dimension(:), intent(inout) :: & floatingEdges !< Input/Output: 0/1 mask of floating edges !----------------------------------------------------------------- @@ -507,10 +562,13 @@ subroutine li_calculate_extrapolate_floating_edgemask(meshPool, vertexMask, floa call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + ! Build floatingEdges mask that is extended forward one extra edge do iEdge = 1, nEdges floatingEdges(iEdge) = maxval(li_mask_is_floating_ice_int(vertexMask(verticesOnEdge(:, iEdge)))) enddo + ! Now includes vertices that include 2 cells with ice and one extended floating cell + ! This will be when the two cells with ice were Dirichlet cells end subroutine li_calculate_extrapolate_floating_edgemask @@ -585,6 +643,22 @@ function li_mask_is_dynamic_ice_intout_0d(mask) end function li_mask_is_dynamic_ice_intout_0d + ! -- Functions that check for presence of active albany -- + function li_mask_is_albany_active_logout_1d(mask) + integer, dimension(:), intent(in) :: mask + logical, dimension(size(mask)) :: li_mask_is_albany_active_logout_1d + + li_mask_is_albany_active_logout_1d = (iand(mask, li_mask_ValueAlbanyActive) == li_mask_ValueAlbanyActive) + end function li_mask_is_albany_active_logout_1d + + function li_mask_is_albany_active_logout_0d(mask) + integer, intent(in) :: mask + logical :: li_mask_is_albany_active_logout_0d + + li_mask_is_albany_active_logout_0d = (iand(mask, li_mask_ValueAlbanyActive) == li_mask_ValueAlbanyActive) + end function li_mask_is_albany_active_logout_0d + + ! -- Functions that check for presence of dynamic margin -- function li_mask_is_dynamic_margin_logout_1d(mask) integer, dimension(:), intent(in) :: mask @@ -615,6 +689,22 @@ function li_mask_is_dynamic_margin_intout_0d(mask) end function li_mask_is_dynamic_margin_intout_0d + ! -- Functions that check for presence of albany margin neighbor -- + function li_mask_is_albany_margin_neighbor_logout_1d(mask) + integer, dimension(:), intent(in) :: mask + logical, dimension(size(mask)) :: li_mask_is_albany_margin_neighbor_logout_1d + + li_mask_is_albany_margin_neighbor_logout_1d = (iand(mask, li_mask_ValueAlbanyMarginNeighbor) == li_mask_ValueAlbanyMarginNeighbor) + end function li_mask_is_albany_margin_neighbor_logout_1d + + function li_mask_is_albany_margin_neighbor_logout_0d(mask) + integer, intent(in) :: mask + logical :: li_mask_is_albany_margin_neighbor_logout_0d + + li_mask_is_albany_margin_neighbor_logout_0d = (iand(mask, li_mask_ValueAlbanyMarginNeighbor) == li_mask_ValueAlbanyMarginNeighbor) + end function li_mask_is_albany_margin_neighbor_logout_0d + + ! -- Functions that check for presence of floating ice -- function li_mask_is_floating_ice_logout_1d(mask) integer, dimension(:), intent(in) :: mask From d0994f3bd35078958e7100a23a76e28db163c15a Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 20 Oct 2015 14:18:53 -0600 Subject: [PATCH 0332/1724] Registry.xml compiles --- src/core_ocean/Registry.xml | 91 +++++++++++++++++++++++-------------- 1 file changed, 56 insertions(+), 35 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 3070ebc28f..e2f7bfe8fa 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -602,10 +602,6 @@ description="The length scale of exponential decay of surface fluxes. Fluxes are multiplied by $e^{z/\gamma}$, where this coefficient is $\gamma$." possible_values="Any positive real number." /> - + + + + + + + - - - + @@ -1149,7 +1162,8 @@ - + + @@ -1481,6 +1495,12 @@ packages="thicknessFilter" /> + + + - - - + /> + + + + + + + + + - - - - - Date: Tue, 20 Oct 2015 15:28:20 -0600 Subject: [PATCH 0333/1724] add mpas_ocn_frazil_forcing.o to compilation --- src/core_ocean/shared/Makefile | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/core_ocean/shared/Makefile b/src/core_ocean/shared/Makefile index 91f3d78a4c..5f4938139d 100644 --- a/src/core_ocean/shared/Makefile +++ b/src/core_ocean/shared/Makefile @@ -49,6 +49,7 @@ OBJS = mpas_ocn_init_routines.o \ mpas_ocn_forcing.o \ mpas_ocn_surface_bulk_forcing.o \ mpas_ocn_surface_land_ice_fluxes.o \ + mpas_ocn_frazil_forcing.o \ mpas_ocn_forcing_restoring.o \ mpas_ocn_time_average.o \ mpas_ocn_time_average_coupled.o \ @@ -58,7 +59,7 @@ all: $(OBJS) mpas_ocn_init_routines.o: mpas_ocn_constants.o mpas_ocn_time_average.o mpas_ocn_diagnostics.o mpas_ocn_gm.o -mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_restoring.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_surface_bulk_forcing.o mpas_ocn_surface_land_ice_fluxes.o mpas_ocn_tracer_surface_flux_to_tend.o mpas_ocn_tracer_interior_restoring.o mpas_ocn_tracer_exponential_decay.o mpas_ocn_tracer_ideal_age.o mpas_ocn_tracer_TTD.o mpas_ocn_vmix.o mpas_ocn_constants.o +mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_restoring.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_surface_bulk_forcing.o mpas_ocn_surface_land_ice_fluxes.o mpas_ocn_tracer_surface_flux_to_tend.o mpas_ocn_tracer_interior_restoring.o mpas_ocn_tracer_exponential_decay.o mpas_ocn_tracer_ideal_age.o mpas_ocn_tracer_TTD.o mpas_ocn_vmix.o mpas_ocn_constants.o mpas_ocn_frazil_forcing.o mpas_ocn_diagnostics_routines.o: mpas_ocn_constants.o @@ -149,6 +150,8 @@ mpas_ocn_forcing.o: mpas_ocn_constants.o mpas_ocn_forcing_restoring.o mpas_ocn_surface_bulk_forcing.o: mpas_ocn_surface_land_ice_fluxes.o: mpas_ocn_constants.o + +mpas_ocn_frazil_forcing.o: mpas_ocn_constants.o mpas_ocn_forcing_restoring.o: mpas_ocn_constants.o From 1511944d49c171a64cb8ed1c8ef5e18466391e72 Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 20 Oct 2015 15:28:46 -0600 Subject: [PATCH 0334/1724] add missing config_ options. fix name of frazil thickness tendency array name --- src/core_ocean/Registry.xml | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index e2f7bfe8fa..b7329fb6ef 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -636,6 +636,14 @@ description="Energy per kilogram per C needed to raise ocean temperature 1 C. NOTE: test and make consistent with ACME." possible_values="Any positive real number." /> + + - From e05955a95750a1391253cf21cbcb63200ea299fb Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 20 Oct 2015 15:29:57 -0600 Subject: [PATCH 0335/1724] add frazil contribution to total surface pressure + pressure(1,iCell) = 0.0_RKIND + pressure(1,iCell) = pressure(1,iCell) + frazilSurfacePressure(iCell) + pressure(1,iCell) = pressure(1,iCell) + seaSurfacePressure(iCell) + pressure(1,iCell) = pressure(1,iCell) + density(1,iCell)*gravity*0.5*layerThickness(1,iCell) --- src/core_ocean/shared/mpas_ocn_diagnostics.F | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index 163f883d66..949bf282f1 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -113,7 +113,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic real (kind=RKIND), dimension(:), allocatable:: pTop, div_hu,div_huTransport,div_huGMBolus real (kind=RKIND), dimension(:), pointer :: & - bottomDepth, fVertex, dvEdge, dcEdge, areaCell, areaTriangle, ssh, seaSurfacePressure + bottomDepth, fVertex, dvEdge, dcEdge, areaCell, areaTriangle, ssh, seaSurfacePressure, frazilSurfacePressure real (kind=RKIND), dimension(:,:), pointer :: & weightsOnEdge, kiteAreasOnVertex, layerThicknessEdge, layerThickness, normalVelocity, normalTransportVelocity, normalGMBolusVelocity, tangentialVelocity, pressure,& circulation, kineticEnergyCell, montgomeryPotential, vertAleTransportTop, zMid, zTop, divergence, & @@ -221,6 +221,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) + call mpas_pool_get_array(forcingPool, 'frazilSurfacePressure', frazilSurfacePressure) call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) @@ -530,8 +531,10 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ! Pressure for generalized coordinates. ! Pressure at top surface may be due to atmospheric pressure ! or an ice-shelf depression. - pressure(1,iCell) = seaSurfacePressure(iCell) + density(1,iCell)*gravity & - * 0.5*layerThickness(1,iCell) + pressure(1,iCell) = 0.0_RKIND + pressure(1,iCell) = pressure(1,iCell) + frazilSurfacePressure(iCell) + pressure(1,iCell) = pressure(1,iCell) + seaSurfacePressure(iCell) + pressure(1,iCell) = pressure(1,iCell) + density(1,iCell)*gravity*0.5*layerThickness(1,iCell) do k = 2, maxLevelCell(iCell) pressure(k,iCell) = pressure(k-1,iCell) & From 71869e31c5e9a6adeeaabc6b469ad46eef0970e2 Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 20 Oct 2015 15:30:46 -0600 Subject: [PATCH 0336/1724] this version of the frazil algorithm compiles --- .../shared/mpas_ocn_frazil_forcing.F | 319 +++++++++++------- 1 file changed, 194 insertions(+), 125 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_frazil_forcing.F b/src/core_ocean/shared/mpas_ocn_frazil_forcing.F index 4d4f7f9e58..e6f5da1170 100644 --- a/src/core_ocean/shared/mpas_ocn_frazil_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_frazil_forcing.F @@ -20,9 +20,11 @@ module ocn_frazil_forcing use mpas_kind_types + use mpas_constants use mpas_derived_types use mpas_pool_routines use mpas_timekeeping + use mpas_timer use ocn_constants implicit none @@ -43,7 +45,7 @@ module ocn_frazil_forcing public :: ocn_frazil_forcing_build_arrays, & ocn_frazil_forcing_tracers, & - ocn_frazil_forcing_thickness, & + ocn_frazil_forcing_layer_thickness, & ocn_frazil_forcing_surface_pressure, & ocn_frazil_forcing_init @@ -80,9 +82,6 @@ subroutine ocn_frazil_forcing_tracers(meshPool, groupName, forcingPool, tracersT ! input variables ! !----------------------------------------------------------------- - type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information - type (mpas_pool_type), intent(in) :: forcingPool !< Input: forcing pool holding frazil-induced tendencies - type (mpas_pool_type), intent(in) :: tracersTendPool !< Input: tracer tendency pool used to time step tracer fields character (len=*) :: groupName !< Input: Name of tracer group !----------------------------------------------------------------- @@ -90,6 +89,9 @@ subroutine ocn_frazil_forcing_tracers(meshPool, groupName, forcingPool, tracersT ! input/output variables ! !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: meshPool !< Input/Output: mesh information + type (mpas_pool_type), intent(inout) :: forcingPool !< Input/Output: forcing pool holding frazil-induced tendencies + type (mpas_pool_type), intent(inout) :: tracersTendPool !< Input/Output: tracer tendency pool used to time step tracer fields !----------------------------------------------------------------- ! @@ -117,7 +119,7 @@ end subroutine ocn_frazil_forcing_tracers!}}} !*********************************************************************** ! -! routine ocn_frazil_forcing_thickness +! routine ocn_frazil_forcing_layer_thickness ! !> \brief Add tendency due to frazil processes !> \author Todd Ringler @@ -127,7 +129,7 @@ end subroutine ocn_frazil_forcing_tracers!}}} ! !----------------------------------------------------------------------- - subroutine ocn_frazil_forcing_thickness(meshPool, forcingPool, tendPool, err)!{{{ + subroutine ocn_frazil_forcing_layer_thickness(meshPool, forcingPool, tendPool, err)!{{{ !----------------------------------------------------------------- ! @@ -161,6 +163,7 @@ subroutine ocn_frazil_forcing_thickness(meshPool, forcingPool, tendPool, err)!{{ integer :: iCell, k integer, pointer :: nCells integer, dimension(:), pointer :: maxLevelCell + real (kind=RKIND), dimension(:,:), pointer :: frazilLayerThicknessTendency real (kind=RKIND), dimension(:,:), pointer :: layerThicknessTend err = 0 @@ -177,9 +180,74 @@ subroutine ocn_frazil_forcing_thickness(meshPool, forcingPool, tendPool, err)!{{ do k = 1, maxLevelCell(iCell) layerThicknessTend(k,iCell) = layerThicknessTend(k,iCell) + frazilLayerThicknessTendency(k,iCell) end do + end do end subroutine ocn_frazil_forcing_layer_thickness!}}} + +!*********************************************************************** +! +! routine ocn_frazil_forcing_surface_pressure +! +!> \brief Add frazil pressure to total pressure +!> \author Todd Ringler +!> \date 18 October 2015 +!> \details +!> This routine adds frazil surface pressure to total surface pressure +! +!----------------------------------------------------------------------- + + subroutine ocn_frazil_forcing_surface_pressure(meshPool, forcingPool, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell + integer, pointer :: nCells + real (kind=RKIND), dimension(:), pointer :: frazilSurfacePressure + real (kind=RKIND), dimension(:), pointer :: seaSurfacePressure + + err = 0 + + if ( .not. frazilFormationOn ) return + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) + call mpas_pool_get_array(forcingPool, 'frazilSurfacePressure', frazilSurfacePressure) + + ! add frazil surface pressure to total surface pressure + do iCell = 1, nCells + seaSurfacePressure(iCell) = seaSurfacePressure(iCell) + frazilSurfacePressure(iCell) + end do + + end subroutine ocn_frazil_forcing_surface_pressure!}}} + !*********************************************************************** ! ! routine ocn_frazil_forcing_active_tracers @@ -193,7 +261,7 @@ end subroutine ocn_frazil_forcing_layer_thickness!}}} ! !----------------------------------------------------------------------- - subroutine ocn_frazil_forcing_active_tracers(meshPool, forcingPool, tracerTendPool, err)!{{{ + subroutine ocn_frazil_forcing_active_tracers(meshPool, forcingPool, tracersTendPool, err)!{{{ !----------------------------------------------------------------- ! @@ -208,7 +276,7 @@ subroutine ocn_frazil_forcing_active_tracers(meshPool, forcingPool, tracerTendPo ! !----------------------------------------------------------------- type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information - type (mpas_pool_type), intent(inout) :: tracerTendPool !< Input: tendency pool + type (mpas_pool_type), intent(inout) :: tracersTendPool !< Input: tendency pool !----------------------------------------------------------------- ! @@ -226,12 +294,13 @@ subroutine ocn_frazil_forcing_active_tracers(meshPool, forcingPool, tracerTendPo integer :: iCell, k integer, pointer :: nCells - integer, pointer :: indexTemperature, indexSalinity + integer, pointer :: indexTemperature + integer, pointer :: indexSalinity integer, pointer, dimension(:) :: maxLevelCell real (kind=RKIND), dimension(:,:), pointer :: frazilTemperatureTendency real (kind=RKIND), dimension(:,:), pointer :: frazilSalinityTendency - real (kind=RKIND), dimension(:,:,:), pointer :: activeTracerTend + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracersTend err = 0 @@ -290,8 +359,6 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo !----------------------------------------------------------------- type (mpas_pool_type), pointer, intent(in) :: meshPool !< Input: Mesh information - type (mpas_pool_type), pointer, intent(in) :: forcingPool !< Input: Forcing information - type (mpas_pool_type), pointer, intent(in) :: statePool !< Input: State information type (mpas_pool_type), pointer, intent(in) :: diagnosticsPool !< Input: Diagnostic information !----------------------------------------------------------------- @@ -299,6 +366,7 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo ! input/output variables ! !----------------------------------------------------------------- + type (mpas_pool_type), pointer, intent(in) :: statePool !< Input: State information type (mpas_pool_type), pointer, intent(in) :: forcingPool !< Input: Forcing information integer, intent(inout) :: err !< Error flag @@ -313,37 +381,40 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo ! local variables ! !----------------------------------------------------------------- - type (block_type), pointer :: block - type (mpas_pool_type) :: tracerPool + type (mpas_pool_type), pointer :: tracersPool real (kind=RKIND), dimension(:,:), pointer :: frazilLayerThicknessTendency real (kind=RKIND), dimension(:,:), pointer :: frazilTemperatureTendency real (kind=RKIND), dimension(:,:), pointer :: frazilSalinityTendency - real (kind=RKIND), dimension(:), pointer :: frazilSurfacePressure + real (kind=RKIND), dimension(:), pointer :: frazilSurfacePressure - integer :: iCell, k, kBottomFrazil + integer :: iCell, k integer, pointer :: nCells, nVertLevels + real (kind=RKIND), pointer :: config_dt real (kind=RKIND), pointer :: config_frazil_heat_of_fusion real (kind=RKIND), pointer :: config_frazil_sea_ice_density real (kind=RKIND), pointer :: config_frazil_fractional_thickness_limit + real (kind=RKIND), pointer :: config_frazil_maximum_depth + real (kind=RKIND), pointer :: config_specific_heat_sea_water + real (kind=RKIND), pointer :: config_frazil_ice_reference_salinity real (kind=RKIND) :: newFrazilIceThickness real (kind=RKIND) :: sumNewFrazilIceThickness real (kind=RKIND) :: meltedFrazilIceThickness real (kind=RKIND) :: oceanFreezingTemperature - real (kind=RKIND), pointer, dimension(:) :: accumulatedFrazilIceMassNew - real (kind=RKIND), pointer, dimension(:) :: accumulatedFrazilIceMassOld - real (kind=RKIND), pointer, dimension(:,:) :: zMid - real (kind=RKIND), pointer, dimension(:,:) :: density - real (kind=RKIND), pointer, dimension(:,:) :: layerThickness + real (kind=RKIND), pointer, dimension(:) :: accumulatedFrazilIceMassNew + real (kind=RKIND), pointer, dimension(:) :: accumulatedFrazilIceMassOld + real (kind=RKIND), pointer, dimension(:,:) :: zMid + real (kind=RKIND), pointer, dimension(:,:) :: layerThickness + real (kind=RKIND), pointer, dimension(:,:,:) :: activeTracers integer, dimension(:), pointer :: maxLevelCell - integer :: indexTemperature !< index in tracers array for temperature - integer :: indexSalinity !< index in tracers array for salinity + integer, pointer :: indexTemperature !< index in tracers array for temperature + integer, pointer :: indexSalinity !< index in tracers array for salinity + integer :: kBottomFrazil ! k index where testing for frazil begins - real (kind=RKIND) :: kBottomFrazil ! k index where testing for frazil begins real (kind=RKIND) :: potential ! scalar holding freezing/melt potential real (kind=RKIND) :: freezingEnergy ! energy available for freezing, positive definite real (kind=RKIND) :: meltingEnergy ! energy available for melting, positive definite @@ -352,104 +423,101 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo if(.not. frazilFormationOn) return call mpas_timer_start("fazil", .false., timer_frazil) - block => domain % blocklist - do while (associated(block)) - - ! get pool pointers - call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) - call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) - call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) - - ! get dimensions - call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) - call mpas_pool_get_dimension(block % dimensions, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) - call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) - - ! get mesh information - call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - - ! get arrays - ! note: state information is used to produce tendencies, so always grab "new" time level - call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 2) - call mpas_pool_get_array(statePool, 'accumulatedFrazilIceMass', accumulatedFrazilIceMassNew, 2) - call mpas_pool_get_array(statePool, 'accumulatedFrazilIceMass', accumulatedFrazilIceMassOld, 1) - call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 2) - call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) - call mpas_pool_get_array(diagnosticsPool, 'density', density) - call mpas_pool_get_array(forcingPool, 'frazilTemperatureTendency', frazilTemperatureTendency) - call mpas_pool_get_array(forcingPool,'frazilSalinityTendency', frazilSalinityTendency) - call mpas_pool_get_array(forcingPool,'frazilThicknessTendency', frazilThicknessTendency) - call mpas_pool_get_array(forcingPool,'frazilSurfacePressure', frazilSurfacePressure) - - ! get configure parameters - call mpas_pool_get_config(domain % configs, 'config_frazil_maximum_depth', config_frazil_maximum_depth) - call mpas_pool_get_config(domain % configs, 'config_frazil_fractional_thickness_limit', config_frazil_fractional_thickness_limit) - call mpas_pool_get_config(domain % configs, 'config_specific_heat_sea_water', config_specific_heat_sea_water) - call mpas_pool_get_config(domain % configs, 'config_frazil_heat_of_fusion', config_frazil_heat_of_fusion) - call mpas_pool_get_config(domain % configs, 'config_frazil_sea_ice_density', config_frazil_sea_ice_density) - - ! initialize frazil tendency fields - frazilTemperatureTendency = 0.0_RKIND - frazilSalinityTendency = 0.0_RKIND - frazilThicknessTendency = 0.0_RKIND - - ! loop over all columns - do iCell=1,nCells - - ! find deepest level where frazil can be created - do k=maxLevelCell(iCell), 1, -1 - if(-zMid(k,iCell).lt.config_frazil_maximum_depth) then - kBottomFrazil=k - exit - endif - enddo - - ! zero the sum of new frazil ice created - sumNewFrazilIceThickness = 0.0_RKIND - - ! loop from maximum depth of frazil creation to surface - do k = kBottomFrazil, 1, -1 - - ! get freezing temperature - oceanFreezingTemperature = ocn_freezing_temperature(activeTracers(indexSalinity,k,iCell)) - - potential = layerThickness(k,iCell) * config_specific_heat_sea_water & - * density(k,iCell) * (activeTracers(indexTemperature,k,iCell) - oceanFreezingTemperature) - freezingEnergy = max(0.0_RKIND, -potential) - meltingEnergy = max(0.0_RKIND, potential) - - if (freezingEnergy < 0) then - - ! new frazil ice formation measured in meters - newFrazilIceThickness = freezingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) - - ! limit the frazil formed appropriately - newFrazilIceThickness = min(newFrazilIceThickness, layerThickness(k,iCell) * config_frazil_fractional_thickness_limit) - ! compute tendency to thickness, temperature and salinity - ! layerTendency is scaled so that mass of ice created == mass of ocean water removed + ! get pool pointers + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + + ! get dimensions + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) + + ! get mesh information + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + + ! get arrays + ! note: state information is used to produce tendencies, so always grab "new" time level + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 2) + call mpas_pool_get_array(statePool, 'accumulatedFrazilIceMass', accumulatedFrazilIceMassNew, 2) + call mpas_pool_get_array(statePool, 'accumulatedFrazilIceMass', accumulatedFrazilIceMassOld, 1) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 2) + call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + call mpas_pool_get_array(forcingPool, 'frazilTemperatureTendency', frazilTemperatureTendency) + call mpas_pool_get_array(forcingPool,'frazilSalinityTendency', frazilSalinityTendency) + call mpas_pool_get_array(forcingPool,'frazilLayerThicknessTendency', frazilLayerThicknessTendency) + call mpas_pool_get_array(forcingPool,'frazilSurfacePressure', frazilSurfacePressure) + + ! get configure parameters + call mpas_pool_get_config(ocnConfigs, 'config_dt', config_dt) + call mpas_pool_get_config(ocnConfigs, 'config_frazil_maximum_depth', config_frazil_maximum_depth) + call mpas_pool_get_config(ocnConfigs, 'config_frazil_fractional_thickness_limit', config_frazil_fractional_thickness_limit) + call mpas_pool_get_config(ocnConfigs, 'config_specific_heat_sea_water', config_specific_heat_sea_water) + call mpas_pool_get_config(ocnConfigs, 'config_frazil_heat_of_fusion', config_frazil_heat_of_fusion) + call mpas_pool_get_config(ocnConfigs, 'config_frazil_sea_ice_density', config_frazil_sea_ice_density) + call mpas_pool_get_config(ocnConfigs, 'config_frazil_ice_reference_salinity', config_frazil_ice_reference_salinity) + + ! initialize frazil tendency fields + frazilTemperatureTendency = 0.0_RKIND + frazilSalinityTendency = 0.0_RKIND + frazilLayerThicknessTendency = 0.0_RKIND + + ! loop over all columns + do iCell=1,nCells - ! layer thickness decreased due to creation of frazil - frazilThicknessTendency(k,iCell) = - newFrazilIceThickness * config_frazil_sea_ice_density / density(k,iCell) / dt + ! find deepest level where frazil can be created + kBottomFrazil=maxLevelCell(iCell) + do k=maxLevelCell(iCell), 1, -1 + if(-zMid(k,iCell).lt.config_frazil_maximum_depth) then + kBottomFrazil=k + exit + endif + enddo - ! salt is extracted with the frazil - frazilSalinityTendency(k,iCell) = - newFrazilIceThickness * config_frazil_iceReferenceSalinity / dt + ! zero the sum of new frazil ice created + sumNewFrazilIceThickness = 0.0_RKIND - ! ocean fluid temperature is warmed due to creation of frazil - frazilTemperatureTendency(k,iCell) = & - + ( newFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density ) & - / (config_specific_heat_sea_water * density(k,iCell)) / dt + ! loop from maximum depth of frazil creation to surface + do k = kBottomFrazil, 1, -1 - ! accumulate frazil mass to column total - ! note: accumulatedFrazilIceMass (at both time levels) is reset to zero after being sent to the coupler - accumulatedFrazilIceMassNew(iCell) = accumulatedFrazilIceMassOld(iCell) + newFrazilIceThickness*config_frazil_sea_ice_density + ! get freezing temperature + oceanFreezingTemperature = ocn_freezing_temperature(activeTracers(indexSalinity,k,iCell)) - ! keep track of sum of frazil ice - sumNewFrazilIceThickness = sumNewFrazilIceThickness + newFrazilIceThickness + potential = layerThickness(k,iCell) * config_specific_heat_sea_water & + * rho_sw * (activeTracers(indexTemperature,k,iCell) - oceanFreezingTemperature) + freezingEnergy = max(0.0_RKIND, -potential) + meltingEnergy = max(0.0_RKIND, potential) - else + if (freezingEnergy < 0) then + + ! new frazil ice formation measured in meters + newFrazilIceThickness = freezingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) + + ! limit the frazil formed appropriately + newFrazilIceThickness = min(newFrazilIceThickness, layerThickness(k,iCell) * config_frazil_fractional_thickness_limit) + + ! compute tendency to thickness, temperature and salinity + ! layerTendency is scaled so that mass of ice created == mass of ocean water removed + + ! layer thickness decreased due to creation of frazil + frazilLayerThicknessTendency(k,iCell) = - newFrazilIceThickness * config_frazil_sea_ice_density / rho_sw / config_dt + + ! salt is extracted with the frazil + frazilSalinityTendency(k,iCell) = - newFrazilIceThickness * config_frazil_ice_reference_salinity / config_dt + + ! ocean fluid temperature is warmed due to creation of frazil + frazilTemperatureTendency(k,iCell) = & + + ( newFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density ) & + / (config_specific_heat_sea_water * rho_sw) / config_dt + + ! accumulate frazil mass to column total + ! note: accumulatedFrazilIceMass (at both time levels) is reset to zero after being sent to the coupler + accumulatedFrazilIceMassNew(iCell) = accumulatedFrazilIceMassOld(iCell) + newFrazilIceThickness*config_frazil_sea_ice_density + + ! keep track of sum of frazil ice + sumNewFrazilIceThickness = sumNewFrazilIceThickness + newFrazilIceThickness + + else ! ocean water is warm enough to melt frazil @@ -468,15 +536,15 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo ! compute tendency to thickness, temperature and salinity ! layer thickness increases due to melting of frazil - frazilThicknessTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_sea_ice_density / density(k,iCell) / dt + frazilLayerThicknessTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_sea_ice_density / rho_sw / config_dt ! salt is released into ocean with the melting frazil - frazilSalinityTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_iceReferenceSalinity / dt + frazilSalinityTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_ice_reference_salinity / config_dt ! ocean fluid temperature is cooled due to melting of frazil frazilTemperatureTendency(k,iCell) = & - ( meltedFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density ) & - / (config_specific_heat_sea_water * density(k,iCell)) / dt + / (config_specific_heat_sea_water * rho_sw) / config_dt ! deaccumulate frazil accumulatedFrazilIceMassNew(iCell) = accumulatedFrazilIceMassOld(iCell) - meltedFrazilIceThickness*config_frazil_sea_ice_density @@ -484,16 +552,17 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo ! keep track of new frazil ice sumNewFrazilIceThickness = sumNewFrazilIceThickness - meltedFrazilIceThickness - endif ! if (freezingEnergy < 0) + endif ! if (sumNewFrazilIceThickness > 0.0_RKIND) + + endif ! if (freezingEnergy < 0) - enddo ! do k=kBottom,1-1 + enddo ! do k=kBottom,1-1 - ! sea surface pressure due to the net production of frazil ice - frazilSurfacePressure(iCell) = accumulatedFrazilIceMass(iCell) * gravity / dt + ! sea surface pressure due to the net production of frazil ice + frazilSurfacePressure(iCell) = accumulatedFrazilIceMassNew(iCell) * gravity - enddo ! do iCell = 1, nCells + enddo ! do iCell = 1, nCells - enddo ! iBlock call mpas_timer_stop("frazil", timer_frazil) end subroutine ocn_frazil_forcing_build_arrays!}}} @@ -547,7 +616,7 @@ end subroutine ocn_frazil_forcing_init!}}} !*********************************************************************** -end module ocn_sea_ice +end module ocn_frazil_forcing !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! vim: foldmethod=marker From f504f30a8899c0ae81e2924dc826321d1d360d11 Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 20 Oct 2015 15:31:10 -0600 Subject: [PATCH 0337/1724] connect frazil algorithm to model driver layer (note, from ocn_tendency are still missing) --- src/core_ocean/mode_forward/mpas_ocn_forward_mode.F | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index dd0af04696..3881c35876 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -52,6 +52,7 @@ module ocn_forward_mode use ocn_vel_forcing_surface_stress use ocn_surface_bulk_forcing use ocn_surface_land_ice_fluxes + use ocn_frazil_forcing use ocn_tracer_hmix use ocn_tracer_surface_flux_to_tend @@ -210,6 +211,8 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ ierr = ior(ierr, err_tmp) call ocn_surface_land_ice_fluxes_init(err_tmp) ierr = ior(ierr, err_tmp) + call ocn_frazil_forcing_init(err_tmp) + ierr = ior(ierr, err_tmp) call ocn_tracer_hmix_init(err_tmp) ierr = ior(ierr, err_tmp) @@ -488,9 +491,7 @@ function ocn_forward_mode_run(domain) result(ierr)!{{{ forcingPool, scratchPool, err) call mpas_timer_stop("land_ice_build_arrays") - !! TDR - call ocn_frazil_build_arrays( ) - !! TDR + call ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPool, statePool, err) block_ptr => block_ptr % next end do From 067a021725ca1d5f6086a2ff6255de268ff2acdb Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 20 Oct 2015 16:16:21 -0600 Subject: [PATCH 0338/1724] change config to config_use_frazil_ice_formation remove call to old sea_ice routines --- src/core_ocean/driver/mpas_ocn_core_interface.F | 7 +++---- .../mode_forward/mpas_ocn_time_integration_rk4.F | 7 ------- .../mode_forward/mpas_ocn_time_integration_split.F | 9 --------- src/core_ocean/shared/mpas_ocn_sea_ice.F | 6 +++--- 4 files changed, 6 insertions(+), 23 deletions(-) diff --git a/src/core_ocean/driver/mpas_ocn_core_interface.F b/src/core_ocean/driver/mpas_ocn_core_interface.F index 25a295f52f..9bd8656276 100644 --- a/src/core_ocean/driver/mpas_ocn_core_interface.F +++ b/src/core_ocean/driver/mpas_ocn_core_interface.F @@ -136,7 +136,7 @@ function ocn_setup_packages(configPool, packagePool, iocontext) result(ierr)!{{{ logical, pointer :: config_use_tracerGroup_ttd_forcing logical, pointer :: config_use_freq_filtered_thickness - logical, pointer :: config_frazil_ice_formation + logical, pointer :: config_use_frazil_ice_formation character (len=StrKIND), pointer :: config_time_integrator character (len=StrKIND), pointer :: config_ocean_run_mode character (len=StrKIND), pointer :: config_pressure_gradient_type @@ -221,10 +221,9 @@ function ocn_setup_packages(configPool, packagePool, iocontext) result(ierr)!{{{ ! ! test for use of frazil ice formation, frazilIceActive ! - ! TDR: need to add PKG call mpas_pool_get_package(packagePool, 'frazilIceActive', frazilIceActive) - call mpas_pool_get_config(configPool, 'config_frazil_ice_formation', config_frazil_ice_formation) - if (config_frazil_ice_formation) then + call mpas_pool_get_config(configPool, 'config_use_frazil_ice_formation', config_use_frazil_ice_formation) + if (config_use_frazil_ice_formation) then frazilIceActive = .true. end if diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F index 1f361219af..e81c14e643 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F @@ -36,7 +36,6 @@ module ocn_time_integration_rk4 use ocn_vmix use ocn_time_average use ocn_time_average_coupled - use ocn_sea_ice implicit none private @@ -166,9 +165,6 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ real (kind=RKIND), dimension(:,:,:), pointer :: tracerGroup, tracersCur, tracersNew - ! Forcing Array pointers - real (kind=RKIND), dimension(:), pointer :: seaIceEnergy - ! Diagnostics Field Pointers type (field1DReal), pointer :: boundaryLayerDepthField type (field2DReal), pointer :: normalizedRelativeVorticityEdgeField, divergenceField, relativeVorticityField @@ -694,8 +690,6 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(forcingPool, 'seaIceEnergy', seaIceEnergy) - call mpas_pool_begin_iteration(tracersPool) do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) if ( groupItr % memberType == MPAS_POOL_FIELD ) then @@ -711,7 +705,6 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ end do call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) - call ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, layerThicknessNew, tracersNew, seaIceEnergy, err) block => block % next end do diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F index 58230e7392..14356bde62 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F @@ -38,8 +38,6 @@ module ocn_time_integration_split use ocn_time_average use ocn_time_average_coupled - use ocn_sea_ice - implicit none private save @@ -181,9 +179,6 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ real (kind=RKIND), dimension(:,:), pointer :: gradSSHZonal, gradSSHMeridional real (kind=RKIND), dimension(:,:), pointer :: surfaceVelocity, SSHGradient - ! Forcing Array Pointer - real (kind=RKIND), dimension(:), pointer :: seaIceEnergy - ! Diagnostics Field Pointers type (field2DReal), pointer :: normalizedRelativeVorticityEdgeField, divergenceField, relativeVorticityField type (field1DReal), pointer :: barotropicThicknessFluxField, boundaryLayerDepthField @@ -1487,11 +1482,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(statePool, 'layerThickness', layerThicknessNew, 2) call mpas_pool_get_array(tracersPool, 'activeTracers', tracersGroupNew, 2) - call mpas_pool_get_array(forcingPool, 'seaIceEnergy', seaIceEnergy) - call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) - call ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, layerThicknessNew, & - tracersGroupNew, seaIceEnergy, err) block => block % next end do diff --git a/src/core_ocean/shared/mpas_ocn_sea_ice.F b/src/core_ocean/shared/mpas_ocn_sea_ice.F index 55809b8c58..73a3b862d6 100644 --- a/src/core_ocean/shared/mpas_ocn_sea_ice.F +++ b/src/core_ocean/shared/mpas_ocn_sea_ice.F @@ -274,16 +274,16 @@ subroutine ocn_sea_ice_init(nVertLevels, err)!{{{ integer, intent(in) :: nVertLevels !< Input: Number of vertical levels suggested for level cap integer, intent(out) :: err !< Output: error flag - logical, pointer :: config_frazil_ice_formation, config_monotonic + logical, pointer :: config_use_frazil_ice_formation, config_monotonic err = 0 - call mpas_pool_get_config(ocnConfigs, 'config_frazil_ice_formation', config_frazil_ice_formation) + call mpas_pool_get_config(ocnConfigs, 'config_use_frazil_ice_formation', config_use_frazil_ice_formation) call mpas_pool_get_config(ocnConfigs, 'config_monotonic', config_monotonic) frazilFormationOn = .false. - if(config_frazil_ice_formation) then + if(config_use_frazil_ice_formation) then frazilFormationOn = .true. end if From 1080a3b6d7f79fe61ade98eac26c97dfab041384 Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 21 Oct 2015 14:10:39 -0600 Subject: [PATCH 0339/1724] add configure variable to use as a threshold for testing if frazil is produced --- src/core_ocean/Registry.xml | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index b7329fb6ef..779e795fbb 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -644,6 +644,10 @@ description="assumed salinity of frazil ice." possible_values="Any positive real number." /> + - - - From da8fc064b3797746fab178dd50d31304741217d9 Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 21 Oct 2015 14:11:50 -0600 Subject: [PATCH 0340/1724] call build_arrays from the forward model. --- src/core_ocean/mode_forward/mpas_ocn_forward_mode.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index 3881c35876..ec7d656482 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -491,7 +491,7 @@ function ocn_forward_mode_run(domain) result(ierr)!{{{ forcingPool, scratchPool, err) call mpas_timer_stop("land_ice_build_arrays") - call ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPool, statePool, err) + call ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagnosticsPool, statePool, err) block_ptr => block_ptr % next end do From a322d3dfb6684dec19306e1611fc5dbcddfaf04f Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 21 Oct 2015 14:12:14 -0600 Subject: [PATCH 0341/1724] only add frazilSurfacePressure is associated --- src/core_ocean/shared/mpas_ocn_diagnostics.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index 949bf282f1..cdc339f40a 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -532,7 +532,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ! Pressure at top surface may be due to atmospheric pressure ! or an ice-shelf depression. pressure(1,iCell) = 0.0_RKIND - pressure(1,iCell) = pressure(1,iCell) + frazilSurfacePressure(iCell) + if ( associated(frazilSurfacePressure) ) pressure(1,iCell) = pressure(1,iCell) + frazilSurfacePressure(iCell) pressure(1,iCell) = pressure(1,iCell) + seaSurfacePressure(iCell) pressure(1,iCell) = pressure(1,iCell) + density(1,iCell)*gravity*0.5*layerThickness(1,iCell) From 87e7cc125d87763e2da1a43ba379fdfedd1a7573 Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 21 Oct 2015 14:12:45 -0600 Subject: [PATCH 0342/1724] get layerThickness and tracer tendencies due to frazil processes --- src/core_ocean/shared/mpas_ocn_tendency.F | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index 83319eecaa..8758fb0553 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -177,6 +177,13 @@ subroutine ocn_tend_thick(tendPool, forcingPool, diagnosticsPool, meshPool)!{{{ call ocn_thick_surface_flux_tend(meshPool, fractionAbsorbed, layerThickness, surfaceThicknessFlux, tend_layerThickness, err) call mpas_timer_stop("surface flux") + ! + ! surface flux tendency + ! + call mpas_timer_start("frazil thickness tendency", .false.) + call ocn_frazil_forcing_layer_thickness(meshPool, forcingPool, tend_layerThickness, err) + call mpas_timer_stop("frazil thickness tendency") + call mpas_timer_stop("ocn_tend_thick") end subroutine ocn_tend_thick!}}} @@ -362,7 +369,7 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me type (mpas_pool_type), intent(in) :: statePool !< Input: State information type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostic information - type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + type (mpas_pool_type), intent(inout) :: meshPool !< Input: Mesh information type (mpas_pool_type), intent(in) :: scratchPool !< Input: Scratch information real (kind=RKIND), intent(in) :: dt !< Input: Time step integer, intent(in), optional :: timeLevelIn !< Input/Optional: Time Level Indes @@ -673,6 +680,14 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me call ocn_tracer_nonlocalflux_tend(meshPool, vertNonLocalFlux, tracerGroupSurfaceFlux, tracerGroupTend, err) call mpas_timer_stop("non-local flux from KPP") end if + + ! + ! Compute tracer tendency due to production/destruction of frazil ice + ! + call mpas_timer_start("frazil", .false.) + call ocn_frazil_forcing_tracers(meshPool, tracersPool, groupItr%memberName, forcingPool, tracerGroupTend, err) + call mpas_timer_stop("frazil") + end if end if end do From 2c420d026cca4715ccb6854c4bb45f44e9b6324d Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 21 Oct 2015 14:13:30 -0600 Subject: [PATCH 0343/1724] add many print statements for debugging make connections to be called from ocean tendency routine --- .../shared/mpas_ocn_frazil_forcing.F | 130 +++++++++++++----- 1 file changed, 92 insertions(+), 38 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_frazil_forcing.F b/src/core_ocean/shared/mpas_ocn_frazil_forcing.F index e6f5da1170..54b974ef2b 100644 --- a/src/core_ocean/shared/mpas_ocn_frazil_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_frazil_forcing.F @@ -75,7 +75,7 @@ module ocn_frazil_forcing ! !----------------------------------------------------------------------- - subroutine ocn_frazil_forcing_tracers(meshPool, groupName, forcingPool, tracersTendPool, err)!{{{ + subroutine ocn_frazil_forcing_tracers(meshPool, tracersPool, groupName, forcingPool, tracersTend, err)!{{{ !----------------------------------------------------------------- ! @@ -90,9 +90,9 @@ subroutine ocn_frazil_forcing_tracers(meshPool, groupName, forcingPool, tracersT ! !----------------------------------------------------------------- type (mpas_pool_type), intent(inout) :: meshPool !< Input/Output: mesh information + type (mpas_pool_type), intent(inout) :: tracersPool !< Input/Output: tracer tendency pool type (mpas_pool_type), intent(inout) :: forcingPool !< Input/Output: forcing pool holding frazil-induced tendencies - type (mpas_pool_type), intent(inout) :: tracersTendPool !< Input/Output: tracer tendency pool used to time step tracer fields - + real (kind=RKIND), dimension(:,:,:), intent(inout) :: tracersTend !----------------------------------------------------------------- ! ! output variables @@ -109,10 +109,12 @@ subroutine ocn_frazil_forcing_tracers(meshPool, groupName, forcingPool, tracersT err = 0 + write(stderrUnit,*) 'entering ocn_frazil_forcing_tracers', trim(groupName) + if ( .not. frazilFormationOn ) return if ( trim(groupName) == 'activeTracers' ) then - call ocn_frazil_forcing_active_tracers(meshPool, forcingPool, tracersTendPool, err) + call ocn_frazil_forcing_active_tracers(meshPool, tracersPool, forcingPool, tracersTend, err) end if end subroutine ocn_frazil_forcing_tracers!}}} @@ -129,7 +131,7 @@ end subroutine ocn_frazil_forcing_tracers!}}} ! !----------------------------------------------------------------------- - subroutine ocn_frazil_forcing_layer_thickness(meshPool, forcingPool, tendPool, err)!{{{ + subroutine ocn_frazil_forcing_layer_thickness(meshPool, forcingPool, layerThicknessTend, err)!{{{ !----------------------------------------------------------------- ! @@ -137,14 +139,14 @@ subroutine ocn_frazil_forcing_layer_thickness(meshPool, forcingPool, tendPool, e ! !----------------------------------------------------------------- type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: forcingPool !< Input: Forcing information !----------------------------------------------------------------- ! ! input/output variables ! !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information - type (mpas_pool_type), intent(inout) :: tendPool !< Input: Tendency information + real (kind=RKIND), intent(inout), dimension(:,:) :: layerThicknessTend !----------------------------------------------------------------- ! @@ -164,16 +166,16 @@ subroutine ocn_frazil_forcing_layer_thickness(meshPool, forcingPool, tendPool, e integer, pointer :: nCells integer, dimension(:), pointer :: maxLevelCell real (kind=RKIND), dimension(:,:), pointer :: frazilLayerThicknessTendency - real (kind=RKIND), dimension(:,:), pointer :: layerThicknessTend err = 0 + write(stderrUnit,*) 'entering ocn_frazil_layer_thickness' + if ( .not. frazilFormationOn ) return call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) call mpas_pool_get_array(forcingPool, 'frazilLayerThicknessTendency', frazilLayerThicknessTendency) - call mpas_pool_get_array(tendPool, 'layerThicknessTend', layerThicknessTend) ! Build surface fluxes at cell centers do iCell = 1, nCells @@ -182,6 +184,8 @@ subroutine ocn_frazil_forcing_layer_thickness(meshPool, forcingPool, tendPool, e end do end do + write(stderrUnit,*) ' max val ', maxval(abs(frazilLayerThicknessTendency)) + end subroutine ocn_frazil_forcing_layer_thickness!}}} @@ -234,6 +238,8 @@ subroutine ocn_frazil_forcing_surface_pressure(meshPool, forcingPool, err)!{{{ err = 0 + write(stderrUnit,*) 'entering ocn_frazil_forcing_surface_pressure' + if ( .not. frazilFormationOn ) return call mpas_pool_get_dimension(meshPool, 'nCells', nCells) @@ -261,7 +267,7 @@ end subroutine ocn_frazil_forcing_surface_pressure!}}} ! !----------------------------------------------------------------------- - subroutine ocn_frazil_forcing_active_tracers(meshPool, forcingPool, tracersTendPool, err)!{{{ + subroutine ocn_frazil_forcing_active_tracers(meshPool, tracersPool, forcingPool, activeTracersTend, err)!{{{ !----------------------------------------------------------------- ! @@ -269,14 +275,15 @@ subroutine ocn_frazil_forcing_active_tracers(meshPool, forcingPool, tracersTendP ! !----------------------------------------------------------------- type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + type (mpas_pool_type), intent(inout) :: tracersPool !< Input: tracer tendency pool + type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information !----------------------------------------------------------------- ! ! input/output variables ! !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information - type (mpas_pool_type), intent(inout) :: tracersTendPool !< Input: tendency pool + real (kind=RKIND), dimension(:,:,:), intent(inout) :: activeTracersTend !----------------------------------------------------------------- ! @@ -300,18 +307,18 @@ subroutine ocn_frazil_forcing_active_tracers(meshPool, forcingPool, tracersTendP real (kind=RKIND), dimension(:,:), pointer :: frazilTemperatureTendency real (kind=RKIND), dimension(:,:), pointer :: frazilSalinityTendency - real (kind=RKIND), dimension(:,:,:), pointer :: activeTracersTend err = 0 + write(stderrUnit,*) ' entering ocn_frazil_forcing_active_tracers' + if ( .not. frazilFormationOn ) return call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_dimension(tracersTendPool, 'index_temperature', indexTemperature) - call mpas_pool_get_dimension(tracersTendPool, 'index_salinity', indexSalinity) + call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(tracersTendPool, 'activeTracersTend', activeTracersTend) call mpas_pool_get_array(forcingPool, 'frazilTemperatureTendency', frazilTemperatureTendency) call mpas_pool_get_array(forcingPool, 'frazilSalinityTendency', frazilSalinityTendency) @@ -323,6 +330,8 @@ subroutine ocn_frazil_forcing_active_tracers(meshPool, forcingPool, tracersTendP end do end do + write(stderrUnit,*) ' max val ', maxval(abs(frazilTemperatureTendency)), maxval(abs(frazilSalinityTendency)) + end subroutine ocn_frazil_forcing_active_tracers!}}} @@ -350,7 +359,7 @@ end subroutine ocn_frazil_forcing_active_tracers!}}} ! !----------------------------------------------------------------------- - subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPool, statePool, err)!{{{ + subroutine ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagnosticsPool, statePool, err)!{{{ !----------------------------------------------------------------- ! @@ -366,8 +375,9 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo ! input/output variables ! !----------------------------------------------------------------- - type (mpas_pool_type), pointer, intent(in) :: statePool !< Input: State information - type (mpas_pool_type), pointer, intent(in) :: forcingPool !< Input: Forcing information + type (domain_type), intent(inout) :: domain + type (mpas_pool_type), pointer, intent(inout) :: statePool !< Input: State information + type (mpas_pool_type), pointer, intent(inout) :: forcingPool !< Input: Forcing information integer, intent(inout) :: err !< Error flag !----------------------------------------------------------------- @@ -390,14 +400,16 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo integer :: iCell, k integer, pointer :: nCells, nVertLevels + real (kind=RKIND) :: dt, columnTemperatureMin - real (kind=RKIND), pointer :: config_dt + type (MPAS_timeInterval_type) :: timeStep real (kind=RKIND), pointer :: config_frazil_heat_of_fusion real (kind=RKIND), pointer :: config_frazil_sea_ice_density real (kind=RKIND), pointer :: config_frazil_fractional_thickness_limit real (kind=RKIND), pointer :: config_frazil_maximum_depth real (kind=RKIND), pointer :: config_specific_heat_sea_water real (kind=RKIND), pointer :: config_frazil_ice_reference_salinity + real (kind=RKIND), pointer :: config_frazil_maximum_freezing_temperature real (kind=RKIND) :: newFrazilIceThickness real (kind=RKIND) :: sumNewFrazilIceThickness @@ -419,10 +431,12 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo real (kind=RKIND) :: freezingEnergy ! energy available for freezing, positive definite real (kind=RKIND) :: meltingEnergy ! energy available for melting, positive definite + write(stderrUnit,*) 'entering ocn_frazil_forcing_build_arrays', frazilFormationOn + ! if frazil is not enabled, return if(.not. frazilFormationOn) return - call mpas_timer_start("fazil", .false., timer_frazil) + call mpas_timer_start("frazil", .false., timer_frazil) ! get pool pointers call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) @@ -449,19 +463,25 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo call mpas_pool_get_array(forcingPool,'frazilSurfacePressure', frazilSurfacePressure) ! get configure parameters - call mpas_pool_get_config(ocnConfigs, 'config_dt', config_dt) call mpas_pool_get_config(ocnConfigs, 'config_frazil_maximum_depth', config_frazil_maximum_depth) call mpas_pool_get_config(ocnConfigs, 'config_frazil_fractional_thickness_limit', config_frazil_fractional_thickness_limit) call mpas_pool_get_config(ocnConfigs, 'config_specific_heat_sea_water', config_specific_heat_sea_water) call mpas_pool_get_config(ocnConfigs, 'config_frazil_heat_of_fusion', config_frazil_heat_of_fusion) call mpas_pool_get_config(ocnConfigs, 'config_frazil_sea_ice_density', config_frazil_sea_ice_density) call mpas_pool_get_config(ocnConfigs, 'config_frazil_ice_reference_salinity', config_frazil_ice_reference_salinity) + call mpas_pool_get_config(ocnConfigs, 'config_frazil_maximum_freezing_temperature', config_frazil_maximum_freezing_temperature) + + ! get time step in units of seconds + timeStep = mpas_get_clock_timestep(domain % clock, ierr=err) + call mpas_get_timeInterval(timeStep, dt=dt) ! initialize frazil tendency fields frazilTemperatureTendency = 0.0_RKIND frazilSalinityTendency = 0.0_RKIND frazilLayerThicknessTendency = 0.0_RKIND + ! write(stderrUnit,*) 'got time step', dt + ! loop over all columns do iCell=1,nCells @@ -474,7 +494,20 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo endif enddo - ! zero the sum of new frazil ice created + ! find minimum temperature between 1:kBottomFrazil + columnTemperatureMin = 1.0e30_RKIND + do k=1,kBottomFrazil + if(activeTracers(indexTemperature,k,iCell).lt.columnTemperatureMin) columnTemperatureMin=activeTracers(indexTemperature,k,iCell) + enddo + + ! write(stderrUnit,*) 'min temp ', columnTemperatureMin, config_frazil_maximum_freezing_temperature, kBottomFrazil + + ! test min temperature agains max freezing temperature to see if we should even consider creating frazil + if(columnTemperatureMin.gt.config_frazil_maximum_freezing_temperature) cycle + + write(stderrUnit,*) 'pressing on for cell ', iCell + + ! initialize the sum of new frazil ice created sumNewFrazilIceThickness = 0.0_RKIND ! loop from maximum depth of frazil creation to surface @@ -483,12 +516,19 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo ! get freezing temperature oceanFreezingTemperature = ocn_freezing_temperature(activeTracers(indexSalinity,k,iCell)) + write(stderrUnit,*) ' ', 'freezing temperature ', k, oceanFreezingTemperature + potential = layerThickness(k,iCell) * config_specific_heat_sea_water & * rho_sw * (activeTracers(indexTemperature,k,iCell) - oceanFreezingTemperature) freezingEnergy = max(0.0_RKIND, -potential) meltingEnergy = max(0.0_RKIND, potential) - if (freezingEnergy < 0) then + write(stderrUnit,*) ' ', freezingEnergy, meltingEnergy, activeTracers(indexTemperature,k,iCell) - oceanFreezingTemperature + + if (freezingEnergy > 0) then + + write(stderrUnit,*) ' ', ' freezing ' + write(stderrUnit,*) ' ', config_frazil_sea_ice_density, rho_sw ! new frazil ice formation measured in meters newFrazilIceThickness = freezingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) @@ -500,23 +540,29 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo ! layerTendency is scaled so that mass of ice created == mass of ocean water removed ! layer thickness decreased due to creation of frazil - frazilLayerThicknessTendency(k,iCell) = - newFrazilIceThickness * config_frazil_sea_ice_density / rho_sw / config_dt + ! TDR -- need this to be density (not rho_sw) to keep buoyancy equal + frazilLayerThicknessTendency(k,iCell) = - newFrazilIceThickness * config_frazil_sea_ice_density / rho_sw / dt ! salt is extracted with the frazil - frazilSalinityTendency(k,iCell) = - newFrazilIceThickness * config_frazil_ice_reference_salinity / config_dt + frazilSalinityTendency(k,iCell) = - newFrazilIceThickness * config_frazil_ice_reference_salinity / dt ! ocean fluid temperature is warmed due to creation of frazil frazilTemperatureTendency(k,iCell) = & + ( newFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density ) & - / (config_specific_heat_sea_water * rho_sw) / config_dt - - ! accumulate frazil mass to column total - ! note: accumulatedFrazilIceMass (at both time levels) is reset to zero after being sent to the coupler - accumulatedFrazilIceMassNew(iCell) = accumulatedFrazilIceMassOld(iCell) + newFrazilIceThickness*config_frazil_sea_ice_density + / (config_specific_heat_sea_water * rho_sw) / dt ! keep track of sum of frazil ice sumNewFrazilIceThickness = sumNewFrazilIceThickness + newFrazilIceThickness + write(stderrUnit,*) ' ', ' newFrazilIceThickness ', newFrazilIceThickness + write(stderrUnit,*) ' ', ' limiter ', layerThickness(k,iCell) * config_frazil_fractional_thickness_limit + write(stderrUnit,*) ' ', ' layer tend ', frazilLayerThicknessTendency(k,iCell) + write(stderrUnit,*) ' ', ' salt tend ', frazilSalinityTendency(k,iCell) + write(stderrUnit,*) ' ', ' temp tend ', frazilTemperatureTendency(k,iCell) + write(stderrUnit,*) ' ', ' temp def ', activeTracers(indexTemperature,k,iCell) - oceanFreezingTemperature + write(stderrUnit,*) ' ', ' temp inc ', frazilTemperatureTendency(k,iCell)/layerThickness(k,iCell)*dt + write(stderrUnit,*) ' ', ' new sum ice thick ', sumNewFrazilIceThickness + else ! ocean water is warm enough to melt frazil @@ -524,6 +570,8 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo ! test to see if there is frazil to be melted if (sumNewFrazilIceThickness > 0.0_RKIND) then + write(stderrUnit,*) ' ', ' melting ' + ! Frazil melting meltedFrazilIceThickness = meltingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) @@ -536,19 +584,16 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo ! compute tendency to thickness, temperature and salinity ! layer thickness increases due to melting of frazil - frazilLayerThicknessTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_sea_ice_density / rho_sw / config_dt + frazilLayerThicknessTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_sea_ice_density / rho_sw / dt ! salt is released into ocean with the melting frazil - frazilSalinityTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_ice_reference_salinity / config_dt + frazilSalinityTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_ice_reference_salinity / dt ! ocean fluid temperature is cooled due to melting of frazil frazilTemperatureTendency(k,iCell) = & - ( meltedFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density ) & - / (config_specific_heat_sea_water * rho_sw) / config_dt + / (config_specific_heat_sea_water * rho_sw) / dt - ! deaccumulate frazil - accumulatedFrazilIceMassNew(iCell) = accumulatedFrazilIceMassOld(iCell) - meltedFrazilIceThickness*config_frazil_sea_ice_density - ! keep track of new frazil ice sumNewFrazilIceThickness = sumNewFrazilIceThickness - meltedFrazilIceThickness @@ -558,9 +603,16 @@ subroutine ocn_frazil_forcing_build_arrays(meshPool, forcingPool, diagnosticsPoo enddo ! do k=kBottom,1-1 + ! accumulate frazil mass to column total + ! note: accumulatedFrazilIceMass (at both time levels) is reset to zero after being sent to the coupler + accumulatedFrazilIceMassNew(iCell) = accumulatedFrazilIceMassOld(iCell) + sumNewFrazilIceThickness*config_frazil_sea_ice_density + ! sea surface pressure due to the net production of frazil ice frazilSurfacePressure(iCell) = accumulatedFrazilIceMassNew(iCell) * gravity + write(stderrUnit,*) ' ', ' accumul ice mass ', accumulatedFrazilIceMassNew(iCell), accumulatedFrazilIceMassOld(iCell) + write(stderrUnit,*) ' ', ' surface pressure ', frazilSurfacePressure(iCell) + enddo ! do iCell = 1, nCells call mpas_timer_stop("frazil", timer_frazil) @@ -606,6 +658,8 @@ subroutine ocn_frazil_forcing_init(err)!{{{ call mpas_pool_get_config(ocnConfigs, 'config_use_frazil_ice_formation', config_use_frazil_ice_formation) + write(stderrUnit,*) 'entering ocn_frazil_forcing_init' + frazilFormationOn = .false. if(config_use_frazil_ice_formation) then From 86b87e5fbb390690ae0e866a48d2233b1c58f815 Mon Sep 17 00:00:00 2001 From: Luke Van Roekel Date: Wed, 21 Oct 2015 09:06:03 -0600 Subject: [PATCH 0344/1724] this fixes two issues in the mixed layer depths AM. First, when the depth of the ML reached the bottom, this code could try access nVertLevels+1, this is fixed by looking only to maxLevelCell-1. Second, there were two allocate statements for the gradient code that were not deallocated. --- .../mpas_ocn_mixed_layer_depths.F | 28 ++++++++++--------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F index 8a0b3070d8..316e2262fe 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F +++ b/src/core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F @@ -242,7 +242,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ found_temp_mld = .false. - do k=1, maxLevelCell(iCell) + do k=1, maxLevelCell(iCell)-1 if(pressure(k+1,iCell) > refPress) then localvals(2:3)=tracers(index_temperature,k:k+1,iCell) localvals(5:6)=pressure(k:k+1,iCell) @@ -255,7 +255,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ endif enddo - do k=refIndex,maxLevelCell(iCell) + do k=refIndex,maxLevelCell(iCell)-1 if(.not. found_temp_mld .and. abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) .ge. tempThresh) then dVp1 = abs(tracers(index_temperature,k+1,iCell) - temp_ref_lev) @@ -283,7 +283,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ found_den_mld = .false. - do k=1, maxLevelCell(iCell) + do k=1, maxLevelCell(iCell)-1 if(pressure(k+1,iCell) > refPress) then localvals(2:3)=potentialDensity(k:k+1,iCell) localvals(5:6)=pressure(k:k+1,iCell) @@ -296,7 +296,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ endif enddo - do k=refIndex,maxLevelCell(iCell) + do k=refIndex,maxLevelCell(iCell)-1 if(.not. found_den_mld .and. abs(potentialDensity(k+1,iCell) - den_ref_lev) .ge. denThresh) then dVp1 = abs(potentialDensity(k+1,iCell) - den_ref_lev) @@ -325,17 +325,16 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ if(tGradientFlag) then call mpas_pool_get_array(mixedLayerDepthsAMPool, 'tGradMLD',tGradientMLD) - - allocate(temperatureGradient(nVertLevels,2)) - + allocate(temperatureGradient(nVertLevels,2)) + + do iCell = 1,nCellsSolve + temperatureGradient(:,1) = 0.0_RKIND temperatureGradient(1,2) = 1 - do iCell = 1,nCellsSolve - found_temp_mld=.false. - do k=2,maxLevelCell(iCell) + do k=2,maxLevelCell(iCell)-1 dz=abs(pressure(k-1,iCell)-pressure(k,iCell)) temperatureGradient(k,1) = abs(tracers(index_temperature,k-1,iCell) - tracers(index_temperature,k,iCell)) / dz temperatureGradient(k,2) = k @@ -369,21 +368,23 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ enddo !icell + deallocate(temperatureGradient) + endif !if(temperaturegradientflag) if(dGradientFlag) then call mpas_pool_get_array(mixedLayerDepthsAMPool, 'dGradMLD',dGradientMLD) allocate(densityGradient(nVertLevels,2)) + + do iCell = 1,nCellsSolve densityGradient(:,1)=0.0_RKIND densityGradient(1,2) = 1 - do iCell = 1,nCellsSolve - found_den_mld=.false. - do k=2,maxLevelCell(iCell) + do k=2,maxLevelCell(iCell)-1 dz=abs(pressure(k-1,iCell)-pressure(k,iCell)) densityGradient(k,1) = abs(potentialDensity(k-1,iCell)-potentialDensity(k,iCell)) / dz densityGradient(k,2) = k @@ -416,6 +417,7 @@ subroutine ocn_compute_mixed_layer_depths(domain, timeLevel, err)!{{{ enddo !icell + deallocate(densityGradient) endif !if(densitygradientflag) block => block % next From e0ecd61b75e76622379768caed88b9c2dffe49b9 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 22 Oct 2015 11:01:46 -0600 Subject: [PATCH 0345/1724] Adding templates for ocean analysis members This commit adds template definitions for the ocean analysis members, so they can be used in setting up test case configurations. --- .../ocean/templates/ocean/eliassen_palm.xml | 90 +++++++++++++ .../ocean/templates/ocean/global_stats.xml | 34 +++++ .../templates/ocean/high_frequency_output.xml | 30 +++++ .../ocean/lagrangian_particle_tracking.xml | 124 ++++++++++++++++++ .../ocean/layer_volume_weighted_averages.xml | 31 +++++ .../ocean/meridional_heat_transport.xml | 34 +++++ .../templates/ocean/mixed_layer_depths.xml | 41 ++++++ .../ocean/templates/ocean/okubo_weiss.xml | 36 +++++ .../ocean/surface_area_weighted_averages.xml | 28 ++++ .../templates/ocean/test_compute_interval.xml | 26 ++++ .../ocean/templates/ocean/time_filters.xml | 51 +++++++ .../templates/ocean/time_series_stats.xml | 58 ++++++++ .../templates/ocean/water_mass_census.xml | 34 +++++ .../ocean/templates/ocean/zonal_mean.xml | 35 +++++ 14 files changed, 652 insertions(+) create mode 100644 test_cases/ocean/templates/ocean/eliassen_palm.xml create mode 100644 test_cases/ocean/templates/ocean/global_stats.xml create mode 100644 test_cases/ocean/templates/ocean/high_frequency_output.xml create mode 100644 test_cases/ocean/templates/ocean/lagrangian_particle_tracking.xml create mode 100644 test_cases/ocean/templates/ocean/layer_volume_weighted_averages.xml create mode 100644 test_cases/ocean/templates/ocean/meridional_heat_transport.xml create mode 100644 test_cases/ocean/templates/ocean/mixed_layer_depths.xml create mode 100644 test_cases/ocean/templates/ocean/okubo_weiss.xml create mode 100644 test_cases/ocean/templates/ocean/surface_area_weighted_averages.xml create mode 100644 test_cases/ocean/templates/ocean/test_compute_interval.xml create mode 100644 test_cases/ocean/templates/ocean/time_filters.xml create mode 100644 test_cases/ocean/templates/ocean/time_series_stats.xml create mode 100644 test_cases/ocean/templates/ocean/water_mass_census.xml create mode 100644 test_cases/ocean/templates/ocean/zonal_mean.xml diff --git a/test_cases/ocean/templates/ocean/eliassen_palm.xml b/test_cases/ocean/templates/ocean/eliassen_palm.xml new file mode 100644 index 0000000000..e7f63a99b2 --- /dev/null +++ b/test_cases/ocean/templates/ocean/eliassen_palm.xml @@ -0,0 +1,90 @@ + diff --git a/test_cases/ocean/templates/ocean/global_stats.xml b/test_cases/ocean/templates/ocean/global_stats.xml new file mode 100644 index 0000000000..c66ef35455 --- /dev/null +++ b/test_cases/ocean/templates/ocean/global_stats.xml @@ -0,0 +1,34 @@ + diff --git a/test_cases/ocean/templates/ocean/high_frequency_output.xml b/test_cases/ocean/templates/ocean/high_frequency_output.xml new file mode 100644 index 0000000000..39e52a625c --- /dev/null +++ b/test_cases/ocean/templates/ocean/high_frequency_output.xml @@ -0,0 +1,30 @@ + diff --git a/test_cases/ocean/templates/ocean/lagrangian_particle_tracking.xml b/test_cases/ocean/templates/ocean/lagrangian_particle_tracking.xml new file mode 100644 index 0000000000..490b5c9632 --- /dev/null +++ b/test_cases/ocean/templates/ocean/lagrangian_particle_tracking.xml @@ -0,0 +1,124 @@ + diff --git a/test_cases/ocean/templates/ocean/layer_volume_weighted_averages.xml b/test_cases/ocean/templates/ocean/layer_volume_weighted_averages.xml new file mode 100644 index 0000000000..3c78379fc7 --- /dev/null +++ b/test_cases/ocean/templates/ocean/layer_volume_weighted_averages.xml @@ -0,0 +1,31 @@ + diff --git a/test_cases/ocean/templates/ocean/meridional_heat_transport.xml b/test_cases/ocean/templates/ocean/meridional_heat_transport.xml new file mode 100644 index 0000000000..53ebac9378 --- /dev/null +++ b/test_cases/ocean/templates/ocean/meridional_heat_transport.xml @@ -0,0 +1,34 @@ + diff --git a/test_cases/ocean/templates/ocean/mixed_layer_depths.xml b/test_cases/ocean/templates/ocean/mixed_layer_depths.xml new file mode 100644 index 0000000000..e774f7886b --- /dev/null +++ b/test_cases/ocean/templates/ocean/mixed_layer_depths.xml @@ -0,0 +1,41 @@ + diff --git a/test_cases/ocean/templates/ocean/okubo_weiss.xml b/test_cases/ocean/templates/ocean/okubo_weiss.xml new file mode 100644 index 0000000000..9f15424f6d --- /dev/null +++ b/test_cases/ocean/templates/ocean/okubo_weiss.xml @@ -0,0 +1,36 @@ + diff --git a/test_cases/ocean/templates/ocean/surface_area_weighted_averages.xml b/test_cases/ocean/templates/ocean/surface_area_weighted_averages.xml new file mode 100644 index 0000000000..44174f82ce --- /dev/null +++ b/test_cases/ocean/templates/ocean/surface_area_weighted_averages.xml @@ -0,0 +1,28 @@ + diff --git a/test_cases/ocean/templates/ocean/test_compute_interval.xml b/test_cases/ocean/templates/ocean/test_compute_interval.xml new file mode 100644 index 0000000000..c565e716df --- /dev/null +++ b/test_cases/ocean/templates/ocean/test_compute_interval.xml @@ -0,0 +1,26 @@ + diff --git a/test_cases/ocean/templates/ocean/time_filters.xml b/test_cases/ocean/templates/ocean/time_filters.xml new file mode 100644 index 0000000000..ae86c5fbca --- /dev/null +++ b/test_cases/ocean/templates/ocean/time_filters.xml @@ -0,0 +1,51 @@ + diff --git a/test_cases/ocean/templates/ocean/time_series_stats.xml b/test_cases/ocean/templates/ocean/time_series_stats.xml new file mode 100644 index 0000000000..fe0f3c774a --- /dev/null +++ b/test_cases/ocean/templates/ocean/time_series_stats.xml @@ -0,0 +1,58 @@ + diff --git a/test_cases/ocean/templates/ocean/water_mass_census.xml b/test_cases/ocean/templates/ocean/water_mass_census.xml new file mode 100644 index 0000000000..7aafe9c3ad --- /dev/null +++ b/test_cases/ocean/templates/ocean/water_mass_census.xml @@ -0,0 +1,34 @@ + diff --git a/test_cases/ocean/templates/ocean/zonal_mean.xml b/test_cases/ocean/templates/ocean/zonal_mean.xml new file mode 100644 index 0000000000..2b986efde3 --- /dev/null +++ b/test_cases/ocean/templates/ocean/zonal_mean.xml @@ -0,0 +1,35 @@ + From 132f5de901015d5d005dfa7b1b2e9944eee16087 Mon Sep 17 00:00:00 2001 From: toddringler Date: Thu, 22 Oct 2015 13:24:46 -0600 Subject: [PATCH 0346/1724] addition of new frazil algorithm algorithm add tendencies to layer thickness, temperature and salinity in addition, frazil-induced surface pressure forcing is included. the ziso test case is overloaded to provide a way to test the frazil algorithm. --- src/core_ocean/mode_init/Registry_ziso.xml | 8 +++ src/core_ocean/mode_init/mpas_ocn_init_ziso.F | 55 +++++++++++++++++- .../shared/mpas_ocn_frazil_forcing.F | 58 +++---------------- 3 files changed, 70 insertions(+), 51 deletions(-) diff --git a/src/core_ocean/mode_init/Registry_ziso.xml b/src/core_ocean/mode_init/Registry_ziso.xml index da221ba22f..f06e2d3aae 100644 --- a/src/core_ocean/mode_init/Registry_ziso.xml +++ b/src/core_ocean/mode_init/Registry_ziso.xml @@ -103,4 +103,12 @@ description="Initial temperature profile constant $m_T$ in $T(z,t=0) = T_1 + T_2 \tanh(z/h_1) + m_T z$." possible_values="Any real number." /> + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_ziso.F b/src/core_ocean/mode_init/mpas_ocn_init_ziso.F index 6fa1837d85..9df604c2ba 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_ziso.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_ziso.F @@ -118,8 +118,11 @@ subroutine ocn_init_setup_ziso(domain, iErr)!{{{ real (kind=RKIND), pointer :: config_ziso_wind_stress_shelf_front_max logical, pointer :: config_ziso_add_easterly_wind_stress_ASF - integer, pointer :: config_ziso_vert_levels + ! configure settings related to frazil + logical, pointer :: config_ziso_frazil_enable + real (kind=RKIND), pointer :: config_ziso_frazil_temperature_anomaly + integer, pointer :: config_ziso_vert_levels ! Define dimension pointers integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, nVertLevelsP1 @@ -143,10 +146,12 @@ subroutine ocn_init_setup_ziso(domain, iErr)!{{{ character (len=StrKIND) :: streamID integer :: directionProperty + ! Local variable related to frazil + real (kind=RKIND) :: distanceX, distanceY, distance, frazil_temperature, scaleFactor + ! assume no error iErr = 0 - ! test if ZISO is the desired configuration call mpas_pool_get_config(ocnConfigs, 'config_init_configuration', config_init_configuration) if(config_init_configuration .ne. trim('ziso')) return @@ -182,6 +187,10 @@ subroutine ocn_init_setup_ziso(domain, iErr)!{{{ call mpas_pool_get_config(domain % configs, 'config_ziso_wind_transition_position', config_ziso_wind_transition_position) call mpas_pool_get_config(domain % configs, 'config_ziso_antarctic_shelf_front_width', config_ziso_antarctic_shelf_front_width) call mpas_pool_get_config(domain % configs, 'config_ziso_wind_stress_shelf_front_max', config_ziso_wind_stress_shelf_front_max) + + ! frazil configures + call mpas_pool_get_config(domain % configs, 'config_ziso_frazil_enable', config_ziso_frazil_enable) + call mpas_pool_get_config(domain % configs, 'config_ziso_frazil_temperature_anomaly', config_ziso_frazil_temperature_anomaly) !}}} ! Determine vertical grid for configuration @@ -456,8 +465,50 @@ subroutine ocn_init_setup_ziso(domain, iErr)!{{{ end if enddo +!**************************************************************************************************************************************** +! this test case is overloaded with the ability to evaluate the frazil algorithm +! if config_ziso_enable_frazil is true, some of the configure options are over written to make the test useful for frazil +!**************************************************************************************************************************************** + + if(config_ziso_frazil_enable) then + config_ziso_initial_temp_t1 = 0.0_RKIND + config_ziso_initial_temp_t2 = -1.0_RKIND + config_ziso_initial_temp_h1 = 300.0_RKIND + config_ziso_initial_temp_mt = 0.0_RKIND + + ! recompute initial temperature with altered parameters + idx = index_temperature + do k = 1, nVertLevels + activeTracers(idx, k, iCell) = config_ziso_initial_temp_t1 + & + config_ziso_initial_temp_t2*tanh(refZMid(k)/config_ziso_initial_temp_h1) + config_ziso_initial_temp_mt*refZMid(k) + end do + + distanceX = config_ziso_meridional_extent/4.0_RKIND-xCell(iCell) + distanceY = config_ziso_meridional_extent/2.0_RKIND-yCell(iCell) + distance = sqrt(distanceY**2+distanceX**2) + scaleFactor = exp(-distance/config_ziso_meridional_extent*20.0_RKIND) + if (scaleFactor.gt.0.9_RKIND) write(stderrUnit,*) ' frazil production likely at this cell: ', iCell + do k = 1, nVertLevels + frazil_temperature = config_ziso_frazil_temperature_anomaly + & + config_ziso_initial_temp_t2*tanh(refZMid(k)/config_ziso_initial_temp_h1) + config_ziso_initial_temp_mt*refZMid(k) + if (refZMid(k).gt.-50.0) frazil_temperature = frazil_temperature + 1.0_RKIND*cos( refZMid(k) / 50.0_RKIND * pii / 2.0_RKIND) + activeTracers(idx, k, iCell) = (1.0_RKIND-scaleFactor)* activeTracers(idx, k, iCell) + scaleFactor*frazil_temperature + end do + end if + +!**************************************************************************************************************************************** +! end frazil overload +!**************************************************************************************************************************************** + end do ! do iCell + ! write warning to stderrUnit + if(config_ziso_frazil_enable) then + write(stderrUnit,*) + write(stderrUnit,*) ' this test case is configured for the testing of the frazil algorithm' + write(stderrUnit,*) + endif + ! Set Coriolis parameters, if other than zero do iCell = 1, nCellsSolve fCell(iCell) = config_ziso_reference_coriolis + yCell(iCell) * config_ziso_coriolis_gradient diff --git a/src/core_ocean/shared/mpas_ocn_frazil_forcing.F b/src/core_ocean/shared/mpas_ocn_frazil_forcing.F index 54b974ef2b..ecae070afe 100644 --- a/src/core_ocean/shared/mpas_ocn_frazil_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_frazil_forcing.F @@ -109,8 +109,6 @@ subroutine ocn_frazil_forcing_tracers(meshPool, tracersPool, groupName, forcingP err = 0 - write(stderrUnit,*) 'entering ocn_frazil_forcing_tracers', trim(groupName) - if ( .not. frazilFormationOn ) return if ( trim(groupName) == 'activeTracers' ) then @@ -169,8 +167,6 @@ subroutine ocn_frazil_forcing_layer_thickness(meshPool, forcingPool, layerThickn err = 0 - write(stderrUnit,*) 'entering ocn_frazil_layer_thickness' - if ( .not. frazilFormationOn ) return call mpas_pool_get_dimension(meshPool, 'nCells', nCells) @@ -184,8 +180,6 @@ subroutine ocn_frazil_forcing_layer_thickness(meshPool, forcingPool, layerThickn end do end do - write(stderrUnit,*) ' max val ', maxval(abs(frazilLayerThicknessTendency)) - end subroutine ocn_frazil_forcing_layer_thickness!}}} @@ -238,8 +232,6 @@ subroutine ocn_frazil_forcing_surface_pressure(meshPool, forcingPool, err)!{{{ err = 0 - write(stderrUnit,*) 'entering ocn_frazil_forcing_surface_pressure' - if ( .not. frazilFormationOn ) return call mpas_pool_get_dimension(meshPool, 'nCells', nCells) @@ -310,8 +302,6 @@ subroutine ocn_frazil_forcing_active_tracers(meshPool, tracersPool, forcingPool, err = 0 - write(stderrUnit,*) ' entering ocn_frazil_forcing_active_tracers' - if ( .not. frazilFormationOn ) return call mpas_pool_get_dimension(meshPool, 'nCells', nCells) @@ -330,8 +320,6 @@ subroutine ocn_frazil_forcing_active_tracers(meshPool, tracersPool, forcingPool, end do end do - write(stderrUnit,*) ' max val ', maxval(abs(frazilTemperatureTendency)), maxval(abs(frazilSalinityTendency)) - end subroutine ocn_frazil_forcing_active_tracers!}}} @@ -420,6 +408,7 @@ subroutine ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagno real (kind=RKIND), pointer, dimension(:) :: accumulatedFrazilIceMassOld real (kind=RKIND), pointer, dimension(:,:) :: zMid real (kind=RKIND), pointer, dimension(:,:) :: layerThickness + real (kind=RKIND), pointer, dimension(:,:) :: density real (kind=RKIND), pointer, dimension(:,:,:) :: activeTracers integer, dimension(:), pointer :: maxLevelCell @@ -431,8 +420,6 @@ subroutine ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagno real (kind=RKIND) :: freezingEnergy ! energy available for freezing, positive definite real (kind=RKIND) :: meltingEnergy ! energy available for melting, positive definite - write(stderrUnit,*) 'entering ocn_frazil_forcing_build_arrays', frazilFormationOn - ! if frazil is not enabled, return if(.not. frazilFormationOn) return @@ -452,11 +439,12 @@ subroutine ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagno ! get arrays ! note: state information is used to produce tendencies, so always grab "new" time level - call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 2) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) call mpas_pool_get_array(statePool, 'accumulatedFrazilIceMass', accumulatedFrazilIceMassNew, 2) call mpas_pool_get_array(statePool, 'accumulatedFrazilIceMass', accumulatedFrazilIceMassOld, 1) - call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 2) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) + call mpas_pool_get_array(diagnosticsPool, 'density', density) call mpas_pool_get_array(forcingPool, 'frazilTemperatureTendency', frazilTemperatureTendency) call mpas_pool_get_array(forcingPool,'frazilSalinityTendency', frazilSalinityTendency) call mpas_pool_get_array(forcingPool,'frazilLayerThicknessTendency', frazilLayerThicknessTendency) @@ -480,8 +468,6 @@ subroutine ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagno frazilSalinityTendency = 0.0_RKIND frazilLayerThicknessTendency = 0.0_RKIND - ! write(stderrUnit,*) 'got time step', dt - ! loop over all columns do iCell=1,nCells @@ -500,13 +486,9 @@ subroutine ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagno if(activeTracers(indexTemperature,k,iCell).lt.columnTemperatureMin) columnTemperatureMin=activeTracers(indexTemperature,k,iCell) enddo - ! write(stderrUnit,*) 'min temp ', columnTemperatureMin, config_frazil_maximum_freezing_temperature, kBottomFrazil - ! test min temperature agains max freezing temperature to see if we should even consider creating frazil if(columnTemperatureMin.gt.config_frazil_maximum_freezing_temperature) cycle - write(stderrUnit,*) 'pressing on for cell ', iCell - ! initialize the sum of new frazil ice created sumNewFrazilIceThickness = 0.0_RKIND @@ -516,20 +498,13 @@ subroutine ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagno ! get freezing temperature oceanFreezingTemperature = ocn_freezing_temperature(activeTracers(indexSalinity,k,iCell)) - write(stderrUnit,*) ' ', 'freezing temperature ', k, oceanFreezingTemperature - potential = layerThickness(k,iCell) * config_specific_heat_sea_water & * rho_sw * (activeTracers(indexTemperature,k,iCell) - oceanFreezingTemperature) freezingEnergy = max(0.0_RKIND, -potential) meltingEnergy = max(0.0_RKIND, potential) - write(stderrUnit,*) ' ', freezingEnergy, meltingEnergy, activeTracers(indexTemperature,k,iCell) - oceanFreezingTemperature - if (freezingEnergy > 0) then - write(stderrUnit,*) ' ', ' freezing ' - write(stderrUnit,*) ' ', config_frazil_sea_ice_density, rho_sw - ! new frazil ice formation measured in meters newFrazilIceThickness = freezingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) @@ -540,8 +515,8 @@ subroutine ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagno ! layerTendency is scaled so that mass of ice created == mass of ocean water removed ! layer thickness decreased due to creation of frazil - ! TDR -- need this to be density (not rho_sw) to keep buoyancy equal - frazilLayerThicknessTendency(k,iCell) = - newFrazilIceThickness * config_frazil_sea_ice_density / rho_sw / dt + ! note: -- this has to be density (not rho_sw) to keep buoyancy equal + frazilLayerThicknessTendency(k,iCell) = - newFrazilIceThickness * config_frazil_sea_ice_density / density(k,iCell) / dt ! salt is extracted with the frazil frazilSalinityTendency(k,iCell) = - newFrazilIceThickness * config_frazil_ice_reference_salinity / dt @@ -554,15 +529,6 @@ subroutine ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagno ! keep track of sum of frazil ice sumNewFrazilIceThickness = sumNewFrazilIceThickness + newFrazilIceThickness - write(stderrUnit,*) ' ', ' newFrazilIceThickness ', newFrazilIceThickness - write(stderrUnit,*) ' ', ' limiter ', layerThickness(k,iCell) * config_frazil_fractional_thickness_limit - write(stderrUnit,*) ' ', ' layer tend ', frazilLayerThicknessTendency(k,iCell) - write(stderrUnit,*) ' ', ' salt tend ', frazilSalinityTendency(k,iCell) - write(stderrUnit,*) ' ', ' temp tend ', frazilTemperatureTendency(k,iCell) - write(stderrUnit,*) ' ', ' temp def ', activeTracers(indexTemperature,k,iCell) - oceanFreezingTemperature - write(stderrUnit,*) ' ', ' temp inc ', frazilTemperatureTendency(k,iCell)/layerThickness(k,iCell)*dt - write(stderrUnit,*) ' ', ' new sum ice thick ', sumNewFrazilIceThickness - else ! ocean water is warm enough to melt frazil @@ -570,8 +536,6 @@ subroutine ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagno ! test to see if there is frazil to be melted if (sumNewFrazilIceThickness > 0.0_RKIND) then - write(stderrUnit,*) ' ', ' melting ' - ! Frazil melting meltedFrazilIceThickness = meltingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) @@ -584,7 +548,8 @@ subroutine ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagno ! compute tendency to thickness, temperature and salinity ! layer thickness increases due to melting of frazil - frazilLayerThicknessTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_sea_ice_density / rho_sw / dt + ! note -- scaling by local ocean density to mimimize surface pressure forcing errors + frazilLayerThicknessTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_sea_ice_density / density(k,iCell) / dt ! salt is released into ocean with the melting frazil frazilSalinityTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_ice_reference_salinity / dt @@ -604,15 +569,12 @@ subroutine ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagno enddo ! do k=kBottom,1-1 ! accumulate frazil mass to column total - ! note: accumulatedFrazilIceMass (at both time levels) is reset to zero after being sent to the coupler + ! note: the accumulatedFrazilIceMass (at both time levels) is reset to zero after being sent to the coupler accumulatedFrazilIceMassNew(iCell) = accumulatedFrazilIceMassOld(iCell) + sumNewFrazilIceThickness*config_frazil_sea_ice_density ! sea surface pressure due to the net production of frazil ice frazilSurfacePressure(iCell) = accumulatedFrazilIceMassNew(iCell) * gravity - write(stderrUnit,*) ' ', ' accumul ice mass ', accumulatedFrazilIceMassNew(iCell), accumulatedFrazilIceMassOld(iCell) - write(stderrUnit,*) ' ', ' surface pressure ', frazilSurfacePressure(iCell) - enddo ! do iCell = 1, nCells call mpas_timer_stop("frazil", timer_frazil) @@ -658,8 +620,6 @@ subroutine ocn_frazil_forcing_init(err)!{{{ call mpas_pool_get_config(ocnConfigs, 'config_use_frazil_ice_formation', config_use_frazil_ice_formation) - write(stderrUnit,*) 'entering ocn_frazil_forcing_init' - frazilFormationOn = .false. if(config_use_frazil_ice_formation) then From 3da4cd4411d48b2af3c71427f87cecc3dc2b2779 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Mon, 19 Oct 2015 13:40:39 -0600 Subject: [PATCH 0347/1724] Have interface reconstruct velo at all edges, let MPAS decide which to use MPAS only 'keeps' normalVelocity on edges that are defined as 'dynamic' in edgeMask. Now that normalVelocity is being calculated on all edges of the FEM mesh, special logic is needed for the MPAS edge locations that correspond to the edges of the FEM mesh. For boundary edges one of the two triangles sharing the edge is not part of the velocity solver's FEM mesh, so if the edge is not in the triangle that does exist, then instead project the edge location on to the edge of the triangle that exists. This will be slightly inaccurate in these situations, but this situation only occurs for edges between two Dirichlet nodes and only in a variable resolution mesh (and only roughly half of those). (Note that these edges will be solved for all the time, but the values are only actually used by MPAS in the situation where the edge is between two Dirichlet nodes.) --- .../Interface_velocity_solver.cpp | 60 ++++++++++++++----- .../mode_forward/mpas_li_velocity_external.F | 13 ++++ 2 files changed, 59 insertions(+), 14 deletions(-) diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.cpp b/src/core_landice/mode_forward/Interface_velocity_solver.cpp index c9d8ed8757..5d176ec6fb 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.cpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.cpp @@ -943,8 +943,8 @@ void get_prism_velocity_on_FEdges(double * uNormal, UInt nPoints3D = nCells_F * (nLayers + 1); - //Looping through the internal edges of the triangulation - for (int i = numBoundaryEdges; i < nEdges; i++) { + // Loop over all edges of the triangulation - MPAS will decide which edges it should use. + for (int i = 0; i < nEdges; i++) { //identifying vertices on the edge ID lId0 = verticesOnEdge[2 * i]; @@ -984,15 +984,42 @@ void get_prism_velocity_on_FEdges(double * uNormal, e_mid[1] = 0.5*(yVertex_F[fVertex0] + yVertex_F[fVertex1]); if((verticesMask_F[fVertex0] & dynamic_ice_bit_value) && belongToTria(e_mid, t0, bcoords)) { - for (int j = 0; j < 3; j++) - iCells[j] = cellsOnVertex_F[3 * fVertex0 + j] - 1; - } - else if((verticesMask_F[fVertex1] & dynamic_ice_bit_value) && belongToTria(e_mid, t1, bcoords)) { + // triangle1 is in the mesh AND midpoint is in triangle1 + for (int j = 0; j < 3; j++) + iCells[j] = cellsOnVertex_F[3 * fVertex0 + j] - 1; + } + else if((verticesMask_F[fVertex1] & dynamic_ice_bit_value) && belongToTria(e_mid, t1, bcoords)) { + //triangle2 is in the mesh AND midpoint is in triangle2 for (int j = 0; j < 3; j++) iCells[j] = cellsOnVertex_F[3 * fVertex1 + j] - 1; - } - else { //error, edge midpont does not belong to either triangles - std::cout << "Error, edge midpont does not belong to either triangles" << std::endl; + } + else if(i& velocityOnVertices, @@ -1639,9 +1666,14 @@ bool belongToTria(double const* x, double const* t, double bcoords[3], double ep } double det = (v3[1]-v2[1])*(v3[0]-v1[0]) - (v3[0]-v2[0])*(v3[1]-v1[1]); double c1,c2; - return ( (bcoords[0] = ((v3[1]-v2[1])*(v3[0]-x[0]) - (v3[0]-v2[0])*(v3[1]-x[1]))/det) > -eps) && - ( (bcoords[1] = (-(v3[1]-v1[1])*(v3[0]-x[0]) + (v3[0]-v1[0])*(v3[1]-x[1]))/det) > -eps) && - ( (bcoords[2] = 1.0 - bcoords[0] - bcoords[1]) > -eps ); + + bcoords[0] = ((v3[1]-v2[1])*(v3[0]-x[0]) - (v3[0]-v2[0])*(v3[1]-x[1]))/det; + bcoords[1] = (-(v3[1]-v1[1])*(v3[0]-x[0]) + (v3[0]-v1[0])*(v3[1]-x[1]))/det; + bcoords[2] = 1.0 - bcoords[0] - bcoords[1]; + + return ( bcoords[0] > -eps) && + ( bcoords[1] > -eps) && + ( bcoords[2] > -eps ); } int prismType(long long int const* prismVertexMpasIds, int& minIndex) diff --git a/src/core_landice/mode_forward/mpas_li_velocity_external.F b/src/core_landice/mode_forward/mpas_li_velocity_external.F index 6da2301851..68b3d424e7 100644 --- a/src/core_landice/mode_forward/mpas_li_velocity_external.F +++ b/src/core_landice/mode_forward/mpas_li_velocity_external.F @@ -405,6 +405,8 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc logical, pointer :: config_output_external_velocity_solver_data integer, pointer :: anyDynamicVertexMaskChanged integer, pointer :: dirichletMaskChanged + integer, pointer :: nEdges + integer :: iEdge real(kind=RKIND), parameter :: secondsInYear = 365.0 * 24.0 * 3600.0 !< The value of seconds in a year assumed by external dycores err = 0 @@ -417,6 +419,7 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc ! Mesh variables call mpas_pool_get_array(meshPool, 'layerThicknessFractions', layerThicknessFractions) call mpas_pool_get_array(meshPool, 'deltat', deltat) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) ! Geometry variables call mpas_pool_get_array(geometryPool, 'thickness', thickness) @@ -536,6 +539,16 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc uReconstructX = uReconstructX / secondsInYear uReconstructY = uReconstructY / secondsInYear + ! The external solver will calculate normalVelocity for all edges, + ! but some of those edges are not dynamically active according to MPASLI's + ! Voronoi grid conventions. This zeros velocity on those edges. + ! (Note: the choice of edges to get reconstructed used to be controlled + ! inside the interface, but as logic got more complicated with Dirichlet + ! b.c., that became unwieldly. Look in the mask routine to see the logic + ! for which edges are dynamic.) + do iEdge = 1, nEdges + if (.not. li_mask_is_dynamic_ice(edgeMask(iEdge)) ) normalVelocity(:,iEdge) = 0.0d0 + end do !-------------------------------------------------------------------- From 99a5ee3f254e2e454f0f476f090ea2ac32023895 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Thu, 22 Oct 2015 16:49:59 -0600 Subject: [PATCH 0348/1724] Remove check for velocity on non-dynamic edges In recent commits, we have made the Albany interface calculate the normalVelocity on all edges, and then MPAS only keeps the velocity on the edges it had determined to be 'dynamic', so this check is now redundant. --- .../mode_forward/mpas_li_velocity.F | 74 +------------------ 1 file changed, 2 insertions(+), 72 deletions(-) diff --git a/src/core_landice/mode_forward/mpas_li_velocity.F b/src/core_landice/mode_forward/mpas_li_velocity.F index ef6abb8f98..68d33bc8f3 100644 --- a/src/core_landice/mode_forward/mpas_li_velocity.F +++ b/src/core_landice/mode_forward/mpas_li_velocity.F @@ -266,7 +266,7 @@ subroutine li_velocity_solve(domain, err) integer :: vertex1, vertex2 integer :: iEdge integer :: iCell - integer :: inletEdgesFixed, uphillMarginEdgesFixed + integer :: uphillMarginEdgesFixed integer :: err_tmp real (kind=RKIND) :: maxThicknessOnProc, maxThicknessAllProcs @@ -280,7 +280,6 @@ subroutine li_velocity_solve(domain, err) call mpas_pool_get_config(liConfigs, 'config_print_velocity_cleanup_details', config_print_velocity_cleanup_details) call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) - inletEdgesFixed = 0 uphillMarginEdgesFixed = 0 @@ -355,65 +354,6 @@ subroutine li_velocity_solve(domain, err) ! Some "quality control" of normalVelocity do iEdge = 1, nEdgesSolve - ! Check if the velocity solver has returned a velocity on any non-dynamic edges - if ( li_mask_is_ice(edgeMask(iEdge)) .and. & - (.not.(li_mask_is_dynamic_ice(edgeMask(iEdge)))) .and. & - (maxval(abs(normalVelocity(:,iEdge))) /= 0.0_RKIND) & - ) then - ! There is an edge case where this is ok. If there are two peninsulas of dynamic ice - ! with a single 'row' of nondynamic cells between them, the FEM velo solver will likely - ! calculate a nonzero velocity on an edge that has 0 thickness. The two FEM elements - ! neighboring this edge have nonzero thickness everywhere except along this edge, and - ! so there is no guarantee of zero-velocity on this edge. Schematically, this looks like: - ! - ! \ I / - ! A |--e--| A - ! / I \ - ! - ! where the lines are edges, and e is the edge with the issue. I's are inactive cells, and - ! A's are active cells. So check for this specific situation before calling this an error. - cell1 = cellsOnEdge(1, iEdge) - cell2 = cellsOnEdge(2, iEdge) - ! Criterion 1: both cells adjacent to edge are inactive - if ( ( .not. li_mask_is_dynamic_ice(cellMask(cell1)) ) .and. & - ( .not. li_mask_is_dynamic_ice(cellMask(cell2)) ) ) then - ! Criterion 2: both remaining cells adjacent to edge's vertices are active - vertex1 = verticesOnEdge(1, iEdge) - cell3 = -999 - do iCell = 1, 3 - thisCell = cellsOnVertex(iCell, vertex1) - if ((thisCell /= cell1) .and. (thisCell /= cell2)) then - cell3 = thisCell - exit ! we found the remaining cell on the vertex - endif - enddo - vertex2 = verticesOnEdge(2, iEdge) - cell4 = -999 - do iCell = 1, 3 - thisCell = cellsOnVertex(iCell, vertex2) - if ((thisCell /= cell1) .and. (thisCell /= cell2)) then - cell4 = thisCell - exit ! we found the remaining cell on the vertex - endif - enddo - if ( (li_mask_is_dynamic_ice(cellMask(cell3))) .and. & - (li_mask_is_dynamic_ice(cellMask(cell4))) ) then - if (config_print_velocity_cleanup_details) then - write (stderrUnit,*) "Notice: External velocity solver returned a nonzero normalVelocity on a non-dynamic " & - // "edge, but this is ok because the location is in a non-dynamic 'inlet'. " & - // "normalVelocity has been set to 0 at this location. Location is edge " & - // "index:", indexToEdgeID(iEdge) - endif - normalVelocity(:,iEdge) = 0.0_RKIND - inletEdgesFixed = inletEdgesFixed + 1 - else - write (stderrUnit,*) 'ERROR: VELO ON NON-DYNAMIC EDGE, edge=', indexToEdgeID(iEdge) - err_tmp= 1 - !!!normalVelocity(:,iEdge) = 0.0_RKIND ! a hack to ignore this error. - endif ! Criterion 2 check - endif ! Criterion 1 check - endif - ! Don't allow normalVelocity on edges where an unglaciated cell with ! higher elevation neighbors a glaciated cell. Some velocity solvers ! could generate a nonzero velocity on these edges. In the case of a @@ -442,20 +382,10 @@ subroutine li_velocity_solve(domain, err) enddo - if (err_tmp == 1) then - write(stderrUnit,*) 'Error: Velocity has been calculated on non-dynamic edges. There is a problem with the velocity solver.' !!! Velocity on those edges have been set to 0, but this should be a fatal error.' - err = 1 - end if - block => block % next end do - if (inletEdgesFixed > 0) then - write (stderrUnit,*) "Notice: External velocity solver returned a nonzero normalVelocity on non-dynamic edge(s), but " & - // "this is ok because the location is in a non-dynamic 'inlet'. normalVelocity has been set to 0 " & - // "at these location(s). Number of edges affected on this processor:", inletEdgesFixed - endif - if (uphillMarginEdgesFixed > 0) then + if (uphillMarginEdgesFixed > 0) then write (stderrUnit,*) "Notice: Nonzero velocity has been calculated on 'uphill' margin edge(s). normalVelocity has " & // "been set to 0 at these location(s). Number of edges affected on this processor:", & uphillMarginEdgesFixed From 1d9c271587d4b04c34d5390572673de2d8b8dd12 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Fri, 23 Oct 2015 09:25:49 -0600 Subject: [PATCH 0349/1724] 0 uReconstructX/Y in Interface before setting new solution When ice retreats, the previous larger extent solution will still exist in the places where the ice has retreated in the uReconstructX/Y fields. This change ensures that only the new solution is retained. --- src/core_landice/mode_forward/Interface_velocity_solver.cpp | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.cpp b/src/core_landice/mode_forward/Interface_velocity_solver.cpp index 5d176ec6fb..2022fef601 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.cpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.cpp @@ -1053,6 +1053,11 @@ void mapVerticesToCells(const std::vector& velocityOnVertices, int vertexLayerShift = (ordering == 0) ? 1 : numLayers + 1; int nVertices3D = nVertices * (numLayers + 1); + + // 0 entire field so no values from previous solve are left behind + // if the ice extent has retreated. + std::fill(velocityOnCells, velocityOnCells + nCells_F * (numLayers+1) * fieldDim, 0.); + for (UInt j = 0; j < nVertices3D; ++j) { int ib = (ordering == 0) * (j % lVertexColumnShift) + (ordering == 1) * (j / vertexLayerShift); From 1de3a981d85dd3fa72a032ff095047f64552a5a5 Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Fri, 23 Oct 2015 10:51:14 -0600 Subject: [PATCH 0350/1724] add comment on expected range for meshScaling note, this only changes a comment. no change in executed source code --- src/core_ocean/shared/mpas_ocn_init_routines.F | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/core_ocean/shared/mpas_ocn_init_routines.F b/src/core_ocean/shared/mpas_ocn_init_routines.F index 5162aa8c27..18270bfcd1 100644 --- a/src/core_ocean/shared/mpas_ocn_init_routines.F +++ b/src/core_ocean/shared/mpas_ocn_init_routines.F @@ -325,6 +325,9 @@ subroutine ocn_init_routines_compute_mesh_scaling(meshPool, scaleHmixWithMesh, m ! ! Compute the scaling factors to be used in the del2 and del4 dissipation ! + ! Typical use cases have the minval(meshScaling)==1. + ! meshScaling values of approximately 1 indicate the highest resolution of the domain. + meshScalingDel2(:) = 1.0 meshScalingDel4(:) = 1.0 meshScaling(:) = 1.0 From eeb3c7c257f9d2abd067b8d57db4fce33cbd9286 Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Fri, 23 Oct 2015 10:52:47 -0600 Subject: [PATCH 0351/1724] minor cleanup of Leith closure replace 3.14 with pii but using mpas_constants replace invLength{1,2} with invLength{_dc,_dv} for clarity --- src/core_ocean/shared/mpas_ocn_vel_hmix_leith.F | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_vel_hmix_leith.F b/src/core_ocean/shared/mpas_ocn_vel_hmix_leith.F index 3ff4ff3af4..b883a24187 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_hmix_leith.F +++ b/src/core_ocean/shared/mpas_ocn_vel_hmix_leith.F @@ -22,6 +22,7 @@ module ocn_vel_hmix_leith use mpas_derived_types use mpas_pool_routines + use mpas_constants use ocn_constants implicit none @@ -127,7 +128,7 @@ subroutine ocn_vel_hmix_leith_tend(meshPool, divergence, relativeVorticity, visc integer, dimension(:), pointer :: maxLevelEdgeTop integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgeMask - real (kind=RKIND) :: u_diffusion, invLength1, invLength2, visc2 + real (kind=RKIND) :: u_diffusion, invLength_dc, invLength_dv, visc2 real (kind=RKIND), dimension(:), pointer :: meshScaling, & dcEdge, dvEdge @@ -163,8 +164,8 @@ subroutine ocn_vel_hmix_leith_tend(meshPool, divergence, relativeVorticity, visc vertex1 = verticesOnEdge(1,iEdge) vertex2 = verticesOnEdge(2,iEdge) - invLength1 = 1.0 / dcEdge(iEdge) - invLength2 = 1.0 / dvEdge(iEdge) + invLength_dc = 1.0_RKIND / dcEdge(iEdge) + invLength_dv = 1.0_RKIND / dvEdge(iEdge) do k = 1, maxLevelEdgeTop(iEdge) @@ -172,14 +173,14 @@ subroutine ocn_vel_hmix_leith_tend(meshPool, divergence, relativeVorticity, visc ! is - \nabla relativeVorticity pointing from vertex 2 to vertex 1, or equivalently ! + k \times \nabla relativeVorticity pointing from cell1 to cell2. - u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * invLength1 & - -( relativeVorticity(k,vertex2) - relativeVorticity(k,vertex1) ) * invLength2 + u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * invLength_dc & + -( relativeVorticity(k,vertex2) - relativeVorticity(k,vertex1) ) * invLength_dv ! Here the first line is (\delta x)^3 ! the second line is |\nabla \omega| ! and u_diffusion is \nabla^2 u (see formula for $\bf{D}$ above). - visc2 = ( config_leith_parameter * config_leith_dx * meshScaling(iEdge) / 3.14)**3 & - * abs( relativeVorticity(k,vertex2) - relativeVorticity(k,vertex1) ) * invLength1 * sqrt(3.0) + visc2 = ( config_leith_parameter * config_leith_dx * meshScaling(iEdge) / pii)**3 & + * abs( relativeVorticity(k,vertex2) - relativeVorticity(k,vertex1) ) * invLength_dc * sqrt(3.0_RKIND) visc2 = min(visc2, config_leith_visc2_max) tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * visc2 * u_diffusion From 0d6210c3eeebae64b6ff2b0dc8624b7654b16da2 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Thu, 22 Oct 2015 15:58:34 -0600 Subject: [PATCH 0352/1724] bug fix/cleanup: no intra-proc IO MPI commun. This commit removes communciation from a processor to itself by modifying the IO halo to ensure it does not include its host processor. This is conceptually cleaner and rectifies a bug that did not occur for openmpi/1.8.1 but did for openmpi/1.6.5 The issue was that messages communicated from the host to the host were corrupted on 1.6.5. Now, no IO communication occurs from host to host which increases efficiency and avoids this bug. This commit also now explicitly addresses the corner case where a particle on processor A with ioProc A is being sent to processor B. Before, B would not show up in A's ioProc halo due to restructuring in 1beb979. Now, this case is explicitly covered in order to ensure symmetry of the ioProc communication graph which is required for the MPI communication to occur for IO. --- .../mpas_ocn_lagrangian_particle_tracking.F | 2 +- .../analysis_members/mpas_ocn_particle_list.F | 80 +++++++++++++++++-- 2 files changed, 74 insertions(+), 8 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F index 55a41f38e5..cc60db8364 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -770,7 +770,7 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ call mpas_timer_start("particleAssignments", .false., timerParticleAssignment) #endif ! update halo fields - call mpas_particle_list_update_computational_halos(domain, block, particle, 'lagrPartTrackCells', iCell, arrayIndex, ioProcRecvList, g_ioProcNeighs) + call mpas_particle_list_update_computational_halos(domain, block, particle, 'lagrPartTrackCells', iCell, arrayIndex, ioProcRecvList, ioProcSendList, g_ioProcNeighs) #ifdef MPAS_DEBUG call mpas_timer_stop("particleAssignments", timerParticleAssignment) #endif diff --git a/src/core_ocean/analysis_members/mpas_ocn_particle_list.F b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F index cbcb704215..f8104f248a 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_particle_list.F +++ b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F @@ -525,6 +525,7 @@ subroutine mpas_particle_list_build_io_halos(domain, err, namedBlock, ioProcNeig ! get a complete list of the processors (including itself) call uniqueIntegerList(tempInt,ioProcNeighs) + call removeValueFromIntList(ioProcNeighs, domain % dminfo % my_proc_id) #ifdef MPAS_DEBUG write(stderrUnit,*) 'ioProcNeighs = ', ioProcNeighs #endif @@ -592,7 +593,10 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS ! compute send list now that all particles reside on correct block (processor) 'currentBlock' ! didn't show up with serial IO because all computational processors sent data to proc 0 - call compute_particle_send_list(domain, ioProcSendList) + ! note that this could be missing communication where before transfer particle on proc A + ! has ioProc of A and is sent to B (must have previously kept a record that B is in A's halo list + ! note, may be slightly redundant because we could update ioProcSendList once particles are transfered + call compute_additional_particle_send_list(domain, ioProcSendList) #ifdef MPAS_DEBUG ! need to update IO processors as to the change also so that they know where to get data from!!! @@ -608,6 +612,7 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS allocate(sendRequestID(nioProcNeighs), recvRequestID(nioProcNeighs)) completeList = .False. + recvList = .False. ! for each ioProc, send logical array information do i = 1, nioProcNeighs #ifdef _MPI @@ -662,6 +667,7 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS ! now get the desired integer halo list deallocate(ioProcNeighs) call uniqueIntegerList(intArray, ioProcNeighs) + call removeValueFromIntList(ioProcNeighs, domain % dminfo % my_proc_id) deallocate(intArray, completeList, sendRequestID, recvRequestID) @@ -2336,11 +2342,63 @@ subroutine compute_procNeighs(domain, err, procNeighs) !{{{ ! get unique array for complete list call uniqueIntegerList(tempIntegerArray, procNeighs) + call removeValueFromIntList(procNeighs, domain % dminfo % my_proc_id) deallocate(tempIntegerArray) end subroutine compute_procNeighs !}}} + +!*********************************************************************** +! +! routine removeValueFromIntList(list, removeval) +! +!> \brief Remove value removeval from list vector +!> \author Phillip Wolfram +!> \date 10/22/2015 +!> \details +!> This routine remotes the removeval value from the list in-place. +! +!----------------------------------------------------------------------- + subroutine removeValueFromIntList(list, removeval) !{{{ + implicit none + integer, dimension(:), pointer, intent(inout) :: list + integer, intent(in) :: removeval + + integer, dimension(:), pointer :: tmparray + integer :: nsize, i + + ! get size of new array + nsize = 0 + do i = 1, size(list) + if (list(i) /= removeval) then + nsize = nsize + 1 + end if + end do + + allocate(tmparray(nsize)) + nsize = 0 + do i = 1, size(list) + if (list(i) /= removeval) then + nsize = nsize + 1 + tmparray(nsize) = list(i) + end if + end do + + ! resize the list + deallocate(list) + allocate(list(nsize)) + + ! transfer contents back to list + do i = 1, nsize + list(i) = tmparray(i) + end do + + deallocate(tmparray) + + end subroutine removeValueFromIntList + + !*********************************************************************** ! ! routine uniqueIntegerList(array, uniqueList) @@ -2820,7 +2878,7 @@ end subroutine communicate_num_particles_send_recv !}}} !*********************************************************************** ! -! routine compute_particle_send_list +! routine compute_additional_particle_send_list ! !> \brief Update send list !> \author Phillip Wolfram @@ -2828,7 +2886,7 @@ end subroutine communicate_num_particles_send_recv !}}} !> \details !> Compute send list for all particles residing on correct block 'currentBlock' !----------------------------------------------------------------------- - subroutine compute_particle_send_list(domain, ioProcSendList) !{{{ + subroutine compute_additional_particle_send_list(domain, ioProcSendList) !{{{ implicit none type (domain_type), intent(in) :: domain logical, dimension(:), pointer, intent(inout) :: ioProcSendList @@ -2855,7 +2913,7 @@ subroutine compute_particle_send_list(domain, ioProcSendList) !{{{ block => block % next end do !}}} - end subroutine compute_particle_send_list !}}} + end subroutine compute_additional_particle_send_list !}}} !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! @@ -3827,7 +3885,7 @@ end subroutine read_nonhaloData!}}} ! !----------------------------------------------------------------------- subroutine mpas_particle_list_update_computational_halos(domain, block, particle, poolname, iCell, & - arrayIndex, ioProcRecvList, gioProcNeighs ) !{{{ + arrayIndex, ioProcRecvList, ioProcSendList, gioProcNeighs ) !{{{ implicit none type (domain_type), intent(inout) :: domain type (block_type), intent(inout), pointer :: block @@ -3836,6 +3894,7 @@ subroutine mpas_particle_list_update_computational_halos(domain, block, particle integer, intent(inout) :: iCell, arrayIndex integer, dimension(:), pointer, intent(inout) :: gioProcNeighs logical, dimension(:,:), pointer, intent(inout) :: ioProcRecvList + logical, dimension(:), pointer, intent(inout) :: ioProcSendList ! local variables integer :: currentProc, ioProc @@ -3864,8 +3923,15 @@ subroutine mpas_particle_list_update_computational_halos(domain, block, particle write(stderrUnit,*) 'g_ioProcNeighs=',gioProcNeighs write(stderrUnit,*) 'ioProc=',ioProc #endif - arrayIndex = find_index(gioProcNeighs, ioProc) - ioProcRecvList(arrayIndex, currentProc+1) = .True. + ! do not need to transfer information for particles on-processor, this is computed from the send list + ! which is dependent upon current, on-processor particles + if (ioProc /= domain % dminfo % my_proc_id) then + arrayIndex = find_index(gioProcNeighs, ioProc) + ioProcRecvList(arrayIndex, currentProc+1) = .True. + else + ! consider the case where a particle on A has an ioProc of A and is sent to B (need to have B in A's halo). + ioProcSendList(currentProc+1) = .True. + end if ! must be computed after computational particles are transferred (this was a bug left-over from serial IO) end subroutine mpas_particle_list_update_computational_halos !}}} From 9c59bb18d9250223c274f99145edb7f1e593f217 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 10 Sep 2015 15:25:09 -0600 Subject: [PATCH 0353/1724] Added basic framework for calving I added a module and some config parameters for iceberg calving, based on the calving module recently added in CISM. The new code builds but has not yet been tested. The new config parameters in the Registry are as follows: * config_calving - specifies the calving option (0) 'none' Do nothing (this is the default) (1) 'floating' Calve all floating ice (2) 'topographic_threshold' Calve ice based on a topographic threshold (3) 'thickness_threshold' Calve ice based on a thickness threshold * config_calving_topographic_threshold - Calve all ice where bed topography (relative to sea level) lies below this threshold - for option (2) above; default value = -200 m * config_calving_thickness_threshold - Calve all ice thinner than this threshold (apart from a one-cell ring of inactive ice) - for option (3) above; default value = 200 m * config_calving_timescale - Calve a thickness fraction max(dt/calving_timescale, 1) - Value of 0 => calve the full thickness of each eligible column - for options (1)-(3); default value 0.0 * config_calving_on_startup - If true, calve ice on startup; else wait until first prognostic step - for options (1)-(3); default value 'false' The new calving module is called li_calving.F. It contains a single public subroutine, do_calving. This subroutine is called from li_time_integrator_forward_euler, after update_prognostics and before the diagnostic velocity solve. Optionally, it will also be called at initialization, but I haven't set this up yet. --- src/core_landice/Registry.xml | 39 +- src/core_landice/mode_forward/Makefile | 6 + .../mode_forward/mpas_li_calving.F | 361 ++++++++++++++++++ .../mode_forward/mpas_li_time_integration.F | 2 +- .../mpas_li_time_integration_fe.F | 6 + 5 files changed, 412 insertions(+), 2 deletions(-) create mode 100644 src/core_landice/mode_forward/mpas_li_calving.F diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 857c521ec6..ebb96aaa0c 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -85,6 +85,28 @@ --> + + + + + + + + + @@ -487,6 +514,9 @@ is the value of that variable from the *previous* time level! + @@ -640,6 +670,9 @@ is the value of that variable from the *previous* time level! description="Basal mass balance on floating regions" /> + + \brief MPAS land ice calving scheme +!> \author William Lipscomb +!> \date September 2015 +!> \details +!> This module contains several options for calving ice. +! +!----------------------------------------------------------------------- + +module li_calving + + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + use mpas_dmpar + use li_setup + use li_mask + + implicit none + private + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: do_calving + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + +!*********************************************************************** + contains +!*********************************************************************** + + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ! routine do_calving +! +!> \brief MPAS land ice calving scheme +!> \author William Lipscomb +!> \date September 2015 +!> \details +!> This routine contains several options for calving ice: +!> (0) Do nothing +!> (1) Calve all floating ice +!> (2) Calve ice based on a topographic threshold +!> (3) Calve ice based on an ice thickness threshold +!----------------------------------------------------------------------- + + subroutine do_calving(domain, deltat, err) + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + real (kind=RKIND), intent(in) :: deltat !< Input: time step + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: & + domain !< Input/Output: domain object + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + + type (dm_info), pointer :: dminfo + type (block_type), pointer :: block + + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: geometryPool + type (mpas_pool_type), pointer :: scratchPool + type (mpas_pool_type), pointer :: velocityPool + + ! calving-relevant config options + character (len=StrKIND), pointer :: config_calving + logical, pointer :: config_print_calving_info + real(kind=RKIND), pointer :: config_calving_topographic_threshold, & + config_calving_thickness_threshold, & + config_calving_timescale, & + config_sea_level + + ! fields for calving masks + ! The calvingLaw mask is used for the floating and topographic_threshold options + ! The inactiveMargin and ocean masks are used for the more complex thickness_threshold option + + type (field1dInteger), pointer :: calvingLawMaskField + integer, dimension(:), pointer :: calvingLawMask ! = 1 where calving-law criterion is satisfied, else = 0 + + type (field1dInteger), pointer :: inactiveMarginMaskField + integer, dimension(:), pointer :: inactiveMarginMask ! = 1 for inactive cells (thin or no ice) that have 1 or more active neighbors + + type (field1dInteger), pointer :: oceanMaskField + integer, dimension(:), pointer :: oceanMask ! = 1 for cells that are not land and do not have active ice + ! may include floating cells with inactive ice + + integer, pointer :: nCells + + integer, dimension(:), pointer :: & + nCellsOnCell, & ! number of cells that border each cell + cellMask ! bit mask describing whether ice is floating, dynamically active, etc. + + integer, dimension(:), pointer :: & + indexToCellID ! list of global cell IDs + + integer, dimension(:,:), pointer :: & + cellsOnCell ! list of cells that neighbor each cell + + real (kind=RKIND) :: & + calvingFraction ! fraction of ice that calves in each column; depends on calving_timescale + + real (kind=RKIND), dimension(:), pointer :: & + thickness, & ! ice thickness + bedTopography ! bed topography (negative below sea level) + + real (kind=RKIND), dimension(:), pointer :: & + calvingThickness ! thickness of ice that calves (computed in this subroutine) + ! typically the entire ice thickness, but will be a fraction of the thickness if calving_timescale > dt + + integer :: iCell, iCellOnCell, iCellNeighbor + + integer :: err_tmp + + real (kind=RKIND), parameter :: scyr = 31536000.0_RKIND ! seconds per 365-day year; diagnostic only + !TODO - put this in a constants module? + err = 0 + + ! get config options + dminfo => domain % dminfo + call mpas_pool_get_config(liConfigs, 'config_calving', config_calving) + call mpas_pool_get_config(liConfigs, 'config_calving_thickness_threshold', config_calving_thickness_threshold) + call mpas_pool_get_config(liConfigs, 'config_calving_topographic_threshold', config_calving_topographic_threshold) + call mpas_pool_get_config(liConfigs, 'config_calving_timescale', config_calving_timescale) + call mpas_pool_get_config(liConfigs, 'config_print_calving_info', config_print_calving_info) + call mpas_pool_get_config(liConfigs, 'config_sea_level', config_sea_level) + + ! based on the calving timescale, set the fraction of ice that calves + if (config_calving_timescale > 0.0_RKIND) then + calvingFraction = max(deltat/config_calving_timescale, 1.0_RKIND) + else + calvingFraction = 1.0_RKIND ! calve the entire thickness in eligible columns + endif + + ! block loop + block => domain % blocklist + do while (associated(block)) + + ! get pools + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) ! required for cellMask computation + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + + ! get dimensions + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + + ! get required fields from the mesh pool + call mpas_pool_get_array(meshPool, 'nCellsOnCell', nCellsOnCell) + call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(meshPool, 'indexToCellID', indexToCellID) ! diagnostic only + + ! get required fields from the geometry pool + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) + call mpas_pool_get_array(geometryPool, 'calvingThickness', calvingThickness) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + + if (config_print_calving_info) then + write(stderrUnit,*) 'Do ice calving, option =', trim(config_calving) + write(stderrUnit,*) 'Calving timscale (yr) =', config_calving_timescale / scyr + endif + + ! calculate masks - so we know where the ice is floating and/or dynamically active + + call li_calculate_mask(meshPool, velocityPool, geometryPool, err_tmp) + err = ior(err, err_tmp) + + ! initialize + calvingThickness = 0.0_RKIND + + ! compute calving based on the calving_config option + + if (trim(config_calving) == 'none') then + + ! do nothing + + elseif (trim(config_calving) == 'thickness_threshold') then + + ! calve ice thinner than the threshold thickness + + !Note: This is not as simple as identifying floating ice thinner than the thickness threshold. + ! The problem with that approach is that any ice advected in front of the calving front + ! would be instantly removed, making it impossible for the calving front to advance. + ! Instead, we define an inactive margin containing cells that are inactive but border active cells. + ! Cells on the inactive margin are protected from calving, but thin floating ice + ! beyond the inactive margin can calve. + ! + ! Specifically, the rules are as follows: + ! - Mark cells as ocean if not land and not active ice. + ! - Mark cells as inactive margin if not active ice, but with an active ice neighbor. + ! - Calve ice in ocean cells that are not on the inactive margin. + + if (config_print_calving_info) then + write(stderrUnit,*) 'Calving thickness threshold (m) =', config_calving_thickness_threshold + endif + + ! get scratch fields for calving + ! 'true' flag means to allocate the field for a single block + + call mpas_pool_get_field(scratchPool, 'iceCellMask', inactiveMarginMaskField) + call mpas_allocate_scratch_field(inactiveMarginMaskField, .true.) + inactiveMarginMask => inactiveMarginMaskField % array + + call mpas_pool_get_field(scratchPool, 'iceCellMask2', oceanMaskField) + call mpas_allocate_scratch_field(oceanMaskField, .true.) + oceanMask => oceanMaskField % array + + ! Identify cells that are inactive but border dynamically active cells + !WHL - This might not work as intended if there are cells on the margin that are thick but have Dirichlet BC + ! and thus are classified as inactive. + do iCell = 1, nCells + inactiveMarginMask(iCell) = 0 + if (.not. li_mask_is_dynamic_ice(cellMask(iCell))) then ! either thin (inactive) ice or no ice + do iCellOnCell = 1, nCellsOnCell(iCell) + iCellNeighbor = cellsOnCell(iCellOnCell,iCell) + if (li_mask_is_dynamic_margin(cellMask(iCellNeighbor))) then ! neighbor cell is on the dynamic ice margin + inactiveMarginMask(iCell) = 1 + exit + endif + enddo ! iCellOnCell + endif ! not dynamic ice + enddo ! iCell + + ! Identify ocean cells (not land and not dynamic ice; may include inactive floating ice) + + where (bedTopography < config_sea_level .and. .not.li_mask_is_dynamic_ice(cellMask)) + oceanMask = 1 + elsewhere + oceanMask = 0 + endwhere + + ! Calve ice in ocean cells that are not on the inactive margin + + where (oceanMask == 1 .and. inactiveMarginMask == 0) + calvingThickness = thickness * calvingFraction + thickness = thickness - calvingThickness + endwhere + + else ! other calving options (floating, topographic_threshold) + + ! get scratch fields for calving + + call mpas_pool_get_field(scratchPool, 'iceCellMask', calvingLawMaskField) + call mpas_allocate_scratch_field(calvingLawMaskField, .true.) + calvingLawMask => calvingLawMaskField % array + + if (trim(config_calving) == 'floating') then + + ! calve floating ice + ! Note: The floating_ice mask includes all floating ice, both inactive and active + + where (li_mask_is_floating_ice(cellMask)) + calvingLawMask = 1 + elsewhere + calvingLawMask = 0 + endwhere + + elseif (trim(config_calving) == 'topographic_threshold') then + + ! calve ice where the bed topography lies below a threshold depth + + if (config_print_calving_info) then + write(stderrUnit,*) 'Calving topographic threshold (m) =', config_calving_topographic_threshold + endif + + where (bedTopography < config_calving_topographic_threshold + config_sea_level) + calvingLawMask = 1 + elsewhere + calvingLawMask = 0 + endwhere + + !Note: Could add other calving options here (e.g., damage-based calving) + + endif ! floating or topographic_threshold + + ! Calve ice where specified by the calving law. + ! If the calving timescale > 0, then will calve only a fraction of the thickness in each calving cell. + + where (calvingLawMask == 1) + + calvingThickness = thickness * calvingFraction + thickness = thickness - calvingThickness + + endwhere + + endif ! config_calving + + ! Optionally, print a list of cells with calving + + if (config_print_calving_info) then + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'Global cell ID, calving thickness:' + do iCell = 1, nCells + if (calvingThickness(iCell) > 0.0_RKIND) then + write(stderrUnit,*) indexToCellID(iCell), calvingThickness(iCell) + endif + enddo + endif + + block => block % next + enddo + + ! === error check + if (err > 0) then + write (stderrUnit,*) "An error has occurred in do_calving." + endif + + !-------------------------------------------------------------------- + end subroutine do_calving + +!*********************************************************************** +!*********************************************************************** +! Private subroutines: +!*********************************************************************** +!*********************************************************************** + +! No private subroutines so far + +end module li_calving + + diff --git a/src/core_landice/mode_forward/mpas_li_time_integration.F b/src/core_landice/mode_forward/mpas_li_time_integration.F index dd540289e7..512d8cd81e 100644 --- a/src/core_landice/mode_forward/mpas_li_time_integration.F +++ b/src/core_landice/mode_forward/mpas_li_time_integration.F @@ -120,7 +120,7 @@ subroutine li_timestep(domain, err) call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=err_tmp) ! === - ! === Non-adpative timestep: Get dt in seconds + ! === Non-adaptive timestep: Get dt in seconds ! === if (.not. config_adaptive_timestep) then ! Get the interval at this point in time - will be fixed for nonadaptive timestep, but need to get it out of the clock diff --git a/src/core_landice/mode_forward/mpas_li_time_integration_fe.F b/src/core_landice/mode_forward/mpas_li_time_integration_fe.F index 52a78befb3..e197278b44 100644 --- a/src/core_landice/mode_forward/mpas_li_time_integration_fe.F +++ b/src/core_landice/mode_forward/mpas_li_time_integration_fe.F @@ -29,6 +29,7 @@ module li_time_integration_fe use mpas_vector_reconstruction use li_velocity, only: li_velocity_solve use li_tendency + use li_calving, only: do_calving use li_diagnostic_vars use li_setup @@ -120,6 +121,11 @@ subroutine li_time_integrator_forwardeuler(domain, deltat, err) err = ior(err, err_tmp) call mpas_timer_stop("calc. new prognostic vars") +! === Calve ice ======================== + call mpas_timer_start("calve_ice") + call do_calving(domain, deltat, err_tmp) + err = ior(err, err_tmp) + call mpas_timer_stop("calve_ice") ! === Calculate diagnostic variables for new state ===================== From 556ed4b2a3d5105fe582d6cf42fa693965f64244 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 19 Oct 2015 14:10:36 -0600 Subject: [PATCH 0354/1724] Added a subroutine to hold the calving front fixed; added simple prescribed velocity options In ACME v1 we plan to hold the calving front fixed, at least for the first round of experiments. To support this choice I added a new config option, config_restore_calving_front. The default is false. If set to true, the model will call a new subroutine (li_restore_calving_front) in lieu of the regular calving subroutine (li_calve_ice). The new subroutine loops through all cells. For each cell with a bed below sea level, the model checks for two things: (1) If ice was present initially but now is very thin or absent, the ice is restored to a small thickness called restoreThicknessMin, which is set to config_dynamic_thickness/10. The ice that is added is put in a new field, restoreThickness, in order to keep track of energy non-conservation. (2) If ice was absent initially but now is present, it is removed and added to calvingThickness. To support this logic, I added a logical function li_mask_is_initial_ice. In addition, I created a new module, li_velocity_simple. This module supports two options for prescribing a simple velocity field: (1) 'uniform' = uniform velocity in a straight line. The speed and direction are controlled by the parameters flowSpeed and flowTheta, set in subroutine li_velocity_simple_block_init. (2) 'radial' = outward from a central point, with speed increasing linearly with distance from the center. The increase of speed with distance is controlled by the parameter flowGradient. The center of flow is (xCenter,yCenter), set to (0,0) by default. Both options assume flow on a plane (not on the surface of a sphere). They can be set in the namelist, with config_velocity_solver = 'simple' and config_simple_velocity_type = 'uniform' or 'radial'. To create these simple velocity fields, I prescribed (u,v) at cell centers and then found the normal velocity components by taking the dot product of (u,v) with the unit normal vector at each cell midpoint. I verified that the normal components are correct for a periodic domain. As a bug check, I reconstructed the center velocity from the normal components. For the periodic mesh used in the circular shelf problem, the reconstruction works in the mesh interior but is incorrect along the boundary. Doug reports that the reconstruction coefficients should be correct for a v1 compliant periodic mesh, but Matt says that the land-ice periodic meshes are not yet v1 compliant. Other changes: - I created a new mask, activeForCalvingMask, to support the calving thickness threshold option. This option treats grounded ice as active where thickness > config_dynamic_thickness, but treats floating ice as active where thickness > config_calving_thickness. - For brevity, I changed 'config_calving_thickness_threshold' to 'config_calving_thickness', and 'config_calving_topographic_threshold' to 'config_calving_topography'. The default values are now 100 m and -500 m, respectively. I checked that it is OK for config_calving_thickness to be >, < or = to config_dynamic_thickness. - I decided not to support the config_calving_on_startup option, at least for now. The issue is that subroutine calve_ice is called with input argument 'domain', which means it cannot be called from within landice_init_block, which otherwise would be the most natural place to do calving on startup. We can add this option later, if needed. - I modified some logic so that vector reconstruction coefficients are always computed at initialization, and then are given a halo update. This is in anticipation that we will almost always want these coefficients. For example, incremental remapping requires them. - I added scyr = 31536000.0 to the mpas_li_constants module. This is the number of seconds in a 365-day year. Although MPAS-LI uses SI units, it is useful to have this constant available (e.g., for velocity diagnostics where it's easier to think in terms of m/yr than m/s). - To support various test cases, I added some code to li_velocity_simple_init_block to tweak the thickness, bedTopography and sfcMassBal fields. I will remove this code later but am including it in this commit, to make it easy to repeat the testing if desired. Using these simple velocity fields in the circular-shelf test problem, I verified that the calving subroutines are working as intended. In particular: When config_restore_calving_front = .true.: - With prescribed radially outward flow, ice advances beyond the initial calving front but then is removed. - With a prescribed negative SMB along the periphery, ice behind the initial calving front melts away, but then is restored with a thickness of restoreThicknessMin. When config_calving = 'floating': - Ice calves wherever the ice is floating (and not elsewhere). When config_calving = 'topographic_threshold': - Ice calves wherever the bed topography lies lower than the topographic threshold (and not elsewhere). When config_calving = 'thickness_threshold': - Ice calves wherever the ice is floating and is thinner than config_calving_thickness (apart from a protected one-cell ring around floating ice that is below the thickness threshold). - The calving front can advance and retreat under appropriate forcing. When config_calving_timescale > 0: - Ice calves at the desired rate; a fraction of the ice is removed during each time step. --- src/core_landice/Registry.xml | 36 +- src/core_landice/mode_forward/Makefile | 5 + .../mode_forward/mpas_li_calving.F | 465 +++++++++++-- src/core_landice/mode_forward/mpas_li_core.F | 30 +- .../mpas_li_time_integration_fe.F | 23 +- .../mode_forward/mpas_li_velocity.F | 44 +- .../mode_forward/mpas_li_velocity_simple.F | 620 ++++++++++++++++++ src/core_landice/shared/mpas_li_constants.F | 2 +- src/core_landice/shared/mpas_li_mask.F | 19 +- 9 files changed, 1155 insertions(+), 89 deletions(-) create mode 100644 src/core_landice/mode_forward/mpas_li_velocity_simple.F diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index ebb96aaa0c..b8af5c77ba 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -47,8 +47,8 @@ + @@ -90,22 +94,22 @@ description="Selection of the method for calving ice." possible_values="'none', 'floating', 'topographic_threshold', 'thickness_threshold'" /> - - - + @@ -669,10 +673,13 @@ is the value of that variable from the *previous* time level! - + + + @@ -802,6 +812,10 @@ is the value of that variable from the *previous* time level! description="mask set to 1 in cells where some criterion is satisfied and 0 otherwise" persistence="scratch" /> + \brief MPAS land ice calving scheme !> \author William Lipscomb @@ -72,7 +74,7 @@ module li_calving !> (3) Calve ice based on an ice thickness threshold !----------------------------------------------------------------------- - subroutine do_calving(domain, deltat, err) + subroutine li_calve_ice(domain, deltat, err) !----------------------------------------------------------------- ! input variables @@ -105,24 +107,33 @@ subroutine do_calving(domain, deltat, err) ! calving-relevant config options character (len=StrKIND), pointer :: config_calving logical, pointer :: config_print_calving_info - real(kind=RKIND), pointer :: config_calving_topographic_threshold, & - config_calving_thickness_threshold, & + + real(kind=RKIND), pointer :: config_calving_topography, & + config_calving_thickness, & config_calving_timescale, & - config_sea_level + config_sea_level, & + config_dynamic_thickness, & + config_ice_density, & + config_ocean_density ! fields for calving masks ! The calvingLaw mask is used for the floating and topographic_threshold options - ! The inactiveMargin and ocean masks are used for the more complex thickness_threshold option + ! The activeForCalving, inactiveMargin and ocean masks are used for the more complex thickness_threshold option type (field1dInteger), pointer :: calvingLawMaskField integer, dimension(:), pointer :: calvingLawMask ! = 1 where calving-law criterion is satisfied, else = 0 + type (field1dInteger), pointer :: activeForCalvingMaskField + integer, dimension(:), pointer :: activeForCalvingMask ! = 1 for grounded cells thicker than config_dynamic_thickness; + ! = 1 for floating cells thicker than config_calving_thickness; + ! = 0 elsewhere + type (field1dInteger), pointer :: inactiveMarginMaskField integer, dimension(:), pointer :: inactiveMarginMask ! = 1 for inactive cells (thin or no ice) that have 1 or more active neighbors type (field1dInteger), pointer :: oceanMaskField integer, dimension(:), pointer :: oceanMask ! = 1 for cells that are not land and do not have active ice - ! may include floating cells with inactive ice + ! includes floating cells with inactive ice integer, pointer :: nCells @@ -137,7 +148,8 @@ subroutine do_calving(domain, deltat, err) cellsOnCell ! list of cells that neighbor each cell real (kind=RKIND) :: & - calvingFraction ! fraction of ice that calves in each column; depends on calving_timescale + calvingFraction, & ! fraction of ice that calves in each column; depends on calving_timescale + flotationThickness ! thickness at which marine-based ice starts to float real (kind=RKIND), dimension(:), pointer :: & thickness, & ! ice thickness @@ -151,22 +163,32 @@ subroutine do_calving(domain, deltat, err) integer :: err_tmp - real (kind=RKIND), parameter :: scyr = 31536000.0_RKIND ! seconds per 365-day year; diagnostic only - !TODO - put this in a constants module? + !WHL - debug + integer, parameter :: ncellsPerRow = 40 + integer, parameter :: nRows = 46 + integer :: i, iRow + err = 0 ! get config options dminfo => domain % dminfo call mpas_pool_get_config(liConfigs, 'config_calving', config_calving) - call mpas_pool_get_config(liConfigs, 'config_calving_thickness_threshold', config_calving_thickness_threshold) - call mpas_pool_get_config(liConfigs, 'config_calving_topographic_threshold', config_calving_topographic_threshold) + call mpas_pool_get_config(liConfigs, 'config_calving_thickness', config_calving_thickness) + call mpas_pool_get_config(liConfigs, 'config_calving_topography', config_calving_topography) call mpas_pool_get_config(liConfigs, 'config_calving_timescale', config_calving_timescale) call mpas_pool_get_config(liConfigs, 'config_print_calving_info', config_print_calving_info) call mpas_pool_get_config(liConfigs, 'config_sea_level', config_sea_level) + call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) + call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) + call mpas_pool_get_config(liConfigs, 'config_ocean_density', config_ocean_density) ! based on the calving timescale, set the fraction of ice that calves if (config_calving_timescale > 0.0_RKIND) then - calvingFraction = max(deltat/config_calving_timescale, 1.0_RKIND) + calvingFraction = min(deltat/config_calving_timescale, 1.0_RKIND) + !WHL - debug + write(stderrUnit,*) 'deltat (s) =', deltat + write(stderrUnit,*) 'deltat (yr) =', deltat/scyr + write(stderrUnit,*) 'calvingFraction =', calvingFraction else calvingFraction = 1.0_RKIND ! calve the entire thickness in eligible columns endif @@ -196,14 +218,26 @@ subroutine do_calving(domain, deltat, err) call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) if (config_print_calving_info) then - write(stderrUnit,*) 'Do ice calving, option =', trim(config_calving) - write(stderrUnit,*) 'Calving timscale (yr) =', config_calving_timescale / scyr - endif + write(stderrUnit,*) 'Do ice calving, option = ', trim(config_calving) + write(stderrUnit,*) 'Calving timscale (yr) = ', config_calving_timescale / scyr - ! calculate masks - so we know where the ice is floating and/or dynamically active + !WHL - debug - for circular shelf test case + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'Ice thickness before calving' + do iRow = nRows, 1, -1 + if (mod(iRow,2) == 0) then ! indent for even-numbered rows + write(stderrUnit,'(a3)',advance='no') ' ' + endif +!! do i = 1, nCellsPerRow + do i = nCellsPerRow/2 - 2, nCellsPerRow + iCell = (iRow-1)*nCellsPerRow + i +!! write(stderrUnit,'(i5)',advance='no') iCell + write(stderrUnit,'(f8.2)',advance='no') thickness(iCell) + enddo + write(stderrUnit,*) ' ' + enddo - call li_calculate_mask(meshPool, velocityPool, geometryPool, err_tmp) - err = ior(err, err_tmp) + endif ! config_print_calving_info ! initialize calvingThickness = 0.0_RKIND @@ -216,62 +250,150 @@ subroutine do_calving(domain, deltat, err) elseif (trim(config_calving) == 'thickness_threshold') then - ! calve ice thinner than the threshold thickness - - !Note: This is not as simple as identifying floating ice thinner than the thickness threshold. - ! The problem with that approach is that any ice advected in front of the calving front - ! would be instantly removed, making it impossible for the calving front to advance. - ! Instead, we define an inactive margin containing cells that are inactive but border active cells. - ! Cells on the inactive margin are protected from calving, but thin floating ice - ! beyond the inactive margin can calve. + ! calve ice thinner than a thickness threshold + + ! Note: The thickness-threshold option is different from the others. + ! For the other options, we look at each cell and determine whether it meets the calving-law criteria + ! (e.g., ice is floating, or the topography lies below a given level). + ! If a cell meets the criteria and lies in the calving domain (e.g., at the margin), it is calved. + ! For the thickness-threshold option, ice thinner than config_calving_thickness is calved, + ! but only if it lies beyond a protected ring of thin ice at the floating margin. + ! The reason for this more complicated approach is that we do not want to remove all floating ice + ! thinner than the calving thickness, because then we would remove thin ice that has just + ! been advected from active cells at the margin, and the calving front would be unable to advance. + ! By protecting a ring of inactive ice (thickness < config_calving_thickness) at the margin, + ! we allow ice in these cells to thicken and become active, thus advancing the calving front. + ! The calving front retreats when active floating ice thins to become inactive, removing protection + ! from previously protected cells. ! ! Specifically, the rules are as follows: - ! - Mark cells as ocean if not land and not active ice. - ! - Mark cells as inactive margin if not active ice, but with an active ice neighbor. + ! - Mark cells as active-for-calving if either (1) grounded, with thickness > config_dynamic_thickness + ! or (2) floating, with thickness > config_calving_thickness. + ! - Mark cells as ocean if not land and not active. + ! - Mark cells as lying on the inactive margin if not active, but with an active neighbor. ! - Calve ice in ocean cells that are not on the inactive margin. if (config_print_calving_info) then - write(stderrUnit,*) 'Calving thickness threshold (m) =', config_calving_thickness_threshold + write(stderrUnit,*) 'Calving thickness (m) =', config_calving_thickness + write(stderrUnit,*) 'Dynamic thickness (m) =', config_dynamic_thickness + endif + + ! Make sure config_calving_thickness > config_dynamic_thickness. + ! Otherwise the algorithm will not work. + + if (config_calving_thickness < config_dynamic_thickness) then + write(stderrUnit,*) 'ERROR: Must have config_calving_thickness > config_dynamic_thickness' + write(stderrUnit,*) 'config_calving_thickness (m) =', config_calving_thickness + write(stderrUnit,*) 'config_dynamic_thickness (m) =', config_dynamic_thickness +!! call mpas_dmpar_global_abort('Aborting with calving error') endif ! get scratch fields for calving ! 'true' flag means to allocate the field for a single block - call mpas_pool_get_field(scratchPool, 'iceCellMask', inactiveMarginMaskField) + call mpas_pool_get_field(scratchPool, 'iceCellMask', activeForCalvingMaskField) + call mpas_allocate_scratch_field(activeForCalvingMaskField, .true.) + activeForCalvingMask => activeForCalvingMaskField % array + + call mpas_pool_get_field(scratchPool, 'iceCellMask2', inactiveMarginMaskField) call mpas_allocate_scratch_field(inactiveMarginMaskField, .true.) inactiveMarginMask => inactiveMarginMaskField % array - call mpas_pool_get_field(scratchPool, 'iceCellMask2', oceanMaskField) + call mpas_pool_get_field(scratchPool, 'iceCellMask3', oceanMaskField) call mpas_allocate_scratch_field(oceanMaskField, .true.) oceanMask => oceanMaskField % array - ! Identify cells that are inactive but border dynamically active cells - !WHL - This might not work as intended if there are cells on the margin that are thick but have Dirichlet BC - ! and thus are classified as inactive. + ! Identify cells that are active-for-calving: + ! (1) Grounded ice with thickness > config_dynamic_thickness + ! (2) Floating ice with thickness > config_calving_thickness + + activeForCalvingMask(:) = 0 + + do iCell = 1, nCells + + if (bedTopography(iCell) >= config_sea_level) then ! land cell + if (thickness(iCell) > config_dynamic_thickness) then ! active for calving + activeForCalvingMask(iCell) = 1 + endif + else ! marine cell, topography below sea level + flotationThickness = (config_ocean_density/config_ice_density) * (config_sea_level - bedTopography(iCell)) + if (thickness(iCell) < flotationThickness) then ! floating + if (thickness(iCell) > config_calving_thickness) then + activeForCalvingMask(iCell) = 1 + endif + else ! grounded marine ice + if (thickness(iCell) > config_dynamic_thickness) then ! active for calving + activeForCalvingMask(iCell) = 1 + endif + endif ! floating or grounded + endif ! land or marine + + enddo ! iCell + + ! Identify cells that are inactive but border active-for-calving cells + + inactiveMarginMask(:) = 0 + do iCell = 1, nCells - inactiveMarginMask(iCell) = 0 - if (.not. li_mask_is_dynamic_ice(cellMask(iCell))) then ! either thin (inactive) ice or no ice - do iCellOnCell = 1, nCellsOnCell(iCell) + if (activeForCalvingMask(iCell) == 0) then ! inactive + + ! check whether any neighbor cells are active + !WHL - TODO - Add nCellsOnCell to circular shelf test case. For now, assume nCellsOnCell = 6 for all cells +!! do iCellOnCell = 1, nCellsOnCell(iCell) + do iCellOnCell = 1, 6 iCellNeighbor = cellsOnCell(iCellOnCell,iCell) - if (li_mask_is_dynamic_margin(cellMask(iCellNeighbor))) then ! neighbor cell is on the dynamic ice margin + if (activeForCalvingMask(iCellNeighbor) == 1) then ! neighbor cell is active inactiveMarginMask(iCell) = 1 exit endif - enddo ! iCellOnCell - endif ! not dynamic ice - enddo ! iCell + enddo ! iCellOnCell + + endif ! inactive + enddo ! iCell - ! Identify ocean cells (not land and not dynamic ice; may include inactive floating ice) + ! Identify ocean cells (not land and not active ice, but including inactive floating ice) - where (bedTopography < config_sea_level .and. .not.li_mask_is_dynamic_ice(cellMask)) + where (bedTopography < config_sea_level .and. activeForCalvingMask == 0) oceanMask = 1 elsewhere oceanMask = 0 endwhere - ! Calve ice in ocean cells that are not on the inactive margin + if (config_print_calving_info) then - where (oceanMask == 1 .and. inactiveMarginMask == 0) +! write(stderrUnit,*) 'Active-for-calving mask' + do iRow = nRows, 1, -1 + if (mod(iRow,2) == 0) then ! indent for even-numbered rows +! write(stderrUnit,'(a3)',advance='no') ' ' + endif + !! do i = 1, nCellsPerRow + do i = nCellsPerRow/2 - 2, nCellsPerRow + iCell = (iRow-1)*nCellsPerRow + i + !! write(stderrUnit,'(i5)',advance='no') iCell +! write(stderrUnit,'(i8)',advance='no') activeForCalvingMask(iCell) + enddo +! write(stderrUnit,*) ' ' + enddo + +! write(stderrUnit,*) 'Inactive margin mask' + do iRow = nRows, 1, -1 + if (mod(iRow,2) == 0) then ! indent for even-numbered rows +! write(stderrUnit,'(a3)',advance='no') ' ' + endif + !! do i = 1, nCellsPerRow + do i = nCellsPerRow/2 - 2, nCellsPerRow + iCell = (iRow-1)*nCellsPerRow + i + !! write(stderrUnit,'(i5)',advance='no') iCell +! write(stderrUnit,'(i8)',advance='no') inactiveMarginMask(iCell) + enddo +! write(stderrUnit,*) ' ' + enddo + + endif ! config_print_calving_info + + ! Calve ice in ocean cells that are not on the protected inactive margin + + where (oceanMask == 1 .and. inactiveMarginMask == 0 .and. thickness > 0.0_RKIND) calvingThickness = thickness * calvingFraction thickness = thickness - calvingThickness endwhere @@ -286,6 +408,10 @@ subroutine do_calving(domain, deltat, err) if (trim(config_calving) == 'floating') then + ! calculate masks - so we know where the ice is floating + call li_calculate_mask(meshPool, velocityPool, geometryPool, err_tmp) + err = ior(err, err_tmp) + ! calve floating ice ! Note: The floating_ice mask includes all floating ice, both inactive and active @@ -300,10 +426,10 @@ subroutine do_calving(domain, deltat, err) ! calve ice where the bed topography lies below a threshold depth if (config_print_calving_info) then - write(stderrUnit,*) 'Calving topographic threshold (m) =', config_calving_topographic_threshold + write(stderrUnit,*) 'Calving topographic threshold (m) =', config_calving_topography endif - where (bedTopography < config_calving_topographic_threshold + config_sea_level) + where (bedTopography < config_calving_topography + config_sea_level) calvingLawMask = 1 elsewhere calvingLawMask = 0 @@ -322,31 +448,258 @@ subroutine do_calving(domain, deltat, err) thickness = thickness - calvingThickness endwhere - + endif ! config_calving ! Optionally, print a list of cells with calving - + if (config_print_calving_info) then + write(stderrUnit,*) ' ' - write(stderrUnit,*) 'Global cell ID, calving thickness:' + write(stderrUnit,*) 'Global cell ID, bedTopography, calvingThickness:' do iCell = 1, nCells if (calvingThickness(iCell) > 0.0_RKIND) then - write(stderrUnit,*) indexToCellID(iCell), calvingThickness(iCell) + write(stderrUnit,*) indexToCellID(iCell), bedTopography(iCell), calvingThickness(iCell) endif enddo + + !WHL - debug - for circular shelf test case + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'Ice thickness after calving' + do iRow = nRows, 1, -1 + if (mod(iRow,2) == 0) then ! indent for even-numbered rows + write(stderrUnit,'(a3)',advance='no') ' ' + endif + !! do i = 1, nCellsPerRow + do i = nCellsPerRow/2 - 2, nCellsPerRow + iCell = (iRow-1)*nCellsPerRow + i + !! write(stderrUnit,'(i5)',advance='no') iCell + write(stderrUnit,'(f8.2)',advance='no') thickness(iCell) + enddo + write(stderrUnit,*) ' ' + enddo + + endif ! config_print_calving_info + + block => block % next + enddo + + + ! === error check + if (err > 0) then + write (stderrUnit,*) "An error has occurred in li_calve_ice." + endif + + !-------------------------------------------------------------------- + end subroutine li_calve_ice + + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ! routine li_restore_calving_front +! +!> \brief MPAS land ice restore the calving front +!> \author William Lipscomb +!> \date September 2015 +!> \details +!> This routine restores the calving front to its initial position. +!> There are several options: +!> (1) Remove any floating ice that has advanced beyond the initial front. +!> (2) Add back a thin layer of ice wherever the ice has retreated from +!> the initial front. +!> (3) Both (1) and (2) combined +!----------------------------------------------------------------------- + + subroutine li_restore_calving_front(domain, err) + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: & + domain !< Input/Output: domain object + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + + type (dm_info), pointer :: dminfo + type (block_type), pointer :: block + + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: geometryPool + type (mpas_pool_type), pointer :: scratchPool + type (mpas_pool_type), pointer :: velocityPool + + integer, pointer :: nCellsSolve + + logical, pointer :: & + config_print_calving_info + + real (kind=RKIND), pointer :: & + config_sea_level, & + config_dynamic_thickness + + integer, dimension(:), pointer :: & + cellMask ! bit mask describing whether ice is floating, dynamically active, etc. + + real (kind=RKIND), dimension(:), pointer :: & + thickness, & ! ice thickness + bedTopography, & ! elevation of the bed + calvingThickness, & ! thickness of ice that calves + ! > 0 for cells below sea level that were initially ice-free and now have ice + restoreThickness ! thickness of ice that is added to restore the calving front to its initial position + ! > 0 for cells below sea level that were initially ice-covered and now have very thin or no ice + + real (kind=RKIND) :: & + restoreThicknessMin ! small thickness to which ice is restored should it fall below this thickness + + integer :: iCell, err_tmp + + !WHL - debug + integer, parameter :: ncellsPerRow = 40 + integer, parameter :: nRows = 46 + integer :: i, iRow + + ! block loop + block => domain % blocklist + do while (associated(block)) + + ! get pools + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) ! required for cellMask computation + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + + ! get dimensions + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + + ! get required fields from the geometry pool + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) + call mpas_pool_get_array(geometryPool, 'calvingThickness', calvingThickness) + call mpas_pool_get_array(geometryPool, 'restoreThickness', restoreThickness) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + + ! get config variables + call mpas_pool_get_config(liConfigs, 'config_print_calving_info', config_print_calving_info) + call mpas_pool_get_config(liConfigs, 'config_sea_level', config_sea_level) + call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) + + if (config_print_calving_info) then + write(stderrUnit,*) 'Restore calving front' + write(stderrUnit,*) 'max thickness (m) =', maxval(thickness) + + !WHL - debug - for circular shelf test case + write(stderrUnit,*) 'Initial ice thickness' + do iRow = nRows, 1, -1 + if (mod(iRow,2) == 0) then ! indent for even-numbered rows + write(stderrUnit,'(a3)',advance='no') ' ' + endif +!! do i = 1, nCellsPerRow + do i = nCellsPerRow/2 - 2, nCellsPerRow + iCell = (iRow-1)*nCellsPerRow + i +!! write(stderrUnit,'(i5)',advance='no') iCell + write(stderrUnit,'(f8.2)',advance='no') thickness(iCell) + enddo + write(stderrUnit,*) ' ' + enddo + endif + ! set restoreThicknessMin + ! It should be less than config_dynamic_thickness so that the restored ice remains dynamically inactive, + ! even with a certain amount of natural variability. + ! It should also be large enough to permit stable thermal calculations. + ! For now, setting it to 1/10 of config_dynamic_thickness + + restoreThicknessMin = 0.1_RKIND * config_dynamic_thickness + + ! calculate masks - so we know where the calving front was located initially + call li_calculate_mask(meshPool, velocityPool, geometryPool, err_tmp) + err = ior(err, err_tmp) + + ! initialize + calvingThickness = 0.0_RKIND + restoreThickness = 0.0_RKIND + + ! loop over locally owned cells + do iCell = 1, nCellsSolve + + if (bedTopography(iCell) < config_sea_level) then + + ! The bed is below sea level; test for calving-front advance and retreat. + + if (li_mask_is_initial_ice(cellMask(iCell)) .and. thickness(iCell) < restoreThicknessMin) then + + ! Ice was present in this cell initially, but now is either very thin or absent. + ! Save the difference (restoreThicknessMin - thickness) so as to keep track of energy non-conservation. + ! Reset the thickness to restoreThicknessMin + + if (config_print_calving_info) then + write(stderrUnit,*) 'Restore ice: iCell, thickness =', iCell, thickness(iCell) + endif + + restoreThickness(iCell) = restoreThicknessMin - thickness(iCell) + thickness(iCell) = restoreThicknessMin + !WHL TODO - Restore the temperature profile also? + + elseif (.not.li_mask_is_initial_ice(cellMask(iCell)) .and. thickness(iCell) > 0.0_RKIND) then + + ! This cell was initially ice-free but now has ice. + ! Remove the ice and add it to calvingThickness. + + if (config_print_calving_info) then + write(stderrUnit,*) 'Remove ice: iCell, thickness =', iCell, thickness(iCell) + endif + + calvingThickness(iCell) = thickness(iCell) + thickness(iCell) = 0.0_RKIND + + endif ! li_mask_is_initial_ice + + endif ! bedTopography < config_sea_level + + enddo ! iCell + block => block % next enddo + if (config_print_calving_info) then + write(stderrUnit,*) 'Restored the initial calving front' + + !WHL - debug - for circular shelf test case + write(stderrUnit,*) 'Final ice thickness' + do iRow = nRows, 1, -1 + if (mod(iRow,2) == 0) then ! indent for even-numbered rows + write(stderrUnit,'(a3)',advance='no') ' ' + endif +!! do i = 1, nCellsPerRow + do i = nCellsPerRow/2 - 2, nCellsPerRow + iCell = (iRow-1)*nCellsPerRow + i +!! write(stderrUnit,'(i5)',advance='no') iCell + write(stderrUnit,'(f8.2)',advance='no') thickness(iCell) + enddo + write(stderrUnit,*) ' ' + enddo + + endif + ! === error check if (err > 0) then - write (stderrUnit,*) "An error has occurred in do_calving." + write (stderrUnit,*) "An error has occurred in li_restore_calving_front." endif - !-------------------------------------------------------------------- - end subroutine do_calving + + end subroutine li_restore_calving_front !*********************************************************************** !*********************************************************************** diff --git a/src/core_landice/mode_forward/mpas_li_core.F b/src/core_landice/mode_forward/mpas_li_core.F index f757c18de2..ecc5741c7c 100644 --- a/src/core_landice/mode_forward/mpas_li_core.F +++ b/src/core_landice/mode_forward/mpas_li_core.F @@ -101,6 +101,8 @@ function li_core_init(domain, startTimeStamp) result(err) type (MPAS_TimeInterval_type) :: timeStepInterval character (len=StrKIND), pointer :: xtime + type(field3DReal), pointer :: & + coeffsReconstructField ! field for reconstruction coefficients err = 0 err_tmp = 0 @@ -156,7 +158,6 @@ function li_core_init(domain, startTimeStamp) result(err) block => block % next end do - ! === ! === Initialize modules === ! === @@ -185,6 +186,12 @@ function li_core_init(domain, startTimeStamp) result(err) call li_analysis_init(domain, err_tmp) err = ior(err, err_tmp) + ! halo update for reconstruction coefficients + !WHL - Results on multiple processors may be incorrect without this update + + call mpas_pool_get_field(meshPool, 'coeffs_reconstruct', coeffsReconstructField) + call mpas_dmpar_exch_halo_field(coeffsReconstructField) + ! check for errors and exit call mpas_dmpar_max_int(domain % dminfo, err, globalErr) ! Find out if any blocks got an error @@ -730,19 +737,24 @@ subroutine landice_init_block(block, dminfo, err) !!! call mpas_ocn_tracer_advection_coefficients(mesh, err_tmp) !!! err = ior(err, err_tmp) + ! Init for reconstruction of velocity + !WHL - Initialize the reconstruction regardless of the velocity solver, because + ! these coefficients will be needed later for IR transport. +!! if ( (trim(config_velocity_solver) == 'sia') .or. & +!! (trim(config_velocity_solver) == 'simple') .or. & +!! config_do_velocity_reconstruction_for_external_dycore .or. & +!! config_adaptive_timestep_include_DCFL) then + call mpas_rbf_interp_initialize(meshPool) + call mpas_init_reconstruct(meshPool) +!! endif + + ! Initialize velocity solver + !WHL - This is now after the call to mpas_init_reconstruct, so that the reconstruction coefficients are available. call mpas_timer_start("initialize velocity") call li_velocity_block_init(block, err_tmp) err = ior(err, err_tmp) call mpas_timer_stop("initialize velocity") - ! Init for reconstruction of velocity - if ( (trim(config_velocity_solver) == 'sia') .or. & - config_do_velocity_reconstruction_for_external_dycore .or. & - config_adaptive_timestep_include_DCFL) then - call mpas_rbf_interp_initialize(meshPool) - call mpas_init_reconstruct(meshPool) - endif - ! Mask init identifies initial ice extent call li_calculate_mask_init(geometryPool, err=err_tmp) err = ior(err, err_tmp) diff --git a/src/core_landice/mode_forward/mpas_li_time_integration_fe.F b/src/core_landice/mode_forward/mpas_li_time_integration_fe.F index e197278b44..3a2082e7fc 100644 --- a/src/core_landice/mode_forward/mpas_li_time_integration_fe.F +++ b/src/core_landice/mode_forward/mpas_li_time_integration_fe.F @@ -29,7 +29,7 @@ module li_time_integration_fe use mpas_vector_reconstruction use li_velocity, only: li_velocity_solve use li_tendency - use li_calving, only: do_calving + use li_calving, only: li_calve_ice, li_restore_calving_front use li_diagnostic_vars use li_setup @@ -97,6 +97,9 @@ subroutine li_time_integrator_forwardeuler(domain, deltat, err) type (block_type), pointer :: block integer :: err_tmp + logical, pointer :: config_restore_calving_front + + call mpas_pool_get_config(liConfigs, 'config_restore_calving_front', config_restore_calving_front) ! During integration, time level 1 stores the model state at the beginning of the ! time step, and time level 2 stores the state advanced dt in time by timestep(...) @@ -113,7 +116,6 @@ subroutine li_time_integrator_forwardeuler(domain, deltat, err) err = ior(err, err_tmp) call mpas_timer_stop("calculate tendencies") - ! === Compute new state for prognostic variables ================================== ! (once implicit column physics are added (i.e. temp diffusion), these calculations will need to be adjusted to apply to the new values as needed) call mpas_timer_start("calc. new prognostic vars") @@ -123,8 +125,21 @@ subroutine li_time_integrator_forwardeuler(domain, deltat, err) ! === Calve ice ======================== call mpas_timer_start("calve_ice") - call do_calving(domain, deltat, err_tmp) - err = ior(err, err_tmp) + + if (config_restore_calving_front) then + + ! restore the calving front to its initial position; calving options are ignored + call li_restore_calving_front(domain, err_tmp) + err = ior(err, err_tmp) + + else + + ! ice calving + call li_calve_ice(domain, deltat, err_tmp) + err = ior(err, err_tmp) + + endif + call mpas_timer_stop("calve_ice") ! === Calculate diagnostic variables for new state ===================== diff --git a/src/core_landice/mode_forward/mpas_li_velocity.F b/src/core_landice/mode_forward/mpas_li_velocity.F index 68d33bc8f3..1bdcc96c02 100644 --- a/src/core_landice/mode_forward/mpas_li_velocity.F +++ b/src/core_landice/mode_forward/mpas_li_velocity.F @@ -27,6 +27,7 @@ module li_velocity use mpas_pool_routines use mpas_timer use li_velocity_external + use li_velocity_simple use li_sia use li_setup @@ -115,6 +116,8 @@ subroutine li_velocity_init(domain, err) ! Do nothing case ('sia') call li_sia_init(domain, err) + case ('simple') + call li_velocity_simple_init(domain, err) case ('L1L2', 'FO', 'Stokes') call li_velocity_external_init(domain, err) case default @@ -173,8 +176,8 @@ subroutine li_velocity_block_init(block, err) ! local variables ! !----------------------------------------------------------------- - character (len=StrKIND), pointer :: config_velocity_solver + character (len=StrKIND), pointer :: config_velocity_solver err = 0 @@ -185,6 +188,8 @@ subroutine li_velocity_block_init(block, err) ! Do nothing case ('sia') call li_sia_block_init(block, err) + case ('simple') + call li_velocity_simple_block_init(block, err) case ('L1L2', 'FO', 'Stokes') call li_velocity_external_block_init(block, err) case default @@ -251,7 +256,8 @@ subroutine li_velocity_solve(domain, err) integer, pointer :: nEdgesSolve integer, pointer :: nVertInterfaces integer, dimension(:), pointer :: edgeMask, cellMask - real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional + real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, normalVelocityInitial + real (kind=RKIND), dimension(:,:), pointer :: uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional real (kind=RKIND), dimension(:), pointer :: thickness real (kind=RKIND), dimension(:), pointer :: surfaceSpeed, basalSpeed integer, dimension(:,:), pointer :: cellsOnEdge @@ -325,10 +331,15 @@ subroutine li_velocity_solve(domain, err) ! Solve velocity select case (config_velocity_solver) case ('none') + ! Do nothing + case ('sia') + call li_sia_solve(meshPool, geometryPool, velocityPool, err_tmp) + case ('L1L2', 'FO', 'Stokes') + if (maxThicknessAllProcs < config_dynamic_thickness) then ! External dycores may not be able to handle case when there is no ice call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX) @@ -342,15 +353,32 @@ subroutine li_velocity_solve(domain, err) else call li_velocity_external_solve(meshPool, geometryPool, thermalPool, velocityPool, err_tmp) endif - case default + + case('simple') + + ! Set the normal velocities to the values computed at initialization + ! Note: The reason these velocities are reset to the initial values during each time step is that + ! they may have been altered during the previous time step (e.g., set to zero for non-dynamic edges). + call mpas_pool_get_array(velocityPool, 'normalVelocityInitial', normalVelocityInitial) + normalVelocity = normalVelocityInitial + + ! Fix up these velocities by setting them to zero on non-dynamic edges + do iEdge = 1, nEdgesSolve + if (.not.(li_mask_is_dynamic_ice(edgeMask(iEdge)))) then + normalVelocity(:,iEdge) = 0.0_RKIND + endif + enddo + + case default + write(stderrUnit,*) 'Error: ', trim(config_velocity_solver), ' is not a valid land ice velocity solver option.' err = 1 call mpas_timer_stop("velocity solve") return + end select err = ior(err, err_tmp) - ! Some "quality control" of normalVelocity do iEdge = 1, nEdgesSolve @@ -421,10 +449,11 @@ subroutine li_velocity_solve(domain, err) call mpas_pool_get_array(velocityPool, 'surfaceSpeed', surfaceSpeed) call mpas_pool_get_array(velocityPool, 'basalSpeed', basalSpeed) - ! Native SIA dycore needs to have reconstructed velocities calculated. + ! Velocities need to be reconstructed at cell centers for the native SIA dycore and for prescribed simple velocities. ! External dycores return their native velocities at cell center locations, ! but these can optionally be overwritten by reconstructed velocities for testing. - if ( (trim(config_velocity_solver) == 'sia') .or. & + if ( (trim(config_velocity_solver) == 'sia') .or. & + (trim(config_velocity_solver) == 'simple') .or. & config_do_velocity_reconstruction_for_external_dycore ) then call mpas_reconstruct(meshPool, normalVelocity, & uReconstructX, uReconstructY, uReconstructZ, & @@ -435,7 +464,6 @@ subroutine li_velocity_solve(domain, err) uReconstructMeridional = uReconstructY end if - ! --- ! --- Calculate diagnostic speed arrays ! --- @@ -509,6 +537,8 @@ subroutine li_velocity_finalize(domain, err) ! Do nothing case ('sia') call li_sia_finalize(domain, err) + case ('simple') + call li_velocity_simple_finalize(err) case ('L1L2', 'FO', 'Stokes') call li_velocity_external_finalize(err) case default diff --git a/src/core_landice/mode_forward/mpas_li_velocity_simple.F b/src/core_landice/mode_forward/mpas_li_velocity_simple.F new file mode 100644 index 0000000000..974887b363 --- /dev/null +++ b/src/core_landice/mode_forward/mpas_li_velocity_simple.F @@ -0,0 +1,620 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! li_velocity_simple +! +!> \MPAS land-ice simple velocity driver +!> \author William Lipscomb +!> \date October 2015 +!> \details +!> This module contains the routines for calculating simple velocity fields +!> (e.g., uniform in x direction, radially symmetric). +!> +! +!----------------------------------------------------------------------- + +module li_velocity_simple + + use mpas_derived_types + use mpas_pool_routines + use mpas_dmpar + use li_mask + use li_setup + use li_constants + + implicit none + private + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + public :: li_velocity_simple_init, & + li_velocity_simple_finalize, & + li_velocity_simple_block_init + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine li_velocity_simple_init +! +!> \brief Initializes simple velocity +!> \author William Lipscomb +!> \date October 2015 +!> \details +!> This routine initializes the simple velocity cases. +! +!----------------------------------------------------------------------- + + subroutine li_velocity_simple_init(domain, err) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain !< Input/Output: domain object + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + !-------------------------------------------------------------------- + + end subroutine li_velocity_simple_init + + + +!*********************************************************************** +! +! routine li_velocity_simple_block_init +! +!> \brief Initializes blocks for simple velocity +!> \author William Lipscomb +!> \date October 2015 +!> \details +!> This routine initializes each block with a simple velocity field +!> (uniform velocity in a straight line, or radially symmetric). +!> NOTE: This subroutine assumes flow in a plane with all z components = 0. +! +!----------------------------------------------------------------------- + + subroutine li_velocity_simple_block_init(block, err) + + use mpas_vector_reconstruction + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + type (block_type), intent(inout) :: & + block !< Input/Output: block object + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: velocityPool + type (mpas_pool_type), pointer :: scratchPool + + integer, pointer :: nCells, nEdges + integer, pointer :: nCellsSolve, nEdgesSolve + integer, pointer :: nVertInterfaces + integer, pointer :: config_stats_cell_ID + + character(len=StrKind), pointer :: config_simple_velocity_type + + !NOTE: Assume a planar mesh, so z coordinates are not needed + real (kind=RKIND), dimension(:), pointer :: & + xCell, yCell, & ! cell center coordinates + xEdge, yEdge, & ! edge midpoint coordinates + dcEdge ! distance between the 2 cell centers on each side of an edge + + ! prescribed velocity at cell centers + type (field1dReal), pointer :: uVelocityXField + type (field1dReal), pointer :: uVelocityYField + real (kind=RKIND), dimension(:), pointer :: uVelocityX + real (kind=RKIND), dimension(:), pointer :: uVelocityY + + real (kind=RKIND), dimension(:,:), pointer :: & + normalVelocityInitial, & ! normal component of velocity on edges + uReconstructX, uReconstructY, uReconstructZ, & ! x/y/z velocity components at cell center + uReconstructZonal, uReconstructMeridional ! zonal and meridional velocity components at cell center + + integer, dimension(:,:), pointer :: cellsOnEdge ! indices for the 2 cells on each edge + + real (kind=RKIND), dimension(2) :: unitNormalVector ! x/y components of normal vector on an edge + + real (kind=RKIND) :: magnitude, radius, speed, xDiff, yDiff + + real (kind=RKIND) :: uEdgeX, uEdgeY ! x/y components of velocity at edge midpoints + + integer :: err_tmp + + integer :: iLevel, iEdge, iCell, iCell1, iCell2 + + real (kind=RKIND), parameter :: flowSpeed = 1000._RKIND/scyr ! flow speed (m/s) + ! applies to uniform flow + real (kind=RKIND), parameter :: flowTheta = 0.0_RKIND ! direction of flow (0 < theta < 2*pi) + ! applied to uniform flow (not radial) + + !Note: For radial flow, the user may want to reset these parameters + real (kind=RKIND), parameter :: flowGradient = 1.2e-3_RKIND/scyr ! du/dr for radial flow + + real (kind=RKIND), parameter :: xCenter = 0.0_RKIND ! x coordinate of center of radial flow + real (kind=RKIND), parameter :: yCenter = 0.0_RKIND ! y coordinate of center of radial flow + + !WHL - debug diagnostics only + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnCell ! index for each edge on a cell + real(kind=RKIND), dimension(:,:,:), pointer :: & + coeffsReconstruct ! coefficients for reconstructing edge-based fields at cell centers + integer :: iEdgeOnCell + + logical, parameter :: velocity_simple_bug_check = .false. + + !-------------------------------- + !WHL - optional thickness, SMB and topography tweaking for the radial velocity field and circular-shelf test case + !TODO - Remove these options after testing + + character(len=StrKIND), pointer :: config_calving + + logical, parameter :: radialMelting = .false. +!! logical, parameter :: radialMelting = .true. + type (mpas_pool_type), pointer :: geometryPool + real (kind=RKIND), dimension(:), pointer :: thickness + real (kind=RKIND), dimension(:), pointer :: sfcMassBal + real (kind=RKIND), dimension(:), pointer :: bedTopography + + real (kind=RKIND), parameter :: & + maxRadius = 21000.0_RKIND ! ice radius (m) for circular shelf problem + + real (kind=RKIND), parameter :: & + maxMelt = 100.0_RKIND * 910.0_RKIND / scyr ! max melt rate, kg/m2/s (converted from 100 m/yr) + ! for radial melting option + real (kind=RKIND), parameter :: & + spikeTopography = -880.0_RKIND ! elevation of spike that grounds the ice + ! for config_calving = 'floating' + + integer, parameter :: ncellsPerRow = 40 + integer, parameter :: nRows = 46 + integer :: i, iRow + !-------------------------------- + + ! No block init needed. + err = 0 + err_tmp = 0 + + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + + ! Set needed variables and pointers + + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nVertInterfaces', nVertInterfaces) + + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'xEdge', xEdge) + call mpas_pool_get_array(meshPool, 'yEdge', yEdge) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + + call mpas_pool_get_array(velocityPool, 'normalVelocityInitial', normalVelocityInitial) + call mpas_pool_get_array(velocityPool, 'uReconstructX', uReconstructX) + call mpas_pool_get_array(velocityPool, 'uReconstructY', uReconstructY) + call mpas_pool_get_array(velocityPool, 'uReconstructZ', uReconstructZ) + call mpas_pool_get_array(velocityPool, 'uReconstructZonal', uReconstructZonal) + call mpas_pool_get_array(velocityPool, 'uReconstructMeridional', uReconstructMeridional) + + call mpas_pool_get_field(scratchPool, 'workCell', uVelocityXField) + call mpas_allocate_scratch_field(uVelocityXField, .true.) + uVelocityX => uVelocityXField % array + + call mpas_pool_get_field(scratchPool, 'workCell2', uVelocityYField) + call mpas_allocate_scratch_field(uVelocityYField, .true.) + uVelocityY => uVelocityYField % array + + call mpas_pool_get_config(liConfigs, 'config_stats_cell_ID', config_stats_cell_ID) + call mpas_pool_get_config(liConfigs, 'config_simple_velocity_type', config_simple_velocity_type) + + !WHL - debug diagnostics only + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'coeffs_reconstruct', coeffsReconstruct) + + uVelocityX(:) = 0.0_RKIND + uVelocityY(:) = 0.0_RKIND + + ! prescribe the x and y velocity components at cell centers (with no vertical variation) + + if (trim(config_simple_velocity_type) == 'uniform') then + + uVelocityX(:) = flowSpeed * cos(flowTheta) + uVelocityY(:) = flowSpeed * sin(flowTheta) + + elseif (trim(config_simple_velocity_type) == 'radial') then + + do iCell = 1, nCells + xDiff = xCell(iCell) - xCenter + yDiff = yCell(iCell) - yCenter + radius = sqrt(xDiff**2 + yDiff**2) + if (radius > 0.0_RKIND) then + speed = flowGradient * radius + uVelocityX(iCell) = speed * xDiff/radius + uVelocityY(iCell) = speed * yDiff/radius + else + uVelocityX(iCell) = 0.0_RKIND + uVelocityY(iCell) = 0.0_RKIND + endif + enddo + + endif + + ! given the velocity components at cell centers, compute the normal velocity component on edges + + normalVelocityInitial(:,:) = 0.0_RKIND + + do iEdge = 1, nEdgesSolve + + iLevel = 1 + iCell1 = cellsOnEdge(1,iEdge) + iCell2 = cellsOnEdge(2,iEdge) + + ! average the velocity from the neighboring cells to the edge + uEdgeX = 0.5_RKIND * (uVelocityX(iCell1) + uVelocityX(iCell2)) + uEdgeY = 0.5_RKIND * (uVelocityY(iCell1) + uVelocityY(iCell2)) + + ! Compute the components of the normal vector on the edge + + unitNormalVector(1) = xEdge(iEdge) - xCell(iCell1) + unitNormalVector(2) = yEdge(iEdge) - yCell(iCell1) + magnitude = sqrt(unitNormalVector(1)**2 + unitNormalVector(2)**2) + + ! Note: The magnitude should be dcEdge/2. + ! But this may not be the case for edges at the border of a periodic domain; + ! for these cells, the magnitude may be comparable to the domain size. + ! For such edges, create the normal vector from iCell2 instead. + if (magnitude > dcEdge(iEdge)) then +! write(stderrUnit,*) 'Use iCell2 instead: iEdge, iCell1, iCell2, magnitude, dcEdge =', iEdge, iCell1, iCell2, magnitude, dcEdge(iEdge) + unitNormalVector(1) = -(xEdge(iEdge) - xCell(iCell2)) + unitNormalVector(2) = -(yEdge(iEdge) - yCell(iCell2)) + magnitude = sqrt(unitNormalVector(1)**2 + unitNormalVector(2)**2) + endif + + unitNormalVector(:) = unitNormalVector(:)/magnitude + + ! Compute the dot product of the velocity with the normal vector + ! Set to the same value everywhere in the column + normalVelocityInitial(:,iEdge) = uEdgeX*unitNormalVector(1) + uEdgeY*unitNormalVector(2) + + enddo + + !WHL - debug + iCell = config_stats_cell_ID + iLevel = 1 + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'Prescribed velocity, iCell, uvel, vvel (m/yr):', iCell, uVelocityX(iCell)*scyr, uVelocityY(iCell)*scyr + write(stderrUnit,*) 'xCell, yCell:', xCell(iCell), yCell(iCell) + write(stderrUnit,*) 'iEdgeOnCell, cellsOnEdge, normalVelocity:' + do iEdgeOnCell = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(iEdgeOnCell,iCell) + write(stderrUnit,*) iEdgeOnCell, cellsOnEdge(:,iEdge), normalVelocityInitial(iLevel,iEdge)*scyr + enddo + + if (velocity_simple_bug_check) then + + ! Make sure we can recover the cell-center velocity to a good approximation + call mpas_reconstruct(meshPool, normalVelocityInitial, & + uReconstructX, uReconstructY, uReconstructZ, & + uReconstructZonal, uReconstructMeridional ) + + ! Loop over cells, comparing the reconstructed velocity to the prescribed velocity + ! Note: Currently, the reconstruction coefficients are not correct for cells at the edge of a periodic domain, + ! so errors will be generated even though the normal velocities are correct. + ! For this reason I have commented out the warning messages. + + do iCell = 1, nCellsSolve + + speed = sqrt(uVelocityX(iCell)**2 + uVelocityY(iCell)**2) + + if (iCell == config_stats_cell_ID) then + iLevel = 1 + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'Velocity reconstruction, iCell =', iCell + write(stderrUnit,*) 'Initial velocity:', uVelocityX(iCell), uVelocityY(iCell) + write(stderrUnit,*) 'Reconstructed velocity:', uReconstructX(iLevel,iCell), uReconstructY(iLevel,iCell) + write(stderrUnit,*) 'Reconstruction coefficients:' + write(stderrUnit,*) ' ' + do iEdgeOnCell = 1, nEdgesOnCell(iCell) + write(stderrUnit,*) iEdgeOnCell, coeffsReconstruct(:,iEdgeOnCell,iCell) + enddo + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'iEdgeOnCell, cellsOnEdge, normalVelocity:' + do iEdgeOnCell = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(iEdgeOnCell,iCell) + write(stderrUnit,*) iEdgeOnCell, cellsOnEdge(:,iEdge), normalVelocityInitial(iLevel,iEdge) + enddo + endif + + iLevel = 1 ! Check at one level only, since the velocity is vertically uniform + + if (abs(uReconstructX(iLevel,iCell) - uVelocityX(iCell)) > 1.e-8_RKIND*speed .or. & + abs(uReconstructY(iLevel,iCell) - uVelocityY(iCell)) > 1.e-8_RKIND*speed) then + + xDiff = abs(uReconstructX(iLevel,iCell) - uVelocityX(iCell)) / speed + yDiff = abs(uReconstructY(iLevel,iCell) - uVelocityY(iCell)) / speed + + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'WARNING: Reconstructed velocity not equal to uniform velocity, iCell, xDiff, yDiff=', iCell, xDiff, yDiff + write(stderrUnit,*) 'Prescribed velocity: ', uVelocityX(iCell), uVelocityY(iCell) + write(stderrUnit,*) 'Reconstructed velocity:', uReconstructX(iLevel,iCell), uReconstructY(iLevel,iCell) + write(stderrUnit,*) 'iEdgeOnCell, cellsOnEdge, normal velocity:' + do iEdgeOnCell = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(iEdgeOnCell,iCell) + write(stderrUnit,*) iEdgeOnCell, cellsOnEdge(:,iEdge), normalVelocityInitial(iLevel,iEdge) + enddo + err = 1 + endif + + enddo ! iCell + + endif ! bug check + + + !-------------------------------- + !TODO - Remove these options after testing the calving scheme + + call mpas_pool_get_config(liConfigs, 'config_calving', config_calving) + + if (radialMelting) then ! force the calving front to retreat + + write(stderrUnit,*) 'Setting up radially symmetric melting' + write(stderrUnit,*) 'Melt rate at periphery (m/yr) =', maxMelt * scyr / 910.0_RKIND + + ! Zero out the normal velocities, since we are testing ice retreat + normalVelocityInitial(:,:) = 0.0_RKIND + + ! Set the thickness and melt rate + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'sfcMassBal', sfcMassBal) + + do iCell = 1, nCells + xDiff = xCell(iCell) - xCenter + yDiff = yCell(iCell) - yCenter + radius = sqrt(xDiff**2 + yDiff**2) + ! set thickness to taper away from the center + thickness(iCell) = thickness(iCell) * (1.0_RKIND - radius/maxRadius) + ! set melting to increase away from the center + sfcMassBal(iCell) = maxMelt * (-radius/maxRadius) + enddo + + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'thickness (m):' + do iRow = nRows, 1, -1 + if (mod(iRow,2) == 0) then ! indent for even-numbered rows + write(stderrUnit,'(a3)',advance='no') ' ' + endif + do i = nCellsPerRow/2 - 2, nCellsPerRow + iCell = (iRow-1)*nCellsPerRow + i + write(stderrUnit,'(f8.2)',advance='no') thickness(iCell) + enddo + write(stderrUnit,*) ' ' + enddo + + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'melt rate (m/yr):' + do iRow = nRows, 1, -1 + if (mod(iRow,2) == 0) then ! indent for even-numbered rows + write(stderrUnit,'(a3)',advance='no') ' ' + endif + do i = nCellsPerRow/2 - 2, nCellsPerRow + iCell = (iRow-1)*nCellsPerRow + i + write(stderrUnit,'(f8.2)',advance='no') -sfcMassBal(iCell)*scyr/910.0_RKIND + enddo + write(stderrUnit,*) ' ' + enddo + + endif ! radialMelting + + if (trim(config_calving) == 'topographic_threshold') then + + write(stderrUnit,*) 'Setting topography to drop off at periphery' + + ! Set the bed topography to drop off near the periphery of the ice + ! so as to check that the calving topographic threshold option is working. + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) + + do iCell = 1, nCells + xDiff = xCell(iCell) - xCenter + yDiff = yCell(iCell) - yCenter + radius = sqrt(xDiff**2 + yDiff**2) + if (radius > 0.9_RKIND*maxRadius) then ! close to the edge + bedTopography(iCell) = bedTopography(iCell) * radius/(0.9_RKIND*maxRadius) + endif + enddo + + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'bedTopography (m):' + do iRow = nRows, 1, -1 + if (mod(iRow,2) == 0) then ! indent for even-numbered rows + write(stderrUnit,'(a3)',advance='no') ' ' + endif + do i = nCellsPerRow/2 - 2, nCellsPerRow + iCell = (iRow-1)*nCellsPerRow + i + write(stderrUnit,'(f8.2)',advance='no') -bedTopography(iCell) + enddo + write(stderrUnit,*) ' ' + enddo + + elseif (trim(config_calving) == 'floating') then + + write(stderrUnit,*) 'Setting topography to be mostly grounded' + write(stderrUnit,*) 'Spike depth =', spikeTopography + + ! Put in a large spike that grounds most of the ice, but leaves the peripheral ice floating, + ! so as to check that the calving no-float option is working. + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) + + do iCell = 1, nCells + xDiff = xCell(iCell) - xCenter + yDiff = yCell(iCell) - yCenter + radius = sqrt(xDiff**2 + yDiff**2) + if (radius < 0.9_RKIND*maxRadius) then ! inner part of ice shelf + bedTopography(iCell) = spikeTopography + endif + enddo + + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'bed depth (m):' + do iRow = nRows, 1, -1 + if (mod(iRow,2) == 0) then ! indent for even-numbered rows + write(stderrUnit,'(a3)',advance='no') ' ' + endif + do i = nCellsPerRow/2 - 2, nCellsPerRow + iCell = (iRow-1)*nCellsPerRow + i + write(stderrUnit,'(f8.2)',advance='no') -bedTopography(iCell) + enddo + write(stderrUnit,*) ' ' + enddo + + endif ! config_calving + !-------------------------------- + + ! === error check + if (err > 0) then + write (stderrUnit,*) "An error has occurred in li_velocity_uniform_init." + endif + + !-------------------------------------------------------------------- + end subroutine li_velocity_simple_block_init + + +!*********************************************************************** +! +! routine li_velocity_simple_finalize +! +!> \brief finalizes simple velocity +!> \author William Lipscomb +!> \date October 2015 +!> \details +!> This routine finalizes the simple velocity cases. +! +!----------------------------------------------------------------------- + + subroutine li_velocity_simple_finalize(err) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + + !-------------------------------------------------------------------- + + end subroutine li_velocity_simple_finalize + + + + ! private subroutines + + + + +!*********************************************************************** + + end module li_velocity_simple + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| diff --git a/src/core_landice/shared/mpas_li_constants.F b/src/core_landice/shared/mpas_li_constants.F index d9db0e6913..7acf86aa61 100644 --- a/src/core_landice/shared/mpas_li_constants.F +++ b/src/core_landice/shared/mpas_li_constants.F @@ -46,7 +46,7 @@ module li_constants ! conversion factors real (kind=RKIND), parameter, public :: kelvin_to_celsius = 273.15_RKIND !< factor to convert Kelvin to Celsius - + real (kind=RKIND), parameter, public :: scyr = 31536000.0_RKIND !< seconds in a 365-day year; used for diagnostics !*********************************************************************** diff --git a/src/core_landice/shared/mpas_li_mask.F b/src/core_landice/shared/mpas_li_mask.F index 153adb553b..a3bb3bf41e 100644 --- a/src/core_landice/shared/mpas_li_mask.F +++ b/src/core_landice/shared/mpas_li_mask.F @@ -118,6 +118,11 @@ module li_mask module procedure li_mask_is_grounded_ice_logout_0d end interface + interface li_mask_is_initial_ice + module procedure li_mask_is_initial_ice_logout_1d + module procedure li_mask_is_initial_ice_logout_0d + end interface + !! SFP: the 1d versions below have not been tested yet - activate and use at your own risk! !! Also check the corresponding function below. interface li_mask_is_grounded_ice_int @@ -332,7 +337,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) ! Is it floating? (ice thickness equal to floatation is considered floating) ! For now floating ice and grounded ice are mutually exclusive. - ! This may change if a ground line parameterization is added. + ! This may change if a grounding line parameterization is added. where ( li_mask_is_ice(cellMask) .and. (config_ice_density / config_ocean_density * thickness) <= (config_sea_level - bedTopography) ) cellMask = ior(cellMask, li_mask_ValueFloating) end where @@ -774,7 +779,19 @@ function li_mask_is_grounded_ice_intout_0d(mask) endif end function li_mask_is_grounded_ice_intout_0d + function li_mask_is_initial_ice_logout_1d(mask) + integer, dimension(:), intent(in) :: mask + logical, dimension(size(mask)) :: li_mask_is_initial_ice_logout_1d + + li_mask_is_initial_ice_logout_1d = (iand(mask, li_mask_ValueInitialIceExtent) == li_mask_ValueInitialIceExtent) + end function li_mask_is_initial_ice_logout_1d + + function li_mask_is_initial_ice_logout_0d(mask) + integer, intent(in) :: mask + logical :: li_mask_is_initial_ice_logout_0d + li_mask_is_initial_ice_logout_0d = (iand(mask, li_mask_ValueInitialIceExtent) == li_mask_ValueInitialIceExtent) + end function li_mask_is_initial_ice_logout_0d From 5dfca1af9eb9822a3d524549c9db4b05b8a8b708 Mon Sep 17 00:00:00 2001 From: Stephen Price Date: Mon, 28 Sep 2015 15:36:03 -0600 Subject: [PATCH 0355/1724] Add AM for global mass loss due to calving flux --- .../analysis_members/Registry_global_stats.xml | 4 ++++ .../analysis_members/mpas_li_global_stats.F | 18 +++++++++++++++++- 2 files changed, 21 insertions(+), 1 deletion(-) diff --git a/src/core_landice/analysis_members/Registry_global_stats.xml b/src/core_landice/analysis_members/Registry_global_stats.xml index ef7b811003..8ece7adb29 100644 --- a/src/core_landice/analysis_members/Registry_global_stats.xml +++ b/src/core_landice/analysis_members/Registry_global_stats.xml @@ -57,6 +57,9 @@ + + diff --git a/src/core_landice/analysis_members/mpas_li_global_stats.F b/src/core_landice/analysis_members/mpas_li_global_stats.F index 9925988c65..399292d938 100644 --- a/src/core_landice/analysis_members/mpas_li_global_stats.F +++ b/src/core_landice/analysis_members/mpas_li_global_stats.F @@ -163,10 +163,13 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ type (mpas_pool_type), pointer :: geometryPool ! arrays, vars needed from other pools for calculations here + real (kind=RKIND), pointer :: config_ice_density + real (kind=RKIND), pointer :: deltat real (kind=RKIND), dimension(:), pointer :: areaCell real (kind=RKIND), dimension(:), pointer :: thickness real (kind=RKIND), dimension(:), pointer :: sfcMassBal real (kind=RKIND), dimension(:), pointer :: basalMassBal + real (kind=RKIND), dimension(:), pointer :: calvingThickness integer, dimension(:), pointer :: cellMask integer, pointer :: nCellsSolve @@ -178,6 +181,7 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ real (kind=RKIND), pointer :: floatingIceArea, floatingIceVolume real (kind=RKIND), pointer :: iceThicknessMax, iceThicknessMin, iceThicknessMean real (kind=RKIND), pointer :: totalSfcMassBal, totalBasalMassBal + real (kind=RKIND), pointer :: totalCalvingFlux ! scalar sums over blocks real (kind=RKIND) :: blockSumIceArea, blockSumIceVolume @@ -185,6 +189,7 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ real (kind=RKIND) :: blockSumFloatingIceArea, blockSumFloatingIceVolume real (kind=RKIND) :: blockThickMin, blockThickMax real (kind=RKIND) :: blockSumSfcMassBal, blockSumBasalMassBal + real (kind=RKIND) :: blockSumCalvingFlux ! local parameters real (kind=RKIND), parameter :: scyr = 31536000.0_RKIND ! seconds per 365-day year @@ -202,9 +207,10 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ blockSumFloatingIceVolume = 0.0_RKIND blockSumSfcMassBal = 0.0_RKIND blockSumBasalMassBal = 0.0_RKIND + blockSumCalvingFlux = 0.0_RKIND ! initialize max, min, mean values to 0 - blockThickMin = 0.0_RKIND + blockThickMin = 100000.0_RKIND blockThickMax = 0.0_RKIND ! loop over blocks @@ -217,12 +223,15 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) ! get values and arrays from standard pools + call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) call mpas_pool_get_dimension(block % dimensions, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_array(meshPool, 'deltat', deltat) call mpas_pool_get_array(meshPool, 'areaCell', areaCell) call mpas_pool_get_array(geometryPool, 'thickness', thickness) call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) call mpas_pool_get_array(geometryPool, 'sfcMassBal', sfcMassBal) call mpas_pool_get_array(geometryPool, 'basalMassBal', basalMassBal) + call mpas_pool_get_array(geometryPool, 'calvingThickness', calvingThickness) ! get values from global stats pool call mpas_pool_get_array(globalStatsAMPool, 'totalIceArea', totalIceArea) @@ -236,6 +245,7 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ call mpas_pool_get_array(globalStatsAMPool, 'iceThicknessMean', iceThicknessMean) call mpas_pool_get_array(globalStatsAMPool, 'totalSfcMassBal', totalSfcMassBal) call mpas_pool_get_array(globalStatsAMPool, 'totalBasalMassBal', totalBasalMassBal) + call mpas_pool_get_array(globalStatsAMPool, 'totalCalvingFlux', totalCalvingFlux) ! loop over cells do iCell = 1,nCellsSolve @@ -271,6 +281,11 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ blockSumBasalMassBal = blockSumBasalMassBal + real(li_mask_is_ice_int(cellMask(iCell)),RKIND) & * areaCell(iCell) * basalMassBal(iCell) * scyr + ! mass lass due do calving (kg yr^{-1}) + !SFP: These calculations need to be tested still + blockSumCalvingFlux = blockSumCalvingFlux + real(li_mask_is_floating_ice_int(cellMask(iCell)),RKIND) & + * areaCell(iCell) * calvingThickness(iCell) * config_ice_density / ( deltat * scyr ) + end do ! end loop over cells block => block % next @@ -286,6 +301,7 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ call mpas_dmpar_sum_real(dminfo, blockSumFloatingIceVolume, floatingIceVolume) call mpas_dmpar_sum_real(dminfo, blockSumSfcMassBal, totalSfcMassBal) call mpas_dmpar_sum_real(dminfo, blockSumBasalMassBal, totalBasalMassBal) + call mpas_dmpar_sum_real(dminfo, blockSumCalvingFlux, totalCalvingFlux) ! find min, max, mean thickness over all procs call mpas_dmpar_min_real(dminfo, blockThickMin, iceThicknessMin) From 0af9ace37969a04ed62b75659a2c578789c58542 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Mon, 19 Oct 2015 23:01:30 -0700 Subject: [PATCH 0356/1724] Added optional ssh and restingThickness arguments restingThickness is required if ssh is present. The layerThickness, zMid and the restingThickness with a z* vertical coordinate depressed to the given ssh. The layerThickness should be bit-identical to what it was before if the ssh argument is not present. zMid will be different to machine roundoff because it is summed from layerThickness rather than being computed directly from refBottomDepth as before. --- .../mode_init/mpas_ocn_init_vertical_grids.F | 50 +++++++++++++++---- 1 file changed, 39 insertions(+), 11 deletions(-) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F index bb8aa729c8..5dcee51230 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_vertical_grids.F @@ -505,42 +505,70 @@ end subroutine ocn_generate_1dCVT_vertical_grid!}}} ! !----------------------------------------------------------------------- - subroutine ocn_compute_layerThickness_zMid_from_bottomDepth(layerThickness,zMid,refBottomDepth,bottomDepth,maxLevelCell,nVertLevels,iErr)!{{{ + subroutine ocn_compute_layerThickness_zMid_from_bottomDepth(layerThickness,zMid,refBottomDepth,bottomDepth, & + maxLevelCell,nVertLevels,iErr,restingThickness,ssh)!{{{ real (kind=RKIND), dimension(nVertLevels), intent(out) :: layerThickness, zMid real (kind=RKIND), dimension(nVertLevels), intent(in) :: refBottomDepth real (kind=RKIND), intent(in) :: bottomDepth integer, intent(in) :: maxLevelCell, nVertLevels integer, intent(out) :: iErr + real (kind=RKIND), dimension(nVertLevels), intent(out), optional :: restingThickness + real (kind=RKIND), intent(in), optional :: ssh + integer :: k + real (kind=RKIND) :: layerStretch, zTop iErr = 0 - if (maxLevelCell<=0) then + layerThickness(:) = 0.0_RKIND + zMid(:) = 0.0_RKIND + + if(present(ssh) .and. .not. present(restingThickness)) then + write (stderrUnit,*) ' Error: ssh present but restingThickness not present in ocn_compute_layerThickness_zMid_from_bottomDepth' + iErr = 1 return - elseif (maxLevelCell==1) then + end if + + if (maxLevelCell<=0) return + + ! first, compute the resting layer thickness (same as layer thickness if ssh not present) + if (maxLevelCell==1) then layerThickness(1) = bottomDepth - zMid(1) = - bottomDepth/2.0 else layerThickness(1) = refBottomDepth(1) - zMid(1) = - refBottomDepth(1)/2.0 do k = 2, maxLevelCell-1 layerThickness(k) = refBottomDepth(k) - refBottomDepth(k-1) - zMid(k) = - refBottomDepth(k-1) - layerThickness(k)/2.0 end do k = maxLevelCell layerThickness(k) = bottomDepth - refBottomDepth(k-1) - zMid(k) = - refBottomDepth(k-1) - layerThickness(k)/2.0 - do k = maxLevelCell+1, nVertLevels - layerThickness(k) = 0.0_RKIND - zMid(k) = 0.0_RKIND - end do endif + zTop = 0.0_RKIND + ! copy to layerThickness to restingThickness + if (present(restingThickness)) then + restingThickness(:) = layerThickness(:) + ! stretch layers if ssh is present + if(present(ssh)) then + layerStretch = (ssh + bottomDepth)/bottomDepth + zTop = ssh + do k=1,maxLevelCell + layerThickness(k) = layerStretch*restingThickness(k) + end do + end if + end if + + ! compute zMid based on the layer thickness + do k = 1, maxLevelCell + zMid(k) = zTop - 0.5_RKIND*layerThickness(k) + zTop = zTop - layerThickness(k) + end do + end subroutine ocn_compute_layerThickness_zMid_from_bottomDepth !}}} + !*********************************************************************** ! ! routine ocn_alter_bottomDepth_for_pbcs From acf385c83733caef82839389fd5feedbf004e6fb Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Tue, 27 Oct 2015 08:38:11 -0600 Subject: [PATCH 0357/1724] Remove pbc alteration from forward mode. --- src/core_ocean/Registry.xml | 10 +- .../shared/mpas_ocn_init_routines.F | 114 +----------------- 2 files changed, 9 insertions(+), 115 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 8235cd3fe1..45b8861e48 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -213,6 +213,10 @@ description="Determines if the positive Z axis is aligned with the positive K index direction." possible_values=".true. or .false." /> + - + - domain % blocklist @@ -411,7 +406,6 @@ subroutine ocn_init_routines_vert_coord(domain)!{{{ call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) call mpas_pool_get_array(verticalMeshPool, 'refLayerThickness', refLayerThickness) @@ -439,106 +433,6 @@ subroutine ocn_init_routines_vert_coord(domain)!{{{ endif - ! Initial condition files (ocean.nc, produced by basin) include a realistic - ! bottomDepth variable and h,T,S variables for full thickness cells. - ! If running with pbcs, set config_alter_ICs_for_pbc='zlevel_pbcs_on'. Then thin pbc cells - ! will be changed, and h,T,S will be altered to match the pbcs. - ! If running without pbcs, set config_alter_ICs_for_pbc='zlevel_pbcs_off'. Then - ! bottomDepth will be altered so it is full cells everywhere. - ! If your input file does not include bottomDepth, the false option will - ! initialize bottomDepth correctly for a non-pbc run. - - if (.not. config_do_restart .and. config_alter_ICs_for_pbcs) then - - if (config_pbc_alteration_type .eq. 'partial_cell') then - - write (stdoutUnit,'(a)') ' Altering bottomDepth to avoid very thin cells.' - write (stdoutUnit,'(a)') ' Altering layerThickness and tracer initial conditions to conform with partial bottom cells.' - - allocate(minBottomDepth(nVertLevels),minBottomDepthMid(nVertLevels),zMidZLevel(nVertLevels)) - - ! min_pbc_fraction restricts pbcs from being too small. - ! A typical value is 10%, so pbcs must occupy at least 10% of the cell thickness. - ! If min_pbc_fraction = 0.0, bottomDepth gives the actual depth for that cell. - ! If min_pbc_fraction = 1.0, bottomDepth reverts to discrete z-level depths, same - ! as partial_bottom_cells = .false. - - minBottomDepth(1) = (1.0-config_min_pbc_fraction)*refBottomDepth(1) - minBottomDepthMid(1) = 0.5*(minBottomDepth(1) + refBottomDepthTopOfCell(1)) - zMidZLevel(1) = - 0.5*(refBottomDepth(1) + refBottomDepthTopOfCell(1)) - do k = 2, nVertLevels - minBottomDepth(k) = refBottomDepth(k) - (1.0-config_min_pbc_fraction)*(refBottomDepth(k) - refBottomDepth(k-1)) - minBottomDepthMid(k) = 0.5*(minBottomDepth(k) + refBottomDepthTopOfCell(k)) - zMidZLevel(k) = - 0.5*(refBottomDepth(k) + refBottomDepthTopOfCell(k)) - end do - - do iCell = 1, nCells - - ! Change value of maxLevelCell for partial bottom cells - k = maxLevelCell(iCell) - if (bottomDepth(iCell) .lt. minBottomDepthMid(k)) then - ! Round up to cell above - maxLevelCell(iCell) = maxLevelCell(iCell) - 1 - bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) - else if (bottomDepth(iCell) .lt. minBottomDepth(k)) then - ! Round down cell to the min_pbc_fraction. - bottomDepth(iCell) = minBottomDepth(k) - end if - ! reset k to new value of maxLevelCell - k = maxLevelCell(iCell) - - ! Alter thickness of bottom level to account for PBC - layerThickness(k,iCell) = bottomDepth(iCell) - refBottomDepthTopOfCell(k) - end do - - call mpas_pool_begin_iteration(tracersPool) - do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) - if ( groupItr % memberType == MPAS_POOL_FIELD ) then - call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroup, 1) - - if ( associated(tracersGroup) ) then - do iCell = 1, nCells - ! Linearly interpolate the initial T&S for new location of bottom cell for PBCs - k = maxLevelCell(iCell) - zMidPBC = -0.5_RKIND * (bottomDepth(iCell) + refBottomDepthTopOfCell(k)) - km1 = max(k-1,1) - tracersGroup(:, k, iCell) = tracersGroup(:, k, iCell) & - + (tracersGroup(:, km1, iCell) - tracersGroup(:, k, iCell)) & - /(zMidZLevel(km1) - zMidZLevel(k) + 1.0e-16_RKIND) & - *(zMidPBC - zMidZLevel(k)) - - end do - end if - end if - end do - - deallocate(minBottomDepth,minBottomDepthMid,zMidZLevel) - - elseif (config_pbc_alteration_type .eq. 'full_cell') then - - do iCell = 1,nCells - bottomDepth(iCell) = refBottomDepth(maxLevelCell(iCell)) - enddo - - else - - write (stderrUnit,*) ' Incorrect choice of config_pbc_alteration_type.' - call mpas_dmpar_abort(dminfo) - - endif - - endif ! .not.config_do_restart - - if (.not. config_do_restart) then - - ! Layer thickness when the ocean is at rest, i.e. without SSH or internal perturbations. - ! This is applied only from the initial condition - if (config_set_restingThickness_to_IC) then - restingThickness = layerThickness - endif - - endif ! .not.config_do_restart.and.config_alter_ICs_for_pbcs - if (config_check_ssh_consistency) then consistentSSH = .true. do iCell = 1,nCells From aa13b89f0ebaee99c38e24edba9fe4504dc0df49 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Tue, 27 Oct 2015 08:43:21 -0600 Subject: [PATCH 0358/1724] Move ssh check to debug flags. --- src/core_ocean/Registry.xml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 45b8861e48..ef9c7b8549 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -213,10 +213,6 @@ description="Determines if the positive Z axis is aligned with the positive K index direction." possible_values=".true. or .false." /> - + Date: Tue, 27 Oct 2015 09:21:06 -0600 Subject: [PATCH 0359/1724] Fixing an issue with reused buffers in li statistics This commit fixes an issue in the mpas_li_statistics module where dmpar allreduce (i.e. max_int, min_int, etc...) routines used the same buffer for the send and receive. Certain MPI implementations fail when this is done (i.e. MPICH), so this commit changes the behavior to have independnt buffers for each part of the communication. --- src/core_landice/mpas_li_statistics.F | 36 +++++++++++++++++++-------- 1 file changed, 25 insertions(+), 11 deletions(-) diff --git a/src/core_landice/mpas_li_statistics.F b/src/core_landice/mpas_li_statistics.F index c2cc77eade..6337f13614 100644 --- a/src/core_landice/mpas_li_statistics.F +++ b/src/core_landice/mpas_li_statistics.F @@ -149,6 +149,10 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) real (kind=RKIND) :: globalVelocityMax, globalBasalVelocityMax ! diagnostic info for user-specified grid cell + integer :: diagnosticCellLocal, diagnosticBlockIDLocal, diagnosticProcIDLocal + real (kind=RKIND) :: diagnosticUpperSurfaceLocal, diagnosticThicknessLocal, diagnosticBedTopographyLocal + real (kind=RKIND) :: diagnosticSfcMassBalLocal, diagnosticSurfaceTemperatureLocal, diagnosticBasalTemperatureLocal + integer :: diagnosticCell, diagnosticBlockID, diagnosticProcID real (kind=RKIND) :: diagnosticUpperSurface, diagnosticThickness, diagnosticBedTopography real (kind=RKIND) :: diagnosticSfcMassBal, diagnosticSurfaceTemperature, diagnosticBasalTemperature @@ -472,17 +476,27 @@ subroutine li_compute_statistics(domain, timeLevel, timeIndex) ! Note: These reductions are done with global sums rather than broadcasts. ! Global sums will work provided that the quantity of interest ! has nonzero values on only a single processor. - - call mpas_dmpar_sum_int (dminfo, diagnosticCell, diagnosticCell) - call mpas_dmpar_sum_int (dminfo, diagnosticBlockID, diagnosticBlockID) - call mpas_dmpar_sum_int (dminfo, diagnosticProcID, diagnosticProcID) - - call mpas_dmpar_sum_real (dminfo, diagnosticUpperSurface, diagnosticUpperSurface) - call mpas_dmpar_sum_real (dminfo, diagnosticThickness, diagnosticThickness) - call mpas_dmpar_sum_real (dminfo, diagnosticBedTopography, diagnosticBedTopography) - call mpas_dmpar_sum_real (dminfo, diagnosticSfcMassBal, diagnosticSfcMassBal) - call mpas_dmpar_sum_real (dminfo, diagnosticSurfaceTemperature, diagnosticSurfaceTemperature) - call mpas_dmpar_sum_real (dminfo, diagnosticBasalTemperature, diagnosticBasalTemperature) + diagnosticCellLocal = diagnosticCell + diagnosticBlockIDLocal = diagnosticBlockID + diagnosticProcIDLocal = diagnosticProcID + + diagnosticUpperSurfaceLocal = diagnosticUpperSurface + diagnosticThicknessLocal = diagnosticThickness + diagnosticBedTopographyLocal = diagnosticBedTopography + diagnosticSfcMassBalLocal = diagnosticSfcMassBal + diagnosticSurfaceTemperatureLocal = diagnosticSurfaceTemperature + diagnosticBasalTemperatureLocal = diagnosticBasalTemperature + + call mpas_dmpar_sum_int (dminfo, diagnosticCellLocal, diagnosticCell) + call mpas_dmpar_sum_int (dminfo, diagnosticBlockIDLocal, diagnosticBlockID) + call mpas_dmpar_sum_int (dminfo, diagnosticProcIDLocal, diagnosticProcID) + + call mpas_dmpar_sum_real (dminfo, diagnosticUpperSurfaceLocal, diagnosticUpperSurface) + call mpas_dmpar_sum_real (dminfo, diagnosticThicknessLocal, diagnosticThickness) + call mpas_dmpar_sum_real (dminfo, diagnosticBedTopographyLocal, diagnosticBedTopography) + call mpas_dmpar_sum_real (dminfo, diagnosticSfcMassBalLocal, diagnosticSfcMassBal) + call mpas_dmpar_sum_real (dminfo, diagnosticSurfaceTemperatureLocal, diagnosticSurfaceTemperature) + call mpas_dmpar_sum_real (dminfo, diagnosticBasalTemperatureLocal, diagnosticBasalTemperature) !TODO - Change to nVertLevels + 1 if velocity lives on layer interfaces allocate (workArray1d(nVertLevels)) From d7072aa9801c1931c4439d2f742559b1454ff1ca Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Thu, 8 Oct 2015 15:55:46 -0600 Subject: [PATCH 0360/1724] Modify analysis members that have restart capabilities This commit updates analysis members that have a restart capability to use the newly defined routine in the analysis member driver rather than built in functionality to the analysis member. --- .../Registry_eliassen_palm.xml | 11 ++-- .../Registry_lagrangian_particle_tracking.xml | 14 ++++- .../Registry_time_filters.xml | 8 +-- .../Registry_time_series_stats.xml | 3 +- .../mpas_ocn_analysis_driver.F | 12 ++++- .../analysis_members/mpas_ocn_eliassen_palm.F | 51 +------------------ .../mpas_ocn_lagrangian_particle_tracking.F | 13 ----- .../analysis_members/mpas_ocn_time_filters.F | 39 +++++++------- .../mpas_ocn_time_series_stats.F | 36 ++++++------- .../mode_forward/mpas_ocn_forward_mode.F | 9 ---- 10 files changed, 66 insertions(+), 130 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml index fe66ed93df..80bce671ad 100644 --- a/src/core_ocean/analysis_members/Registry_eliassen_palm.xml +++ b/src/core_ocean/analysis_members/Registry_eliassen_palm.xml @@ -11,6 +11,10 @@ description="Name of the stream that the eliassenPalm analysis member should be tied to." possible_values="Any existing stream name or 'none'" /> + - + + + immutable="false"> @@ -119,11 +128,12 @@ + immutable="false"> diff --git a/src/core_ocean/analysis_members/Registry_time_filters.xml b/src/core_ocean/analysis_members/Registry_time_filters.xml index a721fd76bf..3da15c3b4a 100644 --- a/src/core_ocean/analysis_members/Registry_time_filters.xml +++ b/src/core_ocean/analysis_members/Registry_time_filters.xml @@ -11,6 +11,10 @@ description="Name of the stream that the timeFilters analysis member should be tied to." possible_values="Any existing stream name or 'none'" /> + - diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F index 6b21d8a480..43fe11a77b 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -266,14 +266,19 @@ subroutine ocn_analysis_read_init_streams(domain, err)!{{{ timerName = trim(initReadTimerPrefix) // poolItr % memberName(1:nameLength) call mpas_timer_start(timerName, .false.) configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_restart_stream' + nullify(config_AM_restart_stream) call mpas_pool_get_config(domain % configs, configName, config_AM_restart_stream) configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_input_stream' + nullify(config_AM_input_stream) call mpas_pool_get_config(domain % configs, configName, config_AM_input_stream) ! Verify the restart stream exists if ( associated(config_AM_restart_stream) ) then - if ( .not. mpas_stream_mgr_stream_exists(domain % streamManager, config_AM_restart_stream) ) then + if ( trim(config_AM_restart_stream) == 'none' ) then + ! If the stream is set to 'none' nullify the config, so it doesn't get read in + nullify(config_AM_restart_stream) + else if ( .not. mpas_stream_mgr_stream_exists(domain % streamManager, config_AM_restart_stream) ) then call mpas_dmpar_global_abort('ERROR: Stream named ''' // trim(config_AM_restart_stream) // & ''' does not exist in config for analysis member ''' // & trim(poolItr % memberName(1:nameLength)) // '''') @@ -282,7 +287,10 @@ subroutine ocn_analysis_read_init_streams(domain, err)!{{{ ! Verify the input stream exists if ( associated(config_AM_input_stream) ) then - if ( .not. mpas_stream_mgr_stream_exists(domain % streamManager, config_AM_input_stream) ) then + if ( trim(config_AM_input_stream) == 'none' ) then + ! If the stream is set to 'none' nullify the config, so it doesn't get read in + nullify(config_AM_input_stream) + else if ( .not. mpas_stream_mgr_stream_exists(domain % streamManager, config_AM_input_stream) ) then call mpas_dmpar_global_abort('ERROR: Stream named ''' // trim(config_AM_input_stream) // & ''' does not exist in config for analysis member ''' // & trim(poolItr % memberName(1:nameLength)) // '''') diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index 0b5d83cc96..9df5d3ea6c 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -117,7 +117,7 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ real (kind=RKIND), dimension(:), pointer :: buoyancyMidRef real (kind=RKIND), dimension(:), pointer :: buoyancyInterfaceRef - logical, pointer :: amEPFTActive, config_AM_eliassenPalm_do_restart + logical, pointer :: amEPFTActive logical, pointer :: config_AM_eliassenPalm_compute_on_startup integer, pointer :: config_AM_eliassenPalm_nBuoyancyLayers real (kind=RKIND), pointer :: config_AM_eliassenPalm_rhomax_buoycoor @@ -145,8 +145,6 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ err = 0 - call mpas_pool_get_config(domain % configs, 'config_AM_eliassenPalm_do_restart', & - config_AM_eliassenPalm_do_restart) call mpas_pool_get_config(domain % configs, 'config_AM_eliassenPalm_compute_on_startup', & config_AM_eliassenPalm_compute_on_startup) call mpas_pool_get_config(domain % configs, 'config_AM_eliassenPalm_nBuoyancyLayers', & @@ -200,53 +198,6 @@ subroutine ocn_init_eliassen_palm(domain, err)!{{{ potentialDensityMidRef(k) = 0.5*(potentialDensityTopRef(k) + config_AM_eliassenPalm_rhomax_buoycoor) buoyancyMidRef(k) = 0.5*(buoyancyInterfaceRef(k) + buoyancyInterfaceRef(k+1)) - !----------------------------------------------------------------- - ! initialize ensemble averages when it is not a restart - !----------------------------------------------------------------- - if (.not. config_AM_eliassenPalm_do_restart) then - call mpas_pool_get_array(amEPFTPool, 'nSamplesEA', nSamplesEA) - call mpas_pool_get_array(amEPFTPool, 'buoyancyMaskEA', buoyancyMaskEA) - call mpas_pool_get_array(amEPFTPool, 'sigmaEA', sigmaEA) - call mpas_pool_get_array(amEPFTPool, 'heightMidBuoyCoorEA', heightMidBuoyCoorEA) - call mpas_pool_get_array(amEPFTPool, 'montgPotBuoyCoorEA', montgPotBuoyCoorEA) - call mpas_pool_get_array(amEPFTPool, 'montgPotGradZonalEA', montgPotGradZonalEA) - call mpas_pool_get_array(amEPFTPool, 'montgPotGradMeridEA', montgPotGradMeridEA) - call mpas_pool_get_array(amEPFTPool, 'heightMidBuoyCoorSqEA', heightMidBuoyCoorSqEA) - call mpas_pool_get_array(amEPFTPool, 'heightMGradZonalEA', heightMGradZonalEA) - call mpas_pool_get_array(amEPFTPool, 'heightMGradMeridEA', heightMGradMeridEA) - call mpas_pool_get_array(amEPFTPool, 'usigmaEA', usigmaEA) - call mpas_pool_get_array(amEPFTPool, 'vsigmaEA', vsigmaEA) - call mpas_pool_get_array(amEPFTPool, 'varpisigmaEA', varpisigmaEA) - call mpas_pool_get_array(amEPFTPool, 'uusigmaEA', uusigmaEA) - call mpas_pool_get_array(amEPFTPool, 'vvsigmaEA', vvsigmaEA) - call mpas_pool_get_array(amEPFTPool, 'uvsigmaEA', uvsigmaEA) - call mpas_pool_get_array(amEPFTPool, 'uvarpisigmaEA', uvarpisigmaEA) - call mpas_pool_get_array(amEPFTPool, 'vvarpisigmaEA', vvarpisigmaEA) - - nSamplesEA = 0.0 - buoyancyMaskEA = 0.0 - sigmaEA = 0.0 - heightMidBuoyCoorEA = 0.0 - montgPotGradZonalEA = 0.0 - montgPotGradMeridEA = 0.0 - heightMidBuoyCoorSqEA = 0.0 - montgPotBuoyCoorEA = 0.0 - heightMGradZonalEA = 0.0 - heightMGradMeridEA = 0.0 - usigmaEA = 0.0 - vsigmaEA = 0.0 - varpisigmaEA = 0.0 - uusigmaEA = 0.0 - vvsigmaEA = 0.0 - uvsigmaEA = 0.0 - uvarpisigmaEA = 0.0 - vvarpisigmaEA = 0.0 - end if - - if (config_AM_eliassenPalm_do_restart .and. config_AM_eliassenPalm_compute_on_startup) then - write(stderrUnit,*) ' *** WARNING:: Compute on startup was requested on a restart of AM eliassen_palm.' - end if - block => block % next end do diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F index 55a41f38e5..e1a9f24a18 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -125,19 +125,6 @@ subroutine ocn_init_lagrangian_particle_tracking(domain, err)!{{{ call mpas_timer_start("totalLPT", .false., timerTotalLPT) call mpas_timer_start("initLPT", .false., timerInit) - ! load in data -#ifdef MPAS_DEBUG - write(stderrUnit,*) 'starting reading stream for lagrPartTrack' -#endif - call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) - if (config_do_restart) then - call MPAS_stream_mgr_read(domain % streamManager, streamID='lagrPartTrackRestart', ierr=err) - else - call MPAS_stream_mgr_read(domain % streamManager, streamID='lagrPartTrackInput', ierr=err) - end if -#ifdef MPAS_DEBUG - write(stderrUnit,*) 'finished reading stream for lagrPartTrack' -#endif ! resets likely are unnecessary !call mpas_stream_mgr_reset_alarms(stream_manager, streamID='lagrPartTrackInput', ierr=err) !call mpas_stream_mgr_reset_alarms(stream_manager, streamID='lagrPartTrackRestart', ierr=err) diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_filters.F b/src/core_ocean/analysis_members/mpas_ocn_time_filters.F index 281ea05c90..1c3a7f7d7b 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_filters.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_filters.F @@ -17,6 +17,8 @@ !> !----------------------------------------------------------------------- +!#define TIME_FILTERS_DEBUG + module ocn_time_filters use mpas_derived_types @@ -27,7 +29,7 @@ module ocn_time_filters use ocn_constants use ocn_diagnostics_routines -#ifdef MPAS_DEBUG +#ifdef TIME_FILTERS_DEBUG use mpas_constants #endif @@ -57,9 +59,9 @@ module ocn_time_filters ! Private module variables ! !-------------------------------------------------------------------- -#ifdef MPAS_DEBUG +#ifdef TIME_FILTERS_DEBUG integer :: iEdgeOutput = 0, iBlockOutput = 0, iklevel = 1 - real (kind=RKIND) :: lonEdgePoint = (360.0_RKIND-7.5_RKIND)*pii/180.0_RKIND, latEdgePoint = 32.5_RKIND*pii/180.0_RKIND + real (kind=RKIND) :: lonEdgePoint = 10.0_RKIND*pii/180.0_RKIND, latEdgePoint = 30.0_RKIND*pii/180.0_RKIND #endif !*********************************************************************** @@ -112,9 +114,8 @@ subroutine ocn_init_time_filters(domain, err)!{{{ logical, pointer :: initializeFilters type (mpas_pool_type), pointer :: timeFiltersAMPool, statePool real (kind=RKIND), dimension(:,:), pointer :: normalVelocity, normalVelocityLowPass, normalVelocityHighPass - logical, pointer :: config_AM_timeFilters_do_restart -#ifdef MPAS_DEBUG +#ifdef TIME_FILTERS_DEBUG real (kind=RKIND), dimension(:), pointer :: lonEdge, latEdge real (kind=RKIND) :: dist, distmax = 1e9 integer :: i, iBlock @@ -123,15 +124,9 @@ subroutine ocn_init_time_filters(domain, err)!{{{ err = 0 - ! read in data on restart - call mpas_pool_get_config(domain % configs, 'config_AM_timeFilters_do_restart', config_AM_timeFilters_do_restart) - if ( config_AM_timeFilters_do_restart ) then - call MPAS_stream_mgr_read(domain % streamManager, streamID='timeFiltersRestart', ierr=err) - end if - call mpas_pool_get_config(ocnConfigs, 'config_AM_timeFilters_initialize_filters', initializeFilters) if (initializeFilters) then -#ifdef MPAS_DEBUG +#ifdef TIME_FILTERS_DEBUG write(stderrUnit,*) 'initializing time filters' #endif @@ -157,7 +152,7 @@ subroutine ocn_init_time_filters(domain, err)!{{{ end if -#ifdef MPAS_DEBUG +#ifdef TIME_FILTERS_DEBUG ! get index for edge nearest to a location block => domain % blocklist iBlock = 0 @@ -188,10 +183,10 @@ subroutine ocn_init_time_filters(domain, err)!{{{ call mpas_pool_get_subpool(block % structs, 'mesh', statePool) call mpas_pool_get_array(statePool, 'latEdge', latEdge) call mpas_pool_get_array(statePool, 'lonEdge', lonEdge) - write(stderrUnit,*) 'lon = ', 180.0_RKIND/pii*lonEdge(iEdgeOutput), ' lat = ', 180.0_RKIND/pii*latEdge(iEdgeOutput), ' iklevel=',iklevel + write(stderrUnit,*) 'lon = ', 180.0_RKIND/pii*lonEdge(iEdgeOutput), ' lat = ', 180.0_RKIND/pii*latEdge(iEdgeOutput), ' iklevel=',iklevel, ' iEdgeOutput=',iEdgeOutput, ' iBlockOutput = ', iBlockOutput #endif -#ifdef MPAS_DEBUG +#ifdef TIME_FILTERS_DEBUG write(stderrUnit,*) 'finished initializing time filters' #endif @@ -258,7 +253,7 @@ subroutine ocn_compute_time_filters(domain, timeLevel, err)!{{{ type (MPAS_timeInterval_type) :: timeStepESMF character(len=StrKIND), pointer :: config_dt real (kind=RKIND) :: dt, tau -#ifdef MPAS_DEBUG +#ifdef TIME_FILTERS_DEBUG integer :: iBlock #endif @@ -266,7 +261,7 @@ subroutine ocn_compute_time_filters(domain, timeLevel, err)!{{{ dminfo = domain % dminfo -#ifdef MPAS_DEBUG +#ifdef TIME_FILTERS_DEBUG write(stderrUnit,*) 'start computing time filters' #endif @@ -279,16 +274,16 @@ subroutine ocn_compute_time_filters(domain, timeLevel, err)!{{{ call mpas_set_timeInterval(timeStepESMF, timeString=config_dt, ierr=err) call mpas_get_timeInterval(timeStepESMF, dt=tau) -#ifdef MPAS_DEBUG +#ifdef TIME_FILTERS_DEBUG !write(stderrUnit,*) 'dt = ', dt, ' tau = ', tau #endif block => domain % blocklist -#ifdef MPAS_DEBUG +#ifdef TIME_FILTERS_DEBUG iBlock = 0 #endif do while (associated(block)) -#ifdef MPAS_DEBUG +#ifdef TIME_FILTERS_DEBUG iBlock = iBlock + 1 #endif call mpas_pool_get_subpool(block % structs, 'state', statePool) @@ -316,7 +311,7 @@ subroutine ocn_compute_time_filters(domain, timeLevel, err)!{{{ ! normalVelocityTest line can possibly be removed (needed for testing purposes) normalVelocityTest(k,iEdge) = normalVelocity(k,iEdge) end do -#ifdef MPAS_DEBUG +#ifdef TIME_FILTERS_DEBUG if (iEdge == iEdgeOutput .and. iBlock == iBlockOutput) then write(stderrUnit,*) 'vl=', normalVelocityLowPass(iklevel, iEdge), ' v=', normalVelocity(iklevel, iEdge) end if @@ -326,7 +321,7 @@ subroutine ocn_compute_time_filters(domain, timeLevel, err)!{{{ block => block % next end do -#ifdef MPAS_DEBUG +#ifdef TIME_FILTERS_DEBUG write(stderrUnit,*) 'finished computing time filters' #endif diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index 1e136629bc..9ea1e88c69 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -735,7 +735,9 @@ subroutine modify_stream(domain, instance, series, err)!{{{ ! local variables integer :: v, b + logical :: emptyRestartStream character (len=StrKIND), pointer :: output_stream_name, restart_stream_name + character (len=StrKIND) :: fieldName type (field0DReal), pointer :: srcReal, dstReal logical, pointer :: copy_mesh character (len=StrKIND) :: field_name, config, op_name @@ -803,9 +805,20 @@ subroutine modify_stream(domain, instance, series, err)!{{{ end do end if - ! make restart mutable - call mpas_stream_mgr_set_property(domain % streamManager, & - restart_stream_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .false., ierr=err) + ! ensure restart stream is empty + emptyRestartStream = .true. + call mpas_stream_mgr_begin_iteration(domain % streamManager, streamID=restart_stream_name, ierr=err) + do while ( mpas_stream_mgr_get_next_field(domain % streamManager, streamID=restart_stream_name, fieldName=fieldName) ) + emptyRestartStream = .false. + end do + + if ( .not. emptyRestartStream ) then + write(stderrUnit, *) 'ERROR: Stream named ''' // trim(restart_stream_name) // ''' is not empty, but is used in ' + write(stderrUnit, *) ' an instance of teh time series stats analysis member. This stream will be built' + write(stderrUnit, *) ' based on the contents of the ''' // trim(output_stream_name) // ''' stream.' + write(stderrUnit, *) ' Please ensure it is empty in the streams file.' + call mpas_dmpar_global_abort('ERROR: Misconfigured streams for time series stats analysis member.') + end if ! create and put the counters in the streams do b = 1, series % number_of_buffers @@ -875,27 +888,10 @@ subroutine modify_stream(domain, instance, series, err)!{{{ end do end do ! number_of_variables - ! make restart immutable - call mpas_stream_mgr_set_property(domain % streamManager, & - restart_stream_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .true., ierr=err) - - ! read the restart stream - call mpas_stream_mgr_read(domain % streamManager, streamID = restart_stream_name, & - ierr=err) - - ! add xtime afterwards because we don't want to clobber the existing xtime - ! make restart mutable - call mpas_stream_mgr_set_property(domain % streamManager, & - restart_stream_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .false., ierr=err) - ! add xtime to the restart call mpas_stream_mgr_add_field(domain % streamManager, & restart_stream_name, TIME_STREAM, ierr=err) - ! make restart immutable - call mpas_stream_mgr_set_property(domain % streamManager, & - restart_stream_name, MPAS_STREAM_PROPERTY_IMMUTABLE, .true., ierr=err) - end subroutine modify_stream!}}} diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index b69acc314b..460f2a7727 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -117,7 +117,6 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ type (MPAS_TimeInterval_type) :: timeStep logical, pointer :: config_do_restart, config_read_nearest_restart, config_filter_btr_mode, config_conduct_tests - logical, pointer :: config_AM_eliassenPalm_do_restart character (len=StrKIND), pointer :: config_vert_coord_movement, config_pressure_gradient_type real (kind=RKIND), pointer :: config_maxMeshDensity @@ -135,7 +134,6 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) call mpas_pool_get_config(domain % configs, 'config_read_nearest_restart', config_read_nearest_restart) - call mpas_pool_get_config(domain % configs, 'config_AM_eliassenPalm_do_restart', config_AM_eliassenPalm_do_restart) call mpas_pool_get_config(domain % configs, 'config_vert_coord_movement', config_vert_coord_movement) call mpas_pool_get_config(domain % configs, 'config_pressure_gradient_type', config_pressure_gradient_type) call mpas_pool_get_config(domain % configs, 'config_filter_btr_mode', config_filter_btr_mode) @@ -148,13 +146,6 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ call mpas_timer_start('io_read', .false.) call MPAS_stream_mgr_read(domain % streamManager, streamID='mesh', whence=MPAS_STREAM_NEAREST, ierr=err_tmp) - ! Read in a restart file for the eliassen_palm analysis member - if ( config_AM_eliassenPalm_do_restart ) then - call mpas_timer_start('io_read', .false.) - call MPAS_stream_mgr_read(domain % streamManager, streamID='eliassenPalmRestart', ierr=err_tmp) - call mpas_timer_stop('io_read') - end if - if ( config_do_restart ) then if ( config_read_nearest_restart ) then call MPAS_stream_mgr_read(domain % streamManager, streamID='restart', whence=MPAS_STREAM_NEAREST, ierr=err_tmp) From a1a52fec64d820f67b6c1553c5ad8c5798aedd4b Mon Sep 17 00:00:00 2001 From: toddringler Date: Tue, 27 Oct 2015 10:43:32 -0600 Subject: [PATCH 0361/1724] edit files based on code review comments tried to remove spaces from frazil-related text in Registry.xml removed subroutine to add frazil surface pressure to sea surface pressure --- src/core_ocean/Registry.xml | 40 +++++------ .../shared/mpas_ocn_frazil_forcing.F | 67 +------------------ 2 files changed, 21 insertions(+), 86 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 779e795fbb..99ff9014c8 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -2085,7 +2085,7 @@ + /> - - - - - - - + + + + + + + \brief Add frazil pressure to total pressure -!> \author Todd Ringler -!> \date 18 October 2015 -!> \details -!> This routine adds frazil surface pressure to total surface pressure -! -!----------------------------------------------------------------------- - - subroutine ocn_frazil_forcing_surface_pressure(meshPool, forcingPool, err)!{{{ - - !----------------------------------------------------------------- - ! - ! input variables - ! - !----------------------------------------------------------------- - type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information - - !----------------------------------------------------------------- - ! - ! input/output variables - ! - !----------------------------------------------------------------- - type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information - - !----------------------------------------------------------------- - ! - ! output variables - ! - !----------------------------------------------------------------- - - integer, intent(out) :: err !< Output: Error flag - - !----------------------------------------------------------------- - ! - ! local variables - ! - !----------------------------------------------------------------- - - integer :: iCell - integer, pointer :: nCells - real (kind=RKIND), dimension(:), pointer :: frazilSurfacePressure - real (kind=RKIND), dimension(:), pointer :: seaSurfacePressure - - err = 0 - - if ( .not. frazilFormationOn ) return - - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - - call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) - call mpas_pool_get_array(forcingPool, 'frazilSurfacePressure', frazilSurfacePressure) - - ! add frazil surface pressure to total surface pressure - do iCell = 1, nCells - seaSurfacePressure(iCell) = seaSurfacePressure(iCell) + frazilSurfacePressure(iCell) - end do - - end subroutine ocn_frazil_forcing_surface_pressure!}}} - !*********************************************************************** ! ! routine ocn_frazil_forcing_active_tracers @@ -336,8 +272,7 @@ end subroutine ocn_frazil_forcing_active_tracers!}}} !> !> these tendencies can be retrieved at any point by calling into ocn_frazil_forcing_{tracers, thickness} routines !> -!> the pressure exerted by the frazil on the ocean "surface" can be retrieved by calling into -!> ocn_frazil_forcing_surface_pressure +!> the pressure exerted by the frazil on the ocean "surface" is added to the pressure computation in diagnostics !> !> this routine should be call at the beginning of whatever time stepping method is utilized !> and the tendencies should be retieved when building up the RHS of the thickess, temperature From 6ccaaa1976ff3be3ec6b70f4316fd6db2dc2d93f Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Tue, 27 Oct 2015 11:35:55 -0600 Subject: [PATCH 0362/1724] Allow vector reconstruction to happen in halo regions This commit updates specific vector reconstruction calls to compute vector reconstruction fields in halo regions. This is necessary to allow operators (such as the EPFT AM) to be bit-reproducible. --- src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F | 8 ++++---- .../mode_forward/mpas_ocn_time_integration_rk4.F | 8 ++++---- .../mode_forward/mpas_ocn_time_integration_split.F | 8 ++++---- src/core_ocean/shared/mpas_ocn_init_routines.F | 2 +- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F index 0b5d83cc96..b20fb74811 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F +++ b/src/core_ocean/analysis_members/mpas_ocn_eliassen_palm.F @@ -1034,7 +1034,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ !------------------------------------------------------------- call mpas_reconstruct(meshPool, montgPotNormalGradOnEdge, & montgPotGradX, montgPotGradY, montgPotGradZ, & - montgPotGradZonal, montgPotGradMerid) + montgPotGradZonal, montgPotGradMerid, includeHalos=.true.) !------------------------------------------------------------- ! Increment first-order running ensemble average fields @@ -1194,7 +1194,7 @@ subroutine ocn_compute_eliassen_palm(domain, timeLevel, err)!{{{ ! reconstruct full gradient vector at cell centers !------------------------------------------------------------- call mpas_reconstruct(meshPool, ErtelPVNormalGradOnEdge, & - ErtelPVGradX, ErtelPVGradY, ErtelPVGradZ, ErtelPVGradZonal, ErtelPVGradMerid) + ErtelPVGradX, ErtelPVGradY, ErtelPVGradZ, ErtelPVGradZonal, ErtelPVGradMerid, includeHalos=.true.) !------------------------------------------------------------- ! compute the vertical derivative of uTWA @@ -2691,7 +2691,7 @@ subroutine computeErtelPV(nCells, nLayers, nEdges, meshPool, & meshPool, uCell, velNormalGradOnEdge) call mpas_reconstruct(meshPool, velNormalGradOnEdge, & velGradX, velGradY, velGradZ, & - velGradZonal, velGradMerid) + velGradZonal, velGradMerid, includeHalos=.true.) uGradMerid = velGradMerid ! calculate derivative of vTWA with respect to the zonal direction @@ -2699,7 +2699,7 @@ subroutine computeErtelPV(nCells, nLayers, nEdges, meshPool, & meshPool, vCell, velNormalGradOnEdge) call mpas_reconstruct(meshPool, velNormalGradOnEdge, & velGradX, velGradY, velGradZ, & - velGradZonal, velGradMerid) + velGradZonal, velGradMerid, includeHalos=.true.) vGradZonal = velGradZonal ErtelPV = 0.0 diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F index 71876a9865..8f555c6e42 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F @@ -855,10 +855,10 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ ! End: Accumulating various parameterizations of the transport velocity ! ------------------------------------------------------------------ - call mpas_reconstruct(meshPool, normalVelocityNew, & - velocityX, velocityY, velocityZ, & - velocityZonal, velocityMeridional & - ) + call mpas_reconstruct(meshPool, normalVelocityNew, & + velocityX, velocityY, velocityZ, & + velocityZonal, velocityMeridional, & + includeHalos = .true.) call mpas_reconstruct(meshPool, gradSSH, & gradSSHX, gradSSHY, gradSSHZ, & diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F index af5f7c3fe2..ddd2f23192 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F @@ -1607,10 +1607,10 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) end if - call mpas_reconstruct(meshPool, normalVelocityNew, & - velocityX, velocityY, velocityZ, & - velocityZonal, velocityMeridional & - ) + call mpas_reconstruct(meshPool, normalVelocityNew, & + velocityX, velocityY, velocityZ, & + velocityZonal, velocityMeridional, & + includeHalos = .true. ) call mpas_reconstruct(meshPool, gradSSH, & gradSSHX, gradSSHY, gradSSHZ, & diff --git a/src/core_ocean/shared/mpas_ocn_init_routines.F b/src/core_ocean/shared/mpas_ocn_init_routines.F index 1c8d23297a..15b74043bc 100644 --- a/src/core_ocean/shared/mpas_ocn_init_routines.F +++ b/src/core_ocean/shared/mpas_ocn_init_routines.F @@ -633,7 +633,7 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ call mpas_rbf_interp_initialize(meshPool) call mpas_initialize_tangent_vectors(meshPool, edgeTangentVectors) - call mpas_init_reconstruct(meshPool) + call mpas_init_reconstruct(meshPool, includeHalos=.true.) call mpas_reconstruct(meshPool, normalVelocity, & velocityX, & From c4106499d721c3b33ee05a2e70a9a9f8ef8eba6d Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Tue, 27 Oct 2015 12:31:40 -0600 Subject: [PATCH 0363/1724] Add grounding line to bit masks This adds a new bit to the bitmasks cellMask, edgeMask, and vertexMask that identify the location of the grounding line. In this implementation, the GL is defined as the last grounded cell and edges/vertices that have grounded ice on one side and floating ice on the other. --- src/core_landice/shared/mpas_li_mask.F | 38 ++++++++++++++++++++++---- 1 file changed, 33 insertions(+), 5 deletions(-) diff --git a/src/core_landice/shared/mpas_li_mask.F b/src/core_landice/shared/mpas_li_mask.F index a3bb3bf41e..3ec01039cf 100644 --- a/src/core_landice/shared/mpas_li_mask.F +++ b/src/core_landice/shared/mpas_li_mask.F @@ -41,6 +41,7 @@ module li_mask integer, parameter :: li_mask_ValueInitialIceExtent = 1 integer, parameter :: li_mask_ValueAlbanyActive = 64 ! These are locations that Albany includes in its solution integer, parameter :: li_mask_ValueAlbanyMarginNeighbor = 128 ! This the first cell beyond the last active albany cell + integer, parameter :: li_mask_ValueGroundingLine = 256 ! This is grounded cell that has a floating neighbor, or vertex/edge on that boundary !-------------------------------------------------------------------- ! @@ -271,7 +272,9 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) logical :: isMargin logical :: isAlbanyMarginNeighbor logical :: aCellOnVertexHasIce, aCellOnVertexHasNoIce, aCellOnVertexHasDynamicIce, aCellOnVertexHasNoDynamicIce, aCellOnVertexIsFloating, aCellOnVertexIsAlbanyActive + logical :: aCellOnVertexIsGrounded logical :: aCellOnEdgeHasIce, aCellOnEdgeHasNoIce, aCellOnEdgeHasDynamicIce, aCellOnEdgeHasNoDynamicIce, aCellOnEdgeIsFloating + logical :: aCellOnEdgeIsGrounded integer :: numCellsOnVertex integer :: numDiriDynamicCells, numDiriNondynamicCells, numExtendedCells logical :: validVertex @@ -385,6 +388,19 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) enddo endif + ! Identify the grounding line + ! For a cell, we define the GL as a grounded cell with ice with at least one neighbor with floating ice + do i=1,nCells + if (li_mask_is_grounded_ice(cellMask(i))) then ! only need to check grounded cells + do j=1,nEdgesOnCell(i) ! Check if any neighbors are floating + if (li_mask_is_floating_ice(cellMask(cellsOnCell(j,i)))) & + cellMask(i) = ior(cellMask(i), li_mask_ValueGroundingLine) + cycle ! no need to look at additional neighbors + enddo + endif + enddo + + ! ==== ! Calculate vertexMask values based on cellMask values=========================== ! ==== @@ -397,6 +413,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) ! cells (i.e., the cells exist in the mesh). This allows external dycores to use the ! vertexMask to get information about triangles in the Delaunay triangulation. ! (This is done in a way which does not assume vertexMask==3.) + ! Bit: GL is a vertex with at least one neighboring cell grounded ice and at least one neighboring cell floating ice vertexMask = 0 do i = 1,nVertices aCellOnVertexHasIce = .false. @@ -404,6 +421,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) aCellOnVertexHasDynamicIce = .false. aCellOnVertexHasNoDynamicIce = .false. aCellOnVertexIsFloating = .false. + aCellOnVertexIsGrounded = .false. aCellOnVertexIsAlbanyActive = .false. numCellsOnVertex = 0 validVertex = .false. @@ -420,6 +438,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) aCellOnVertexHasDynamicIce = (aCellOnVertexHasDynamicIce .or. li_mask_is_dynamic_ice(cellMask(iCell))) aCellOnVertexHasNoDynamicIce = (aCellOnVertexHasNoDynamicIce .or. (.not. (li_mask_is_dynamic_ice(cellMask(iCell))))) aCellOnVertexIsFloating = (aCellOnVertexIsFloating .or. li_mask_is_floating_ice(cellMask(iCell))) + aCellOnVertexIsGrounded = (aCellOnVertexIsGrounded .or. li_mask_is_grounded_ice(cellMask(iCell))) aCellOnVertexIsAlbanyActive = (aCellOnVertexIsAlbanyActive .or. li_mask_is_albany_active(cellMask(iCell))) if ( .not. ((trim(config_velocity_solver) == 'sia') .or. (trim(config_velocity_solver) == 'none')) ) then !if (li_mask_is_dynamic_ice(cellMask(iCell)) .and. .not. li_mask_is_albany_active(cellMask(iCell))) then ! this finds diri cells @@ -437,10 +456,10 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) if (numCellsOnVertex == vertexDegree) then validVertex = .true. endif - if (aCellOnVertexHasIce .and. validVertex) then + if (aCellOnVertexHasIce) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueIce) endif - if (aCellOnVertexHasDynamicIce .and. validVertex) then + if (aCellOnVertexHasDynamicIce) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueDynamicIce) endif if (aCellOnVertexIsAlbanyActive .and. validVertex) then @@ -452,13 +471,16 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) vertexMask(i) = ior(vertexMask(i), li_mask_ValueAlbanyActive) vertexMask(i) = ior(vertexMask(i), li_mask_ValueAlbanyMarginNeighbor) endif - if (aCellOnVertexIsFloating .and. validVertex) then + if (aCellOnVertexIsFloating) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueFloating) endif - if (aCellOnVertexHasIce .and. aCellOnVertexHasNoIce .and. validVertex) then + if (aCellOnVertexIsFloating .and. aCellOnVertexIsGrounded) then + vertexMask(i) = ior(vertexMask(i), li_mask_ValueGroundingLine) + endif + if (aCellOnVertexHasIce .and. aCellOnVertexHasNoIce) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueMargin) ! vertex with both 1+ ice cell and 1+ non-ice cell as neighbors endif - if (aCellOnVertexHasDynamicIce .and. aCellOnVertexHasNoDynamicIce .and. validVertex) then + if (aCellOnVertexHasDynamicIce .and. aCellOnVertexHasNoDynamicIce) then vertexMask(i) = ior(vertexMask(i), li_mask_ValueDynamicMargin) ! vertex with both 1+ dynamic ice cell(s) and 1+ non-dynamic cell(s) as neighbors endif end do @@ -472,6 +494,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) ! Bit: Floating Edges have at least one neighboring cell floating ! Bit: Edges on margin are edges with one neighboring cell with ice and one neighboring cell without ice ! Bit: Edges on dynamic margin are edges with one neighboring cell with dynamic ice and one neighboring cell without dynamic ice + ! Bit: GL is an edge with one cell grounded ice and one cell floating ice edgeMask = 0 do i = 1,nEdges aCellOnEdgeHasIce = .false. @@ -479,6 +502,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) aCellOnEdgeHasDynamicIce = .false. aCellOnEdgeHasNoDynamicIce = .false. aCellOnEdgeIsFloating = .false. + aCellOnEdgeIsGrounded = .false. do j = 1, 2 iCell = cellsOnEdge(j,i) aCellOnEdgeHasIce = (aCellOnEdgeHasIce .or. li_mask_is_ice(cellMask(iCell))) @@ -486,6 +510,7 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) aCellOnEdgeHasDynamicIce = (aCellOnEdgeHasDynamicIce .or. li_mask_is_dynamic_ice(cellMask(iCell))) aCellOnEdgeHasNoDynamicIce = (aCellOnEdgeHasNoDynamicIce .or. (.not. (li_mask_is_dynamic_ice(cellMask(iCell))))) aCellOnEdgeIsFloating = (aCellOnEdgeIsFloating .or. li_mask_is_floating_ice(cellMask(iCell))) + aCellOnEdgeIsGrounded = (aCellOnEdgeIsGrounded .or. li_mask_is_grounded_ice(cellMask(iCell))) end do if (aCellOnEdgeHasIce) then edgeMask(i) = ior(edgeMask(i), li_mask_ValueIce) @@ -497,6 +522,9 @@ subroutine li_calculate_mask(meshPool, velocityPool, geometryPool, err) if (aCellOnEdgeIsFloating) then edgeMask(i) = ior(edgeMask(i), li_mask_ValueFloating) endif + if (aCellOnEdgeIsFloating .and. aCellOnEdgeIsGrounded) then + edgeMask(i) = ior(edgeMask(i), li_mask_ValueGroundingLine) + endif if (aCellOnEdgeHasIce .and. aCellOnEdgeHasNoIce) then edgeMask(i) = ior(edgeMask(i), li_mask_ValueMargin) endif From a0b25444dda58c1050e2c2527caf89ba3f1c9952 Mon Sep 17 00:00:00 2001 From: Mauro Perego Date: Mon, 26 Oct 2015 16:10:09 -0600 Subject: [PATCH 0364/1724] LI: change to the c++ interface to pass bedrock topography to the velocity solver --- .../Interface_velocity_solver.cpp | 21 ++++++++++--------- .../Interface_velocity_solver.hpp | 1 + 2 files changed, 12 insertions(+), 10 deletions(-) diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.cpp b/src/core_landice/mode_forward/Interface_velocity_solver.cpp index 2022fef601..dcc7f86790 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.cpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.cpp @@ -40,6 +40,7 @@ const double secondsInAYear = 31536000.0; // This may vary slightly in MPAS, bu const double minThick = 1e-3; //1m const double minBeta = 1e-5; double rho_ice; +double rho_ocean; //unsigned char dynamic_ice_bit_value; //unsigned char ice_present_bit_value; int dynamic_ice_bit_value; @@ -52,7 +53,7 @@ std::vector edgesToReceive, fCellsToReceive, indexToTriangleID, std::vector indexToVertexID, vertexToFCell, indexToEdgeID, edgeToFEdge, mask, fVertexToTriangleID, fCellToVertex, floatingEdgesIds, dirichletNodesIDs; std::vector temperatureOnTetra, velocityOnVertices, velocityOnCells, - elevationData, thicknessData, betaData, smbData, thicknessOnCells; + elevationData, thicknessData, betaData, bedTopographyData, smbData, thicknessOnCells; std::vector isVertexBoundary, isBoundaryEdge; ; int numBoundaryEdges; @@ -85,16 +86,12 @@ int velocity_solver_init_mpi(int* fComm) { } -void velocity_solver_set_parameters(double const* rhoi_F, int const* li_mask_ValueDynamicIce, int const* li_mask_ValueIce) { +void velocity_solver_set_parameters(double const* rhoi_F, /*double const* rhoo_F,*/ int const* li_mask_ValueDynamicIce, int const* li_mask_ValueIce) { // This function sets parameter values used by MPAS on the C/C++ side rho_ice = *rhoi_F; - //std::cout << "rhoi Fortran value:" << *rhoi_F << std::endl; - //std::cout << "rhoi C++ value:" << rho_ice << std::endl; + //rho_ocean = *rhoo_F; dynamic_ice_bit_value = *li_mask_ValueDynamicIce; ice_present_bit_value = *li_mask_ValueIce; - //std::cout << "mask dynamic Fortran value:" << *li_mask_ValueDynamicIce << std::endl; - //std::cout << "mask dynamic C++ value:" << dynamic_ice_bit_value << std::endl; - // Could add seconds in a year, but that can change from time step to time step on the MPAS side, so leaving it out for now. } @@ -368,7 +365,7 @@ void velocity_solver_solve_fo(double const* lowerSurface_F, velocity_solver_solve_fo__(nLayers, nGlobalVertices, nGlobalTriangles, Ordering, first_time_step, indexToVertexID, indexToTriangleID, minBeta, regulThk, levelsNormalizedThickness, elevationData, thicknessData, - betaData, smbData, temperatureOnTetra, velocityOnVertices, dt); + betaData, bedTopographyData, smbData, temperatureOnTetra, velocityOnVertices, dt); std::vector mpasIndexToVertexID(nVertices); for (int i = 0; i < nVertices; i++) { @@ -1020,6 +1017,7 @@ void get_prism_velocity_on_FEdges(double * uNormal, } else { //error, edge midpont does not belong to either triangle std::cout << "Error, edge midpont does not belong to either triangle" << std::endl; + for (int j = 0; j < 3; j++) std::cout << "("<first; int ic = it->second; thicknessData[iv] = std::max(thickness_F[ic] / unit_length, eps); - elevationData[iv] = thicknessData[iv] + lowerSurface_F[ic] / unit_length; + bedTopographyData[iv] = lowerSurface_F[ic] / unit_length; + elevationData[iv] = thicknessData[iv] + bedTopographyData[iv]; if (beta_F != 0) betaData[iv] = beta_F[ic] / unit_length; if (smb_F != 0) diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.hpp b/src/core_landice/mode_forward/Interface_velocity_solver.hpp index 484001b3ff..29cb521845 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.hpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.hpp @@ -159,6 +159,7 @@ extern void velocity_solver_solve_fo__(int nLayers, int nGlobalVertices, const std::vector& elevationData, const std::vector& thicknessData, const std::vector& betaData, + const std::vector& bedTopographyData, const std::vector& smbData, const std::vector& temperatureOnTetra, std::vector& velocityOnVertices, From 87d63d39c6dd04ccfa5db95604ff343bf865a068 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Wed, 14 Oct 2015 08:48:39 -0600 Subject: [PATCH 0365/1724] Adding a bootstrap routine for analysis members This commit adds a bootstrap routine to the analysis member driver which can be used to perform setup of things like streams before they are read, which happens before analysis members are initialized. An example of where this is used is the time_series_stats analysis member, which currently builds a restart stream during initialization, however the restart stream needs to be built before it's read. So, the constructon of the restart stream now occurs during bootstrapping, rather than initialization. --- .../mpas_ocn_analysis_driver.F | 55 +- .../mpas_ocn_time_series_stats.F | 586 ++++++++++-------- .../mode_forward/mpas_ocn_forward_mode.F | 2 +- 3 files changed, 363 insertions(+), 280 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F index 43fe11a77b..5bbda8987c 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F +++ b/src/core_ocean/analysis_members/mpas_ocn_analysis_driver.F @@ -59,7 +59,7 @@ module ocn_analysis_driver !-------------------------------------------------------------------- public :: ocn_analysis_setup_packages, & - ocn_analysis_read_init_streams, & + ocn_analysis_bootstrap, & ocn_analysis_init, & ocn_analysis_compute_startup, & ocn_analysis_compute, & @@ -181,9 +181,9 @@ end subroutine ocn_analysis_setup_packages!}}} !*********************************************************************** ! -! routine ocn_analysis_read_init_streams +! routine ocn_analysis_bootstrap ! -!> \brief Setup packages for MPAS-Ocean analysis driver +!> \brief Bootstrap analysis members (pre-init configuration) !> \author Doug Jacobsen !> \date 10/08/2015 !> \details @@ -199,10 +199,13 @@ end subroutine ocn_analysis_setup_packages!}}} !> config_do_restart is true, and the input_stream will be read if config_do_restart is false. !> !> After this call, alarms on both streams are reset. +!> +!> Additionally, if a bootstrap subroutine has been defined properly for the +!> analysis member, it will be called here. ! !----------------------------------------------------------------------- - subroutine ocn_analysis_read_init_streams(domain, err)!{{{ + subroutine ocn_analysis_bootstrap(domain, err)!{{{ !----------------------------------------------------------------- ! @@ -252,7 +255,7 @@ subroutine ocn_analysis_read_init_streams(domain, err)!{{{ poolErrorLevel = mpas_pool_get_error_level() call mpas_pool_set_error_level(MPAS_POOL_SILENT) - call mpas_timer_start('analysis_read_init_streams', .false.) + call mpas_timer_start('analysis_bootstrap', .false.) call mpas_pool_get_config(domain % configs, 'config_do_restart', config_do_restart) @@ -265,6 +268,9 @@ subroutine ocn_analysis_read_init_streams(domain, err)!{{{ if ( config_AM_enable ) then timerName = trim(initReadTimerPrefix) // poolItr % memberName(1:nameLength) call mpas_timer_start(timerName, .false.) + + call ocn_bootstrap_analysis_members(domain, poolItr % memberName(1:nameLength), ierr=err) + configName = 'config_AM_' // poolItr % memberName(1:nameLength) // '_restart_stream' nullify(config_AM_restart_stream) call mpas_pool_get_config(domain % configs, configName, config_AM_restart_stream) @@ -321,11 +327,11 @@ subroutine ocn_analysis_read_init_streams(domain, err)!{{{ end if end do - call mpas_timer_stop('analysis_read_init_streams') + call mpas_timer_stop('analysis_bootstrap') call mpas_pool_set_error_level(poolErrorLevel) - end subroutine ocn_analysis_read_init_streams!}}} + end subroutine ocn_analysis_bootstrap!}}} !*********************************************************************** ! @@ -861,6 +867,41 @@ subroutine ocn_analysis_finalize(domain, err)!{{{ end subroutine ocn_analysis_finalize!}}} +!*********************************************************************** +! +! routine ocn_bootstrap_analysis_members +! +!> \brief Analysis member initialization driver +!> \author Doug Jacobsen +!> \date 07/01/2015 +!> \details +!> This private routine calls the correct init routine for each analysis member. +! +!----------------------------------------------------------------------- + subroutine ocn_bootstrap_analysis_members(domain, analysisMemberName, iErr)!{{{ + type (domain_type), intent(inout) :: domain !< Input: Domain information + character (len=*), intent(in) :: analysisMemberName !< Input: Name of analysis member + integer, intent(out) :: iErr !< Output: Error code + + integer :: nameLength, err_tmp + + iErr = 0 + err_tmp = 0 + + nameLength = len_trim(analysisMemberName) + + !if ( analysisMemberName(1:nameLength) == 'testComputeInterval' ) then + ! call ocn_bootstrap_test_compute_interval(domain, err_tmp) + if ( analysisMemberName(1:nameLength) == 'timeSeriesStats' ) then + call ocn_bootstrap_time_series_stats(domain, err_tmp) +! else if ( analysisMemberName(1:nameLength) == 'temPlate' ) then +! call ocn_init_TEM_PLATE(domain, err_tmp) + end if + + iErr = ior(iErr, err_tmp) + + end subroutine ocn_bootstrap_analysis_members!}}} + !*********************************************************************** ! ! routine ocn_init_analysis_members diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index 9ea1e88c69..6793f5f93d 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -34,7 +34,8 @@ module ocn_time_series_stats ! Public member functions !-------------------------------------------------------------------- - public :: ocn_init_time_series_stats, & + public :: ocn_bootstrap_time_series_stats, & + ocn_init_time_series_stats, & ocn_compute_time_series_stats, & ocn_restart_time_series_stats, & ocn_finalize_time_series_stats @@ -158,7 +159,52 @@ module ocn_time_series_stats !*********************************************************************** contains +!*********************************************************************** +! routine ocn_bootstrap_time_series_stats +! +!> \brief Bootstrap time_series_stats analysis member +!> \author Doug Jacobsen +!> \date 10/08/2015 +!> \details +!> This routine performs pre-init configuration of the analysis member. +!> Specifically, it ensures the streams used for this instance are correctly +!> configured. +!----------------------------------------------------------------------- +subroutine ocn_bootstrap_time_series_stats(domain, err)!{{{ + ! input variables + + ! input/output variables + type (domain_type), intent(inout) :: domain + + ! output variables + integer, intent(out) :: err !< Output: error flag + + ! local variables + integer :: v + character (len=StrKIND) :: instance ! TODO intent(in) + type (time_series_type) :: series + type (time_series_alarms_type), allocatable, dimension(:) :: alarms + + ! start procedure + err = 0 + + ! TODO placeholder for some unique ID if this code is replicated + instance = '' ! TODO to be passed in + + ! initial allocation of instance state for this AM from the namelist + call start_state(domain, instance, series, err) + + ! modify the output and restart streams for this AM instance + ! driver will do a restart read, after this, if necessary to fill values + call modify_stream(domain, instance, series, err) + ! clean up the instance memory + do v = 1, series % number_of_variables + deallocate(series % variables(v) % output_names) + end do + deallocate(series % variables) + deallocate(series % buffers) +end subroutine ocn_bootstrap_time_series_stats!}}} !*********************************************************************** ! routine ocn_init_time_series_stats @@ -166,8 +212,8 @@ module ocn_time_series_stats !> \brief Initialize MPAS-Ocean analysis member !> \author Jon Woodring !> \date September 1, 2015 -!> \details -!> This routine conducts all initializations required for the +!> \details +!> This routine conducts all initializations required for the !> MPAS-Ocean analysis member. !----------------------------------------------------------------------- subroutine ocn_init_time_series_stats(domain, err)!{{{ @@ -184,28 +230,26 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ character (len=StrKIND) :: instance ! TODO intent(in) type (time_series_type) :: series type (time_series_alarms_type), allocatable, dimension(:) :: alarms - + ! start procedure err = 0 ! TODO placeholder for some unique ID if this code is replicated instance = '' ! TODO to be passed in - ! get the basic configuration of this stream - call start_init(domain, instance, series, err) - - ! modify the output and restart streams and read restart - call modify_stream(domain, instance, series, err) + ! coming back from a potential restart read + ! get all of the state for this instance + call get_state(domain, instance, series) - ! get all of the timing and configuration + ! get all of the timing configurations from namelist allocate(alarms(series % number_of_buffers)) call get_alarms(domain, instance, series, alarms, err) - ! set all of the alarms and current flag state based on timers + ! set the values of the alarms and current flag states based on timers call set_alarms(domain, instance, series, alarms, err) deallocate(alarms) - ! clean up the memory + ! clean up the instance memory do v = 1, series % number_of_variables deallocate(series % variables(v) % output_names) end do @@ -214,14 +258,13 @@ subroutine ocn_init_time_series_stats(domain, err)!{{{ end subroutine ocn_init_time_series_stats!}}} - !*********************************************************************** ! routine ocn_compute_time_series_stats ! !> \brief Compute MPAS-Ocean analysis member !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> This routine conducts all computation required for this !> MPAS-Ocean analysis member. !----------------------------------------------------------------------- @@ -246,7 +289,7 @@ subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ ! TODO placeholder for some unique ID if this code is replicated instance = '' ! TODO to be passed in - ! get all of the state + ! get all of the state for this instance to be able to compute call get_state(domain, instance, series) ! update the counter @@ -254,14 +297,14 @@ subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ if (series % buffers(b) % accumulate_flag == 1) then if (series % buffers(b) % reset_flag == 1) then series % buffers(b) % counter = 1 - else + else series % buffers(b) % counter = series % buffers(b) % counter + 1 end if end if end do ! do all of the operations - do v = 1, series % number_of_variables + do v = 1, series % number_of_variables call typed_operate(domain % blocklist, & series % variables(v), & series % buffers, & @@ -271,7 +314,7 @@ subroutine ocn_compute_time_series_stats(domain, timeLevel, err)!{{{ ! do all of the time checking and flag setting call timer_checking(series, domain % clock, err) - ! clean up the memory + ! clean up the instance memory do v = 1, series % number_of_variables deallocate(series % variables(v) % output_names) end do @@ -287,7 +330,7 @@ end subroutine ocn_compute_time_series_stats!}}} !> \brief Save restart for MPAS-Ocean analysis member !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> This routine conducts computation required to save a restart state !> for the MPAS-Ocean analysis member. !----------------------------------------------------------------------- @@ -315,7 +358,7 @@ end subroutine ocn_restart_time_series_stats!}}} !> \brief Finalize MPAS-Ocean analysis member !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> This routine conducts all finalizations required for this !> MPAS-Ocean analysis member. !----------------------------------------------------------------------- @@ -345,7 +388,7 @@ end subroutine ocn_finalize_time_series_stats!}}} !> \brief Get all of the state for this instance. !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> This will allocate and fetch all of the state necessary for this !> instance that is being run. !----------------------------------------------------------------------- @@ -391,7 +434,7 @@ subroutine get_state(domain, instance, series) op_name = AVG_TOKEN else if (series % operation == MIN_OP) then op_name = MIN_TOKEN - else + else op_name = MAX_TOKEN end if @@ -402,7 +445,7 @@ subroutine get_state(domain, instance, series) allocate(series % variables(v) % output_names(series % number_of_buffers)) end do - ! + ! ! get the instance values for variables ! @@ -479,16 +522,16 @@ subroutine get_state(domain, instance, series) end subroutine get_state !*********************************************************************** -! routine start_init +! routine start_state ! !> \brief Begin the initialization of this analysis member !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> This will count the number of variables, number of buffers, and !> also get the stream name and operation strings. !----------------------------------------------------------------------- -subroutine start_init(domain, instance, series, err) +subroutine start_state(domain, instance, series, err) ! input variables character (len=StrKIND), intent(in) :: instance @@ -506,7 +549,7 @@ subroutine start_init(domain, instance, series, err) integer :: b, v type (field0DChar), pointer :: srcString, dstString type (field0DInteger), pointer :: srcInteger, dstInteger - + ! start procedure err = 0 @@ -514,8 +557,8 @@ subroutine start_init(domain, instance, series, err) storage_prefix = trim(FRAMEWORK_PREFIX) // trim(instance) ! - ! allocate some framework memory - ! + ! allocate some framework memory for instance state + ! ! number_of_variables call mpas_pool_get_field(domain % blocklist % allFields, & @@ -607,7 +650,7 @@ subroutine start_init(domain, instance, series, err) end do ! - ! duplicate memory for storing data in the framework + ! duplicate memory for storing AM instance state in the framework ! ! create variable space @@ -704,10 +747,13 @@ subroutine start_init(domain, instance, series, err) dstString % fieldName, series % buffers(b) % reset_alarm_ID, 1) ! - ! counter is not done here, because it is part of the restart stream + ! counter is not allocated here, because it is part of the restart stream, + ! and not just the internal AM state + ! + ! it is allocated in modify_stream ! end do -end subroutine start_init +end subroutine start_state @@ -717,7 +763,7 @@ end subroutine start_init !> \brief Remove existing variables and replace them with new ones !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> Given a stream name, this will remove the existing variables !> in a stream and replace them with similiarly named ones for !> their accumulation. It will also add xtime and optionally the mesh. @@ -764,11 +810,11 @@ subroutine modify_stream(domain, instance, series, err)!{{{ op_name = AVG_TOKEN else if (series % operation == MIN_OP) then op_name = MIN_TOKEN - else + else op_name = MAX_TOKEN end if - ! get the old field names + ! get the old field names call mpas_stream_mgr_begin_iteration(domain % streamManager, & output_stream_name, err) v = 1 @@ -777,8 +823,8 @@ subroutine modify_stream(domain, instance, series, err)!{{{ series % variables(v) % input_name = field_name v = v + 1 end do - - ! remove the old ones from the stream + + ! remove the old ones from the stream do v = 1, series % number_of_variables call mpas_stream_mgr_remove_field(domain % streamManager, & output_stream_name, series % variables(v) % input_name) @@ -788,11 +834,11 @@ subroutine modify_stream(domain, instance, series, err)!{{{ ! create memory and modify the stream ! - ! add xtime to the stream + ! add xtime to the output stream call mpas_stream_mgr_add_field(domain % streamManager, & output_stream_name, TIME_STREAM, ierr=err) - ! optionally add mesh to stream + ! optionally add mesh to output stream config = trim(namelist_prefix) // trim(ADD_MESH_SUFFIX) call mpas_pool_get_config(domain % configs, config, copy_mesh) if (copy_mesh) then @@ -808,13 +854,13 @@ subroutine modify_stream(domain, instance, series, err)!{{{ ! ensure restart stream is empty emptyRestartStream = .true. call mpas_stream_mgr_begin_iteration(domain % streamManager, streamID=restart_stream_name, ierr=err) - do while ( mpas_stream_mgr_get_next_field(domain % streamManager, streamID=restart_stream_name, fieldName=fieldName) ) + do while (mpas_stream_mgr_get_next_field(domain % streamManager, streamID=restart_stream_name, fieldName=fieldName) .and. emptyRestartStream) emptyRestartStream = .false. end do - if ( .not. emptyRestartStream ) then + if (.not. emptyRestartStream) then write(stderrUnit, *) 'ERROR: Stream named ''' // trim(restart_stream_name) // ''' is not empty, but is used in ' - write(stderrUnit, *) ' an instance of teh time series stats analysis member. This stream will be built' + write(stderrUnit, *) ' an instance of the time series stats analysis member. This stream will be built' write(stderrUnit, *) ' based on the contents of the ''' // trim(output_stream_name) // ''' stream.' write(stderrUnit, *) ' Please ensure it is empty in the streams file.' call mpas_dmpar_global_abort('ERROR: Misconfigured streams for time series stats analysis member.') @@ -843,12 +889,12 @@ subroutine modify_stream(domain, instance, series, err)!{{{ ! put it in the restart stream call mpas_stream_mgr_add_field(domain % streamManager, & restart_stream_name, dstReal % fieldName, ierr=err) - end do + end do ! set up the variables call mpas_stream_mgr_begin_iteration(domain % streamManager, & output_stream_name, err) - do v = 1, series % number_of_variables + do v = 1, series % number_of_variables ! get the info of the field call mpas_pool_get_field_info(domain % blocklist % allFields, & series % variables(v) % input_name, info) @@ -878,7 +924,7 @@ subroutine modify_stream(domain, instance, series, err)!{{{ series % variables(v) % output_names(b), & domain % blocklist % allFields) - ! add the field to the stream + ! add the field to the output stream call mpas_stream_mgr_add_field(domain % streamManager, & output_stream_name, series % variables(v) % output_names(b), ierr=err) @@ -888,10 +934,6 @@ subroutine modify_stream(domain, instance, series, err)!{{{ end do end do ! number_of_variables - ! add xtime to the restart - call mpas_stream_mgr_add_field(domain % streamManager, & - restart_stream_name, TIME_STREAM, ierr=err) - end subroutine modify_stream!}}} @@ -901,7 +943,7 @@ end subroutine modify_stream!}}} !> \brief Given an input name, create a cooresponding output name !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> Code to create consistent output names from input names. !----------------------------------------------------------------------- character (len=StrKIND) function output_naming & @@ -920,13 +962,13 @@ end function output_naming !> \brief Given an buffer number, create a cooresponding counter name !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> Code to create consistent counter names from buffer numbers. !----------------------------------------------------------------------- character (len=StrKIND) function counter_naming & (storage_prefix, buf_identifier) character (len=StrKIND), intent(in) :: storage_prefix, buf_identifier - + counter_naming = trim(storage_prefix) // trim(COUNTER_SUFFIX) // & trim(buf_identifier) end function counter_naming @@ -939,7 +981,7 @@ end function counter_naming !> \brief Read the namelist for timings !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> This will read the namelist and get the strings and set the clocks !> for the different timers to be used. The actual alarms are not set. !----------------------------------------------------------------------- @@ -970,7 +1012,7 @@ subroutine get_alarms(domain, instance, series, alarms, err) config = trim(namelist_prefix) // trim(REFERENCE_TIMES_SUFFIX) call mpas_pool_get_config(domain % configs, config, config_results) call set_times(series, alarms, domain % clock, START_TIMES, & - config_results, ok, err) + config_results, ok, err) ! order matters, don't reorder these following ones! ! it matters because times/intervals can be configured to be equal @@ -980,7 +1022,7 @@ subroutine get_alarms(domain, instance, series, alarms, err) config = trim(namelist_prefix) // trim(RESET_INTERVALS_SUFFIX) call mpas_pool_get_config(domain % configs, config, config_results) call set_times(series, alarms, domain % clock, RESET_INTERVALS, & - config_results, ok, err) + config_results, ok, err) if (.not. ok) then call mpas_dmpar_global_abort('Error: number of times in ' // & 'reset_intervals is not consistent with number of times ' // & @@ -992,7 +1034,7 @@ subroutine get_alarms(domain, instance, series, alarms, err) config = trim(namelist_prefix) // trim(REPEAT_INTERVALS_SUFFIX) call mpas_pool_get_config(domain % configs, config, config_results) call set_times(series, alarms, domain % clock, REPEAT_INTERVALS, & - config_results, ok, err) + config_results, ok, err) if (.not. ok) then call mpas_dmpar_global_abort('Error: number of times in ' // & 'repeat_intervals is not consistent with number of times ' // & @@ -1004,7 +1046,7 @@ subroutine get_alarms(domain, instance, series, alarms, err) config = trim(namelist_prefix) // trim(DURATION_INTERVALS_SUFFIX) call mpas_pool_get_config(domain % configs, config, config_results) call set_times(series, alarms, domain % clock, DURATION_INTERVALS, & - config_results, ok, err) + config_results, ok, err) if (.not. ok) then call mpas_dmpar_global_abort('Error: number of times in ' // & 'duration_intervals is not consistent with number of times ' // & @@ -1018,7 +1060,7 @@ subroutine get_alarms(domain, instance, series, alarms, err) do b = 1, series % number_of_buffers call mpas_interval_division(alarms(b) % start_time, & alarms(b) % repeat_interval, & - alarms(b) % reset_interval, n, rem) + alarms(b) % reset_interval, n, rem) if (n > 1 .or. (n == 1 .and. rem /= zero)) then write(stderrUnit,*) 'Warning: repeat_interval > ' // & @@ -1029,7 +1071,7 @@ subroutine get_alarms(domain, instance, series, alarms, err) call mpas_interval_division(alarms(b) % start_time, & alarms(b) % duration_interval, & - alarms(b) % repeat_interval, n, rem) + alarms(b) % repeat_interval, n, rem) if (n > 1 .or. (n == 1 .and. rem /= zero)) then write(stderrUnit,*) 'Warning: duration_interval > ' // & @@ -1048,7 +1090,7 @@ end subroutine get_alarms !> \brief Set the alarms based on the clocks !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> Alarms for the different timers are set, such that temporal !> window alarms are configured. !----------------------------------------------------------------------- @@ -1200,7 +1242,7 @@ end subroutine set_alarms !> \brief Walk a semicolon delimited string to find substrings !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> Walk a string delimited by semicolons and return the first substring !> from start index, and modify start to point at the next candidate. !----------------------------------------------------------------------- @@ -1226,12 +1268,12 @@ subroutine walk_string(next, substr, ok)!{{{ ok = i > 0 if (.not. ok) then return - end if + end if copy = trim(next(i:)) ! find the first semicolon and split i = scan(copy, ';') - + ! return that substring and the remainder if (i > 0) then substr = trim(copy(1:i-1)) @@ -1240,7 +1282,7 @@ subroutine walk_string(next, substr, ok)!{{{ substr = trim(copy) next = '' end if - + end subroutine walk_string!}}} @@ -1251,7 +1293,7 @@ end subroutine walk_string!}}} !> \brief Set a list of times !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> Walk a list of times delimited by spaces and set the time info !> for the buffer structure so that alarms can be set. !----------------------------------------------------------------------- @@ -1267,11 +1309,11 @@ subroutine set_times(series, alarms, clock, which, config, ok, err) ! output variables logical, intent(out) :: ok - integer, intent(out) :: err + integer, intent(out) :: err ! local variables character (len=StrKIND) :: next, time - integer :: b + integer :: b ! find the first time in the list next = config @@ -1312,7 +1354,7 @@ subroutine set_times(series, alarms, clock, which, config, ok, err) else call mpas_set_timeInterval(alarms(b) % reset_interval, & timeString=time, ierr=err) - end if + end if ! get the next time string call walk_string(next, time, ok) @@ -1330,7 +1372,7 @@ end subroutine set_times !> \brief Function to create a new field from an existing field !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> This routine conducts all initializations required for !> duplicating a field and adding it to the allFields pool. !----------------------------------------------------------------------- @@ -1340,7 +1382,7 @@ subroutine add_new_field(info, inname, outname, pool)!{{{ character (len=StrKIND), intent(in) :: inname, outname ! input/output variables - type (mpas_pool_type), intent(inout) :: pool + type (mpas_pool_type), intent(inout) :: pool ! output variables @@ -1378,21 +1420,21 @@ end subroutine add_new_field!}}} !*********************************************************************** -! routine timer_checking +! routine timer_checking ! !> \brief Timer functions to determine when to run !> \author Jon Woodring !> \date September 1, 2015 -!> \details -!> This routine conducts timer checking to determine if it -!> needs to run at this particular time. +!> \details +!> This routine conducts timer checking to determine if it +!> needs to run at this particular time. !----------------------------------------------------------------------- subroutine timer_checking(series, clock, err)!{{{ ! input variables ! input/output variables type (time_series_type), intent(inout) :: series - type (mpas_clock_type), intent(inout) :: clock + type (mpas_clock_type), intent(inout) :: clock ! output variables integer, intent(out) :: err @@ -1441,7 +1483,7 @@ subroutine timer_checking(series, clock, err)!{{{ ! turn off accumulation ! - ! duration needs to be >= 2 * compute_interval + ! duration needs to be >= 2 * compute_interval ! (a series can only be 2 or more) if (mpas_is_alarm_ringing(clock, & series % buffers(b) % duration_alarm_ID, ierr=err)) then @@ -1450,7 +1492,7 @@ subroutine timer_checking(series, clock, err)!{{{ series % buffers(b) % accumulate_flag = 0 end if - ! turn on accumulation + ! turn on accumulation ! (this is second, in case the duration and repeat ! overlaps on the same timer) if (mpas_is_alarm_ringing(clock, & @@ -1471,7 +1513,7 @@ end subroutine timer_checking!}}} !> \brief Do the operation, but switch on run-time type !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> Since we don't know the type of the array, we need to do some !> run-time type switching based on the type of the array. !----------------------------------------------------------------------- @@ -1501,7 +1543,7 @@ subroutine typed_operate(block, variable, buffers, operation)!{{{ call operate0r_min(block, variable, buffers) else call operate0r_max(block, variable, buffers) - end if + end if else if (info % nDims == 1) then if (operation == AVG_OP) then call operate1r_avg(block, variable, buffers) @@ -1509,7 +1551,7 @@ subroutine typed_operate(block, variable, buffers, operation)!{{{ call operate1r_min(block, variable, buffers) else call operate1r_max(block, variable, buffers) - end if + end if else if (info % nDims == 2) then if (operation == AVG_OP) then call operate2r_avg(block, variable, buffers) @@ -1517,7 +1559,7 @@ subroutine typed_operate(block, variable, buffers, operation)!{{{ call operate2r_min(block, variable, buffers) else call operate2r_max(block, variable, buffers) - end if + end if else if (info % nDims == 3) then if (operation == AVG_OP) then call operate3r_avg(block, variable, buffers) @@ -1525,7 +1567,7 @@ subroutine typed_operate(block, variable, buffers, operation)!{{{ call operate3r_min(block, variable, buffers) else call operate3r_max(block, variable, buffers) - end if + end if else if (info % nDims == 4) then if (operation == AVG_OP) then call operate4r_avg(block, variable, buffers) @@ -1533,7 +1575,7 @@ subroutine typed_operate(block, variable, buffers, operation)!{{{ call operate4r_min(block, variable, buffers) else call operate4r_max(block, variable, buffers) - end if + end if else if (operation == AVG_OP) then call operate5r_avg(block, variable, buffers) @@ -1541,9 +1583,9 @@ subroutine typed_operate(block, variable, buffers, operation)!{{{ call operate5r_min(block, variable, buffers) else call operate5r_max(block, variable, buffers) - end if + end if end if - else + else if (info % nDims == 0) then if (operation == AVG_OP) then call operate0i_avg(block, variable, buffers) @@ -1551,7 +1593,7 @@ subroutine typed_operate(block, variable, buffers, operation)!{{{ call operate0i_min(block, variable, buffers) else call operate0i_max(block, variable, buffers) - end if + end if else if (info % nDims == 1) then if (operation == AVG_OP) then call operate1i_avg(block, variable, buffers) @@ -1559,7 +1601,7 @@ subroutine typed_operate(block, variable, buffers, operation)!{{{ call operate1i_min(block, variable, buffers) else call operate1i_max(block, variable, buffers) - end if + end if else if (info % nDims == 2) then if (operation == AVG_OP) then call operate2i_avg(block, variable, buffers) @@ -1567,7 +1609,7 @@ subroutine typed_operate(block, variable, buffers, operation)!{{{ call operate2i_min(block, variable, buffers) else call operate2i_max(block, variable, buffers) - end if + end if else if (operation == AVG_OP) then call operate3i_avg(block, variable, buffers) @@ -1575,7 +1617,7 @@ subroutine typed_operate(block, variable, buffers, operation)!{{{ call operate3i_min(block, variable, buffers) else call operate3i_max(block, variable, buffers) - end if + end if end if end if end subroutine typed_operate!}}} @@ -1583,12 +1625,12 @@ end subroutine typed_operate!}}} !*********************************************************************** -! routine copy_field_X +! routine copy_field_X ! !> \brief Functions to create a new field from an existing field !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> This routine conducts initializations required for !> duplicating a field and adding it to the allFields pool based on type. !----------------------------------------------------------------------- @@ -1820,7 +1862,7 @@ end subroutine copy_field_3i!}}} !> \brief Series of subroutines to support operations on run-time types !> \author Jon Woodring !> \date September 1, 2015 -!> \details +!> \details !> These subroutines encapsulate the different opertions that can occur !> based on the run-time types. (This would likely be !> instantiated generics/templates in other languages.) @@ -1840,7 +1882,7 @@ subroutine operate0r_avg (start_block, variable, buffers) real (kind=RKIND), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -1857,18 +1899,18 @@ subroutine operate0r_avg (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else out_array = (out_array * & (buffers(b) % counter - 1) + in_array) & / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate0r_avg subroutine operate1r_avg (start_block, variable, buffers) @@ -1878,7 +1920,7 @@ subroutine operate1r_avg (start_block, variable, buffers) real (kind=RKIND), dimension(:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -1895,18 +1937,18 @@ subroutine operate1r_avg (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else out_array = (out_array * & (buffers(b) % counter - 1) + in_array) & / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate1r_avg subroutine operate2r_avg (start_block, variable, buffers) @@ -1916,7 +1958,7 @@ subroutine operate2r_avg (start_block, variable, buffers) real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -1933,18 +1975,18 @@ subroutine operate2r_avg (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else out_array = (out_array * & (buffers(b) % counter - 1) + in_array) & / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate2r_avg subroutine operate3r_avg (start_block, variable, buffers) @@ -1954,7 +1996,7 @@ subroutine operate3r_avg (start_block, variable, buffers) real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -1971,18 +2013,18 @@ subroutine operate3r_avg (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else out_array = (out_array * & (buffers(b) % counter - 1) + in_array) & / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate3r_avg subroutine operate4r_avg (start_block, variable, buffers) @@ -1992,7 +2034,7 @@ subroutine operate4r_avg (start_block, variable, buffers) real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2009,18 +2051,18 @@ subroutine operate4r_avg (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else out_array = (out_array * & (buffers(b) % counter - 1) + in_array) & / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate4r_avg subroutine operate5r_avg (start_block, variable, buffers) @@ -2030,7 +2072,7 @@ subroutine operate5r_avg (start_block, variable, buffers) real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2047,18 +2089,18 @@ subroutine operate5r_avg (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else out_array = (out_array * & (buffers(b) % counter - 1) + in_array) & / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate5r_avg subroutine operate0i_avg (start_block, variable, buffers) @@ -2068,7 +2110,7 @@ subroutine operate0i_avg (start_block, variable, buffers) integer, pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2085,18 +2127,18 @@ subroutine operate0i_avg (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else out_array = (out_array * & (buffers(b) % counter - 1) + in_array) & / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate0i_avg subroutine operate1i_avg (start_block, variable, buffers) @@ -2106,7 +2148,7 @@ subroutine operate1i_avg (start_block, variable, buffers) integer, dimension(:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2123,18 +2165,18 @@ subroutine operate1i_avg (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else out_array = (out_array * & (buffers(b) % counter - 1) + in_array) & / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate1i_avg subroutine operate2i_avg (start_block, variable, buffers) @@ -2144,7 +2186,7 @@ subroutine operate2i_avg (start_block, variable, buffers) integer, dimension(:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2161,18 +2203,18 @@ subroutine operate2i_avg (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else out_array = (out_array * & (buffers(b) % counter - 1) + in_array) & / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate2i_avg subroutine operate3i_avg (start_block, variable, buffers) @@ -2182,7 +2224,7 @@ subroutine operate3i_avg (start_block, variable, buffers) integer, dimension(:,:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2199,18 +2241,18 @@ subroutine operate3i_avg (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else out_array = (out_array * & (buffers(b) % counter - 1) + in_array) & / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate3i_avg subroutine operate0r_min (start_block, variable, buffers) @@ -2220,7 +2262,7 @@ subroutine operate0r_min (start_block, variable, buffers) real (kind=RKIND), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2237,18 +2279,18 @@ subroutine operate0r_min (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate0r_min subroutine operate1r_min (start_block, variable, buffers) @@ -2258,7 +2300,7 @@ subroutine operate1r_min (start_block, variable, buffers) real (kind=RKIND), dimension(:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2275,18 +2317,18 @@ subroutine operate1r_min (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate1r_min subroutine operate2r_min (start_block, variable, buffers) @@ -2296,7 +2338,7 @@ subroutine operate2r_min (start_block, variable, buffers) real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2313,18 +2355,18 @@ subroutine operate2r_min (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate2r_min subroutine operate3r_min (start_block, variable, buffers) @@ -2334,7 +2376,7 @@ subroutine operate3r_min (start_block, variable, buffers) real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2351,18 +2393,18 @@ subroutine operate3r_min (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate3r_min subroutine operate4r_min (start_block, variable, buffers) @@ -2372,7 +2414,7 @@ subroutine operate4r_min (start_block, variable, buffers) real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2389,18 +2431,18 @@ subroutine operate4r_min (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate4r_min subroutine operate5r_min (start_block, variable, buffers) @@ -2410,7 +2452,7 @@ subroutine operate5r_min (start_block, variable, buffers) real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2427,18 +2469,18 @@ subroutine operate5r_min (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate5r_min subroutine operate0i_min (start_block, variable, buffers) @@ -2448,7 +2490,7 @@ subroutine operate0i_min (start_block, variable, buffers) integer, pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2465,18 +2507,18 @@ subroutine operate0i_min (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate0i_min subroutine operate1i_min (start_block, variable, buffers) @@ -2486,7 +2528,7 @@ subroutine operate1i_min (start_block, variable, buffers) integer, dimension(:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2503,18 +2545,18 @@ subroutine operate1i_min (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate1i_min subroutine operate2i_min (start_block, variable, buffers) @@ -2524,7 +2566,7 @@ subroutine operate2i_min (start_block, variable, buffers) integer, dimension(:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2541,18 +2583,18 @@ subroutine operate2i_min (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate2i_min subroutine operate3i_min (start_block, variable, buffers) @@ -2562,7 +2604,7 @@ subroutine operate3i_min (start_block, variable, buffers) integer, dimension(:,:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2579,18 +2621,18 @@ subroutine operate3i_min (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; out_array = min(out_array, in_array) ; ! out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate3i_min subroutine operate0r_max (start_block, variable, buffers) @@ -2600,7 +2642,7 @@ subroutine operate0r_max (start_block, variable, buffers) real (kind=RKIND), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2617,18 +2659,18 @@ subroutine operate0r_max (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate0r_max subroutine operate1r_max (start_block, variable, buffers) @@ -2638,7 +2680,7 @@ subroutine operate1r_max (start_block, variable, buffers) real (kind=RKIND), dimension(:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2655,18 +2697,18 @@ subroutine operate1r_max (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate1r_max subroutine operate2r_max (start_block, variable, buffers) @@ -2676,7 +2718,7 @@ subroutine operate2r_max (start_block, variable, buffers) real (kind=RKIND), dimension(:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2693,18 +2735,18 @@ subroutine operate2r_max (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate2r_max subroutine operate3r_max (start_block, variable, buffers) @@ -2714,7 +2756,7 @@ subroutine operate3r_max (start_block, variable, buffers) real (kind=RKIND), dimension(:,:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2731,18 +2773,18 @@ subroutine operate3r_max (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate3r_max subroutine operate4r_max (start_block, variable, buffers) @@ -2752,7 +2794,7 @@ subroutine operate4r_max (start_block, variable, buffers) real (kind=RKIND), dimension(:,:,:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2769,18 +2811,18 @@ subroutine operate4r_max (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate4r_max subroutine operate5r_max (start_block, variable, buffers) @@ -2790,7 +2832,7 @@ subroutine operate5r_max (start_block, variable, buffers) real (kind=RKIND), dimension(:,:,:,:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2807,18 +2849,18 @@ subroutine operate5r_max (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate5r_max subroutine operate0i_max (start_block, variable, buffers) @@ -2828,7 +2870,7 @@ subroutine operate0i_max (start_block, variable, buffers) integer, pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2845,18 +2887,18 @@ subroutine operate0i_max (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate0i_max subroutine operate1i_max (start_block, variable, buffers) @@ -2866,7 +2908,7 @@ subroutine operate1i_max (start_block, variable, buffers) integer, dimension(:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2883,18 +2925,18 @@ subroutine operate1i_max (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate1i_max subroutine operate2i_max (start_block, variable, buffers) @@ -2904,7 +2946,7 @@ subroutine operate2i_max (start_block, variable, buffers) integer, dimension(:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2921,18 +2963,18 @@ subroutine operate2i_max (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate2i_max subroutine operate3i_max (start_block, variable, buffers) @@ -2942,7 +2984,7 @@ subroutine operate3i_max (start_block, variable, buffers) integer, dimension(:,:,:), pointer :: in_array, out_array integer :: b - type (block_type), pointer :: block + type (block_type), pointer :: block block => start_block do while (associated(block)) @@ -2959,18 +3001,18 @@ subroutine operate3i_max (start_block, variable, buffers) if (buffers(b) % reset_flag == 1) then out_array = in_array - else + else ! out_array = (out_array * & ! (buffers(b) % counter - 1) + in_array) & ! / buffers(b) % counter ; ! out_array = min(out_array, in_array) ; out_array = max(out_array, in_array) ; - end if - end do + end if + end do - block => block % next - end do + block => block % next + end do end subroutine operate3i_max end module ocn_time_series_stats diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index 460f2a7727..0abca0098f 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -156,7 +156,7 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ call MPAS_stream_mgr_read(domain % streamManager, streamID='input', ierr=err_tmp) end if - call ocn_analysis_read_init_streams(domain, err=err_tmp) + call ocn_analysis_bootstrap(domain, err=err_tmp) call mpas_timer_stop('io_read') call mpas_timer_start('reset_io_alarms', .false.) From ee0bf82b046274de150151069c1a986ee0ba392f Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Tue, 27 Oct 2015 14:16:28 -0600 Subject: [PATCH 0366/1724] Update time series stats default streams This commit updates the default streams for the time series stats analysis member to have type="output" rather than type="none". --- src/core_ocean/analysis_members/Registry_time_series_stats.xml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/core_ocean/analysis_members/Registry_time_series_stats.xml b/src/core_ocean/analysis_members/Registry_time_series_stats.xml index d9af949366..bb4df14214 100644 --- a/src/core_ocean/analysis_members/Registry_time_series_stats.xml +++ b/src/core_ocean/analysis_members/Registry_time_series_stats.xml @@ -120,7 +120,7 @@ From 6dbb947310b1e4d97db312de943afda01a46d9fd Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Tue, 27 Oct 2015 14:27:24 -0600 Subject: [PATCH 0367/1724] reapply: add forcing tracers to init streams fixes an issue with default namelist.ocean.init files not having appropriate namelist records available for forcing This is a bug fix following the accidental overwrite of work in PR at https://github.com/MPAS-Dev/MPAS/pull/542#issuecomment-151633670 by commit eb69775. --- src/core_ocean/Registry.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 2a0b51adb3..7919138ff9 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -585,7 +585,7 @@ possible_values="Any positive value" /> - + Date: Tue, 27 Oct 2015 20:13:59 -0600 Subject: [PATCH 0368/1724] Fixed totalCalvingFlux analaysis member and confirmed working correctly on idealized test case. --- src/core_landice/analysis_members/mpas_li_global_stats.F | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/core_landice/analysis_members/mpas_li_global_stats.F b/src/core_landice/analysis_members/mpas_li_global_stats.F index 399292d938..98e9532498 100644 --- a/src/core_landice/analysis_members/mpas_li_global_stats.F +++ b/src/core_landice/analysis_members/mpas_li_global_stats.F @@ -282,9 +282,7 @@ subroutine li_compute_global_stats(domain, memberName, timeLevel, err)!{{{ * areaCell(iCell) * basalMassBal(iCell) * scyr ! mass lass due do calving (kg yr^{-1}) - !SFP: These calculations need to be tested still - blockSumCalvingFlux = blockSumCalvingFlux + real(li_mask_is_floating_ice_int(cellMask(iCell)),RKIND) & - * areaCell(iCell) * calvingThickness(iCell) * config_ice_density / ( deltat * scyr ) + blockSumCalvingFlux = blockSumCalvingFlux + calvingThickness(iCell) * areaCell(iCell) * config_ice_density / ( deltat * scyr ) end do ! end loop over cells From 02118e94caa7cdef06fa4b52beeb0c41d6bbdfda Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Tue, 27 Oct 2015 22:09:31 -0600 Subject: [PATCH 0369/1724] clean up and extend the del4 operator for momentum. add a configure option to scale the div part of the del4 operator relative to the curl part. new parameter in hmix_del4 namelist record is config_mom_del4_div_factor with a default value of 1.0 other minor clean up: when possible, use dvEdge (instead of dcEdge/sqrt(3.0)). when dvEdge is very short, use 0.25 of dcEdge --- src/core_ocean/Registry.xml | 4 ++++ src/core_ocean/shared/mpas_ocn_vel_hmix_del4.F | 11 ++++++----- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 7919138ff9..efe55955a2 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -300,6 +300,10 @@ description="Coefficient for horizontal biharmonic operator on momentum." possible_values="any positive real" /> + Date: Wed, 28 Oct 2015 14:35:51 -0600 Subject: [PATCH 0370/1724] Removed the call to mpas_init_reconstruct when using the external FO dycore In a previous calving commit, I changed some logic in subroutine landice_init_block such that mpas_init_reconstruct would always be called (in anticipation of needing reconstruction coefficients for IR transport). This change was premature. At present, the periodic_hex grid generator does not set the attributes x_period and y_period. As a result, mpas_init_reconstruct dies with a seg fault when called with the periodic MISMIP mesh. Thanks for Matt Hoffman for help in sorting this out. With this commit, I went back to the old logic, such that the reconstruction routine is not called with the external FO dycore (unless certain config variables are explicitly set to 'true'). I re-ran a circular-shelf test case for calving and verified that the results have not changed. --- src/core_landice/mode_forward/mpas_li_core.F | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/src/core_landice/mode_forward/mpas_li_core.F b/src/core_landice/mode_forward/mpas_li_core.F index ecc5741c7c..0e9dcbbf15 100644 --- a/src/core_landice/mode_forward/mpas_li_core.F +++ b/src/core_landice/mode_forward/mpas_li_core.F @@ -170,7 +170,6 @@ function li_core_init(domain, startTimeStamp) result(err) !!! call mpas_tracer_advection_init(err_tmp) ! Calling signature may be incorrect here. !!! err = ior(err,err_tmp) - ! === ! === Initialize blocks === ! === @@ -187,7 +186,7 @@ function li_core_init(domain, startTimeStamp) result(err) err = ior(err, err_tmp) ! halo update for reconstruction coefficients - !WHL - Results on multiple processors may be incorrect without this update + ! Note: Results on multiple processors may be incorrect without this update call mpas_pool_get_field(meshPool, 'coeffs_reconstruct', coeffsReconstructField) call mpas_dmpar_exch_halo_field(coeffsReconstructField) @@ -738,15 +737,18 @@ subroutine landice_init_block(block, dminfo, err) !!! err = ior(err, err_tmp) ! Init for reconstruction of velocity - !WHL - Initialize the reconstruction regardless of the velocity solver, because - ! these coefficients will be needed later for IR transport. -!! if ( (trim(config_velocity_solver) == 'sia') .or. & -!! (trim(config_velocity_solver) == 'simple') .or. & -!! config_do_velocity_reconstruction_for_external_dycore .or. & -!! config_adaptive_timestep_include_DCFL) then + !TODO - Initialize the reconstruction regardless of the velocity solver, because + ! these coefficients will be needed in the future for IR transport. + ! For now, we avoid calling these subroutines when using the external FO solver, + ! because mpas_init_reconstruct fails with the MISMIP periodic mesh + ! (since x_period and y_period are not set properly). + if ( (trim(config_velocity_solver) == 'sia') .or. & + (trim(config_velocity_solver) == 'simple') .or. & + config_do_velocity_reconstruction_for_external_dycore .or. & + config_adaptive_timestep_include_DCFL) then call mpas_rbf_interp_initialize(meshPool) call mpas_init_reconstruct(meshPool) -!! endif + endif ! Initialize velocity solver !WHL - This is now after the call to mpas_init_reconstruct, so that the reconstruction coefficients are available. From 4f25287504f9538ec38baeaaa070e722044ebe54 Mon Sep 17 00:00:00 2001 From: toddringler Date: Wed, 28 Oct 2015 15:33:56 -0600 Subject: [PATCH 0371/1724] add divergence cell centers and relative vorticity at cell vertices to high frequency output --- .../Registry_high_frequency_output.xml | 6 ++++++ .../analysis_members/mpas_ocn_high_frequency_output.F | 10 +++++++++- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/src/core_ocean/analysis_members/Registry_high_frequency_output.xml b/src/core_ocean/analysis_members/Registry_high_frequency_output.xml index 2d34c49c4c..5505c31736 100644 --- a/src/core_ocean/analysis_members/Registry_high_frequency_output.xml +++ b/src/core_ocean/analysis_members/Registry_high_frequency_output.xml @@ -30,6 +30,12 @@ + + Date: Wed, 28 Oct 2015 15:48:01 -0600 Subject: [PATCH 0372/1724] Update analysis member templates based on restart capabilities This commit updates the analysis member templates in the testing infrastructure to have the correct namelist option names, given the recent modifications to analysis members to support restart / input capabilities. --- test_cases/ocean/templates/ocean/eliassen_palm.xml | 4 ++-- test_cases/ocean/templates/ocean/global_stats.xml | 2 +- test_cases/ocean/templates/ocean/high_frequency_output.xml | 2 +- .../ocean/templates/ocean/lagrangian_particle_tracking.xml | 4 +++- .../ocean/templates/ocean/layer_volume_weighted_averages.xml | 2 +- .../ocean/templates/ocean/meridional_heat_transport.xml | 2 +- test_cases/ocean/templates/ocean/mixed_layer_depths.xml | 2 +- test_cases/ocean/templates/ocean/okubo_weiss.xml | 2 +- .../ocean/templates/ocean/surface_area_weighted_averages.xml | 2 +- test_cases/ocean/templates/ocean/test_compute_interval.xml | 2 +- test_cases/ocean/templates/ocean/time_filters.xml | 4 ++-- test_cases/ocean/templates/ocean/time_series_stats.xml | 4 ++-- test_cases/ocean/templates/ocean/water_mass_census.xml | 2 +- test_cases/ocean/templates/ocean/zonal_mean.xml | 2 +- 14 files changed, 19 insertions(+), 17 deletions(-) diff --git a/test_cases/ocean/templates/ocean/eliassen_palm.xml b/test_cases/ocean/templates/ocean/eliassen_palm.xml index e7f63a99b2..d2b73d8322 100644 --- a/test_cases/ocean/templates/ocean/eliassen_palm.xml +++ b/test_cases/ocean/templates/ocean/eliassen_palm.xml @@ -2,10 +2,10 @@ - + + - diff --git a/test_cases/ocean/templates/ocean/global_stats.xml b/test_cases/ocean/templates/ocean/global_stats.xml index c66ef35455..7634c60cca 100644 --- a/test_cases/ocean/templates/ocean/global_stats.xml +++ b/test_cases/ocean/templates/ocean/global_stats.xml @@ -6,7 +6,7 @@ - + diff --git a/test_cases/ocean/templates/ocean/high_frequency_output.xml b/test_cases/ocean/templates/ocean/high_frequency_output.xml index 39e52a625c..a57f8d855d 100644 --- a/test_cases/ocean/templates/ocean/high_frequency_output.xml +++ b/test_cases/ocean/templates/ocean/high_frequency_output.xml @@ -2,7 +2,7 @@ - + diff --git a/test_cases/ocean/templates/ocean/lagrangian_particle_tracking.xml b/test_cases/ocean/templates/ocean/lagrangian_particle_tracking.xml index 490b5c9632..e9268dc21e 100644 --- a/test_cases/ocean/templates/ocean/lagrangian_particle_tracking.xml +++ b/test_cases/ocean/templates/ocean/lagrangian_particle_tracking.xml @@ -3,7 +3,9 @@ - + + + diff --git a/test_cases/ocean/templates/ocean/layer_volume_weighted_averages.xml b/test_cases/ocean/templates/ocean/layer_volume_weighted_averages.xml index 3c78379fc7..1d9d36e90e 100644 --- a/test_cases/ocean/templates/ocean/layer_volume_weighted_averages.xml +++ b/test_cases/ocean/templates/ocean/layer_volume_weighted_averages.xml @@ -4,7 +4,7 @@ - + diff --git a/test_cases/ocean/templates/ocean/meridional_heat_transport.xml b/test_cases/ocean/templates/ocean/meridional_heat_transport.xml index 53ebac9378..6f78ac8e70 100644 --- a/test_cases/ocean/templates/ocean/meridional_heat_transport.xml +++ b/test_cases/ocean/templates/ocean/meridional_heat_transport.xml @@ -4,7 +4,7 @@ - + diff --git a/test_cases/ocean/templates/ocean/mixed_layer_depths.xml b/test_cases/ocean/templates/ocean/mixed_layer_depths.xml index e774f7886b..44a756c513 100644 --- a/test_cases/ocean/templates/ocean/mixed_layer_depths.xml +++ b/test_cases/ocean/templates/ocean/mixed_layer_depths.xml @@ -2,7 +2,7 @@ - + diff --git a/test_cases/ocean/templates/ocean/okubo_weiss.xml b/test_cases/ocean/templates/ocean/okubo_weiss.xml index 9f15424f6d..92ef652358 100644 --- a/test_cases/ocean/templates/ocean/okubo_weiss.xml +++ b/test_cases/ocean/templates/ocean/okubo_weiss.xml @@ -4,7 +4,7 @@ - + diff --git a/test_cases/ocean/templates/ocean/surface_area_weighted_averages.xml b/test_cases/ocean/templates/ocean/surface_area_weighted_averages.xml index 44174f82ce..6ad412f1e7 100644 --- a/test_cases/ocean/templates/ocean/surface_area_weighted_averages.xml +++ b/test_cases/ocean/templates/ocean/surface_area_weighted_averages.xml @@ -4,7 +4,7 @@ - + diff --git a/test_cases/ocean/templates/ocean/test_compute_interval.xml b/test_cases/ocean/templates/ocean/test_compute_interval.xml index c565e716df..22e7db0b2d 100644 --- a/test_cases/ocean/templates/ocean/test_compute_interval.xml +++ b/test_cases/ocean/templates/ocean/test_compute_interval.xml @@ -4,7 +4,7 @@ - + diff --git a/test_cases/ocean/templates/ocean/time_filters.xml b/test_cases/ocean/templates/ocean/time_filters.xml index ae86c5fbca..474b6ea6c7 100644 --- a/test_cases/ocean/templates/ocean/time_filters.xml +++ b/test_cases/ocean/templates/ocean/time_filters.xml @@ -2,10 +2,10 @@ - + + - diff --git a/test_cases/ocean/templates/ocean/time_series_stats.xml b/test_cases/ocean/templates/ocean/time_series_stats.xml index fe0f3c774a..b779ee9280 100644 --- a/test_cases/ocean/templates/ocean/time_series_stats.xml +++ b/test_cases/ocean/templates/ocean/time_series_stats.xml @@ -4,8 +4,8 @@ - - + + diff --git a/test_cases/ocean/templates/ocean/water_mass_census.xml b/test_cases/ocean/templates/ocean/water_mass_census.xml index 7aafe9c3ad..645ea57880 100644 --- a/test_cases/ocean/templates/ocean/water_mass_census.xml +++ b/test_cases/ocean/templates/ocean/water_mass_census.xml @@ -2,7 +2,7 @@ - + diff --git a/test_cases/ocean/templates/ocean/zonal_mean.xml b/test_cases/ocean/templates/ocean/zonal_mean.xml index 2b986efde3..6c069eb9a9 100644 --- a/test_cases/ocean/templates/ocean/zonal_mean.xml +++ b/test_cases/ocean/templates/ocean/zonal_mean.xml @@ -4,7 +4,7 @@ - + From 4c2796ff2b2eeb8742283c388533cab000f7f5e1 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 28 Oct 2015 22:05:26 -0600 Subject: [PATCH 0373/1724] Replaced nCellsOnCell with nEdgesOnCell In the calving module, I had originally written a loop over nCellsOnCell. With this commit I am switching to the preferred field, nEdgesOnCell. --- src/core_landice/Registry.xml | 1 - src/core_landice/mode_forward/mpas_li_calving.F | 8 +++----- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index b8af5c77ba..feab344031 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -330,7 +330,6 @@ - diff --git a/src/core_landice/mode_forward/mpas_li_calving.F b/src/core_landice/mode_forward/mpas_li_calving.F index 21b5679ab0..7311ccb480 100644 --- a/src/core_landice/mode_forward/mpas_li_calving.F +++ b/src/core_landice/mode_forward/mpas_li_calving.F @@ -138,7 +138,7 @@ subroutine li_calve_ice(domain, deltat, err) integer, pointer :: nCells integer, dimension(:), pointer :: & - nCellsOnCell, & ! number of cells that border each cell + nEdgesOnCell, & ! number of cells that border each cell cellMask ! bit mask describing whether ice is floating, dynamically active, etc. integer, dimension(:), pointer :: & @@ -207,7 +207,7 @@ subroutine li_calve_ice(domain, deltat, err) call mpas_pool_get_dimension(meshPool, 'nCells', nCells) ! get required fields from the mesh pool - call mpas_pool_get_array(meshPool, 'nCellsOnCell', nCellsOnCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) call mpas_pool_get_array(meshPool, 'indexToCellID', indexToCellID) ! diagnostic only @@ -338,9 +338,7 @@ subroutine li_calve_ice(domain, deltat, err) if (activeForCalvingMask(iCell) == 0) then ! inactive ! check whether any neighbor cells are active - !WHL - TODO - Add nCellsOnCell to circular shelf test case. For now, assume nCellsOnCell = 6 for all cells -!! do iCellOnCell = 1, nCellsOnCell(iCell) - do iCellOnCell = 1, 6 + do iCellOnCell = 1, nEdgesOnCell(iCell) iCellNeighbor = cellsOnCell(iCellOnCell,iCell) if (activeForCalvingMask(iCellNeighbor) == 1) then ! neighbor cell is active inactiveMarginMask(iCell) = 1 From d5378ce366436c2454c402e8836aa7095a322a00 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Thu, 29 Oct 2015 08:34:55 -0600 Subject: [PATCH 0374/1724] Remove wind stress diag variables The variables windStressZonalDiag windStressMeridionalDiag were removed from the code in V3, but were kept in the Registry by mistake. They are not connected to anything. In stand-alone mode, there is currently no way to see zonal and meridional versions of surface stress. The natural way to do that now is to put it in an analysis member. In ACME, one can look at the variables windStressZonal windStressMeridional --- src/core_ocean/Registry.xml | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 9437b0405b..a820f1cc6c 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1182,8 +1182,8 @@ - - + + @@ -1329,8 +1329,8 @@ - - + + @@ -2136,14 +2136,6 @@ description="CVMix/KPP: diagnosed surface friction velocity defined as square root of (mag(wind stress) / reference density)" packages="forwardMode;analysisMode" /> - - Date: Tue, 27 Oct 2015 13:50:46 -0600 Subject: [PATCH 0375/1724] Modified interface to pass physical parameters Namely we are passing: * gravity * ice_density * ocean_density * sea_level * flowParamA (the default scalar config value, not the field) * enhancementFactor * flowLawExponent * dynamic_thickness At the moment sea_level, enhancementFactor and dynamic_thickness are not used by the velocity solver. --- .../Interface_velocity_solver.cpp | 17 ++++++++------- .../Interface_velocity_solver.hpp | 6 ++++-- .../mode_forward/mpas_li_velocity_external.F | 21 +++++++++++++++---- 3 files changed, 30 insertions(+), 14 deletions(-) diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.cpp b/src/core_landice/mode_forward/Interface_velocity_solver.cpp index dcc7f86790..482bcf0b8c 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.cpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.cpp @@ -37,10 +37,9 @@ std::vector xCellProjected, yCellProjected, zCellProjected; const double unit_length = 1000; const double T0 = 273.15; const double secondsInAYear = 31536000.0; // This may vary slightly in MPAS, but this should be close enough for how this is used. -const double minThick = 1e-3; //1m +double minThickness = 1e-3; //[km] const double minBeta = 1e-5; double rho_ice; -double rho_ocean; //unsigned char dynamic_ice_bit_value; //unsigned char ice_present_bit_value; int dynamic_ice_bit_value; @@ -86,12 +85,14 @@ int velocity_solver_init_mpi(int* fComm) { } -void velocity_solver_set_parameters(double const* rhoi_F, /*double const* rhoo_F,*/ int const* li_mask_ValueDynamicIce, int const* li_mask_ValueIce) { +void velocity_solver_set_parameters(double const* gravity_F, double const* ice_density_F, double const* ocean_density_F, double const* sea_level_F, double const* flowParamA_F, double const* enhancementFactor_F, + double const* flowLawExponent_F, double const* dynamic_thickness_F, int const* li_mask_ValueDynamicIce, int const* li_mask_ValueIce) { // This function sets parameter values used by MPAS on the C/C++ side - rho_ice = *rhoi_F; - //rho_ocean = *rhoo_F; + rho_ice = *ice_density_F; dynamic_ice_bit_value = *li_mask_ValueDynamicIce; ice_present_bit_value = *li_mask_ValueIce; + velocity_solver_set_physical_parameters__(*gravity_F, rho_ice, *ocean_density_F, *sea_level_F/unit_length, *flowParamA_F*std::pow(unit_length,4)*secondsInAYear, + *enhancementFactor_F, *flowLawExponent_F, *dynamic_thickness_F/unit_length); } @@ -101,7 +102,7 @@ void velocity_solver_export_2d_data(double const* lowerSurface_F, if (isDomainEmpty) return; #ifdef LIFEV - import2DFields(lowerSurface_F, thickness_F, beta_F, minThick); + import2DFields(lowerSurface_F, thickness_F, beta_F, minThickneess); velocity_solver_export_2d_data__(reducedComm, elevationData, thicknessData, betaData, indexToVertexID); #endif @@ -225,7 +226,7 @@ void velocity_solver_solve_l1l2(double const* lowerSurface_F, if (!isDomainEmpty) { std::vector temperatureData(nLayers * nVertices); - import2DFields(lowerSurface_F, thickness_F, beta_F, minThick); + import2DFields(lowerSurface_F, thickness_F, beta_F, minThickness); for (int index = 0; index < nVertices; index++) { int iCell = vertexToFCell[index]; @@ -351,7 +352,7 @@ void velocity_solver_solve_fo(double const* lowerSurface_F, - import2DFields(lowerSurface_F, thickness_F, beta_F, smb_F, minThick); + import2DFields(lowerSurface_F, thickness_F, beta_F, smb_F, minThickness); std::vector regulThk(thicknessData); for (int index = 0; index < nVertices; index++) diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.hpp b/src/core_landice/mode_forward/Interface_velocity_solver.hpp index 29cb521845..8da76629e5 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.hpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.hpp @@ -84,7 +84,8 @@ int velocity_solver_init_mpi(int* fComm); void velocity_solver_finalize(); -void velocity_solver_set_parameters(double const* rhoi_F, int const* li_mask_ValueDynamicIce, int const* li_mask_ValueIce); +void velocity_solver_set_parameters(double const* gravity_F, double const* ice_density_F, double const* ocean_density_F, double const* sea_level_F, double const* flowParamA_F, + double const* enhancementFactor_F, double const* flowLawExponent_F, double const* dynamic_thickness_F, int const* li_mask_ValueDynamicIce, int const* li_mask_ValueIce); void velocity_solver_init_l1l2(double const* levelsRatio); @@ -148,7 +149,8 @@ extern void velocity_solver_export_l1l2_velocity__(const std::vector& la #endif - +extern void velocity_solver_set_physical_parameters__(double const& gravity, double const& ice_density, double const& ocean_density, double const& sea_level, double const& flowParamA, + double const& enhancementFactor, double const& flowLawExponent, double const& dynamic_thickness); extern void velocity_solver_solve_fo__(int nLayers, int nGlobalVertices, int nGlobalTriangles, bool ordering, bool first_time_step, diff --git a/src/core_landice/mode_forward/mpas_li_velocity_external.F b/src/core_landice/mode_forward/mpas_li_velocity_external.F index 68b3d424e7..5ed9b7af71 100644 --- a/src/core_landice/mode_forward/mpas_li_velocity_external.F +++ b/src/core_landice/mode_forward/mpas_li_velocity_external.F @@ -22,6 +22,7 @@ module li_velocity_external use mpas_timer use li_setup use, intrinsic :: iso_c_binding + use mpas_constants, only: gravity implicit none private @@ -47,10 +48,13 @@ module li_velocity_external interface ! Note: Could add all interface routines to this interface... ! For now, just trying it with this new routine. - subroutine velocity_solver_set_parameters(config_ice_density, li_mask_ValueDynamicIce, li_mask_ValueIce) bind(C, name="velocity_solver_set_parameters") + subroutine velocity_solver_set_parameters(gravity, config_ice_density, config_ocean_density, config_sea_level, config_default_flowParamA, config_enhancementFactor, & + config_flowLawExponent, config_dynamic_thickness, li_mask_ValueDynamicIce, li_mask_ValueIce) bind(C, name="velocity_solver_set_parameters") use iso_c_binding, only: C_INT, C_DOUBLE + INTEGER(C_INT) :: li_mask_ValueDynamicIce, li_mask_ValueIce - REAL(C_DOUBLE) :: config_ice_density + REAL(C_DOUBLE) :: config_ice_density, config_ocean_density, config_sea_level, config_default_flowParamA, & + config_enhancementFactor, config_flowLawExponent, config_dynamic_thickness end subroutine velocity_solver_set_parameters end interface @@ -236,7 +240,8 @@ subroutine li_velocity_external_block_init(block, err) real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell, xVertex, yVertex, zVertex, areaTriangle real (kind=RKIND), pointer :: radius type (field1DInteger), pointer :: indexToCellIDField, indexToEdgeIDField, indexToVertexIDField - real (kind=RKIND), pointer :: config_ice_density + real (kind=RKIND), pointer :: config_ice_density, config_ocean_density, config_sea_level, config_default_flowParamA, & + config_enhancementFactor, config_flowLawExponent, config_dynamic_thickness ! halo exchange arrays integer, dimension(:), pointer :: sendCellsArray, & @@ -322,10 +327,18 @@ subroutine li_velocity_external_block_init(block, err) ! Set physical parameters needed on the other side call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) + call mpas_pool_get_config(liConfigs, 'config_ocean_density', config_ocean_density) + call mpas_pool_get_config(liConfigs, 'config_sea_level', config_sea_level) + call mpas_pool_get_config(liConfigs, 'config_default_flowParamA', config_default_flowParamA) + call mpas_pool_get_config(liConfigs, 'config_enhancementFactor', config_enhancementFactor) + call mpas_pool_get_config(liConfigs, 'config_flowLawExponent', config_flowLawExponent) + call mpas_pool_get_config(liConfigs, 'config_dynamic_thickness', config_dynamic_thickness) #if defined(USE_EXTERNAL_L1L2) || defined(USE_EXTERNAL_FIRSTORDER) || defined(USE_EXTERNAL_STOKES) - call velocity_solver_set_parameters(config_ice_density, li_mask_ValueAlbanyActive, li_mask_ValueIce) + call velocity_solver_set_parameters(gravity, config_ice_density, config_ocean_density, config_sea_level, config_default_flowParamA, config_enhancementFactor, & + config_flowLawExponent, config_dynamic_thickness, li_mask_ValueAlbanyActive, li_mask_ValueIce) #endif + ! === error check if (err > 0) then write (stderrUnit,*) "An error has occurred in li_velocity_external_block_init." From 0f21ef34e44a4c536dd876f6792b11bf4f38ee74 Mon Sep 17 00:00:00 2001 From: Mathew Maltrud Date: Thu, 24 Sep 2015 10:26:13 -0600 Subject: [PATCH 0376/1724] Initial implementation of the MPAS-O to columnized BGC module. --- .../mode_forward/mpas_ocn_forward_mode.F | 3 + src/core_ocean/shared/Makefile | 10 +- src/core_ocean/shared/mpas_ocn_tendency.F | 25 +- .../shared/mpas_ocn_tracer_ecosys.F | 902 ++++++++++++++++++ .../tracer_groups/Registry_ecosys.xml | 408 ++++++++ .../tracer_groups/Registry_tracers.xml | 1 + 6 files changed, 1347 insertions(+), 2 deletions(-) create mode 100755 src/core_ocean/shared/mpas_ocn_tracer_ecosys.F create mode 100755 src/core_ocean/tracer_groups/Registry_ecosys.xml diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index 878369e01d..e98423ef2c 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -58,6 +58,7 @@ module ocn_forward_mode use ocn_tracer_short_wave_absorption use ocn_tracer_nonlocalflux use ocn_tracer_advection + use ocn_tracer_ecosys use ocn_gm use ocn_high_freq_thickness_hmix_del2 @@ -212,6 +213,8 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ ierr = ior(ierr,err_tmp) call ocn_tracer_nonlocalflux_init(err_tmp) ierr = ior(ierr,err_tmp) + call ocn_tracer_ecosys_init(domain, err_tmp) + ierr = ior(ierr,err_tmp) call ocn_vmix_init(domain, err_tmp) ierr = ior(ierr, err_tmp) diff --git a/src/core_ocean/shared/Makefile b/src/core_ocean/shared/Makefile index 91f3d78a4c..9fdacbfcb0 100644 --- a/src/core_ocean/shared/Makefile +++ b/src/core_ocean/shared/Makefile @@ -42,6 +42,10 @@ OBJS = mpas_ocn_init_routines.o \ mpas_ocn_tracer_exponential_decay.o \ mpas_ocn_tracer_ideal_age.o \ mpas_ocn_tracer_TTD.o \ + mpas_ocn_tracer_ecosys.o \ + BGC_mod.o \ + BGC_parms.o \ + co2calc.o \ mpas_ocn_high_freq_thickness_hmix_del2.o \ mpas_ocn_tracer_surface_flux_to_tend.o \ mpas_ocn_test.o \ @@ -58,7 +62,7 @@ all: $(OBJS) mpas_ocn_init_routines.o: mpas_ocn_constants.o mpas_ocn_time_average.o mpas_ocn_diagnostics.o mpas_ocn_gm.o -mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_restoring.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_surface_bulk_forcing.o mpas_ocn_surface_land_ice_fluxes.o mpas_ocn_tracer_surface_flux_to_tend.o mpas_ocn_tracer_interior_restoring.o mpas_ocn_tracer_exponential_decay.o mpas_ocn_tracer_ideal_age.o mpas_ocn_tracer_TTD.o mpas_ocn_vmix.o mpas_ocn_constants.o +mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_restoring.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_surface_bulk_forcing.o mpas_ocn_surface_land_ice_fluxes.o mpas_ocn_tracer_surface_flux_to_tend.o mpas_ocn_tracer_interior_restoring.o mpas_ocn_tracer_exponential_decay.o mpas_ocn_tracer_ideal_age.o mpas_ocn_tracer_TTD.o mpas_ocn_vmix.o mpas_ocn_constants.o mpas_ocn_tracer_ecosys.o BGC_mod.o BGC_parms.o co2calc.o mpas_ocn_diagnostics_routines.o: mpas_ocn_constants.o @@ -154,6 +158,10 @@ mpas_ocn_forcing_restoring.o: mpas_ocn_constants.o mpas_ocn_sea_ice.o: mpas_ocn_constants.o +mpas_ocn_tracer_ecosys.o: BGC_mod.o + +BGC_mod.o: BGC_parms.o co2calc.o + clean: $(RM) *.o *.i *.mod *.f90 diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index 5e02242e0a..07f71babc2 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -41,6 +41,7 @@ module ocn_tendency use ocn_tracer_ideal_age use ocn_tracer_TTD use ocn_tracer_surface_flux_to_tend + use ocn_tracer_ecosys use ocn_thick_hadv use ocn_thick_vadv @@ -379,7 +380,7 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! scalar pointers integer :: nTracerGroup - integer, pointer :: nVertLevels, nEdges, nCellsSolve, indexTemperature + integer, pointer :: nVertLevels, nEdges, nCellsSolve, indexTemperature, indexSalinity logical, pointer :: config_disable_tr_all_tend, config_use_cvmix_kpp logical, pointer :: config_use_tracerGroup, config_use_tracerGroup_surface_bulk_forcing, config_use_tracerGroup_surface_restoring, & config_use_tracerGroup_interior_restoring, config_use_tracerGroup_exponential_decay, config_use_tracerGroup_idealAge_forcing, & @@ -413,6 +414,9 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me real (kind=RKIND), dimension(:,:,:), pointer :: & tracerGroup, tracerGroupTend, vertNonLocalFlux + real (kind=RKIND), dimension(:,:,:), pointer :: & + activeTracers ! need T, S for ecosys + real (kind=RKIND), dimension(:,:,:), pointer :: tracerGroupInteriorRestoringRate, tracerGroupInteriorRestoringValue ! @@ -454,6 +458,7 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', indexSalinity) ! ! get configure options @@ -548,6 +553,24 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me call mpas_timer_stop("bulk_" // trim(groupItr % memberName)) end if + ! + ! compute ecosystem source-sink tendencies and net surface fluxes + ! NOTE: must be called before ocn_tracer_surface_flux_tend + ! + if ( trim(groupItr % memberName) == 'ecosysTracers' ) then + call mpas_timer_start("ecosys source-sink", .false.) + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) + call ocn_tracer_ecosys_compute(activeTracers, tracerGroup, forcingPool, nTracerGroup, & + nCellsSolve, maxLevelCell, nVertLevels, layerThickness, zMid, indexTemperature, & + indexSalinity, tracerGroupTend, err) + call mpas_timer_stop("ecosys source-sink") + + call mpas_timer_start("ecosys surface flux", .false.) + call ocn_tracer_ecosys_surface_flux_compute(activeTracers, tracerGroup, forcingPool, & + nTracerGroup, nCellsSolve, zMid, indexTemperature, indexSalinity, tracerGroupSurfaceFlux, err)!{{{ + call mpas_timer_stop("ecosys surface flux") + endif + ! ! ocean surface restoring ! diff --git a/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F b/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F new file mode 100755 index 0000000000..953f8bd1ee --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F @@ -0,0 +1,902 @@ +! copyright (c) 2013, los alamos national security, llc (lans) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tracer_ecosys +! +!> \brief MPAS ocean ecosys +!> \author Mathew Maltrud +!> \date 08/24/2015 +!> \details +!> This module contains routines for computing tracer forcing due to ecosys +! +!----------------------------------------------------------------------- + +module ocn_tracer_ecosys + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use ocn_constants + + use BGC_mod + use BGC_parms + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_tracer_ecosys_compute, & + ocn_tracer_ecosys_surface_flux_compute, & + ocn_tracer_ecosys_init + + integer, public:: & + numColumnsMax + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! name the necessary BGC derived types +! all of these are defined in BGC_mod +!----------------------------------------------------------------------- + +! autotroph_cnt comes from BGC_parms module + type(autotroph_type), dimension(autotroph_cnt), public :: autotrophs + type(BGC_indices_type) , public :: BGC_indices + type(BGC_input_type) , public :: BGC_input + type(BGC_forcing_type) , public :: BGC_forcing + type(BGC_output_type) , public :: BGC_output + type(BGC_diagnostics_type), public :: BGC_diagnostic_fields + type(BGC_flux_diagnostics_type), public :: BGC_flux_diagnostic_fields + +! hold indices in tracer pool corresponding to each eco tracer array + type(BGC_indices_type) :: ecosysIndices + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_tracer_ecosys_compute +! +!> \brief computes a tracer tendency due to ecosys +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine computes a tracer tendency due to ecosys +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_ecosys_compute(activeTracers, ecosysTracers, forcingPool, nTracers, nCellsSolve, & + maxLevelCell, nVertLevels, layerThickness, zMid, indexTemperature, indexSalinity, ecosysTracersTend, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + ! one dimensional arrays + integer, dimension(:), intent(in) :: & + maxLevelCell + + ! two dimensional arrays + real (kind=RKIND), dimension(:,:), intent(in) :: & + zMid, layerThickness + + ! three dimensional arrays + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + ecosysTracers + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + activeTracers + + ! scalars + integer, intent(in) :: nTracers, nCellsSolve, nVertLevels, indexTemperature, indexSalinity + + type (mpas_pool_type), intent(inout) :: forcingPool + + ! + ! two dimensional pointers + ! + real (kind=RKIND), dimension(:), pointer :: & + dust_FLUX_IN, PAR_surface, shortWaveHeatFlux + + ! two dimensional arrays + real (kind=RKIND), dimension(:,:), pointer :: & + PH_PREV_3D, PH_PREV_ALT_CO2_3D, FESEDFLUX + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:,:), intent(inout) :: & + ecosysTracersTend + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: ecosysAuxiliary ! additional forcing fields + + real (kind=RKIND) :: zTop, zBot, convertLengthScale = 1.0_RKIND + + integer :: iCell, iLevel, iTracer, numColumns, column + + err = 0 + + call mpas_pool_get_subpool(forcingPool, 'ecosysAuxiliary', ecosysAuxiliary) + + call mpas_pool_get_array(ecosysAuxiliary, 'PH_PREV_3D', PH_PREV_3D) + call mpas_pool_get_array(ecosysAuxiliary, 'PH_PREV_ALT_CO2_3D', PH_PREV_ALT_CO2_3D) + call mpas_pool_get_array(ecosysAuxiliary, 'FESEDFLUX', FESEDFLUX) + call mpas_pool_get_array(ecosysAuxiliary, 'dust_FLUX_IN', dust_FLUX_IN) + call mpas_pool_get_array(ecosysAuxiliary, 'PAR_surface', PAR_surface) + + call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) + + numColumns = 1 + do iCell=1,nCellsSolve + BGC_input%number_of_active_levels(column) = maxLevelCell(iCell) + BGC_forcing%dust_FLUX_IN(column) = dust_FLUX_IN(iCell) + BGC_forcing%ShortWaveFlux_surface(column) = shortWaveHeatFlux(iCell) + zTop = 0.0_RKIND + do iLevel=1,maxLevelCell(iCell) + BGC_input%PotentialTemperature(iLevel,iCell) = activeTracers(indexTemperature,iLevel,iCell) + BGC_input%Salinity(iLevel,iCell) = activeTracers(indexSalinity,iLevel,iCell) + BGC_input%cell_center_depth(iLevel,iCell) = zMid(iLevel,iCell)*convertLengthScale + BGC_input%cell_thickness(iLevel,iCell) = layerThickness(iLevel,iCell)*convertLengthScale + zBot = zTop - layerThickness(iLevel,iCell) + BGC_input%cell_bottom_depth(iLevel,iCell) = zBot*convertLengthScale + zTop = zBot + + BGC_output%PH_PREV_3D(iLevel,iCell) = PH_PREV_3D(iLevel,iCell) + BGC_output%PH_PREV_ALT_CO2_3D(iLevel,iCell) = PH_PREV_ALT_CO2_3D(iLevel,iCell) + + BGC_forcing%FESEDFLUX(iLevel,iCell) = FESEDFLUX(iLevel,iCell) + BGC_forcing%NUTR_RESTORE_RTAU(iLevel,iCell) = 0.0_RKIND + BGC_forcing%NO3_CLIM(iLevel,iCell) = 0.0_RKIND + BGC_forcing%PO4_CLIM(iLevel,iCell) = 0.0_RKIND + BGC_forcing%SiO3_CLIM(iLevel,iCell) = 0.0_RKIND + +!maltrud NOT GOING TO WORK--do each separately +! do iTracer=1,nTracers +! BGC_input%BGC_tracers(iLevel,iCell,iTracer) = ecosysTracers(iTracer,iLevel,iCell) +! enddo + + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%po4_ind) = ecosysTracers(ecosysIndices%po4_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%no3_ind) = ecosysTracers(ecosysIndices%no3_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%sio3_ind) = ecosysTracers(ecosysIndices%sio3_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%nh4_ind) = ecosysTracers(ecosysIndices%nh4_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%fe_ind) = ecosysTracers(ecosysIndices%fe_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%o2_ind) = ecosysTracers(ecosysIndices%o2_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%dic_ind) = ecosysTracers(ecosysIndices%dic_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%dic_alt_co2_ind) = ecosysTracers(ecosysIndices%dic_alt_co2_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%alk_ind) = ecosysTracers(ecosysIndices%alk_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%doc_ind) = ecosysTracers(ecosysIndices%doc_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%don_ind) = ecosysTracers(ecosysIndices%don_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%dofe_ind) = ecosysTracers(ecosysIndices%dofe_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%dop_ind) = ecosysTracers(ecosysIndices%dop_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%donr_ind) = ecosysTracers(ecosysIndices%donr_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%dopr_ind) = ecosysTracers(ecosysIndices%dopr_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%zooC_ind) = ecosysTracers(ecosysIndices%zooC_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%spC_ind) = ecosysTracers(ecosysIndices%spC_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%spChl_ind) = ecosysTracers(ecosysIndices%spChl_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%spFe_ind) = ecosysTracers(ecosysIndices%spFe_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%spCaCO3_ind) = ecosysTracers(ecosysIndices%spCaCO3_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diatC_ind) = ecosysTracers(ecosysIndices%diatC_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diatChl_ind) = ecosysTracers(ecosysIndices%diatChl_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diatFe_ind) = ecosysTracers(ecosysIndices%diatFe_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diatSi_ind) = ecosysTracers(ecosysIndices%diatSi_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%phaeoC_ind) = ecosysTracers(ecosysIndices%phaeoC_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%phaeoChl_ind) = ecosysTracers(ecosysIndices%phaeoChl_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%phaeoFe_ind) = ecosysTracers(ecosysIndices%phaeoFe_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diazC_ind) = ecosysTracers(ecosysIndices%diazC_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diazChl_ind) = ecosysTracers(ecosysIndices%diazChl_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diazFe_ind) = ecosysTracers(ecosysIndices%diazFe_ind,iLevel,iCell) + + enddo ! iLevel + + call BGC_SourceSink(autotrophs, BGC_indices, BGC_input, BGC_forcing, & + BGC_output, BGC_diagnostic_fields, nVertLevels, & + numColumnsMax, numColumns) + + do iLevel=1,maxLevelCell(iCell) + + ecosysTracersTend(ecosysIndices%po4_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%po4_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%po4_ind) + ecosysTracersTend(ecosysIndices%no3_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%no3_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%no3_ind) + ecosysTracersTend(ecosysIndices%sio3_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%sio3_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%sio3_ind) + ecosysTracersTend(ecosysIndices%nh4_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%nh4_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%nh4_ind) + ecosysTracersTend(ecosysIndices%fe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%fe_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%fe_ind) + ecosysTracersTend(ecosysIndices%o2_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%o2_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%o2_ind) + ecosysTracersTend(ecosysIndices%dic_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dic_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%dic_ind) + ecosysTracersTend(ecosysIndices%dic_alt_co2_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dic_alt_co2_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%dic_alt_co2_ind) + ecosysTracersTend(ecosysIndices%alk_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%alk_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%alk_ind) + ecosysTracersTend(ecosysIndices%doc_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%doc_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%doc_ind) + ecosysTracersTend(ecosysIndices%don_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%don_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%don_ind) + ecosysTracersTend(ecosysIndices%dofe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dofe_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%dofe_ind) + ecosysTracersTend(ecosysIndices%dop_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dop_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%dop_ind) + ecosysTracersTend(ecosysIndices%dopr_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dopr_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%dopr_ind) + ecosysTracersTend(ecosysIndices%donr_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%donr_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%donr_ind) + ecosysTracersTend(ecosysIndices%zooC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%zooC_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%zooC_ind) + ecosysTracersTend(ecosysIndices%spC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%spC_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%spC_ind) + ecosysTracersTend(ecosysIndices%spChl_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%spChl_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%spChl_ind) + ecosysTracersTend(ecosysIndices%spFe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%spFe_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%spFe_ind) + ecosysTracersTend(ecosysIndices%spCaCO3_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%spCaCO3_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%spCaCO3_ind) + ecosysTracersTend(ecosysIndices%diatC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diatC_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diatC_ind) + ecosysTracersTend(ecosysIndices%diatChl_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diatChl_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diatChl_ind) + ecosysTracersTend(ecosysIndices%diatFe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diatFe_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diatFe_ind) + ecosysTracersTend(ecosysIndices%diatSi_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diatSi_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diatSi_ind) + ecosysTracersTend(ecosysIndices%diazC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diazC_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diazC_ind) + ecosysTracersTend(ecosysIndices%diazChl_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diazChl_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diazChl_ind) + ecosysTracersTend(ecosysIndices%diazFe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diazFe_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diazFe_ind) + ecosysTracersTend(ecosysIndices%phaeoC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%phaeoC_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%phaeoC_ind) + ecosysTracersTend(ecosysIndices%phaeoChl_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%phaeoChl_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%phaeoChl_ind) + ecosysTracersTend(ecosysIndices%phaeoFe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%phaeoFe_ind,iLevel,iCell) & + + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%phaeoFe_ind) + + PH_PREV_3D(iLevel,iCell) = BGC_output%PH_PREV_3D(iLevel,iCell) + PH_PREV_ALT_CO2_3D(iLevel,iCell) = BGC_output%PH_PREV_ALT_CO2_3D(iLevel,iCell) + + enddo + + enddo ! iCell + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_ecosys_compute!}}} + +!*********************************************************************** +! +! routine ocn_tracer_ecosys_surface_flux_compute +! +!> \brief computes a tracer tendency due to ecosys +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine computes a tracer tendency due to ecosys +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_ecosys_surface_flux_compute(activeTracers, ecosysTracers, forcingPool, & + nTracers, nCellsSolve, zMid, indexTemperature, indexSalinity, ecosysSurfaceFlux, err)!{{{ + + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + ! two dimensional arrays + real (kind=RKIND), dimension(:,:), intent(in) :: & + zMid + real (kind=RKIND), dimension(:,:), intent(inout) :: & + ecosysSurfaceFlux + + ! three dimensional arrays + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + ecosysTracers + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + activeTracers + + ! scalars + integer, intent(in) :: nTracers, nCellsSolve, indexTemperature, indexSalinity + + type (mpas_pool_type), intent(inout) :: forcingPool + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: ecosysAuxiliary ! additional forcing fields + + integer :: numColumns, column, iCell, iTracer, iLevelSurface + +! input flux components in ecosysAuxiliary + real (kind=RKIND), dimension(:), pointer :: & + seaSurfacePressure, & + iceFraction, & + windSpeedSquared10m, & + depositionFluxNO3, & + depositionFluxNH4, & + IRON_FLUX_IN, & + riverFluxNO3, & + riverFluxPO4, & + riverFluxDON, & + riverFluxDONr, & + riverFluxDOP, & + riverFluxDOPr, & + riverFluxSiO3, & + riverFluxFe, & + riverFluxDIC, & + riverFluxDIC_ALT_CO2, & + riverFluxALK, & + riverFluxDOC, & + atmosphericCO2, & + atmosphericCO2_ALT_CO2 + +! specific output fluxes + real (kind=RKIND), dimension(:), pointer :: & + CO2_gas_flux, & + CO2_alt_gas_flux + +! input/output terms + real (kind=RKIND), dimension(:), pointer :: & + PH_PREV, & + PH_PREV_ALT_CO2 + + err = 0 + + call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) + call mpas_pool_get_array(forcingPool, 'iceFraction', iceFraction) + + call mpas_pool_get_subpool(forcingPool, 'ecosysAuxiliary', ecosysAuxiliary) + + call mpas_pool_get_array(ecosysAuxiliary, 'windSpeedSquared10m', windSpeedSquared10m) + call mpas_pool_get_array(ecosysAuxiliary, 'PH_PREV', PH_PREV) + call mpas_pool_get_array(ecosysAuxiliary, 'PH_PREV_ALT_CO2', PH_PREV_ALT_CO2) + call mpas_pool_get_array(ecosysAuxiliary, 'depositionFluxNO3', depositionFluxNO3) + call mpas_pool_get_array(ecosysAuxiliary, 'depositionFluxNH4', depositionFluxNH4) + call mpas_pool_get_array(ecosysAuxiliary, 'IRON_FLUX_IN', IRON_FLUX_IN) + call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxNO3', riverFluxNO3) + call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxPO4', riverFluxPO4) + call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDON', riverFluxDON) + call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDONr', riverFluxDONr) + call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDOP', riverFluxDOP) + call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDOPr', riverFluxDOPr) + call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxSiO3', riverFluxSiO3) + call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxFe', riverFluxFe) + call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDIC', riverFluxDIC) + call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDIC_ALT_CO2', riverFluxDIC_ALT_CO2) + call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxALK', riverFluxALK) + call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDOC', riverFluxDOC) + call mpas_pool_get_array(ecosysAuxiliary, 'atmosphericCO2', atmosphericCO2) + call mpas_pool_get_array(ecosysAuxiliary, 'atmosphericCO2_ALT_CO2', atmosphericCO2_ALT_CO2) + + call mpas_pool_get_array(ecosysAuxiliary, 'CO2_gas_flux', CO2_gas_flux) + call mpas_pool_get_array(ecosysAuxiliary, 'CO2_alt_gas_flux', CO2_alt_gas_flux) + + numColumns = 1 + column = 1 + iLevelSurface = 1 + do iCell=1,nCellsSolve + +! NOTE surface values of BGC_input%BGC_tracers were set in previous call to source-sink routine + + BGC_forcing%surfacePressure(column) = seaSurfacePressure(iCell) + BGC_forcing%iceFraction(column) = iceFraction(iCell) + BGC_forcing%windSpeedSquared10m(column) = windSpeedSquared10m(iCell) + BGC_forcing%atmCO2(column) = atmosphericCO2(column) + BGC_forcing%atmCO2_ALT_CO2(column) = atmosphericCO2_ALT_CO2(column) + BGC_forcing%surface_pH(column) = PH_PREV(iCell) + BGC_forcing%surface_pH_alt_co2(column) = PH_PREV_ALT_CO2(iCell) + BGC_forcing%surfaceDepth(column) = zMid(iLevelSurface,iCell) + BGC_forcing%SST(column) = activeTracers(indexTemperature,iLevelSurface,iCell) + BGC_forcing%SSS(column) = activeTracers(indexSalinity,iLevelSurface,iCell) + +!maltrud NOTE pass in total Fe and mult by parm_Fe_bioavail inside the flux routine +! divide river Fe by bioavail since it is already the available to make it total + + BGC_forcing%depositionFlux(column,BGC_indices%no3_ind) = depositionFluxNO3(iCell) + BGC_forcing%depositionFlux(column,BGC_indices%nh4_ind) = depositionFluxNH4(iCell) + BGC_forcing%depositionFlux(column,BGC_indices%fe_ind) = IRON_FLUX_IN(iCell) + + BGC_forcing%riverFlux(column,BGC_indices%no3_ind) = riverFluxNO3(iCell) + BGC_forcing%riverFlux(column,BGC_indices%po4_ind) = riverFluxPO4(iCell) + BGC_forcing%riverFlux(column,BGC_indices%don_ind) = riverFluxDON(iCell) * 0.9_BGC_r8 + BGC_forcing%riverFlux(column,BGC_indices%donr_ind) = riverFluxDONr(iCell) * 0.1_BGC_r8 + BGC_forcing%riverFlux(column,BGC_indices%dop_ind) = riverFluxDOP(iCell) * 0.975_BGC_r8 + BGC_forcing%riverFlux(column,BGC_indices%dopr_ind) = riverFluxDOPr(iCell) * 0.025_BGC_r8 + BGC_forcing%riverFlux(column,BGC_indices%sio3_ind) = riverFluxSiO3(iCell) + BGC_forcing%riverFlux(column,BGC_indices%fe_ind) = riverFluxFe(iCell) / parm_Fe_bioavail + BGC_forcing%riverFlux(column,BGC_indices%dic_ind) = riverFluxDIC(iCell) + BGC_forcing%riverFlux(column,BGC_indices%dic_alt_co2_ind) = riverFluxDIC(iCell) + BGC_forcing%riverFlux(column,BGC_indices%alk_ind) = riverFluxALK(iCell) + BGC_forcing%riverFlux(column,BGC_indices%doc_ind) = riverFluxDOC(iCell) + + call BGC_SurfaceFluxes(BGC_indices, BGC_input, BGC_forcing, & + BGC_flux_diagnostic_fields, & + numColumnsMax, column) + + PH_PREV(iCell) = BGC_forcing%surface_pH(column) + PH_PREV_ALT_CO2(iCell) = BGC_forcing%surface_pH_alt_co2(column) + + ecosysSurfaceFlux(ecosysIndices%no3_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%no3_ind) + ecosysSurfaceFlux(ecosysIndices%po4_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%po4_ind) + ecosysSurfaceFlux(ecosysIndices%sio3_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%sio3_ind) + ecosysSurfaceFlux(ecosysIndices%nh4_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%nh4_ind) + ecosysSurfaceFlux(ecosysIndices%don_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%don_ind) + ecosysSurfaceFlux(ecosysIndices%donr_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%donr_ind) + ecosysSurfaceFlux(ecosysIndices%dop_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%dop_ind) + ecosysSurfaceFlux(ecosysIndices%dopr_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%dopr_ind) + ecosysSurfaceFlux(ecosysIndices%fe_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%fe_ind) + ecosysSurfaceFlux(ecosysIndices%alk_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%alk_ind) + ecosysSurfaceFlux(ecosysIndices%doc_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%doc_ind) + ecosysSurfaceFlux(ecosysIndices%o2_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%o2_ind) + ecosysSurfaceFlux(ecosysIndices%dic_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%dic_ind) + ecosysSurfaceFlux(ecosysIndices%dic_alt_co2_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%dic_alt_co2_ind) + +!explicitly set the rest to 0 +! NOTE: some will not be zero when we get sea ice fluxes + ecosysSurfaceFlux(ecosysIndices%dofe_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%zooC_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%spC_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%spChl_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%spFe_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%spCaCO3_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%diatC_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%diatChl_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%diatFe_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%diatSi_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%diazC_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%diazChl_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%diazFe_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%phaeoC_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%phaeoChl_ind,iCell) = 0.0_RKIND + ecosysSurfaceFlux(ecosysIndices%phaeoFe_ind,iCell) = 0.0_RKIND + + CO2_gas_flux(iCell) = BGC_forcing%gasFlux(column,BGC_indices%dic_ind) + CO2_alt_gas_flux(iCell) = BGC_forcing%gasFlux(column,BGC_indices%dic_alt_co2_ind) + + enddo ! iCell + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_ecosys_surface_flux_compute!}}} + +!*********************************************************************** +! +! routine ocn_tracer_ecosys_init +! +!> \brief Initializes ocean surface restoring +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine initializes fields required for tracer surface flux restoring +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_ecosys_init(domain,err)!{{{ + +!NOTE: called from mpas_ocn_forward_mode.F + + type (domain_type), intent(inout) :: domain !< Input/Output: domain information + + integer, intent(out) :: err !< Output: error flag + + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tracersPool + + ! three dimensional pointers + real (kind=RKIND), dimension(:,:,:), pointer :: & + ecosysGroup + + ! scalars + integer :: nTracers, numColumnsMax + + ! scalar pointers + integer, pointer :: nVertLevels, index_dummy + + type (block_type), pointer :: block +!maltrud do we need the above? it is in cvmix but i think not used. + + + ! + ! get tracers pools + ! + + err = 0 + + ! + ! Get tracer group so we can get the number of tracers in it + ! + + call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_array(tracersPool, 'ecosysGRP', ecosysGroup) + nTracers = size(ecosysGroup, dim=1) + if (BGC_tracer_cnt /= nTracers) then + err = 1 + return + endif + + ! + ! pull nVertLevels out of the mesh structure + ! + + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nVertLevels', nVertLevels) + +!----------------------------------------------------------------------- +! initialize ecosystem parameters +!----------------------------------------------------------------------- + + allocate( BGC_indices%short_name(BGC_tracer_cnt) ) + allocate( BGC_indices%long_name(BGC_tracer_cnt) ) + allocate( BGC_indices%units(BGC_tracer_cnt) ) + +! no need to allocate the above fields for ecosysIndices (?) + +!----------------------------------------------------------------------- +! sets most of BGC parameters +! sets namelist defaults +! sets autotroph sp_ind, diat_ind, diaz_ind, phaeo_ind (swang) +!----------------------------------------------------------------------- + + call BGC_parms_init(BGC_indices, autotrophs) + +!maltrud modify autotroph values here.... +! for example to change sp_kFe +! autotrophs(BGC_indices%sp_ind)%kFe = 0.05e-3_BGC_r8 + +!maltrud how to handle this? + T0_Kelvin_BGC = T0_Kelvin + + ! + ! for now only do 1 column at a time + ! + numColumnsMax = 1 + + BGC_indices%po4_ind = 1 + BGC_indices%no3_ind = 2 + BGC_indices%sio3_ind = 3 + BGC_indices%nh4_ind = 4 + BGC_indices%fe_ind = 5 + BGC_indices%o2_ind = 6 + BGC_indices%dic_ind = 7 + BGC_indices%dic_alt_co2_ind = 8 + BGC_indices%alk_ind = 9 + BGC_indices%doc_ind = 10 + BGC_indices%don_ind = 11 + BGC_indices%dofe_ind = 12 + BGC_indices%dop_ind = 13 + BGC_indices%dopr_ind = 14 + BGC_indices%donr_ind = 15 + BGC_indices%zooC_ind = 16 + BGC_indices%spChl_ind = 17 + BGC_indices%spC_ind = 18 + BGC_indices%spFe_ind = 19 + BGC_indices%spCaCO3_ind = 20 + BGC_indices%diatChl_ind = 21 + BGC_indices%diatC_ind = 22 + BGC_indices%diatFe_ind = 23 + BGC_indices%diatSi_ind = 24 + BGC_indices%diazChl_ind = 25 + BGC_indices%diazC_ind = 26 + BGC_indices%diazFe_ind = 27 + BGC_indices%phaeoChl_ind = 28 + BGC_indices%phaeoC_ind = 29 + BGC_indices%phaeoFe_ind = 30 + + call mpas_pool_get_dimension(tracersPool, 'index_PO4', index_dummy) + ecosysIndices%po4_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_NO3', index_dummy) + ecosysIndices%no3_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_SiO3', index_dummy) + ecosysIndices%sio3_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_NH4', index_dummy) + ecosysIndices%nh4_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_Fe', index_dummy) + ecosysIndices%fe_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_O2', index_dummy) + ecosysIndices%o2_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DIC', index_dummy) + ecosysIndices%dic_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DIC_ALT_CO2', index_dummy) + ecosysIndices%dic_alt_co2_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_ALK', index_dummy) + ecosysIndices%alk_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DOC', index_dummy) + ecosysIndices%doc_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DON', index_dummy) + ecosysIndices%don_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DOFe', index_dummy) + ecosysIndices%dofe_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DOP', index_dummy) + ecosysIndices%dop_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DOPr', index_dummy) + ecosysIndices%dopr_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DONr', index_dummy) + ecosysIndices%donr_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_zooC', index_dummy) + ecosysIndices%zooC_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_spChl', index_dummy) + ecosysIndices%spChl_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_spC', index_dummy) + ecosysIndices%spC_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_spFe', index_dummy) + ecosysIndices%spFe_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_spCaCO3', index_dummy) + ecosysIndices%spCaCO3_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diatChl', index_dummy) + ecosysIndices%diatChl_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diatC', index_dummy) + ecosysIndices%diatC_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diatFe', index_dummy) + ecosysIndices%diatFe_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diatSi', index_dummy) + ecosysIndices%diatSi_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diazChl', index_dummy) + ecosysIndices%diazChl_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diazC', index_dummy) + ecosysIndices%diazC_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diazFe', index_dummy) + ecosysIndices%diazFe_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_phaeoChl', index_dummy) + ecosysIndices%phaeoChl_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_phaeoC', index_dummy) + ecosysIndices%phaeoC_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_phaeoFe', index_dummy) + ecosysIndices%phaeoFe_ind = index_dummy + +! BGC_init sets short and long names, units in BGC_indices +! also sets autotroph indices within the autotroph derived type + + call BGC_init(BGC_indices, autotrophs) + +!NOTES: + +!also check short_name with mpas variable name + +!----------------------------------------------------------------------- +! allocate input, forcing, diagnostic arrays +!----------------------------------------------------------------------- + + allocate ( BGC_input%BGC_tracers(nVertLevels, numColumnsMax, BGC_tracer_cnt) ) + allocate ( BGC_input%PotentialTemperature(nVertLevels, numColumnsMax) ) + allocate ( BGC_input%Salinity(nVertLevels, numColumnsMax) ) + allocate ( BGC_input%cell_center_depth(nVertLevels, numColumnsMax) ) + allocate ( BGC_input%cell_thickness(nVertLevels, numColumnsMax) ) + allocate ( BGC_input%cell_bottom_depth(nVertLevels, numColumnsMax) ) + allocate ( BGC_input%number_of_active_levels(numColumnsMax) ) + + allocate ( BGC_forcing%FESEDFLUX(nVertLevels, numColumnsMax) ) + allocate ( BGC_forcing%NUTR_RESTORE_RTAU(nVertLevels, numColumnsMax) ) + allocate ( BGC_forcing%NO3_CLIM(nVertLevels, numColumnsMax) ) + allocate ( BGC_forcing%PO4_CLIM(nVertLevels, numColumnsMax) ) + allocate ( BGC_forcing%SiO3_CLIM(nVertLevels, numColumnsMax) ) + + allocate ( BGC_forcing%dust_FLUX_IN(numColumnsMax) ) + allocate ( BGC_forcing%ShortWaveFlux_surface(numColumnsMax) ) + allocate ( BGC_forcing%surfacePressure(numColumnsMax) ) + allocate ( BGC_forcing%iceFraction(numColumnsMax) ) + allocate ( BGC_forcing%windSpeedSquared10m(numColumnsMax) ) + allocate ( BGC_forcing%atmCO2(numColumnsMax) ) + allocate ( BGC_forcing%atmCO2_ALT_CO2(numColumnsMax) ) + allocate ( BGC_forcing%surface_pH(numColumnsMax) ) + allocate ( BGC_forcing%surface_pH_alt_co2(numColumnsMax) ) + allocate ( BGC_forcing%surfaceDepth(numColumnsMax) ) + allocate ( BGC_forcing%SST(numColumnsMax) ) + allocate ( BGC_forcing%SSS(numColumnsMax) ) + + allocate ( BGC_forcing%depositionFlux(numColumnsMax, BGC_tracer_cnt) ) + allocate ( BGC_forcing%riverFlux(numColumnsMax, BGC_tracer_cnt) ) + allocate ( BGC_forcing%gasFlux(numColumnsMax, BGC_tracer_cnt) ) + allocate ( BGC_forcing%seaIceFlux(numColumnsMax, BGC_tracer_cnt) ) + allocate ( BGC_forcing%netFlux(numColumnsMax, BGC_tracer_cnt) ) + + allocate ( BGC_output%BGC_tendencies(nVertLevels, numColumnsMax, BGC_tracer_cnt) ) + allocate ( BGC_output%PH_PREV_3D(nVertLevels, numColumnsMax) ) + allocate ( BGC_output%PH_PREV_ALT_CO2_3D(nVertLevels, numColumnsMax) ) + + !--------------------------------------------------------------------------- + ! allocate flux diagnostic output fields + !--------------------------------------------------------------------------- + + allocate (BGC_flux_diagnostic_fields%pistonVel_O2(numColumnsMax) ) + allocate (BGC_flux_diagnostic_fields%pistonVel_CO2(numColumnsMax) ) + allocate (BGC_flux_diagnostic_fields%SCHMIDT_O2(numColumnsMax) ) + allocate (BGC_flux_diagnostic_fields%SCHMIDT_CO2(numColumnsMax) ) + allocate (BGC_flux_diagnostic_fields%O2SAT(numColumnsMax) ) + allocate (BGC_flux_diagnostic_fields%xkw(numColumnsMax) ) + allocate (BGC_flux_diagnostic_fields%co2star(numColumnsMax) ) + allocate (BGC_flux_diagnostic_fields%dco2star(numColumnsMax) ) + allocate (BGC_flux_diagnostic_fields%pco2surf(numColumnsMax) ) + allocate (BGC_flux_diagnostic_fields%dpco2(numColumnsMax) ) + allocate (BGC_flux_diagnostic_fields%co2star_alt_co2(numColumnsMax) ) + allocate (BGC_flux_diagnostic_fields%dco2star_alt_co2(numColumnsMax) ) + allocate (BGC_flux_diagnostic_fields%pco2surf_alt_co2(numColumnsMax) ) + allocate (BGC_flux_diagnostic_fields%dpco2_alt_co2(numColumnsMax) ) + + !--------------------------------------------------------------------------- + ! allocate diagnostic output fields + !--------------------------------------------------------------------------- + + ! 3D stuff + allocate (BGC_diagnostic_fields%diag_tot_Nfix(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_O2_PRODUCTION(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_O2_CONSUMPTION(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_AOU(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_PO4_RESTORE(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_NO3_RESTORE(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_SiO3_RESTORE(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_PAR_avg(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_POC_FLUX_IN(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_POC_PROD(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_POC_REMIN(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_POC_ACCUM(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_CaCO3_FLUX_IN(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_CaCO3_PROD(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_CaCO3_REMIN(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_SiO2_FLUX_IN(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_SiO2_PROD(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_SiO2_REMIN(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_dust_FLUX_IN(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_dust_REMIN(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_P_iron_FLUX_IN(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_P_iron_PROD(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_P_iron_REMIN(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_auto_graze_TOT(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_zoo_loss(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_photoC_TOT(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_photoC_NO3_TOT(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_DOC_prod(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_DOC_remin(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_DON_prod(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_DON_remin(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_DOFe_prod(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_DOFe_remin(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_DOP_prod(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_DOP_remin(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_Fe_scavenge(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_Fe_scavenge_rate(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_NITRIF(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_DENITRIF(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_DONr_remin(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_DOPr_remin(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_CO3(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_HCO3(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_H2CO3(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_pH_3D(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_CO3_ALT_CO2(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_HCO3_ALT_CO2(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_H2CO3_ALT_CO2(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_pH_3D_ALT_CO2(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_co3_sat_calc(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_co3_sat_arag(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_calcToSed(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_pocToSed(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_ponToSed(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_popToSed(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_bsiToSed(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_dustToSed(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_pfeToSed(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_SedDenitrif(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_OtherRemin(nVertLevels, numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_tot_CaCO3_form(nVertLevels, numColumnsMax) ) + +! 3D stuff for each autotroph + allocate (BGC_diagnostic_fields%diag_N_lim(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_P_lim(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_Fe_lim(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_SiO3_lim(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_light_lim(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_photoC(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_photoC_NO3(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_photoFe(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_photoNO3(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_photoNH4(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_DOP_uptake(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_PO4_uptake(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_auto_graze(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_auto_loss(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_auto_agg(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_bSi_form(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_CaCO3_form(nVertLevels, numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_Nfix(nVertLevels, numColumnsMax, autotroph_cnt) ) + +! 2D stuff for each autotroph + allocate (BGC_diagnostic_fields%diag_photoC_zint(numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_photoC_NO3_zint(numColumnsMax, autotroph_cnt) ) + allocate (BGC_diagnostic_fields%diag_CaCO3_form_zint(numColumnsMax, autotroph_cnt) ) + +! 2D vertical integrals for photoC + allocate (BGC_diagnostic_fields%diag_photoC_TOT_zint(numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_photoC_NO3_TOT_zint(numColumnsMax) ) + +! 2D vertical integrals for nutrients + allocate (BGC_diagnostic_fields%diag_Jint_Ctot(numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_Jint_100m_Ctot(numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_Jint_Ntot(numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_Jint_100m_Ntot(numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_Jint_Ptot(numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_Jint_100m_Ptot(numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_Jint_Sitot(numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_Jint_100m_Sitot(numColumnsMax) ) + +! 2D stuff + allocate (BGC_diagnostic_fields%diag_tot_bSi_form(numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_tot_CaCO3_form_zint(numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_zsatcalc(numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_zsatarag(numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_O2_ZMIN(numColumnsMax) ) + allocate (BGC_diagnostic_fields%diag_O2_ZMIN_DEPTH(numColumnsMax) ) + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_ecosys_init!}}} + +!*********************************************************************** + +end module ocn_tracer_ecosys + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/tracer_groups/Registry_ecosys.xml b/src/core_ocean/tracer_groups/Registry_ecosys.xml new file mode 100755 index 0000000000..a337cf929f --- /dev/null +++ b/src/core_ocean/tracer_groups/Registry_ecosys.xml @@ -0,0 +1,408 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/tracer_groups/Registry_tracers.xml b/src/core_ocean/tracer_groups/Registry_tracers.xml index bc28af3c36..68f3bf1dd1 100644 --- a/src/core_ocean/tracer_groups/Registry_tracers.xml +++ b/src/core_ocean/tracer_groups/Registry_tracers.xml @@ -1,3 +1,4 @@ #include "Registry_activeTracers.xml" #include "Registry_debugTracers.xml" +#include "Registry_ecosys.xml" //#include "Registry_TEMPLATEGRP.xml" From 1d9d9355a444e211b7e765e7d90f8c4b62679bd8 Mon Sep 17 00:00:00 2001 From: Mathew Maltrud Date: Thu, 1 Oct 2015 13:31:19 -0600 Subject: [PATCH 0377/1724] adding code for init mode creation of ecosys_column test case --- src/core_ocean/mode_init/Registry_ecosys.xml | 23 + .../mode_init/mpas_ocn_init_ecosys_column.F | 510 ++++++++++++++++++ 2 files changed, 533 insertions(+) create mode 100644 src/core_ocean/mode_init/Registry_ecosys.xml create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_ecosys_column.F diff --git a/src/core_ocean/mode_init/Registry_ecosys.xml b/src/core_ocean/mode_init/Registry_ecosys.xml new file mode 100644 index 0000000000..2109b2c13d --- /dev/null +++ b/src/core_ocean/mode_init/Registry_ecosys.xml @@ -0,0 +1,23 @@ + + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_ecosys_column.F b/src/core_ocean/mode_init/mpas_ocn_init_ecosys_column.F new file mode 100644 index 0000000000..fe8f00f6f2 --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_ecosys_column.F @@ -0,0 +1,510 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_ecosys_column +! +!> \brief MPAS ocean initialize case -- CVMix Unit Test +!> WSwSBF means Wind Stress with Surface Buoyancy Forcing +!> \author Todd Ringler +!> \date 04/23/2015 +!> \details +!> This module contains the routines for initializing the +!> the ecosys column test configuration. This in a +!> single column configuration +! +!----------------------------------------------------------------------- + +module ocn_init_ecosys_column + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + use mpas_io_streams + + use ocn_init_cell_markers + use ocn_init_vertical_grids + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_ecosys_column, & + ocn_init_setup_ecosys_read_column, & + ocn_init_validate_ecosys_column + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + type (field2DReal) :: columnIC + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_ecosys_column +! +!> \brief Setup for ecosys column test configuration +!> \author Todd Ringler +!> \date 04/23/2015 +!> \details +!> This routine sets up the initial conditions for the ecosys column test configuration. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_ecosys_column(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + type (block_type), pointer :: block_ptr + + type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool + type (mpas_pool_type), pointer :: diagnosticsPool, forcingPool + + type (mpas_pool_type), pointer :: tracersPool + + integer, pointer :: nVertLevels, nVertLevelsP1, nCellsSolve, index_dummy + + integer, dimension(:), pointer :: maxLevelCell + real (kind=RKIND), dimension(:), pointer :: refBottomDepth, refZMid, vertCoordMovementWeights + real (kind=RKIND), dimension(:), pointer :: bottomDepth + real (kind=RKIND), dimension(:, :), pointer :: layerThickness, restingThickness + real (kind=RKIND), dimension(:, :, :), pointer :: activeTracers, ecosysTracers + + real (kind=RKIND), dimension(:), pointer :: interfaceLocations + + real (kind=RKIND), allocatable, dimension(:,:) :: ecoFieldColumn + + integer :: iCell, iEdge, iVertex, iField, k, numTracersTotal, nVertLevelsInputColumn + + integer, allocatable, dimension(:) :: indexField + + character (len=StrKIND) :: fieldName + + character (len=StrKIND), pointer :: config_init_configuration, & + config_ecosys_column_TS_filename, & + config_ecosys_column_ecosys_filename, & + config_ecosys_column_vertical_grid + + integer, pointer :: config_ecosys_column_vert_levels + + real (kind=RKIND), pointer :: config_ecosys_column_bottom_depth + + ! assume no error + iErr = 0 + + ! get and test if this is the configuration specified + call mpas_pool_get_config(domain % configs, 'config_init_configuration', config_init_configuration) + if(config_init_configuration .ne. trim('ecosys_column')) return + + ! build the vertical grid + ! intent(out) is interfaceLocations. An array ranging from 0 to 1 + call mpas_pool_get_config(domain % configs, 'config_ecosys_column_vertical_grid', config_ecosys_column_vertical_grid) + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nVertLevelsP1', nVertLevelsP1) + allocate(interfaceLocations(nVertLevelsP1)) + call ocn_generate_vertical_grid(config_ecosys_column_vertical_grid, interfaceLocations) + + ! load the remaining configuration parameters + call mpas_pool_get_config(domain % configs, 'config_ecosys_column_bottom_depth', config_ecosys_column_bottom_depth) + call mpas_pool_get_config(domain % configs, 'config_ecosys_column_TS_filename', config_ecosys_column_TS_filename) + call mpas_pool_get_config(domain % configs, 'config_ecosys_column_ecosys_filename', config_ecosys_column_ecosys_filename) + call mpas_pool_get_config(domain % configs, 'config_ecosys_column_vert_levels', config_ecosys_column_vert_levels) + + nVertLevelsInputColumn = config_ecosys_column_vert_levels + + ! load data that required to initialize the ocean simulation + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + call mpas_pool_get_array(tracersPool, 'ecosysTracers', ecosysTracers, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + + ! Set refBottomDepth and refBottomDepthTopOfCell + do k = 1, nVertLevels + refBottomDepth(k) = config_ecosys_column_bottom_depth * interfaceLocations(k+1) + refZMid(k) = - 0.5_RKIND * config_ecosys_column_bottom_depth * (interfaceLocations(k) + interfaceLocations(k+1)) + end do + + ! Set vertCoordMovementWeights + vertCoordMovementWeights(:) = 1.0_RKIND + + if (nVertLevelsInputColumn /= nVertLevels) return + + numTracersTotal = 32 ! T,S + 30 eco + allocate(ecoFieldColumn(nVertLevelsInputColumn, numTracersTotal)) + allocate(indexField(numTracersTotal)) + + if ( associated(activeTracers) ) then + fieldName = 'temperature' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_TS_filename, & + nVertLevelsInputColumn, 1, ecoFieldColumn, iErr) + + fieldName = 'salinity' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_TS_filename, & + nVertLevelsInputColumn, 2, ecoFieldColumn, iErr) + + call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_dummy) + indexField(1) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_dummy) + indexField(2) = index_dummy + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + activeTracers(indexField(1), k, iCell) = ecoFieldColumn(k,1) + activeTracers(indexField(2), k, iCell) = ecoFieldColumn(k,2) + end do + end do + end if + + if ( associated(ecosysTracers) ) then + + fieldName = 'PO4' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 3, ecoFieldColumn, iErr) + fieldName = 'NO3' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 4, ecoFieldColumn, iErr) + fieldName = 'SiO3' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 5, ecoFieldColumn, iErr) + fieldName = 'NH4' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 6, ecoFieldColumn, iErr) + fieldName = 'Fe' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 7, ecoFieldColumn, iErr) + fieldName = 'O2' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 8, ecoFieldColumn, iErr) + fieldName = 'DIC' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 9, ecoFieldColumn, iErr) + fieldName = 'DIC_ALT_CO2' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 10, ecoFieldColumn, iErr) + fieldName = 'ALK' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 11, ecoFieldColumn, iErr) + fieldName = 'DOC' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 12, ecoFieldColumn, iErr) + fieldName = 'DON' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 13, ecoFieldColumn, iErr) + fieldName = 'DOFe' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 14, ecoFieldColumn, iErr) + fieldName = 'DOP' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 15, ecoFieldColumn, iErr) + fieldName = 'DOPr' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 16, ecoFieldColumn, iErr) + fieldName = 'DONr' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 17, ecoFieldColumn, iErr) + fieldName = 'zooC' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 18, ecoFieldColumn, iErr) + fieldName = 'spChl' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 19, ecoFieldColumn, iErr) + fieldName = 'spC' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 20, ecoFieldColumn, iErr) + fieldName = 'spFe' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 21, ecoFieldColumn, iErr) + fieldName = 'spCaCO3' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 22, ecoFieldColumn, iErr) + fieldName = 'diatChl' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 23, ecoFieldColumn, iErr) + fieldName = 'diatC' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 24, ecoFieldColumn, iErr) + fieldName = 'diatFe' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 25, ecoFieldColumn, iErr) + fieldName = 'diatSi' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 26, ecoFieldColumn, iErr) + fieldName = 'diazChl' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 27, ecoFieldColumn, iErr) + fieldName = 'diazC' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 28, ecoFieldColumn, iErr) + fieldName = 'diazFe' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 29, ecoFieldColumn, iErr) + fieldName = 'phaeoChl' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 30, ecoFieldColumn, iErr) + fieldName = 'phaeoC' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 31, ecoFieldColumn, iErr) + fieldName = 'phaeoFe' + call ocn_init_setup_ecosys_read_column(domain, fieldName, config_ecosys_column_ecosys_filename, & + nVertLevelsInputColumn, 32, ecoFieldColumn, iErr) + + call mpas_pool_get_dimension(tracersPool, 'index_PO4', index_dummy) + indexField(3) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_NO3', index_dummy) + indexField(4) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_SiO3', index_dummy) + indexField(5) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_NH4', index_dummy) + indexField(6) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_Fe', index_dummy) + indexField(7) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_O2', index_dummy) + indexField(8) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DIC', index_dummy) + indexField(9) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DIC_ALT_CO2', index_dummy) + indexField(10) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_ALK', index_dummy) + indexField(11) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DOC', index_dummy) + indexField(12) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DON', index_dummy) + indexField(13) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DOFe', index_dummy) + indexField(14) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DOP', index_dummy) + indexField(15) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DOPr', index_dummy) + indexField(16) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DONr', index_dummy) + indexField(17) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_zooC', index_dummy) + indexField(18) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_spChl', index_dummy) + indexField(19) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_spC', index_dummy) + indexField(20) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_spFe', index_dummy) + indexField(21) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_spCaCO3', index_dummy) + indexField(22) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diatChl', index_dummy) + indexField(23) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diatC', index_dummy) + indexField(24) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diatFe', index_dummy) + indexField(25) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diatSi', index_dummy) + indexField(26) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diazChl', index_dummy) + indexField(27) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diazC', index_dummy) + indexField(28) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diazFe', index_dummy) + indexField(29) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_phaeoChl', index_dummy) + indexField(30) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_phaeoC', index_dummy) + indexField(31) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_phaeoFe', index_dummy) + indexField(32) = index_dummy + + do iField = 3, numTracersTotal + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + ecosysTracers(indexField(iField), k, iCell) = ecoFieldColumn(k,iField) + end do + end do + end do + + end if ! associated(ecosysTracers) + + do iCell = 1, nCellsSolve + ! Set layerThickness + do k = 1, nVertLevels + layerThickness(k, iCell) = config_ecosys_column_bottom_depth * (interfaceLocations(k+1) - interfaceLocations(k)) + restingThickness(k, iCell) = layerThickness(k, iCell) + end do + + ! Set bottomDepth + bottomDepth(iCell) = config_ecosys_column_bottom_depth + + ! Set maxLevelCell + maxLevelCell(iCell) = nVertLevels + end do + + block_ptr => block_ptr % next + end do + + deallocate(interfaceLocations) + deallocate(ecoFieldColumn, indexField) + + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_ecosys_column!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_ecosys_column +! +!> \brief Validation for CVMix WSwSBF mixing unit test case +!> \author Doug Jacobsen +!> \date 04/01/2015 +!> \details +!> This routine validates the configuration options for the CVMix WSwSBF mixing unit test configuration. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_ecosys_column(configPool, packagePool, iocontext, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (mpas_pool_type), intent(inout) :: configPool + type (mpas_pool_type), intent(inout) :: packagePool + type (mpas_io_context_type), intent(inout) :: iocontext + + integer, intent(out) :: iErr + + character (len=StrKIND), pointer :: config_init_configuration + integer, pointer :: config_vert_levels, config_ecosys_column_vert_levels + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + + if(config_init_configuration .ne. trim('ecosys_column')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_ecosys_column_vert_levels', config_ecosys_column_vert_levels) + + if(config_vert_levels <= 0 .and. config_ecosys_column_vert_levels > 0) then + config_vert_levels = config_ecosys_column_vert_levels + else if(config_vert_levels <= 0) then + write(stderrUnit,*) 'ERROR: Validation failed for ecosys column test case. Not given a usable value for vertical levels.' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_ecosys_column!}}} + +!*********************************************************************** + +! +! routine ocn_init_setup_ecosys_read_column +! +!> \brief Read a column of a specified field from a given file +!> \author Doug Jacobsen +!> \date 03/04/2014 +!> \details +!> This routine reads a column of a specified field from a given file +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_ecosys_read_column(domain, fieldName, fileName, & + nVertLevelsInputColumn, iField, ecoFieldColumn, iErr)!{{{ + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + integer, intent(in) :: nVertLevelsInputColumn, iField + character (len=StrKIND), intent(in) :: fieldName, fileName + real (kind=RKIND), dimension(:,:), intent(inout) :: ecoFieldColumn + + type (block_type), pointer :: block_ptr + + type (MPAS_Stream_type) :: columnStream + + character (len=StrKIND), pointer :: config_global_ocean_temperature_file, config_global_ocean_temperature_varname, & + config_global_ocean_tracer_nlon_dimname, config_global_ocean_tracer_nlat_dimname, & + config_global_ocean_depth_dimname + + integer :: k + + iErr = 0 + + call mpas_pool_get_config(domain % configs, 'config_global_ocean_tracer_nlon_dimname', config_global_ocean_tracer_nlon_dimname) + call mpas_pool_get_config(domain % configs, 'config_global_ocean_depth_dimname', config_global_ocean_depth_dimname) + + ! Define stream for reading a column +! call MPAS_createStream(columnStream, domain % iocontext, fileName, MPAS_IO_NETCDF, MPAS_IO_READ, ierr=iErr) + call MPAS_createStream(columnStream, domain % iocontext, fileName, MPAS_IO_NETCDF, MPAS_IO_READ) + + ! Setup field for stream to be read in + columnIC % fieldName = trim(fieldName) + columnIC % dimSizes(1) = nVertLevelsInputColumn + columnIC % dimSizes(2) = 1 + columnIC % dimNames(1) = 'nVertLevels' + columnIC % dimNames(2) = 'nCells' + columnIC % isVarArray = .false. + columnIC % isPersistent = .true. + columnIC % isActive = .true. + columnIC % hasTimeDimension = .false. + columnIC % block => domain % blocklist + allocate(columnIC % array(nVertLevelsInputColumn, 1)) + + ! Add column field to stream + call MPAS_streamAddField(columnStream, columnIC, iErr) + + ! Read stream + call MPAS_readStream(columnStream, 1, iErr) + + ! Close stream + call MPAS_closeStream(columnStream) + + do k = 1, nVertLevelsInputColumn + ecoFieldColumn(k,iField) = columnIC % array(k,1) + end do + + end subroutine ocn_init_setup_ecosys_read_column + +!*********************************************************************** + +end module ocn_init_ecosys_column + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker From ca80322b6a2af39b1e781d4a0abcd3bea75c6f1b Mon Sep 17 00:00:00 2001 From: Mathew Maltrud Date: Thu, 1 Oct 2015 13:33:05 -0600 Subject: [PATCH 0378/1724] modifications to init mode for including ecosys_column test case --- src/core_ocean/mode_init/Makefile | 3 +++ src/core_ocean/mode_init/Registry.xml | 1 + src/core_ocean/mode_init/mpas_ocn_init_mode.F | 4 ++++ 3 files changed, 8 insertions(+) diff --git a/src/core_ocean/mode_init/Makefile b/src/core_ocean/mode_init/Makefile index 340225be48..7d10fd37a6 100644 --- a/src/core_ocean/mode_init/Makefile +++ b/src/core_ocean/mode_init/Makefile @@ -13,6 +13,7 @@ TEST_CASES = mpas_ocn_init_baroclinic_channel.o \ mpas_ocn_init_cvmix_WSwSBF.o \ mpas_ocn_init_iso.o \ mpas_ocn_init_soma.o \ + mpas_ocn_init_ecosys_column.o \ mpas_ocn_init_global_ocean.o #mpas_ocn_init_TEMPLATE.o @@ -44,6 +45,8 @@ mpas_ocn_init_global_ocean.o: $(UTILS) mpas_ocn_init_cvmix_WSwSBF.o: $(UTILS) +mpas_ocn_init_ecosys_column.o: $(UTILS) + #mpas_ocn_init_TEMPLATE.o: $(UTILS) clean: diff --git a/src/core_ocean/mode_init/Registry.xml b/src/core_ocean/mode_init/Registry.xml index 949da12c45..afdec92162 100644 --- a/src/core_ocean/mode_init/Registry.xml +++ b/src/core_ocean/mode_init/Registry.xml @@ -6,4 +6,5 @@ #include "Registry_cvmix_WSwSBF.xml" #include "Registry_iso.xml" #include "Registry_soma.xml" +#include "Registry_ecosys.xml" // #include "Registry_TEMPLATE.xml" diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 276c7b6fca..a17094f740 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -46,6 +46,7 @@ module ocn_init_mode use ocn_init_cvmix_WSwSBF use ocn_init_iso use ocn_init_soma + use ocn_init_ecosys_column implicit none private @@ -253,6 +254,7 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call ocn_init_setup_cvmix_WSwSBF(domain, ierr) call ocn_init_setup_iso(domain, ierr) call ocn_init_setup_soma(domain, ierr) + call ocn_init_setup_ecosys_column(domain, ierr) !call ocn_init_setup_TEMPLATE(domain, ierr) write(stderrUnit, *) ' Completed setup of: ' // trim(config_init_configuration) @@ -342,6 +344,8 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, ioconte iErr = ior(iErr, err_tmp) call ocn_init_validate_soma(configPool, packagePool, iocontext, iErr=err_tmp) iErr = ior(iErr, err_tmp) + call ocn_init_validate_ecosys_column(configPool, packagePool, iocontext, iErr=err_tmp) + iErr = ior(iErr, err_tmp) ! call ocn_config_TEMPLATE_validate(configPool, packagePool, iocontext, iErr=err_tmp) ! iErr = ior(iErr, err_tmp) end subroutine ocn_init_mode_validate_configuration!}}} From cc4cf589fa006d4d187d890a76785ad6820119d8 Mon Sep 17 00:00:00 2001 From: Mathew Maltrud Date: Thu, 1 Oct 2015 13:33:52 -0600 Subject: [PATCH 0379/1724] bug fixes for ecosys-related code --- .../shared/mpas_ocn_tracer_ecosys.F | 205 +++++++++--------- .../tracer_groups/Registry_ecosys.xml | 28 +-- 2 files changed, 113 insertions(+), 120 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F b/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F index 953f8bd1ee..6d8ab672bc 100755 --- a/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F @@ -169,64 +169,67 @@ subroutine ocn_tracer_ecosys_compute(activeTracers, ecosysTracers, forcingPool, call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) numColumns = 1 + column = 1 do iCell=1,nCellsSolve BGC_input%number_of_active_levels(column) = maxLevelCell(iCell) BGC_forcing%dust_FLUX_IN(column) = dust_FLUX_IN(iCell) - BGC_forcing%ShortWaveFlux_surface(column) = shortWaveHeatFlux(iCell) +!maltrud debug +! BGC_forcing%ShortWaveFlux_surface(column) = shortWaveHeatFlux(iCell) + BGC_forcing%ShortWaveFlux_surface(column) = 200.0_RKIND zTop = 0.0_RKIND do iLevel=1,maxLevelCell(iCell) - BGC_input%PotentialTemperature(iLevel,iCell) = activeTracers(indexTemperature,iLevel,iCell) - BGC_input%Salinity(iLevel,iCell) = activeTracers(indexSalinity,iLevel,iCell) - BGC_input%cell_center_depth(iLevel,iCell) = zMid(iLevel,iCell)*convertLengthScale - BGC_input%cell_thickness(iLevel,iCell) = layerThickness(iLevel,iCell)*convertLengthScale + BGC_input%PotentialTemperature(iLevel,column) = activeTracers(indexTemperature,iLevel,iCell) + BGC_input%Salinity(iLevel,column) = activeTracers(indexSalinity,iLevel,iCell) + BGC_input%cell_center_depth(iLevel,column) = zMid(iLevel,iCell)*convertLengthScale + BGC_input%cell_thickness(iLevel,column) = layerThickness(iLevel,iCell)*convertLengthScale zBot = zTop - layerThickness(iLevel,iCell) - BGC_input%cell_bottom_depth(iLevel,iCell) = zBot*convertLengthScale + BGC_input%cell_bottom_depth(iLevel,column) = zBot*convertLengthScale zTop = zBot - BGC_output%PH_PREV_3D(iLevel,iCell) = PH_PREV_3D(iLevel,iCell) - BGC_output%PH_PREV_ALT_CO2_3D(iLevel,iCell) = PH_PREV_ALT_CO2_3D(iLevel,iCell) + BGC_output%PH_PREV_3D(iLevel,column) = PH_PREV_3D(iLevel,iCell) + BGC_output%PH_PREV_ALT_CO2_3D(iLevel,column) = PH_PREV_ALT_CO2_3D(iLevel,iCell) - BGC_forcing%FESEDFLUX(iLevel,iCell) = FESEDFLUX(iLevel,iCell) - BGC_forcing%NUTR_RESTORE_RTAU(iLevel,iCell) = 0.0_RKIND - BGC_forcing%NO3_CLIM(iLevel,iCell) = 0.0_RKIND - BGC_forcing%PO4_CLIM(iLevel,iCell) = 0.0_RKIND - BGC_forcing%SiO3_CLIM(iLevel,iCell) = 0.0_RKIND + BGC_forcing%FESEDFLUX(iLevel,column) = FESEDFLUX(iLevel,iCell) + BGC_forcing%NUTR_RESTORE_RTAU(iLevel,column) = 0.0_RKIND + BGC_forcing%NO3_CLIM(iLevel,column) = 0.0_RKIND + BGC_forcing%PO4_CLIM(iLevel,column) = 0.0_RKIND + BGC_forcing%SiO3_CLIM(iLevel,column) = 0.0_RKIND !maltrud NOT GOING TO WORK--do each separately ! do iTracer=1,nTracers -! BGC_input%BGC_tracers(iLevel,iCell,iTracer) = ecosysTracers(iTracer,iLevel,iCell) +! BGC_input%BGC_tracers(iLevel,column,iTracer) = ecosysTracers(iTracer,iLevel,iCell) ! enddo - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%po4_ind) = ecosysTracers(ecosysIndices%po4_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%no3_ind) = ecosysTracers(ecosysIndices%no3_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%sio3_ind) = ecosysTracers(ecosysIndices%sio3_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%nh4_ind) = ecosysTracers(ecosysIndices%nh4_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%fe_ind) = ecosysTracers(ecosysIndices%fe_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%o2_ind) = ecosysTracers(ecosysIndices%o2_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%dic_ind) = ecosysTracers(ecosysIndices%dic_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%dic_alt_co2_ind) = ecosysTracers(ecosysIndices%dic_alt_co2_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%alk_ind) = ecosysTracers(ecosysIndices%alk_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%doc_ind) = ecosysTracers(ecosysIndices%doc_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%don_ind) = ecosysTracers(ecosysIndices%don_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%dofe_ind) = ecosysTracers(ecosysIndices%dofe_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%dop_ind) = ecosysTracers(ecosysIndices%dop_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%donr_ind) = ecosysTracers(ecosysIndices%donr_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%dopr_ind) = ecosysTracers(ecosysIndices%dopr_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%zooC_ind) = ecosysTracers(ecosysIndices%zooC_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%spC_ind) = ecosysTracers(ecosysIndices%spC_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%spChl_ind) = ecosysTracers(ecosysIndices%spChl_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%spFe_ind) = ecosysTracers(ecosysIndices%spFe_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%spCaCO3_ind) = ecosysTracers(ecosysIndices%spCaCO3_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diatC_ind) = ecosysTracers(ecosysIndices%diatC_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diatChl_ind) = ecosysTracers(ecosysIndices%diatChl_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diatFe_ind) = ecosysTracers(ecosysIndices%diatFe_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diatSi_ind) = ecosysTracers(ecosysIndices%diatSi_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%phaeoC_ind) = ecosysTracers(ecosysIndices%phaeoC_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%phaeoChl_ind) = ecosysTracers(ecosysIndices%phaeoChl_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%phaeoFe_ind) = ecosysTracers(ecosysIndices%phaeoFe_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diazC_ind) = ecosysTracers(ecosysIndices%diazC_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diazChl_ind) = ecosysTracers(ecosysIndices%diazChl_ind,iLevel,iCell) - BGC_input%BGC_tracers(iLevel,iCell,BGC_indices%diazFe_ind) = ecosysTracers(ecosysIndices%diazFe_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%po4_ind) = ecosysTracers(ecosysIndices%po4_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%no3_ind) = ecosysTracers(ecosysIndices%no3_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%sio3_ind) = ecosysTracers(ecosysIndices%sio3_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%nh4_ind) = ecosysTracers(ecosysIndices%nh4_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%fe_ind) = ecosysTracers(ecosysIndices%fe_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%o2_ind) = ecosysTracers(ecosysIndices%o2_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%dic_ind) = ecosysTracers(ecosysIndices%dic_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%dic_alt_co2_ind) = ecosysTracers(ecosysIndices%dic_alt_co2_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%alk_ind) = ecosysTracers(ecosysIndices%alk_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%doc_ind) = ecosysTracers(ecosysIndices%doc_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%don_ind) = ecosysTracers(ecosysIndices%don_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%dofe_ind) = ecosysTracers(ecosysIndices%dofe_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%dop_ind) = ecosysTracers(ecosysIndices%dop_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%donr_ind) = ecosysTracers(ecosysIndices%donr_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%dopr_ind) = ecosysTracers(ecosysIndices%dopr_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%zooC_ind) = ecosysTracers(ecosysIndices%zooC_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%spC_ind) = ecosysTracers(ecosysIndices%spC_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%spChl_ind) = ecosysTracers(ecosysIndices%spChl_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%spFe_ind) = ecosysTracers(ecosysIndices%spFe_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%spCaCO3_ind) = ecosysTracers(ecosysIndices%spCaCO3_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%diatC_ind) = ecosysTracers(ecosysIndices%diatC_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%diatChl_ind) = ecosysTracers(ecosysIndices%diatChl_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%diatFe_ind) = ecosysTracers(ecosysIndices%diatFe_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%diatSi_ind) = ecosysTracers(ecosysIndices%diatSi_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%phaeoC_ind) = ecosysTracers(ecosysIndices%phaeoC_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%phaeoChl_ind) = ecosysTracers(ecosysIndices%phaeoChl_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%phaeoFe_ind) = ecosysTracers(ecosysIndices%phaeoFe_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%diazC_ind) = ecosysTracers(ecosysIndices%diazC_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%diazChl_ind) = ecosysTracers(ecosysIndices%diazChl_ind,iLevel,iCell) + BGC_input%BGC_tracers(iLevel,column,BGC_indices%diazFe_ind) = ecosysTracers(ecosysIndices%diazFe_ind,iLevel,iCell) enddo ! iLevel @@ -237,68 +240,68 @@ subroutine ocn_tracer_ecosys_compute(activeTracers, ecosysTracers, forcingPool, do iLevel=1,maxLevelCell(iCell) ecosysTracersTend(ecosysIndices%po4_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%po4_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%po4_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%po4_ind) ecosysTracersTend(ecosysIndices%no3_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%no3_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%no3_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%no3_ind) ecosysTracersTend(ecosysIndices%sio3_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%sio3_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%sio3_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%sio3_ind) ecosysTracersTend(ecosysIndices%nh4_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%nh4_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%nh4_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%nh4_ind) ecosysTracersTend(ecosysIndices%fe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%fe_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%fe_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%fe_ind) ecosysTracersTend(ecosysIndices%o2_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%o2_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%o2_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%o2_ind) ecosysTracersTend(ecosysIndices%dic_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dic_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%dic_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dic_ind) ecosysTracersTend(ecosysIndices%dic_alt_co2_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dic_alt_co2_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%dic_alt_co2_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dic_alt_co2_ind) ecosysTracersTend(ecosysIndices%alk_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%alk_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%alk_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%alk_ind) ecosysTracersTend(ecosysIndices%doc_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%doc_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%doc_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%doc_ind) ecosysTracersTend(ecosysIndices%don_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%don_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%don_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%don_ind) ecosysTracersTend(ecosysIndices%dofe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dofe_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%dofe_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dofe_ind) ecosysTracersTend(ecosysIndices%dop_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dop_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%dop_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dop_ind) ecosysTracersTend(ecosysIndices%dopr_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dopr_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%dopr_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dopr_ind) ecosysTracersTend(ecosysIndices%donr_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%donr_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%donr_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%donr_ind) ecosysTracersTend(ecosysIndices%zooC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%zooC_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%zooC_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%zooC_ind) ecosysTracersTend(ecosysIndices%spC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%spC_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%spC_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%spC_ind) ecosysTracersTend(ecosysIndices%spChl_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%spChl_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%spChl_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%spChl_ind) ecosysTracersTend(ecosysIndices%spFe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%spFe_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%spFe_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%spFe_ind) ecosysTracersTend(ecosysIndices%spCaCO3_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%spCaCO3_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%spCaCO3_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%spCaCO3_ind) ecosysTracersTend(ecosysIndices%diatC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diatC_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diatC_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diatC_ind) ecosysTracersTend(ecosysIndices%diatChl_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diatChl_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diatChl_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diatChl_ind) ecosysTracersTend(ecosysIndices%diatFe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diatFe_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diatFe_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diatFe_ind) ecosysTracersTend(ecosysIndices%diatSi_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diatSi_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diatSi_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diatSi_ind) ecosysTracersTend(ecosysIndices%diazC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diazC_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diazC_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diazC_ind) ecosysTracersTend(ecosysIndices%diazChl_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diazChl_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diazChl_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diazChl_ind) ecosysTracersTend(ecosysIndices%diazFe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diazFe_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%diazFe_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diazFe_ind) ecosysTracersTend(ecosysIndices%phaeoC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%phaeoC_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%phaeoC_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%phaeoC_ind) ecosysTracersTend(ecosysIndices%phaeoChl_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%phaeoChl_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%phaeoChl_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%phaeoChl_ind) ecosysTracersTend(ecosysIndices%phaeoFe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%phaeoFe_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,iCell,BGC_indices%phaeoFe_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%phaeoFe_ind) - PH_PREV_3D(iLevel,iCell) = BGC_output%PH_PREV_3D(iLevel,iCell) - PH_PREV_ALT_CO2_3D(iLevel,iCell) = BGC_output%PH_PREV_ALT_CO2_3D(iLevel,iCell) + PH_PREV_3D(iLevel,iCell) = BGC_output%PH_PREV_3D(iLevel,column) + PH_PREV_ALT_CO2_3D(iLevel,iCell) = BGC_output%PH_PREV_ALT_CO2_3D(iLevel,column) enddo @@ -382,13 +385,10 @@ subroutine ocn_tracer_ecosys_surface_flux_compute(activeTracers, ecosysTracers, riverFluxNO3, & riverFluxPO4, & riverFluxDON, & - riverFluxDONr, & riverFluxDOP, & - riverFluxDOPr, & riverFluxSiO3, & riverFluxFe, & riverFluxDIC, & - riverFluxDIC_ALT_CO2, & riverFluxALK, & riverFluxDOC, & atmosphericCO2, & @@ -420,13 +420,10 @@ subroutine ocn_tracer_ecosys_surface_flux_compute(activeTracers, ecosysTracers, call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxNO3', riverFluxNO3) call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxPO4', riverFluxPO4) call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDON', riverFluxDON) - call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDONr', riverFluxDONr) call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDOP', riverFluxDOP) - call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDOPr', riverFluxDOPr) call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxSiO3', riverFluxSiO3) call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxFe', riverFluxFe) call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDIC', riverFluxDIC) - call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDIC_ALT_CO2', riverFluxDIC_ALT_CO2) call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxALK', riverFluxALK) call mpas_pool_get_array(ecosysAuxiliary, 'riverFluxDOC', riverFluxDOC) call mpas_pool_get_array(ecosysAuxiliary, 'atmosphericCO2', atmosphericCO2) @@ -463,9 +460,9 @@ subroutine ocn_tracer_ecosys_surface_flux_compute(activeTracers, ecosysTracers, BGC_forcing%riverFlux(column,BGC_indices%no3_ind) = riverFluxNO3(iCell) BGC_forcing%riverFlux(column,BGC_indices%po4_ind) = riverFluxPO4(iCell) BGC_forcing%riverFlux(column,BGC_indices%don_ind) = riverFluxDON(iCell) * 0.9_BGC_r8 - BGC_forcing%riverFlux(column,BGC_indices%donr_ind) = riverFluxDONr(iCell) * 0.1_BGC_r8 + BGC_forcing%riverFlux(column,BGC_indices%donr_ind) = riverFluxDON(iCell) * 0.1_BGC_r8 BGC_forcing%riverFlux(column,BGC_indices%dop_ind) = riverFluxDOP(iCell) * 0.975_BGC_r8 - BGC_forcing%riverFlux(column,BGC_indices%dopr_ind) = riverFluxDOPr(iCell) * 0.025_BGC_r8 + BGC_forcing%riverFlux(column,BGC_indices%dopr_ind) = riverFluxDOP(iCell) * 0.025_BGC_r8 BGC_forcing%riverFlux(column,BGC_indices%sio3_ind) = riverFluxSiO3(iCell) BGC_forcing%riverFlux(column,BGC_indices%fe_ind) = riverFluxFe(iCell) / parm_Fe_bioavail BGC_forcing%riverFlux(column,BGC_indices%dic_ind) = riverFluxDIC(iCell) @@ -480,20 +477,20 @@ subroutine ocn_tracer_ecosys_surface_flux_compute(activeTracers, ecosysTracers, PH_PREV(iCell) = BGC_forcing%surface_pH(column) PH_PREV_ALT_CO2(iCell) = BGC_forcing%surface_pH_alt_co2(column) - ecosysSurfaceFlux(ecosysIndices%no3_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%no3_ind) - ecosysSurfaceFlux(ecosysIndices%po4_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%po4_ind) - ecosysSurfaceFlux(ecosysIndices%sio3_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%sio3_ind) - ecosysSurfaceFlux(ecosysIndices%nh4_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%nh4_ind) - ecosysSurfaceFlux(ecosysIndices%don_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%don_ind) - ecosysSurfaceFlux(ecosysIndices%donr_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%donr_ind) - ecosysSurfaceFlux(ecosysIndices%dop_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%dop_ind) - ecosysSurfaceFlux(ecosysIndices%dopr_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%dopr_ind) - ecosysSurfaceFlux(ecosysIndices%fe_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%fe_ind) - ecosysSurfaceFlux(ecosysIndices%alk_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%alk_ind) - ecosysSurfaceFlux(ecosysIndices%doc_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%doc_ind) - ecosysSurfaceFlux(ecosysIndices%o2_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%o2_ind) - ecosysSurfaceFlux(ecosysIndices%dic_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%dic_ind) - ecosysSurfaceFlux(ecosysIndices%dic_alt_co2_ind,iCell) = BGC_forcing%netFlux(iCell,BGC_indices%dic_alt_co2_ind) + ecosysSurfaceFlux(ecosysIndices%no3_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%no3_ind) + ecosysSurfaceFlux(ecosysIndices%po4_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%po4_ind) + ecosysSurfaceFlux(ecosysIndices%sio3_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%sio3_ind) + ecosysSurfaceFlux(ecosysIndices%nh4_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%nh4_ind) + ecosysSurfaceFlux(ecosysIndices%don_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%don_ind) + ecosysSurfaceFlux(ecosysIndices%donr_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%donr_ind) + ecosysSurfaceFlux(ecosysIndices%dop_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%dop_ind) + ecosysSurfaceFlux(ecosysIndices%dopr_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%dopr_ind) + ecosysSurfaceFlux(ecosysIndices%fe_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%fe_ind) + ecosysSurfaceFlux(ecosysIndices%alk_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%alk_ind) + ecosysSurfaceFlux(ecosysIndices%doc_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%doc_ind) + ecosysSurfaceFlux(ecosysIndices%o2_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%o2_ind) + ecosysSurfaceFlux(ecosysIndices%dic_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%dic_ind) + ecosysSurfaceFlux(ecosysIndices%dic_alt_co2_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%dic_alt_co2_ind) !explicitly set the rest to 0 ! NOTE: some will not be zero when we get sea ice fluxes @@ -548,7 +545,7 @@ subroutine ocn_tracer_ecosys_init(domain,err)!{{{ ! three dimensional pointers real (kind=RKIND), dimension(:,:,:), pointer :: & - ecosysGroup + ecosysTracers ! scalars integer :: nTracers, numColumnsMax @@ -556,10 +553,6 @@ subroutine ocn_tracer_ecosys_init(domain,err)!{{{ ! scalar pointers integer, pointer :: nVertLevels, index_dummy - type (block_type), pointer :: block -!maltrud do we need the above? it is in cvmix but i think not used. - - ! ! get tracers pools ! @@ -570,10 +563,10 @@ subroutine ocn_tracer_ecosys_init(domain,err)!{{{ ! Get tracer group so we can get the number of tracers in it ! - call mpas_pool_get_subpool(block % structs, 'state', statePool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) - call mpas_pool_get_array(tracersPool, 'ecosysGRP', ecosysGroup) - nTracers = size(ecosysGroup, dim=1) + call mpas_pool_get_array(tracersPool, 'ecosysTracers', ecosysTracers, 1) + nTracers = size(ecosysTracers, dim=1) if (BGC_tracer_cnt /= nTracers) then err = 1 return diff --git a/src/core_ocean/tracer_groups/Registry_ecosys.xml b/src/core_ocean/tracer_groups/Registry_ecosys.xml index a337cf929f..3b4b6deb97 100755 --- a/src/core_ocean/tracer_groups/Registry_ecosys.xml +++ b/src/core_ocean/tracer_groups/Registry_ecosys.xml @@ -1,45 +1,45 @@ - - + - - - - - - - - + - + - + - + - + From dd288d9f628c75bfcf2853ad1fb98c1d1d243dba Mon Sep 17 00:00:00 2001 From: Mathew Maltrud Date: Mon, 26 Oct 2015 14:20:39 -0600 Subject: [PATCH 0380/1724] removed BGC related fluxes from Registry since they are now part of the BGC package --- src/core_ocean/Registry.xml | 33 +-------------------------------- 1 file changed, 1 insertion(+), 32 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 34641c0f44..8e01a05353 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1331,14 +1331,6 @@ - @@ -2324,7 +2316,7 @@ /> @@ -2361,29 +2353,6 @@ - - Date: Mon, 26 Oct 2015 14:22:40 -0600 Subject: [PATCH 0381/1724] BEC interface bug fixes and introduction of more diagnostic arrays. --- .../shared/mpas_ocn_tracer_ecosys.F | 326 +++++++++++++++--- .../tracer_groups/Registry_ecosys.xml | 138 ++++++++ 2 files changed, 410 insertions(+), 54 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F b/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F index 6d8ab672bc..ff216095cc 100755 --- a/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F @@ -151,8 +151,61 @@ subroutine ocn_tracer_ecosys_compute(activeTracers, ecosysTracers, forcingPool, !----------------------------------------------------------------- type (mpas_pool_type), pointer :: ecosysAuxiliary ! additional forcing fields + type (mpas_pool_type), pointer :: ecosysDiagsLevel1 ! diagnostics - real (kind=RKIND) :: zTop, zBot, convertLengthScale = 1.0_RKIND + real (kind=RKIND), dimension(:), pointer :: & + ecosys_diag_tot_CaCO3_form_zint, & + ecosys_diag_photoC_TOT_zint, & + ecosys_diag_Jint_Ctot, & + ecosys_diag_Jint_100m_Ctot, & + ecosys_diag_Jint_Ntot, & + ecosys_diag_Jint_100m_Ntot, & + ecosys_diag_Jint_Ptot, & + ecosys_diag_Jint_100m_Ptot, & + ecosys_diag_Jint_Sitot, & + ecosys_diag_Jint_100m_Sitot, & + ecosys_diag_O2_ZMIN, & + ecosys_diag_O2_ZMIN_DEPTH + + ! two dimensional arrays + real (kind=RKIND), dimension(:,:), pointer :: & + ecosys_diag_tot_Nfix, & + ecosys_diag_NITRIF, & + ecosys_diag_DENITRIF, & + ecosys_diag_O2_PRODUCTION, & + ecosys_diag_O2_CONSUMPTION, & + ecosys_diag_PAR_avg, & + ecosys_diag_zoo_loss, & + ecosys_diag_auto_graze_TOT, & + ecosys_diag_photoC_TOT, & + ecosys_diag_DOC_prod, & + ecosys_diag_DOC_remin, & + ecosys_diag_DON_prod, & + ecosys_diag_DON_remin, & + ecosys_diag_DOP_prod, & + ecosys_diag_DOP_remin, & + ecosys_diag_DOFe_prod, & + ecosys_diag_DOFe_remin, & + ecosys_diag_Fe_scavenge, & + ecosys_diag_Fe_scavenge_rate, & + ecosys_diag_POC_FLUX_IN, & + ecosys_diag_POC_PROD, & + ecosys_diag_POC_REMIN, & + ecosys_diag_CaCO3_FLUX_IN, & + ecosys_diag_CaCO3_PROD, & + ecosys_diag_CaCO3_REMIN, & + ecosys_diag_SiO2_FLUX_IN, & + ecosys_diag_SiO2_PROD, & + ecosys_diag_SiO2_REMIN, & + ecosys_diag_dust_FLUX_IN, & + ecosys_diag_dust_REMIN, & + ecosys_diag_P_iron_FLUX_IN, & + ecosys_diag_P_iron_PROD, & + ecosys_diag_P_iron_REMIN + +!maltrud i think source/sink wants cm instead of m +! real (kind=RKIND) :: zTop, zBot, convertLengthScale = 1.0_RKIND + real (kind=RKIND) :: zTop, zBot, convertLengthScale = 100.0_RKIND integer :: iCell, iLevel, iTracer, numColumns, column @@ -168,21 +221,75 @@ subroutine ocn_tracer_ecosys_compute(activeTracers, ecosysTracers, forcingPool, call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) +!maltrud change to diagnostics pool at some point (needs to be passed in) + call mpas_pool_get_subpool(forcingPool, 'ecosysDiagsLevel1', ecosysDiagsLevel1) + + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_tot_CaCO3_form_zint', ecosys_diag_tot_CaCO3_form_zint) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_photoC_TOT_zint', ecosys_diag_photoC_TOT_zint) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_Jint_Ctot', ecosys_diag_Jint_Ctot) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_Jint_100m_Ctot', ecosys_diag_Jint_100m_Ctot) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_Jint_Ntot', ecosys_diag_Jint_Ntot) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_Jint_100m_Ntot', ecosys_diag_Jint_100m_Ntot) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_Jint_Ptot', ecosys_diag_Jint_Ptot) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_Jint_100m_Ptot', ecosys_diag_Jint_100m_Ptot) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_Jint_Sitot', ecosys_diag_Jint_Sitot) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_Jint_100m_Sitot', ecosys_diag_Jint_100m_Sitot) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_O2_ZMIN', ecosys_diag_O2_ZMIN) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_O2_ZMIN_DEPTH', ecosys_diag_O2_ZMIN_DEPTH) + + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_tot_Nfix', ecosys_diag_tot_Nfix) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_NITRIF', ecosys_diag_NITRIF) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_DENITRIF', ecosys_diag_DENITRIF) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_O2_PRODUCTION', ecosys_diag_O2_PRODUCTION) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_O2_CONSUMPTION', ecosys_diag_O2_CONSUMPTION) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_PAR_avg', ecosys_diag_PAR_avg) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_zoo_loss', ecosys_diag_zoo_loss) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_auto_graze_TOT', ecosys_diag_auto_graze_TOT) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_photoC_TOT', ecosys_diag_photoC_TOT) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_DOC_prod', ecosys_diag_DOC_prod) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_DOC_remin', ecosys_diag_DOC_remin) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_DON_prod', ecosys_diag_DON_prod) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_DON_remin', ecosys_diag_DON_remin) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_DOP_prod', ecosys_diag_DOP_prod) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_DOP_remin', ecosys_diag_DOP_remin) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_DOFe_prod', ecosys_diag_DOFe_prod) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_DOFe_remin', ecosys_diag_DOFe_remin) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_Fe_scavenge', ecosys_diag_Fe_scavenge) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_Fe_scavenge_rate', ecosys_diag_Fe_scavenge_rate) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_POC_FLUX_IN', ecosys_diag_POC_FLUX_IN) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_POC_PROD', ecosys_diag_POC_PROD) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_POC_REMIN', ecosys_diag_POC_REMIN) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_CaCO3_FLUX_IN', ecosys_diag_CaCO3_FLUX_IN) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_CaCO3_PROD', ecosys_diag_CaCO3_PROD) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_CaCO3_REMIN', ecosys_diag_CaCO3_REMIN) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_SiO2_FLUX_IN', ecosys_diag_SiO2_FLUX_IN) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_SiO2_PROD', ecosys_diag_SiO2_PROD) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_SiO2_REMIN', ecosys_diag_SiO2_REMIN) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_dust_FLUX_IN', ecosys_diag_dust_FLUX_IN) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_dust_REMIN', ecosys_diag_dust_REMIN) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_P_iron_FLUX_IN', ecosys_diag_P_iron_FLUX_IN) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_P_iron_PROD', ecosys_diag_P_iron_PROD) + call mpas_pool_get_array(ecosysDiagsLevel1, 'ecosys_diag_P_iron_REMIN', ecosys_diag_P_iron_REMIN) + numColumns = 1 column = 1 do iCell=1,nCellsSolve BGC_input%number_of_active_levels(column) = maxLevelCell(iCell) BGC_forcing%dust_FLUX_IN(column) = dust_FLUX_IN(iCell) !maltrud debug -! BGC_forcing%ShortWaveFlux_surface(column) = shortWaveHeatFlux(iCell) - BGC_forcing%ShortWaveFlux_surface(column) = 200.0_RKIND + BGC_forcing%ShortWaveFlux_surface(column) = shortWaveHeatFlux(iCell) +! BGC_forcing%ShortWaveFlux_surface(column) = 200.0_RKIND zTop = 0.0_RKIND do iLevel=1,maxLevelCell(iCell) BGC_input%PotentialTemperature(iLevel,column) = activeTracers(indexTemperature,iLevel,iCell) BGC_input%Salinity(iLevel,column) = activeTracers(indexSalinity,iLevel,iCell) - BGC_input%cell_center_depth(iLevel,column) = zMid(iLevel,iCell)*convertLengthScale +!maltrud debug +! BGC_input%cell_center_depth(iLevel,column) = zMid(iLevel,iCell)*convertLengthScale + BGC_input%cell_center_depth(iLevel,column) = -1.0_RKIND*zMid(iLevel,iCell)*convertLengthScale BGC_input%cell_thickness(iLevel,column) = layerThickness(iLevel,iCell)*convertLengthScale - zBot = zTop - layerThickness(iLevel,iCell) +!maltrud debug +! zBot = zTop - layerThickness(iLevel,iCell) + zBot = zTop + layerThickness(iLevel,iCell) BGC_input%cell_bottom_depth(iLevel,column) = zBot*convertLengthScale zTop = zBot @@ -240,69 +347,161 @@ subroutine ocn_tracer_ecosys_compute(activeTracers, ecosysTracers, forcingPool, do iLevel=1,maxLevelCell(iCell) ecosysTracersTend(ecosysIndices%po4_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%po4_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%po4_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%po4_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%no3_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%no3_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%no3_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%no3_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%sio3_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%sio3_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%sio3_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%sio3_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%nh4_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%nh4_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%nh4_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%nh4_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%fe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%fe_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%fe_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%fe_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%o2_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%o2_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%o2_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%o2_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%dic_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dic_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dic_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dic_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%dic_alt_co2_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dic_alt_co2_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dic_alt_co2_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dic_alt_co2_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%alk_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%alk_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%alk_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%alk_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%doc_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%doc_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%doc_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%doc_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%don_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%don_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%don_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%don_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%dofe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dofe_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dofe_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dofe_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%dop_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dop_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dop_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dop_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%dopr_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%dopr_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dopr_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%dopr_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%donr_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%donr_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%donr_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%donr_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%zooC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%zooC_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%zooC_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%zooC_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%spC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%spC_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%spC_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%spC_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%spChl_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%spChl_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%spChl_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%spChl_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%spFe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%spFe_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%spFe_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%spFe_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%spCaCO3_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%spCaCO3_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%spCaCO3_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%spCaCO3_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%diatC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diatC_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diatC_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diatC_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%diatChl_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diatChl_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diatChl_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diatChl_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%diatFe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diatFe_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diatFe_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diatFe_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%diatSi_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diatSi_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diatSi_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diatSi_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%diazC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diazC_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diazC_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diazC_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%diazChl_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diazChl_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diazChl_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diazChl_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%diazFe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%diazFe_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diazFe_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%diazFe_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%phaeoC_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%phaeoC_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%phaeoC_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%phaeoC_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%phaeoChl_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%phaeoChl_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%phaeoChl_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%phaeoChl_ind)*layerThickness(iLevel,iCell) ecosysTracersTend(ecosysIndices%phaeoFe_ind,iLevel,iCell) = ecosysTracersTend(ecosysIndices%phaeoFe_ind,iLevel,iCell) & - + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%phaeoFe_ind) + + BGC_output%BGC_tendencies(iLevel,column,BGC_indices%phaeoFe_ind)*layerThickness(iLevel,iCell) PH_PREV_3D(iLevel,iCell) = BGC_output%PH_PREV_3D(iLevel,column) PH_PREV_ALT_CO2_3D(iLevel,iCell) = BGC_output%PH_PREV_ALT_CO2_3D(iLevel,column) + ecosys_diag_tot_CaCO3_form_zint(iCell) = & + BGC_diagnostic_fields%diag_tot_CaCO3_form_zint(column) + ecosys_diag_photoC_TOT_zint(iCell) = & + BGC_diagnostic_fields%diag_photoC_TOT_zint(column) + ecosys_diag_Jint_Ctot(iCell) = & + BGC_diagnostic_fields%diag_Jint_Ctot(column) + ecosys_diag_Jint_100m_Ctot(iCell) = & + BGC_diagnostic_fields%diag_Jint_100m_Ctot(column) + ecosys_diag_Jint_Ntot(iCell) = & + BGC_diagnostic_fields%diag_Jint_Ntot(column) + ecosys_diag_Jint_100m_Ntot(iCell) = & + BGC_diagnostic_fields%diag_Jint_100m_Ntot(column) + ecosys_diag_Jint_Ptot(iCell) = & + BGC_diagnostic_fields%diag_Jint_Ptot(column) + ecosys_diag_Jint_100m_Ptot(iCell) = & + BGC_diagnostic_fields%diag_Jint_100m_Ptot(column) + ecosys_diag_Jint_Sitot(iCell) = & + BGC_diagnostic_fields%diag_Jint_Sitot(column) + ecosys_diag_Jint_100m_Sitot(iCell) = & + BGC_diagnostic_fields%diag_Jint_100m_Sitot(column) + ecosys_diag_O2_ZMIN(iCell) = & + BGC_diagnostic_fields%diag_O2_ZMIN(column) + ecosys_diag_O2_ZMIN_DEPTH(iCell) = & + BGC_diagnostic_fields%diag_O2_ZMIN_DEPTH(column) + + ecosys_diag_tot_Nfix(iLevel,iCell) = & + BGC_diagnostic_fields%diag_tot_Nfix(iLevel,column) + ecosys_diag_NITRIF(iLevel,iCell) = & + BGC_diagnostic_fields%diag_NITRIF(iLevel,column) + ecosys_diag_DENITRIF(iLevel,iCell) = & + BGC_diagnostic_fields%diag_DENITRIF(iLevel,column) + ecosys_diag_O2_PRODUCTION(iLevel,iCell) = & + BGC_diagnostic_fields%diag_O2_PRODUCTION(iLevel,column) + ecosys_diag_O2_CONSUMPTION(iLevel,iCell) = & + BGC_diagnostic_fields%diag_O2_CONSUMPTION(iLevel,column) + ecosys_diag_PAR_avg(iLevel,iCell) = & + BGC_diagnostic_fields%diag_PAR_avg(iLevel,column) + ecosys_diag_zoo_loss(iLevel,iCell) = & + BGC_diagnostic_fields%diag_zoo_loss(iLevel,column) + ecosys_diag_auto_graze_TOT(iLevel,iCell) = & + BGC_diagnostic_fields%diag_auto_graze_TOT(iLevel,column) + ecosys_diag_photoC_TOT(iLevel,iCell) = & + BGC_diagnostic_fields%diag_photoC_TOT(iLevel,column) + ecosys_diag_DOC_prod(iLevel,iCell) = & + BGC_diagnostic_fields%diag_DOC_prod(iLevel,column) + ecosys_diag_DOC_remin(iLevel,iCell) = & + BGC_diagnostic_fields%diag_DOC_remin(iLevel,column) + ecosys_diag_DON_prod(iLevel,iCell) = & + BGC_diagnostic_fields%diag_DON_prod(iLevel,column) + ecosys_diag_DON_remin(iLevel,iCell) = & + BGC_diagnostic_fields%diag_DON_remin(iLevel,column) + ecosys_diag_DOP_prod(iLevel,iCell) = & + BGC_diagnostic_fields%diag_DOP_prod(iLevel,column) + ecosys_diag_DOP_remin(iLevel,iCell) = & + BGC_diagnostic_fields%diag_DOP_remin(iLevel,column) + ecosys_diag_DOFe_prod(iLevel,iCell) = & + BGC_diagnostic_fields%diag_DOFe_prod(iLevel,column) + ecosys_diag_DOFe_remin(iLevel,iCell) = & + BGC_diagnostic_fields%diag_DOFe_remin(iLevel,column) + ecosys_diag_Fe_scavenge(iLevel,iCell) = & + BGC_diagnostic_fields%diag_Fe_scavenge(iLevel,column) + ecosys_diag_Fe_scavenge_rate(iLevel,iCell) = & + BGC_diagnostic_fields%diag_Fe_scavenge_rate(iLevel,column) + ecosys_diag_POC_FLUX_IN(iLevel,iCell) = & + BGC_diagnostic_fields%diag_POC_FLUX_IN(iLevel,column) + ecosys_diag_POC_PROD(iLevel,iCell) = & + BGC_diagnostic_fields%diag_POC_PROD(iLevel,column) + ecosys_diag_POC_REMIN(iLevel,iCell) = & + BGC_diagnostic_fields%diag_POC_REMIN(iLevel,column) + ecosys_diag_CaCO3_FLUX_IN(iLevel,iCell) = & + BGC_diagnostic_fields%diag_CaCO3_FLUX_IN(iLevel,column) + ecosys_diag_CaCO3_PROD(iLevel,iCell) = & + BGC_diagnostic_fields%diag_CaCO3_PROD(iLevel,column) + ecosys_diag_CaCO3_REMIN(iLevel,iCell) = & + BGC_diagnostic_fields%diag_CaCO3_REMIN(iLevel,column) + ecosys_diag_SiO2_FLUX_IN(iLevel,iCell) = & + BGC_diagnostic_fields%diag_SiO2_FLUX_IN(iLevel,column) + ecosys_diag_SiO2_PROD(iLevel,iCell) = & + BGC_diagnostic_fields%diag_SiO2_PROD(iLevel,column) + ecosys_diag_SiO2_REMIN(iLevel,iCell) = & + BGC_diagnostic_fields%diag_SiO2_REMIN(iLevel,column) + ecosys_diag_dust_FLUX_IN(iLevel,iCell) = & + BGC_diagnostic_fields%diag_dust_FLUX_IN(iLevel,column) + ecosys_diag_dust_REMIN(iLevel,iCell) = & + BGC_diagnostic_fields%diag_dust_REMIN(iLevel,column) + ecosys_diag_P_iron_FLUX_IN(iLevel,iCell) = & + BGC_diagnostic_fields%diag_P_iron_FLUX_IN(iLevel,column) + ecosys_diag_P_iron_PROD(iLevel,iCell) = & + BGC_diagnostic_fields%diag_P_iron_PROD(iLevel,column) + ecosys_diag_P_iron_REMIN(iLevel,iCell) = & + BGC_diagnostic_fields%diag_P_iron_REMIN(iLevel,column) + enddo enddo ! iCell @@ -404,6 +603,15 @@ subroutine ocn_tracer_ecosys_surface_flux_compute(activeTracers, ecosysTracers, PH_PREV, & PH_PREV_ALT_CO2 + real (kind=RKIND) :: & + renormFluxes = 0.01_RKIND, & +! PascalsToAtmospheres = 1.0_RKIND/101.325e+3_RKIND, & +! mSquared_to_cmSquared = 1.0e+4_RKIND +! PascalsToAtmospheres = 1.0_RKIND, & +! mSquared_to_cmSquared = 1.0_RKIND + PascalsToAtmospheres = 0.0_RKIND, & + mSquared_to_cmSquared = 1.0_RKIND + err = 0 call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) @@ -432,6 +640,9 @@ subroutine ocn_tracer_ecosys_surface_flux_compute(activeTracers, ecosysTracers, call mpas_pool_get_array(ecosysAuxiliary, 'CO2_gas_flux', CO2_gas_flux) call mpas_pool_get_array(ecosysAuxiliary, 'CO2_alt_gas_flux', CO2_alt_gas_flux) + BGC_forcing%lcalc_O2_gas_flux = .true. + BGC_forcing%lcalc_CO2_gas_flux = .true. + numColumns = 1 column = 1 iLevelSurface = 1 @@ -439,14 +650,16 @@ subroutine ocn_tracer_ecosys_surface_flux_compute(activeTracers, ecosysTracers, ! NOTE surface values of BGC_input%BGC_tracers were set in previous call to source-sink routine - BGC_forcing%surfacePressure(column) = seaSurfacePressure(iCell) + BGC_forcing%surfacePressure(column) = seaSurfacePressure(iCell)*PascalsToAtmospheres BGC_forcing%iceFraction(column) = iceFraction(iCell) - BGC_forcing%windSpeedSquared10m(column) = windSpeedSquared10m(iCell) - BGC_forcing%atmCO2(column) = atmosphericCO2(column) - BGC_forcing%atmCO2_ALT_CO2(column) = atmosphericCO2_ALT_CO2(column) + BGC_forcing%windSpeedSquared10m(column) = windSpeedSquared10m(iCell)*mSquared_to_cmSquared + BGC_forcing%atmCO2(column) = atmosphericCO2(iCell) + BGC_forcing%atmCO2_ALT_CO2(column) = atmosphericCO2_ALT_CO2(iCell) BGC_forcing%surface_pH(column) = PH_PREV(iCell) BGC_forcing%surface_pH_alt_co2(column) = PH_PREV_ALT_CO2(iCell) - BGC_forcing%surfaceDepth(column) = zMid(iLevelSurface,iCell) +!maltrud debug +! BGC_forcing%surfaceDepth(column) = zMid(iLevelSurface,iCell) + BGC_forcing%surfaceDepth(column) = -1.0_RKIND*zMid(iLevelSurface,iCell) BGC_forcing%SST(column) = activeTracers(indexTemperature,iLevelSurface,iCell) BGC_forcing%SSS(column) = activeTracers(indexSalinity,iLevelSurface,iCell) @@ -477,20 +690,20 @@ subroutine ocn_tracer_ecosys_surface_flux_compute(activeTracers, ecosysTracers, PH_PREV(iCell) = BGC_forcing%surface_pH(column) PH_PREV_ALT_CO2(iCell) = BGC_forcing%surface_pH_alt_co2(column) - ecosysSurfaceFlux(ecosysIndices%no3_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%no3_ind) - ecosysSurfaceFlux(ecosysIndices%po4_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%po4_ind) - ecosysSurfaceFlux(ecosysIndices%sio3_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%sio3_ind) - ecosysSurfaceFlux(ecosysIndices%nh4_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%nh4_ind) - ecosysSurfaceFlux(ecosysIndices%don_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%don_ind) - ecosysSurfaceFlux(ecosysIndices%donr_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%donr_ind) - ecosysSurfaceFlux(ecosysIndices%dop_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%dop_ind) - ecosysSurfaceFlux(ecosysIndices%dopr_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%dopr_ind) - ecosysSurfaceFlux(ecosysIndices%fe_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%fe_ind) - ecosysSurfaceFlux(ecosysIndices%alk_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%alk_ind) - ecosysSurfaceFlux(ecosysIndices%doc_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%doc_ind) - ecosysSurfaceFlux(ecosysIndices%o2_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%o2_ind) - ecosysSurfaceFlux(ecosysIndices%dic_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%dic_ind) - ecosysSurfaceFlux(ecosysIndices%dic_alt_co2_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%dic_alt_co2_ind) + ecosysSurfaceFlux(ecosysIndices%no3_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%no3_ind)*renormFluxes + ecosysSurfaceFlux(ecosysIndices%po4_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%po4_ind)*renormFluxes + ecosysSurfaceFlux(ecosysIndices%sio3_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%sio3_ind)*renormFluxes + ecosysSurfaceFlux(ecosysIndices%nh4_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%nh4_ind)*renormFluxes + ecosysSurfaceFlux(ecosysIndices%don_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%don_ind)*renormFluxes + ecosysSurfaceFlux(ecosysIndices%donr_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%donr_ind)*renormFluxes + ecosysSurfaceFlux(ecosysIndices%dop_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%dop_ind)*renormFluxes + ecosysSurfaceFlux(ecosysIndices%dopr_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%dopr_ind)*renormFluxes + ecosysSurfaceFlux(ecosysIndices%fe_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%fe_ind)*renormFluxes + ecosysSurfaceFlux(ecosysIndices%alk_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%alk_ind)*renormFluxes + ecosysSurfaceFlux(ecosysIndices%doc_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%doc_ind)*renormFluxes + ecosysSurfaceFlux(ecosysIndices%o2_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%o2_ind)*renormFluxes + ecosysSurfaceFlux(ecosysIndices%dic_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%dic_ind)*renormFluxes + ecosysSurfaceFlux(ecosysIndices%dic_alt_co2_ind,iCell) = BGC_forcing%netFlux(column,BGC_indices%dic_alt_co2_ind)*renormFluxes !explicitly set the rest to 0 ! NOTE: some will not be zero when we get sea ice fluxes @@ -745,6 +958,11 @@ subroutine ocn_tracer_ecosys_init(domain,err)!{{{ allocate ( BGC_forcing%gasFlux(numColumnsMax, BGC_tracer_cnt) ) allocate ( BGC_forcing%seaIceFlux(numColumnsMax, BGC_tracer_cnt) ) allocate ( BGC_forcing%netFlux(numColumnsMax, BGC_tracer_cnt) ) + BGC_forcing%depositionFlux = 0.0_RKIND + BGC_forcing%riverFlux = 0.0_RKIND + BGC_forcing%gasFlux = 0.0_RKIND + BGC_forcing%seaIceFlux = 0.0_RKIND + BGC_forcing%netFlux = 0.0_RKIND allocate ( BGC_output%BGC_tendencies(nVertLevels, numColumnsMax, BGC_tracer_cnt) ) allocate ( BGC_output%PH_PREV_3D(nVertLevels, numColumnsMax) ) diff --git a/src/core_ocean/tracer_groups/Registry_ecosys.xml b/src/core_ocean/tracer_groups/Registry_ecosys.xml index 3b4b6deb97..788227d742 100755 --- a/src/core_ocean/tracer_groups/Registry_ecosys.xml +++ b/src/core_ocean/tracer_groups/Registry_ecosys.xml @@ -405,4 +405,142 @@ /> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + From 507f43021a190c91d6fc83a86fc7ca1a593c2b8d Mon Sep 17 00:00:00 2001 From: Mathew Maltrud Date: Tue, 27 Oct 2015 16:39:54 -0600 Subject: [PATCH 0382/1724] addition of DMS and MacroMolecules to BGC capability added DMS and Macromolecules. tested for column setup only. it appears that the Macros parameters might not be set correctly, but will be modified later. --- .../mode_forward/mpas_ocn_forward_mode.F | 6 +++ .../mode_init/mpas_ocn_init_ecosys_column.F | 53 ++++++++++++++++++- src/core_ocean/shared/Makefile | 16 +++++- src/core_ocean/shared/mpas_ocn_tendency.F | 45 +++++++++++++++- .../tracer_groups/Registry_tracers.xml | 2 + 5 files changed, 118 insertions(+), 4 deletions(-) diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index e98423ef2c..fd1a9389fe 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -59,6 +59,8 @@ module ocn_forward_mode use ocn_tracer_nonlocalflux use ocn_tracer_advection use ocn_tracer_ecosys + use ocn_tracer_DMS + use ocn_tracer_MacroMolecules use ocn_gm use ocn_high_freq_thickness_hmix_del2 @@ -215,6 +217,10 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ ierr = ior(ierr,err_tmp) call ocn_tracer_ecosys_init(domain, err_tmp) ierr = ior(ierr,err_tmp) + call ocn_tracer_DMS_init(domain, err_tmp) + ierr = ior(ierr,err_tmp) + call ocn_tracer_MacroMolecules_init(domain, err_tmp) + ierr = ior(ierr,err_tmp) call ocn_vmix_init(domain, err_tmp) ierr = ior(ierr, err_tmp) diff --git a/src/core_ocean/mode_init/mpas_ocn_init_ecosys_column.F b/src/core_ocean/mode_init/mpas_ocn_init_ecosys_column.F index fe8f00f6f2..2458610f94 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_ecosys_column.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_ecosys_column.F @@ -87,6 +87,7 @@ subroutine ocn_init_setup_ecosys_column(domain, iErr)!{{{ type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool type (mpas_pool_type), pointer :: diagnosticsPool, forcingPool + type (mpas_pool_type), pointer :: ecosysAuxiliary ! additional forcing fields type (mpas_pool_type), pointer :: tracersPool @@ -96,7 +97,10 @@ subroutine ocn_init_setup_ecosys_column(domain, iErr)!{{{ real (kind=RKIND), dimension(:), pointer :: refBottomDepth, refZMid, vertCoordMovementWeights real (kind=RKIND), dimension(:), pointer :: bottomDepth real (kind=RKIND), dimension(:, :), pointer :: layerThickness, restingThickness - real (kind=RKIND), dimension(:, :, :), pointer :: activeTracers, ecosysTracers + real (kind=RKIND), dimension(:), pointer :: PH_PREV, PH_PREV_ALT_CO2 + real (kind=RKIND), dimension(:, :), pointer :: PH_PREV_3D, PH_PREV_ALT_CO2_3D + real (kind=RKIND), dimension(:, :, :), pointer :: activeTracers, ecosysTracers, DMSTracers, & + MacroMoleculesTracers real (kind=RKIND), dimension(:), pointer :: interfaceLocations @@ -162,8 +166,17 @@ subroutine ocn_init_setup_ecosys_column(domain, iErr)!{{{ call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) call mpas_pool_get_array(tracersPool, 'ecosysTracers', ecosysTracers, 1) + call mpas_pool_get_array(tracersPool, 'DMSTracers', DMSTracers, 1) + call mpas_pool_get_array(tracersPool, 'MacroMoleculesTracers', MacroMoleculesTracers, 1) call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + call mpas_pool_get_subpool(forcingPool, 'ecosysAuxiliary', ecosysAuxiliary) + + call mpas_pool_get_array(ecosysAuxiliary, 'PH_PREV', PH_PREV) + call mpas_pool_get_array(ecosysAuxiliary, 'PH_PREV_ALT_CO2', PH_PREV_ALT_CO2) + call mpas_pool_get_array(ecosysAuxiliary, 'PH_PREV_3D', PH_PREV_3D) + call mpas_pool_get_array(ecosysAuxiliary, 'PH_PREV_ALT_CO2_3D', PH_PREV_ALT_CO2_3D) + ! Set refBottomDepth and refBottomDepthTopOfCell do k = 1, nVertLevels refBottomDepth(k) = config_ecosys_column_bottom_depth * interfaceLocations(k+1) @@ -362,8 +375,46 @@ subroutine ocn_init_setup_ecosys_column(domain, iErr)!{{{ end do end do + do iCell = 1, nCellsSolve + PH_PREV(iCell) = 8.0_RKIND + PH_PREV_ALT_CO2(iCell) = 8.0_RKIND + do k = 1, nVertLevels + PH_PREV_3D(k, iCell) = 8.0_RKIND + PH_PREV_ALT_CO2_3D(k, iCell) = 8.0_RKIND + end do + end do + end if ! associated(ecosysTracers) + if ( associated(DMSTracers) ) then + call mpas_pool_get_dimension(tracersPool, 'index_DMS', index_dummy) + indexField(1) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DMSP', index_dummy) + indexField(2) = index_dummy + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + DMSTracers(indexField(1), k, iCell) = 0.0_RKIND + DMSTracers(indexField(2), k, iCell) = 0.0_RKIND + end do + end do + end if ! associated(DMSTracers) + + if ( associated(MacroMoleculesTracers) ) then + call mpas_pool_get_dimension(tracersPool, 'index_PROT', index_dummy) + indexField(1) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_POLY', index_dummy) + indexField(2) = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_LIP', index_dummy) + indexField(3) = index_dummy + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + MacroMoleculesTracers(indexField(1), k, iCell) = 0.0_RKIND + MacroMoleculesTracers(indexField(2), k, iCell) = 0.0_RKIND + MacroMoleculesTracers(indexField(3), k, iCell) = 0.0_RKIND + end do + end do + end if ! associated(MacroMoleculesTracers) + do iCell = 1, nCellsSolve ! Set layerThickness do k = 1, nVertLevels diff --git a/src/core_ocean/shared/Makefile b/src/core_ocean/shared/Makefile index 9fdacbfcb0..17b2c7f2c1 100644 --- a/src/core_ocean/shared/Makefile +++ b/src/core_ocean/shared/Makefile @@ -43,9 +43,15 @@ OBJS = mpas_ocn_init_routines.o \ mpas_ocn_tracer_ideal_age.o \ mpas_ocn_tracer_TTD.o \ mpas_ocn_tracer_ecosys.o \ + mpas_ocn_tracer_DMS.o \ + mpas_ocn_tracer_MacroMolecules.o \ BGC_mod.o \ BGC_parms.o \ co2calc.o \ + DMS_mod.o \ + DMS_parms.o \ + MACROS_mod.o \ + MACROS_parms.o \ mpas_ocn_high_freq_thickness_hmix_del2.o \ mpas_ocn_tracer_surface_flux_to_tend.o \ mpas_ocn_test.o \ @@ -62,7 +68,7 @@ all: $(OBJS) mpas_ocn_init_routines.o: mpas_ocn_constants.o mpas_ocn_time_average.o mpas_ocn_diagnostics.o mpas_ocn_gm.o -mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_restoring.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_surface_bulk_forcing.o mpas_ocn_surface_land_ice_fluxes.o mpas_ocn_tracer_surface_flux_to_tend.o mpas_ocn_tracer_interior_restoring.o mpas_ocn_tracer_exponential_decay.o mpas_ocn_tracer_ideal_age.o mpas_ocn_tracer_TTD.o mpas_ocn_vmix.o mpas_ocn_constants.o mpas_ocn_tracer_ecosys.o BGC_mod.o BGC_parms.o co2calc.o +mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_restoring.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_surface_bulk_forcing.o mpas_ocn_surface_land_ice_fluxes.o mpas_ocn_tracer_surface_flux_to_tend.o mpas_ocn_tracer_interior_restoring.o mpas_ocn_tracer_exponential_decay.o mpas_ocn_tracer_ideal_age.o mpas_ocn_tracer_TTD.o mpas_ocn_vmix.o mpas_ocn_constants.o mpas_ocn_tracer_ecosys.o BGC_mod.o BGC_parms.o co2calc.o mpas_ocn_tracer_DMS.o DMS_mod.o DMS_parms.o mpas_ocn_tracer_MacroMolecules.o MACROS_mod.o MACROS_parms.o mpas_ocn_diagnostics_routines.o: mpas_ocn_constants.o @@ -162,6 +168,14 @@ mpas_ocn_tracer_ecosys.o: BGC_mod.o BGC_mod.o: BGC_parms.o co2calc.o +mpas_ocn_tracer_DMS.o: DMS_mod.o BGC_mod.o + +DMS_mod.o: DMS_parms.o + +mpas_ocn_tracer_MacroMolecules.o: MACROS_mod.o BGC_mod.o + +MACROS_mod.o: MACROS_parms.o + clean: $(RM) *.o *.i *.mod *.f90 diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index 07f71babc2..bddd0703f0 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -42,6 +42,8 @@ module ocn_tendency use ocn_tracer_TTD use ocn_tracer_surface_flux_to_tend use ocn_tracer_ecosys + use ocn_tracer_DMS + use ocn_tracer_MacroMolecules use ocn_thick_hadv use ocn_thick_vadv @@ -415,7 +417,8 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me tracerGroup, tracerGroupTend, vertNonLocalFlux real (kind=RKIND), dimension(:,:,:), pointer :: & - activeTracers ! need T, S for ecosys + activeTracers, & ! need T, S for ecosys + ecosysTracers ! need ecosys for DMS and MacroMolecules real (kind=RKIND), dimension(:,:,:), pointer :: tracerGroupInteriorRestoringRate, tracerGroupInteriorRestoringValue @@ -427,7 +430,7 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! ! local integers/reals/logicals ! - integer :: err, iEdge, k, timeLevel + integer :: err, iEdge, k, timeLevel, nTracersEcosys ! ! start timers @@ -571,6 +574,44 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me call mpas_timer_stop("ecosys surface flux") endif + ! + ! compute DMS source-sink tendencies and net surface fluxes + ! NOTE: must be called before ocn_tracer_surface_flux_tend + ! + if ( trim(groupItr % memberName) == 'DMSTracers' ) then + call mpas_timer_start("DMS source-sink", .false.) + call mpas_pool_get_array(tracersPool, 'ecosysTracers', ecosysTracers, timeLevel) + nTracersEcosys = size(ecosysTracers, dim=1) + call ocn_tracer_DMS_compute(tracerGroup, nTracerGroup, ecosysTracers, nTracersEcosys, forcingPool, & + nCellsSolve, maxLevelCell, nVertLevels, layerThickness, & + tracerGroupTend, err) + call mpas_timer_stop("DMS source-sink") + + call mpas_timer_start("DMS surface flux", .false.) + call ocn_tracer_DMS_surface_flux_compute(activeTracers, tracerGroup, forcingPool, & + nTracerGroup, nCellsSolve, zMid, indexTemperature, indexSalinity, tracerGroupSurfaceFlux, err)!{{{ + call mpas_timer_stop("DMS surface flux") + endif + + ! + ! compute MacroMolecules source-sink tendencies and net surface fluxes + ! NOTE: must be called before ocn_tracer_surface_flux_tend + ! + if ( trim(groupItr % memberName) == 'MacroMoleculesTracers' ) then + call mpas_timer_start("MacroMolecules source-sink", .false.) + call mpas_pool_get_array(tracersPool, 'ecosysTracers', ecosysTracers, timeLevel) + nTracersEcosys = size(ecosysTracers, dim=1) + call ocn_tracer_MacroMolecules_compute(tracerGroup, nTracerGroup, ecosysTracers, nTracersEcosys, forcingPool, & + nCellsSolve, maxLevelCell, nVertLevels, layerThickness, & + tracerGroupTend, err) + call mpas_timer_stop("MacroMolecules source-sink") + + call mpas_timer_start("MacroMolecules surface flux", .false.) + call ocn_tracer_MacroMolecules_surface_flux_compute(activeTracers, tracerGroup, forcingPool, & + nTracerGroup, nCellsSolve, zMid, indexTemperature, indexSalinity, tracerGroupSurfaceFlux, err)!{{{ + call mpas_timer_stop("MacroMolecules surface flux") + endif + ! ! ocean surface restoring ! diff --git a/src/core_ocean/tracer_groups/Registry_tracers.xml b/src/core_ocean/tracer_groups/Registry_tracers.xml index 68f3bf1dd1..ce11f75662 100644 --- a/src/core_ocean/tracer_groups/Registry_tracers.xml +++ b/src/core_ocean/tracer_groups/Registry_tracers.xml @@ -1,4 +1,6 @@ #include "Registry_activeTracers.xml" #include "Registry_debugTracers.xml" #include "Registry_ecosys.xml" +#include "Registry_DMS.xml" +#include "Registry_MacroMolecules.xml" //#include "Registry_TEMPLATEGRP.xml" From d0399e8fcde14158cc2f3172a26272193b9fa9e6 Mon Sep 17 00:00:00 2001 From: Mathew Maltrud Date: Tue, 27 Oct 2015 16:52:09 -0600 Subject: [PATCH 0383/1724] added both 2d and 3d PH_PREV to restart and init files. added PH_PREV to restart and init since they are used as the init for the iterative carbonate solver. required to get exact restart when using BGC, though this hasn't been tested in MPAS-O yet. --- src/core_ocean/Registry.xml | 918 ++++++++++++++++++------------------ 1 file changed, 461 insertions(+), 457 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 8e01a05353..e9665a822e 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -952,465 +952,27 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + From a048cabdf2844bf96c0f3479b21a65285ebead2b Mon Sep 17 00:00:00 2001 From: Mathew Maltrud Date: Wed, 28 Oct 2015 17:45:27 -0600 Subject: [PATCH 0384/1724] actually added the DMS and MacroMolecules this time. forgot to 'git add' the new files before commiting and pushing. --- src/core_ocean/shared/mpas_ocn_tracer_DMS.F | 532 ++++++++++++++++++ .../shared/mpas_ocn_tracer_MacroMolecules.F | 438 ++++++++++++++ src/core_ocean/tracer_groups/Registry_DMS.xml | 94 ++++ .../tracer_groups/Registry_MacroMolecules.xml | 103 ++++ 4 files changed, 1167 insertions(+) create mode 100644 src/core_ocean/shared/mpas_ocn_tracer_DMS.F create mode 100644 src/core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F create mode 100644 src/core_ocean/tracer_groups/Registry_DMS.xml create mode 100644 src/core_ocean/tracer_groups/Registry_MacroMolecules.xml diff --git a/src/core_ocean/shared/mpas_ocn_tracer_DMS.F b/src/core_ocean/shared/mpas_ocn_tracer_DMS.F new file mode 100644 index 0000000000..0527ec1cb8 --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tracer_DMS.F @@ -0,0 +1,532 @@ +! copyright (c) 2013, los alamos national security, llc (lans) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tracer_DMS +! +!> \brief MPAS ocean DMS +!> \author Mathew Maltrud +!> \date 08/24/2015 +!> \details +!> This module contains routines for computing tracer forcing due to DMS +! +!----------------------------------------------------------------------- + +module ocn_tracer_DMS + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use ocn_constants + + use DMS_mod + use DMS_parms + use BGC_mod + use BGC_parms + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_tracer_DMS_compute, & + ocn_tracer_DMS_surface_flux_compute, & + ocn_tracer_DMS_init + + integer, public:: & + numColumnsMax + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! name the necessary DMS derived types +! all of these are defined in DMS_mod +!----------------------------------------------------------------------- + + type(DMS_indices_type) , public :: DMS_indices + type(DMS_input_type) , public :: DMS_input + type(DMS_forcing_type) , public :: DMS_forcing + type(DMS_output_type) , public :: DMS_output + type(DMS_diagnostics_type), public :: DMS_diagnostic_fields + type(DMS_flux_diagnostics_type), public :: DMS_flux_diagnostic_fields + +! hold indices in tracer pool corresponding to each tracer array + type(DMS_indices_type) :: dmsIndices + type(BGC_indices_type) :: ecosysIndices + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_tracer_DMS_compute +! +!> \brief computes a tracer tendency due to DMS +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine computes a tracer tendency due to DMS +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_DMS_compute(DMSTracers, nTracersDMS, ecosysTracers, nTracersEcosys, forcingPool, & + nCellsSolve, maxLevelCell, nVertLevels, layerThickness, DMSTracersTend, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + ! one dimensional arrays + integer, dimension(:), intent(in) :: & + maxLevelCell + + ! two dimensional arrays + real (kind=RKIND), dimension(:,:), intent(in) :: & + layerThickness + + ! three dimensional arrays + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + DMSTracers + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + ecosysTracers + + type (mpas_pool_type), intent(in) :: forcingPool + + ! scalars + integer, intent(in) :: nTracersDMS, nTracersEcosys, nCellsSolve, nVertLevels + + ! + ! two dimensional pointers + ! + real (kind=RKIND), dimension(:), pointer :: & + shortWaveHeatFlux + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:,:), intent(inout) :: & + DMSTracersTend + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + +!maltrud i think source/sink wants cm instead of m +! real (kind=RKIND) :: zTop, zBot, convertLengthScale = 1.0_RKIND + real (kind=RKIND) :: zTop, zBot, convertLengthScale = 100.0_RKIND + + integer :: iCell, iLevel, iTracer, numColumns, column + + err = 0 + + call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) + + numColumns = 1 + column = 1 + do iCell=1,nCellsSolve + DMS_input%number_of_active_levels(column) = maxLevelCell(iCell) + do iLevel=1,maxLevelCell(iCell) + DMS_input%cell_thickness(iLevel,column) = layerThickness(iLevel,iCell)*convertLengthScale + + DMS_input%DMS_tracers(iLevel,column,DMS_indices%dms_ind) = DMSTracers(dmsIndices%dms_ind,iLevel,iCell) + DMS_input%DMS_tracers(iLevel,column,DMS_indices%dmsp_ind) = DMSTracers(dmsIndices%dmsp_ind,iLevel,iCell) + + DMS_input%DMS_tracers(iLevel,column,DMS_indices%no3_ind) = ecosysTracers(ecosysIndices%no3_ind,iLevel,iCell) + DMS_input%DMS_tracers(iLevel,column,DMS_indices%doc_ind) = ecosysTracers(ecosysIndices%doc_ind,iLevel,iCell) + DMS_input%DMS_tracers(iLevel,column,DMS_indices%zooC_ind) = ecosysTracers(ecosysIndices%zooC_ind,iLevel,iCell) + DMS_input%DMS_tracers(iLevel,column,DMS_indices%spC_ind) = ecosysTracers(ecosysIndices%spC_ind,iLevel,iCell) + DMS_input%DMS_tracers(iLevel,column,DMS_indices%spChl_ind) = ecosysTracers(ecosysIndices%spChl_ind,iLevel,iCell) + DMS_input%DMS_tracers(iLevel,column,DMS_indices%spCaCO3_ind) = ecosysTracers(ecosysIndices%spCaCO3_ind,iLevel,iCell) + DMS_input%DMS_tracers(iLevel,column,DMS_indices%diatC_ind) = ecosysTracers(ecosysIndices%diatC_ind,iLevel,iCell) + DMS_input%DMS_tracers(iLevel,column,DMS_indices%diatChl_ind) = ecosysTracers(ecosysIndices%diatChl_ind,iLevel,iCell) + DMS_input%DMS_tracers(iLevel,column,DMS_indices%phaeoC_ind) = ecosysTracers(ecosysIndices%phaeoC_ind,iLevel,iCell) + DMS_input%DMS_tracers(iLevel,column,DMS_indices%phaeoChl_ind) = ecosysTracers(ecosysIndices%phaeoChl_ind,iLevel,iCell) + DMS_input%DMS_tracers(iLevel,column,DMS_indices%diazC_ind) = ecosysTracers(ecosysIndices%diazC_ind,iLevel,iCell) + DMS_input%DMS_tracers(iLevel,column,DMS_indices%diazChl_ind) = ecosysTracers(ecosysIndices%diazChl_ind,iLevel,iCell) + + enddo ! iLevel + + call DMS_SourceSink(DMS_indices, DMS_input, DMS_forcing, & + DMS_output, DMS_diagnostic_fields, nVertLevels, & + numColumnsMax, numColumns) + + do iLevel=1,maxLevelCell(iCell) + + DMSTracersTend(dmsIndices%dms_ind,iLevel,iCell) = DMSTracersTend(dmsIndices%dms_ind,iLevel,iCell) & + + DMS_output%DMS_tendencies(iLevel,column,DMS_indices%dms_ind)*layerThickness(iLevel,iCell) + DMSTracersTend(dmsIndices%dmsp_ind,iLevel,iCell) = DMSTracersTend(dmsIndices%dmsp_ind,iLevel,iCell) & + + DMS_output%DMS_tendencies(iLevel,column,DMS_indices%dmsp_ind)*layerThickness(iLevel,iCell) + + enddo + + enddo ! iCell + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_DMS_compute!}}} + +!*********************************************************************** +! +! routine ocn_tracer_DMS_surface_flux_compute +! +!> \brief computes a tracer tendency due to DMS +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine computes a tracer tendency due to DMS +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_DMS_surface_flux_compute(activeTracers, DMSTracers, forcingPool, & + nTracers, nCellsSolve, zMid, indexTemperature, indexSalinity, DMSSurfaceFlux, err)!{{{ + + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + ! two dimensional arrays + real (kind=RKIND), dimension(:,:), intent(in) :: & + zMid + real (kind=RKIND), dimension(:,:), intent(inout) :: & + DMSSurfaceFlux + + ! three dimensional arrays + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + DMSTracers + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + activeTracers + + ! scalars + integer, intent(in) :: nTracers, nCellsSolve, indexTemperature, indexSalinity + + type (mpas_pool_type), intent(inout) :: forcingPool + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: ecosysAuxiliary + + integer :: numColumns, column, iCell, iTracer, iLevelSurface + + real (kind=RKIND), dimension(:), pointer :: & + seaSurfacePressure, & + iceFraction, & + windSpeedSquared10m + + real (kind=RKIND) :: & + renormFluxes = 0.01_RKIND, & +! PascalsToAtmospheres = 1.0_RKIND/101.325e+3_RKIND, & +! mSquared_to_cmSquared = 1.0e+4_RKIND +! PascalsToAtmospheres = 1.0_RKIND, & +! mSquared_to_cmSquared = 1.0_RKIND + PascalsToAtmospheres = 0.0_RKIND, & + mSquared_to_cmSquared = 1.0_RKIND + + err = 0 + + call mpas_pool_get_array(forcingPool, 'seaSurfacePressure', seaSurfacePressure) + call mpas_pool_get_array(forcingPool, 'iceFraction', iceFraction) + + call mpas_pool_get_subpool(forcingPool, 'ecosysAuxiliary', ecosysAuxiliary) + call mpas_pool_get_array(ecosysAuxiliary, 'windSpeedSquared10m', windSpeedSquared10m) + + numColumns = 1 + column = 1 + iLevelSurface = 1 + do iCell=1,nCellsSolve + + DMS_forcing%surfacePressure(column) = seaSurfacePressure(iCell)*PascalsToAtmospheres + DMS_forcing%iceFraction(column) = iceFraction(iCell) + DMS_forcing%windSpeedSquared10m(column) = windSpeedSquared10m(iCell)*mSquared_to_cmSquared + DMS_forcing%SST(column) = activeTracers(indexTemperature,iLevelSurface,iCell) + DMS_forcing%SSS(column) = activeTracers(indexSalinity,iLevelSurface,iCell) + + call DMS_SurfaceFluxes(DMS_indices, DMS_input, DMS_forcing, & + DMS_flux_diagnostic_fields, & + numColumnsMax, column) + + DMSSurfaceFlux(dmsIndices%dms_ind,iCell) = DMS_forcing%netFlux(column,DMS_indices%dms_ind)*renormFluxes + DMSSurfaceFlux(dmsIndices%dmsp_ind,iCell) = DMS_forcing%netFlux(column,DMS_indices%dmsp_ind)*renormFluxes + + enddo ! iCell + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_DMS_surface_flux_compute!}}} + +!*********************************************************************** +! +! routine ocn_tracer_DMS_init +! +!> \brief Initializes ocean surface restoring +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine initializes fields required for tracer surface flux restoring +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_DMS_init(domain,err)!{{{ + +!NOTE: called from mpas_ocn_forward_mode.F + + type (domain_type), intent(inout) :: domain !< Input/Output: domain information + + integer, intent(out) :: err !< Output: error flag + + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tracersPool + + ! three dimensional pointers + real (kind=RKIND), dimension(:,:,:), pointer :: & + DMSTracers + + ! scalars + integer :: nTracers, numColumnsMax + + ! scalar pointers + integer, pointer :: nVertLevels, index_dummy + + ! + ! get tracers pools + ! + + err = 0 + + ! + ! Get tracer group so we can get the number of tracers in it + ! + + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_array(tracersPool, 'DMSTracers', DMSTracers, 1) + + if (associated(DMSTracers)) then + + nTracers = size(DMSTracers, dim=1) +!maltrud cannot use DMS_tracer_cnt since it has dms, dmsp, and 12 ecosys fields + if (nTracers /= 2) then + err = 1 + return + endif + + ! + ! pull nVertLevels out of the mesh structure + ! + + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nVertLevels', nVertLevels) + +!----------------------------------------------------------------------- +! initialize DMS parameters +!----------------------------------------------------------------------- + + allocate( DMS_indices%short_name(DMS_tracer_cnt) ) + allocate( DMS_indices%long_name(DMS_tracer_cnt) ) + allocate( DMS_indices%units(DMS_tracer_cnt) ) + +! no need to allocate the above fields for dmsIndices (?) + +!----------------------------------------------------------------------- +! sets most of DMS parameters +! sets namelist defaults +!----------------------------------------------------------------------- + + call DMS_parms_init + +!maltrud modify namelist values here.... + +!maltrud how to handle this? + T0_Kelvin_BGC = T0_Kelvin + + ! + ! for now only do 1 column at a time + ! + numColumnsMax = 1 + + DMS_indices%dms_ind = 1 + DMS_indices%dmsp_ind = 2 + DMS_indices%no3_ind = 3 + DMS_indices%doc_ind = 4 + DMS_indices%zooC_ind = 5 + DMS_indices%spC_ind = 6 + DMS_indices%spCaCO3_ind = 7 + DMS_indices%diatC_ind = 8 + DMS_indices%diazC_ind = 9 + DMS_indices%phaeoC_ind = 10 + DMS_indices%spChl_ind = 11 + DMS_indices%diatChl_ind = 12 + DMS_indices%diazChl_ind = 13 + DMS_indices%phaeoChl_ind = 14 + + call mpas_pool_get_dimension(tracersPool, 'index_DMS', index_dummy) + dmsIndices%dms_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DMSP', index_dummy) + dmsIndices%dmsp_ind = index_dummy + + call mpas_pool_get_dimension(tracersPool, 'index_NO3', index_dummy) + ecosysIndices%no3_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_DOC', index_dummy) + ecosysIndices%doc_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_zooC', index_dummy) + ecosysIndices%zooC_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_spChl', index_dummy) + ecosysIndices%spChl_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_spC', index_dummy) + ecosysIndices%spC_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_spCaCO3', index_dummy) + ecosysIndices%spCaCO3_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diatChl', index_dummy) + ecosysIndices%diatChl_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diatC', index_dummy) + ecosysIndices%diatC_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diazChl', index_dummy) + ecosysIndices%diazChl_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diazC', index_dummy) + ecosysIndices%diazC_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_phaeoChl', index_dummy) + ecosysIndices%phaeoChl_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_phaeoC', index_dummy) + ecosysIndices%phaeoC_ind = index_dummy + +! DMS_init sets short and long names, units in DMS_indices + + call DMS_init(DMS_indices) + +!NOTES: + +!also check short_name with mpas variable name + +!----------------------------------------------------------------------- +! allocate input, forcing, diagnostic arrays +!----------------------------------------------------------------------- + + allocate ( DMS_input%DMS_tracers(nVertLevels, numColumnsMax, DMS_tracer_cnt) ) + allocate ( DMS_input%cell_thickness(nVertLevels, numColumnsMax) ) + allocate ( DMS_input%number_of_active_levels(numColumnsMax) ) + + allocate ( DMS_forcing%ShortWaveFlux_surface(numColumnsMax) ) + allocate ( DMS_forcing%surfacePressure(numColumnsMax) ) + allocate ( DMS_forcing%iceFraction(numColumnsMax) ) + allocate ( DMS_forcing%windSpeedSquared10m(numColumnsMax) ) + allocate ( DMS_forcing%SST(numColumnsMax) ) + allocate ( DMS_forcing%SSS(numColumnsMax) ) + + allocate ( DMS_forcing%netFlux(numColumnsMax, DMS_tracer_cnt) ) + + allocate ( DMS_output%DMS_tendencies(nVertLevels, numColumnsMax, DMS_tracer_cnt) ) + + !--------------------------------------------------------------------------- + ! allocate flux diagnostic output fields + !--------------------------------------------------------------------------- + + allocate (DMS_flux_diagnostic_fields%diag_DMS_IFRAC(numColumnsMax) ) + allocate (DMS_flux_diagnostic_fields%diag_DMS_XKW(numColumnsMax) ) + allocate (DMS_flux_diagnostic_fields%diag_DMS_ATM_PRESS(numColumnsMax) ) + allocate (DMS_flux_diagnostic_fields%diag_DMS_PV(numColumnsMax) ) + allocate (DMS_flux_diagnostic_fields%diag_DMS_SCHMIDT(numColumnsMax) ) + allocate (DMS_flux_diagnostic_fields%diag_DMS_SAT(numColumnsMax) ) + allocate (DMS_flux_diagnostic_fields%diag_DMS_SURF(numColumnsMax) ) + allocate (DMS_flux_diagnostic_fields%diag_DMS_WS(numColumnsMax) ) + + !--------------------------------------------------------------------------- + ! allocate diagnostic output fields + !--------------------------------------------------------------------------- + + allocate (DMS_diagnostic_fields%diag_DMS_S_DMSP(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_DMS_S_TOTAL(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_DMS_R_B(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_DMS_R_PHOT(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_DMS_R_BKGND(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_DMS_R_TOTAL(nVertLevels, numColumnsMax) ) + + allocate (DMS_diagnostic_fields%diag_DMSP_S_PHAEO(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_DMSP_S_NONPHAEO(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_DMSP_S_ZOO(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_DMSP_S_TOTAL(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_DMSP_R_B(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_DMSP_R_BKGND(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_DMSP_R_TOTAL(nVertLevels, numColumnsMax) ) + + allocate (DMS_diagnostic_fields%diag_Cyano_frac(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_Cocco_frac(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_Eukar_frac(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_diatS(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_diatN(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_phytoN(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_coccoS(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_cyanoS(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_eukarS(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_diazS(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_phaeoS(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_zooS(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_zooCC(nVertLevels, numColumnsMax) ) + allocate (DMS_diagnostic_fields%diag_RSNzoo(nVertLevels, numColumnsMax) ) + + end if ! associated(DMS_tracers) + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_DMS_init!}}} + +!*********************************************************************** + +end module ocn_tracer_DMS + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F b/src/core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F new file mode 100644 index 0000000000..b2706a6d8e --- /dev/null +++ b/src/core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F @@ -0,0 +1,438 @@ +! copyright (c) 2013, los alamos national security, llc (lans) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_tracer_MacroMolecules +! +!> \brief MPAS ocean MacroMolecules +!> \author Mathew Maltrud +!> \date 08/24/2015 +!> \details +!> This module contains routines for computing tracer forcing due to MacroMolecules +! +!----------------------------------------------------------------------- + +module ocn_tracer_MacroMolecules + + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + use ocn_constants + + use MACROS_mod + use MACROS_parms + use BGC_mod + use BGC_parms + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_tracer_MacroMolecules_compute, & + ocn_tracer_MacroMolecules_surface_flux_compute, & + ocn_tracer_MacroMolecules_init + + integer, public:: & + numColumnsMax + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! name the necessary MacroMolecules derived types +! all of these are defined in MacroMolecules_mod +!----------------------------------------------------------------------- + + type(MACROS_indices_type) , public :: MacroMolecules_indices + type(MACROS_input_type) , public :: MacroMolecules_input + type(MACROS_output_type) , public :: MacroMolecules_output + type(MACROS_diagnostics_type), public :: MacroMolecules_diagnostic_fields + +! hold indices in tracer pool corresponding to each tracer array + type(MACROS_indices_type) :: macrosIndices + type(BGC_indices_type) :: ecosysIndices + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_tracer_MacroMolecules_compute +! +!> \brief computes a tracer tendency due to MacroMolecules +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine computes a tracer tendency due to MacroMolecules +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_MacroMolecules_compute(MacroMoleculesTracers, nTracersMacroMolecules, & + ecosysTracers, nTracersEcosys, forcingPool, & + nCellsSolve, maxLevelCell, nVertLevels, layerThickness, MacroMoleculesTracersTend, err)!{{{ + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + ! one dimensional arrays + integer, dimension(:), intent(in) :: & + maxLevelCell + + ! two dimensional arrays + real (kind=RKIND), dimension(:,:), intent(in) :: & + layerThickness + + ! three dimensional arrays + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + MacroMoleculesTracers + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + ecosysTracers + + type (mpas_pool_type), intent(in) :: forcingPool + + ! scalars + integer, intent(in) :: nTracersMacroMolecules, nTracersEcosys, nCellsSolve, nVertLevels + + ! + ! two dimensional pointers + ! + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:,:,:), intent(inout) :: & + MacroMoleculesTracersTend + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + +!maltrud i think source/sink wants cm instead of m +! real (kind=RKIND) :: zTop, zBot, convertLengthScale = 1.0_RKIND + real (kind=RKIND) :: zTop, zBot, convertLengthScale = 100.0_RKIND + + integer :: iCell, iLevel, iTracer, numColumns, column + + err = 0 + + numColumns = 1 + column = 1 + do iCell=1,nCellsSolve + MacroMolecules_input%number_of_active_levels(column) = maxLevelCell(iCell) + do iLevel=1,maxLevelCell(iCell) + MacroMolecules_input%cell_thickness(iLevel,column) = layerThickness(iLevel,iCell)*convertLengthScale + + MacroMolecules_input%MACROS_tracers(iLevel,column,MacroMolecules_indices%prot_ind) = & + MacroMoleculesTracers(macrosIndices%prot_ind,iLevel,iCell) + MacroMolecules_input%MACROS_tracers(iLevel,column,MacroMolecules_indices%poly_ind) = & + MacroMoleculesTracers(macrosIndices%poly_ind,iLevel,iCell) + MacroMolecules_input%MACROS_tracers(iLevel,column,MacroMolecules_indices%lip_ind) = & + MacroMoleculesTracers(macrosIndices%lip_ind,iLevel,iCell) + + MacroMolecules_input%MACROS_tracers(iLevel,column,MacroMolecules_indices%zooC_ind) = & + ecosysTracers(ecosysIndices%zooC_ind,iLevel,iCell) + MacroMolecules_input%MACROS_tracers(iLevel,column,MacroMolecules_indices%spC_ind) = & + ecosysTracers(ecosysIndices%spC_ind,iLevel,iCell) + MacroMolecules_input%MACROS_tracers(iLevel,column,MacroMolecules_indices%diatC_ind) = & + ecosysTracers(ecosysIndices%diatC_ind,iLevel,iCell) + MacroMolecules_input%MACROS_tracers(iLevel,column,MacroMolecules_indices%phaeoC_ind) = & + ecosysTracers(ecosysIndices%phaeoC_ind,iLevel,iCell) + MacroMolecules_input%MACROS_tracers(iLevel,column,MacroMolecules_indices%diazC_ind) = & + ecosysTracers(ecosysIndices%diazC_ind,iLevel,iCell) + + enddo ! iLevel + + call MACROS_SourceSink(MacroMolecules_indices, MacroMolecules_input, & + MacroMolecules_output, MacroMolecules_diagnostic_fields, nVertLevels, & + numColumnsMax, numColumns) + + do iLevel=1,maxLevelCell(iCell) + + MacroMoleculesTracersTend(macrosIndices%prot_ind,iLevel,iCell) = & + MacroMoleculesTracersTend(macrosIndices%prot_ind,iLevel,iCell) & + + MacroMolecules_output%MACROS_tendencies(iLevel,column,MacroMolecules_indices%prot_ind) + MacroMoleculesTracersTend(macrosIndices%poly_ind,iLevel,iCell) = & + MacroMoleculesTracersTend(macrosIndices%poly_ind,iLevel,iCell) & + + MacroMolecules_output%MACROS_tendencies(iLevel,column,MacroMolecules_indices%poly_ind) + MacroMoleculesTracersTend(macrosIndices%lip_ind,iLevel,iCell) = & + MacroMoleculesTracersTend(macrosIndices%lip_ind,iLevel,iCell) & + + MacroMolecules_output%MACROS_tendencies(iLevel,column,MacroMolecules_indices%lip_ind) + + enddo + + enddo ! iCell + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_MacroMolecules_compute!}}} + +!*********************************************************************** +! +! routine ocn_tracer_MacroMolecules_surface_flux_compute +! +!> \brief computes a tracer tendency due to MacroMolecules +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine computes a tracer tendency due to MacroMolecules +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_MacroMolecules_surface_flux_compute(activeTracers, MacroMoleculesTracers, forcingPool, & + nTracers, nCellsSolve, zMid, indexTemperature, indexSalinity, MacroMoleculesSurfaceFlux, err)!{{{ + + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + ! two dimensional arrays + real (kind=RKIND), dimension(:,:), intent(in) :: & + zMid + real (kind=RKIND), dimension(:,:), intent(inout) :: & + MacroMoleculesSurfaceFlux + + ! three dimensional arrays + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + MacroMoleculesTracers + real (kind=RKIND), dimension(:,:,:), intent(in) :: & + activeTracers + + ! scalars + integer, intent(in) :: nTracers, nCellsSolve, indexTemperature, indexSalinity + + type (mpas_pool_type), intent(inout) :: forcingPool + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: Error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + integer :: iCell + + err = 0 + + ! fluxes are zero + + do iCell = 1, nCellsSolve + + MacroMoleculesSurfaceFlux(macrosIndices%prot_ind,iCell) = 0.0_RKIND + MacroMoleculesSurfaceFlux(macrosIndices%poly_ind,iCell) = 0.0_RKIND + MacroMoleculesSurfaceFlux(macrosIndices%lip_ind, iCell) = 0.0_RKIND + + enddo ! iCell + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_MacroMolecules_surface_flux_compute!}}} + +!*********************************************************************** +! +! routine ocn_tracer_MacroMolecules_init +! +!> \brief Initializes ocean surface restoring +!> \author Todd Ringler +!> \date 06/09/2015 +!> \details +!> This routine initializes fields required for tracer surface flux restoring +! +!----------------------------------------------------------------------- + + subroutine ocn_tracer_MacroMolecules_init(domain,err)!{{{ + +!NOTE: called from mpas_ocn_forward_mode.F + + type (domain_type), intent(inout) :: domain !< Input/Output: domain information + + integer, intent(out) :: err !< Output: error flag + + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tracersPool + + ! three dimensional pointers + real (kind=RKIND), dimension(:,:,:), pointer :: & + MacroMoleculesTracers + + ! scalars + integer :: nTracers, numColumnsMax + + ! scalar pointers + integer, pointer :: nVertLevels, index_dummy + + ! + ! get tracers pools + ! + + err = 0 + + ! + ! Get tracer group so we can get the number of tracers in it + ! + + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_array(tracersPool, 'MacroMoleculesTracers', MacroMoleculesTracers, 1) + + if (associated(MacroMoleculesTracers)) then + + nTracers = size(MacroMoleculesTracers, dim=1) +!maltrud cannot use MacroMolecules_tracer_cnt since it has poly, prot, lip and 5 ecosys fields + if (nTracers /= 3) then + err = 1 + return + endif + + ! + ! pull nVertLevels out of the mesh structure + ! + + call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nVertLevels', nVertLevels) + +!----------------------------------------------------------------------- +! initialize MacroMolecules parameters +!----------------------------------------------------------------------- + + allocate( MacroMolecules_indices%short_name(MACROS_tracer_cnt) ) + allocate( MacroMolecules_indices%long_name(MACROS_tracer_cnt) ) + allocate( MacroMolecules_indices%units(MACROS_tracer_cnt) ) + +! no need to allocate the above fields for macrosIndices (?) + +!----------------------------------------------------------------------- +! sets most of MacroMolecules parameters +! sets namelist defaults +!----------------------------------------------------------------------- + + call MACROS_parms_init + +!maltrud modify namelist values here.... + +!maltrud how to handle this? + T0_Kelvin_BGC = T0_Kelvin + + ! + ! for now only do 1 column at a time + ! + numColumnsMax = 1 + + MacroMolecules_indices%prot_ind = 1 + MacroMolecules_indices%poly_ind = 2 + MacroMolecules_indices%lip_ind = 3 + MacroMolecules_indices%zooC_ind = 4 + MacroMolecules_indices%spC_ind = 5 + MacroMolecules_indices%diatC_ind = 6 + MacroMolecules_indices%diazC_ind = 7 + MacroMolecules_indices%phaeoC_ind = 8 + + call mpas_pool_get_dimension(tracersPool, 'index_PROT', index_dummy) + macrosIndices%prot_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_POLY', index_dummy) + macrosIndices%poly_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_LIP', index_dummy) + macrosIndices%lip_ind = index_dummy + + call mpas_pool_get_dimension(tracersPool, 'index_zooC', index_dummy) + ecosysIndices%zooC_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_spC', index_dummy) + ecosysIndices%spC_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diatC', index_dummy) + ecosysIndices%diatC_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_diazC', index_dummy) + ecosysIndices%diazC_ind = index_dummy + call mpas_pool_get_dimension(tracersPool, 'index_phaeoC', index_dummy) + ecosysIndices%phaeoC_ind = index_dummy + +! MacroMolecules_init sets short and long names, units in MacroMolecules_indices + + call MACROS_init(MacroMolecules_indices) + +!NOTES: + +!also check short_name with mpas variable name + +!----------------------------------------------------------------------- +! allocate input, forcing, diagnostic arrays +!----------------------------------------------------------------------- + + allocate ( MacroMolecules_input%MACROS_tracers(nVertLevels, numColumnsMax, MACROS_tracer_cnt) ) + allocate ( MacroMolecules_input%cell_thickness(nVertLevels, numColumnsMax) ) + allocate ( MacroMolecules_input%number_of_active_levels(numColumnsMax) ) + + allocate ( MacroMolecules_output%MACROS_tendencies(nVertLevels, numColumnsMax, MACROS_tracer_cnt) ) + + !--------------------------------------------------------------------------- + ! allocate diagnostic output fields + !--------------------------------------------------------------------------- + + allocate (MacroMolecules_diagnostic_fields%diag_PROT_S_TOTAL(nVertLevels, numColumnsMax) ) + allocate (MacroMolecules_diagnostic_fields%diag_POLY_S_TOTAL(nVertLevels, numColumnsMax) ) + allocate (MacroMolecules_diagnostic_fields%diag_LIP_S_TOTAL(nVertLevels, numColumnsMax) ) + allocate (MacroMolecules_diagnostic_fields%diag_PROT_R_TOTAL(nVertLevels, numColumnsMax) ) + allocate (MacroMolecules_diagnostic_fields%diag_POLY_R_TOTAL(nVertLevels, numColumnsMax) ) + allocate (MacroMolecules_diagnostic_fields%diag_LIP_R_TOTAL(nVertLevels, numColumnsMax) ) + + end if ! associated(MacroMoleculesTracers) + + !-------------------------------------------------------------------- + + end subroutine ocn_tracer_MacroMolecules_init!}}} + +!*********************************************************************** + +end module ocn_tracer_MacroMolecules + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/src/core_ocean/tracer_groups/Registry_DMS.xml b/src/core_ocean/tracer_groups/Registry_DMS.xml new file mode 100644 index 0000000000..249c53ecfb --- /dev/null +++ b/src/core_ocean/tracer_groups/Registry_DMS.xml @@ -0,0 +1,94 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/tracer_groups/Registry_MacroMolecules.xml b/src/core_ocean/tracer_groups/Registry_MacroMolecules.xml new file mode 100644 index 0000000000..cc1d3b469f --- /dev/null +++ b/src/core_ocean/tracer_groups/Registry_MacroMolecules.xml @@ -0,0 +1,103 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + From 15e9dc44bf3f61762726049a756b584a446c70e2 Mon Sep 17 00:00:00 2001 From: Mathew Maltrud Date: Wed, 28 Oct 2015 17:48:57 -0600 Subject: [PATCH 0385/1724] added fields for BGC coupling with sea ice. --- .../tracer_groups/Registry_ecosys.xml | 54 +++++++++++++++++++ 1 file changed, 54 insertions(+) mode change 100755 => 100644 src/core_ocean/tracer_groups/Registry_ecosys.xml diff --git a/src/core_ocean/tracer_groups/Registry_ecosys.xml b/src/core_ocean/tracer_groups/Registry_ecosys.xml old mode 100755 new mode 100644 index 788227d742..fc5d85502e --- a/src/core_ocean/tracer_groups/Registry_ecosys.xml +++ b/src/core_ocean/tracer_groups/Registry_ecosys.xml @@ -406,6 +406,60 @@ + + + + + + + + + + + + + + + + + + + + Date: Wed, 28 Oct 2015 17:49:42 -0600 Subject: [PATCH 0386/1724] fixed bgc init bug that caused failure if ecosys is turned off. --- src/core_ocean/shared/mpas_ocn_tracer_ecosys.F | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F b/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F index ff216095cc..3735592283 100755 --- a/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F @@ -779,6 +779,9 @@ subroutine ocn_tracer_ecosys_init(domain,err)!{{{ call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_array(tracersPool, 'ecosysTracers', ecosysTracers, 1) + + if (associated(ecosysTracers)) then + nTracers = size(ecosysTracers, dim=1) if (BGC_tracer_cnt /= nTracers) then err = 1 @@ -1101,6 +1104,8 @@ subroutine ocn_tracer_ecosys_init(domain,err)!{{{ allocate (BGC_diagnostic_fields%diag_O2_ZMIN(numColumnsMax) ) allocate (BGC_diagnostic_fields%diag_O2_ZMIN_DEPTH(numColumnsMax) ) + end if ! associated(ecosysTracers) + !-------------------------------------------------------------------- end subroutine ocn_tracer_ecosys_init!}}} From 54a72d611a3bc5dedb8eae11a08e12d4e5e8bc35 Mon Sep 17 00:00:00 2001 From: Mathew Maltrud Date: Thu, 29 Oct 2015 11:44:36 -0600 Subject: [PATCH 0387/1724] cleanup of tracer routines, addition of getting BGC files from different repo much like cvmix. --- src/core_ocean/Makefile | 20 +++- src/core_ocean/get_BGC.sh | 103 ++++++++++++++++++ src/core_ocean/shared/Makefile | 22 +--- src/core_ocean/shared/mpas_ocn_tracer_DMS.F | 13 +-- .../shared/mpas_ocn_tracer_MacroMolecules.F | 14 +-- .../shared/mpas_ocn_tracer_ecosys.F | 22 +--- 6 files changed, 137 insertions(+), 57 deletions(-) create mode 100755 src/core_ocean/get_BGC.sh diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index 9f0f2d199f..18f92382dd 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -2,9 +2,9 @@ OCEAN_SHARED_INCLUDES = -I$(PWD)/../framework -I$(PWD)/../external/esmf_time_f90 -I$(PWD)/../operators -OCEAN_SHARED_INCLUDES += -I$(PWD)/shared -I$(PWD)/analysis_members -I$(PWD)/cvmix -I$(PWD)/mode_forward -I$(PWD)/mode_analysis -I$(PWD)/mode_init +OCEAN_SHARED_INCLUDES += -I$(PWD)/shared -I$(PWD)/analysis_members -I$(PWD)/cvmix -I$(PWD)/mode_forward -I$(PWD)/mode_analysis -I$(PWD)/mode_init -I$(PWD)/BGC -all: shared libcvmix analysis_members +all: shared libcvmix analysis_members libBGC (cd mode_forward; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(OCEAN_SHARED_INCLUDES)" all ) (cd mode_analysis; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(OCEAN_SHARED_INCLUDES)" all ) (cd mode_init; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(OCEAN_SHARED_INCLUDES)" all ) @@ -60,6 +60,10 @@ cvmix_source: get_cvmix.sh (chmod a+x get_cvmix.sh; ./get_cvmix.sh) (cd cvmix; make clean) +BGC_source: get_BGC.sh + (chmod a+x get_BGC.sh; ./get_BGC.sh) + (cd BGC; make clean) + libcvmix: cvmix_source if [ -d cvmix ]; then \ (cd cvmix; make all FC="$(FC)" FCFLAGS="$(FFLAGS)" FINCLUDES="$(FINCLUDES)") \ @@ -67,7 +71,14 @@ libcvmix: cvmix_source (exit 1) \ fi -shared: libcvmix +libBGC: BGC_source + if [ -d BGC ]; then \ + (cd BGC; make all FC="$(FC)" FCFLAGS="$(FFLAGS)" FINCLUDES="$(FINCLUDES)") \ + else \ + (exit 1) \ + fi + +shared: libcvmix libBGC (cd shared; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(OCEAN_SHARED_INCLUDES)") analysis_members: libcvmix shared @@ -77,6 +88,9 @@ clean: if [ -d cvmix ]; then \ (cd cvmix; make clean) \ fi + if [ -d BGC ]; then \ + (cd BGC; make clean) \ + fi (cd mode_forward; $(MAKE) clean) (cd mode_analysis; $(MAKE) clean) (cd mode_init; $(MAKE) clean) diff --git a/src/core_ocean/get_BGC.sh b/src/core_ocean/get_BGC.sh new file mode 100755 index 0000000000..cf8973e622 --- /dev/null +++ b/src/core_ocean/get_BGC.sh @@ -0,0 +1,103 @@ +#!/bin/bash + +## BGC Tag for build +BGC_TAG=50af425 + +## Subdirectory in BGC repo to use +BGC_SUBDIR=. + +## Available protocols for acquiring BGC source code +BGC_GIT_HTTP_ADDRESS=https://github.com/ACME-Climate/Ocean-BGC.git +BGC_GIT_SSH_ADDRESS=git@github.com:ACME-Climate/Ocean-BGC.git +BGC_SVN_ADDRESS=https://github.com/ACME-Climate/Ocean-BGC-src/tags +BGC_WEB_ADDRESS=https://github.com/ACME-Climate/Ocean-BGC-src/archive + +GIT=`which git` +SVN=`which svn` +PROTOCOL="" + +# BGC exists. Need to make sure it's updated if it is git. +# Otherwise, flush the directory to ensure it's updated. +if [ -d BGC ]; then + unlink BGC + + if [ -d .BGC_all/.git ]; then + cd .BGC_all + git fetch origin &> /dev/null + git checkout ${BGC_TAG} &> /dev/null + cd ../ + ln -sf .BGC_all/${BGC_SUBDIR} BGC + else + rm -rf .BGC_all + fi +fi + +# CVmix Doesn't exist, need to acquire souce code +# If might have been flushed from the above if, in the case where it was svn or wget that acquired the source. +if [ ! -d BGC ]; then + if [ -d .BGC_all ]; then + rm -rf .BGC_all + fi + + if [ "${GIT}" != "" ]; then + echo " ** Using git to acquire BGC source. ** " + PROTOCOL="git ssh" + git clone ${BGC_GIT_SSH_ADDRESS} .BGC_all &> /dev/null + if [ -d .BGC_all ]; then + cd .BGC_all + git checkout ${BGC_TAG} &> /dev/null + cd ../ + ln -sf .BGC_all/${BGC_SUBDIR} BGC + else + git clone ${BGC_GIT_HTTP_ADDRESS} .BGC_all &> /dev/null + PROTOCOL="git http" + if [ -d .BGC_all ]; then + cd .BGC_all + git checkout ${BGC_TAG} &> /dev/null + cd ../ + ln -sf .BGC_all/${BGC_SUBDIR} BGC + fi + fi + elif [ "${SVN}" != "" ]; then + echo " ** Using svn to acquire BGC source. ** " + PROTOCOL="svn" + svn co ${BGC_SVN_ADDRESS}/${BGC_TAG} .BGC_all &> /dev/null + ln -sf .BGC_all/${BGC_SUBDIR} BGC + else + echo " ** Using wget to acquire BGC source. ** " + PROTOCOL="svn" + BGC_ZIP_DIR=`echo ${BGC_TAG} | sed 's/v//g'` + BGC_ZIP_DIR="BGC-src-${BGC_ZIP_DIR}" + if [ ! -e .${BGC_TAG}.zip ]; then + wget ${BGC_WEB_ADDRESS}/${BGC_TAG}.zip &> /dev/null + fi + unzip ${BGC_TAG}.zip &> /dev/null + mv ${BGC_TAG}.zip .${BGC_TAG}.zip + mv ${BGC_ZIP_DIR} .BGC_all + ln -sf .BGC_all/${BGC_SUBDIR} BGC + fi +fi + +if [ ! -d BGC ]; then + echo " ****************************************************** " + echo " ERROR: Build failed to acquire BGC source." + echo "" + echo " Please ensure your proxy information is setup properly for" + echo " the protocol you use to acquire BGC." + echo "" + echo " The automated script attempted to use: ${PROTOCOL}" + echo "" + if [ "${PROTOCOL}" == "git http" ]; then + echo " This protocol requires setting up the http.proxy git config option." + elif [ "${PROTOCOL}" == "git ssh" ]; then + echo " This protocol requires having ssh-keys setup, and ssh access to git@github.com." + echo " Please use 'ssh -vT git@github.com' to debug issues with ssh keys." + elif [ "${PROTOCOL}" == "svn" ]; then + echo " This protocol requires having svn proxys setup properly in ~/.subversion/servers." + elif [ "${PROTOCOL}" == "wget" ]; then + echo " This protocol requires having the http_proxy and https_proxy environment variables" + echo " setup properly for your shell." + fi + echo "" + echo " ****************************************************** " +fi diff --git a/src/core_ocean/shared/Makefile b/src/core_ocean/shared/Makefile index 17b2c7f2c1..ba08b24351 100644 --- a/src/core_ocean/shared/Makefile +++ b/src/core_ocean/shared/Makefile @@ -45,13 +45,6 @@ OBJS = mpas_ocn_init_routines.o \ mpas_ocn_tracer_ecosys.o \ mpas_ocn_tracer_DMS.o \ mpas_ocn_tracer_MacroMolecules.o \ - BGC_mod.o \ - BGC_parms.o \ - co2calc.o \ - DMS_mod.o \ - DMS_parms.o \ - MACROS_mod.o \ - MACROS_parms.o \ mpas_ocn_high_freq_thickness_hmix_del2.o \ mpas_ocn_tracer_surface_flux_to_tend.o \ mpas_ocn_test.o \ @@ -68,7 +61,7 @@ all: $(OBJS) mpas_ocn_init_routines.o: mpas_ocn_constants.o mpas_ocn_time_average.o mpas_ocn_diagnostics.o mpas_ocn_gm.o -mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_restoring.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_surface_bulk_forcing.o mpas_ocn_surface_land_ice_fluxes.o mpas_ocn_tracer_surface_flux_to_tend.o mpas_ocn_tracer_interior_restoring.o mpas_ocn_tracer_exponential_decay.o mpas_ocn_tracer_ideal_age.o mpas_ocn_tracer_TTD.o mpas_ocn_vmix.o mpas_ocn_constants.o mpas_ocn_tracer_ecosys.o BGC_mod.o BGC_parms.o co2calc.o mpas_ocn_tracer_DMS.o DMS_mod.o DMS_parms.o mpas_ocn_tracer_MacroMolecules.o MACROS_mod.o MACROS_parms.o +mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_restoring.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_surface_bulk_forcing.o mpas_ocn_surface_land_ice_fluxes.o mpas_ocn_tracer_surface_flux_to_tend.o mpas_ocn_tracer_interior_restoring.o mpas_ocn_tracer_exponential_decay.o mpas_ocn_tracer_ideal_age.o mpas_ocn_tracer_TTD.o mpas_ocn_vmix.o mpas_ocn_constants.o mpas_ocn_tracer_ecosys.o mpas_ocn_tracer_DMS.o mpas_ocn_tracer_MacroMolecules.o mpas_ocn_diagnostics_routines.o: mpas_ocn_constants.o @@ -164,19 +157,6 @@ mpas_ocn_forcing_restoring.o: mpas_ocn_constants.o mpas_ocn_sea_ice.o: mpas_ocn_constants.o -mpas_ocn_tracer_ecosys.o: BGC_mod.o - -BGC_mod.o: BGC_parms.o co2calc.o - -mpas_ocn_tracer_DMS.o: DMS_mod.o BGC_mod.o - -DMS_mod.o: DMS_parms.o - -mpas_ocn_tracer_MacroMolecules.o: MACROS_mod.o BGC_mod.o - -MACROS_mod.o: MACROS_parms.o - - clean: $(RM) *.o *.i *.mod *.f90 diff --git a/src/core_ocean/shared/mpas_ocn_tracer_DMS.F b/src/core_ocean/shared/mpas_ocn_tracer_DMS.F index 0527ec1cb8..23aa814cdd 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_DMS.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_DMS.F @@ -147,8 +147,7 @@ subroutine ocn_tracer_DMS_compute(DMSTracers, nTracersDMS, ecosysTracers, nTrace ! !----------------------------------------------------------------- -!maltrud i think source/sink wants cm instead of m -! real (kind=RKIND) :: zTop, zBot, convertLengthScale = 1.0_RKIND + ! source/sink wants cm instead of m real (kind=RKIND) :: zTop, zBot, convertLengthScale = 100.0_RKIND integer :: iCell, iLevel, iTracer, numColumns, column @@ -357,10 +356,13 @@ subroutine ocn_tracer_DMS_init(domain,err)!{{{ call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_array(tracersPool, 'DMSTracers', DMSTracers, 1) + ! make sure DMS is turned on + if (associated(DMSTracers)) then + ! cannot use DMS_tracer_cnt since it has dms, dmsp, and 12 ecosys fields + nTracers = size(DMSTracers, dim=1) -!maltrud cannot use DMS_tracer_cnt since it has dms, dmsp, and 12 ecosys fields if (nTracers /= 2) then err = 1 return @@ -389,10 +391,7 @@ subroutine ocn_tracer_DMS_init(domain,err)!{{{ call DMS_parms_init -!maltrud modify namelist values here.... - -!maltrud how to handle this? - T0_Kelvin_BGC = T0_Kelvin + ! modify namelist values here.... ! ! for now only do 1 column at a time diff --git a/src/core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F b/src/core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F index b2706a6d8e..6d976d3803 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F @@ -143,8 +143,8 @@ subroutine ocn_tracer_MacroMolecules_compute(MacroMoleculesTracers, nTracersMacr ! !----------------------------------------------------------------- -!maltrud i think source/sink wants cm instead of m -! real (kind=RKIND) :: zTop, zBot, convertLengthScale = 1.0_RKIND + ! source/sink wants cm instead of m + real (kind=RKIND) :: zTop, zBot, convertLengthScale = 100.0_RKIND integer :: iCell, iLevel, iTracer, numColumns, column @@ -326,10 +326,13 @@ subroutine ocn_tracer_MacroMolecules_init(domain,err)!{{{ call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_array(tracersPool, 'MacroMoleculesTracers', MacroMoleculesTracers, 1) + ! make sure MacrosMolecules is turned on + if (associated(MacroMoleculesTracers)) then + ! cannot use MacroMolecules_tracer_cnt since it has poly, prot, lip and 5 ecosys fields + nTracers = size(MacroMoleculesTracers, dim=1) -!maltrud cannot use MacroMolecules_tracer_cnt since it has poly, prot, lip and 5 ecosys fields if (nTracers /= 3) then err = 1 return @@ -358,10 +361,7 @@ subroutine ocn_tracer_MacroMolecules_init(domain,err)!{{{ call MACROS_parms_init -!maltrud modify namelist values here.... - -!maltrud how to handle this? - T0_Kelvin_BGC = T0_Kelvin +! modify namelist values here.... ! ! for now only do 1 column at a time diff --git a/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F b/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F index 3735592283..a5554ac669 100755 --- a/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F @@ -203,8 +203,7 @@ subroutine ocn_tracer_ecosys_compute(activeTracers, ecosysTracers, forcingPool, ecosys_diag_P_iron_PROD, & ecosys_diag_P_iron_REMIN -!maltrud i think source/sink wants cm instead of m -! real (kind=RKIND) :: zTop, zBot, convertLengthScale = 1.0_RKIND + ! source/sink wants cm instead of m real (kind=RKIND) :: zTop, zBot, convertLengthScale = 100.0_RKIND integer :: iCell, iLevel, iTracer, numColumns, column @@ -276,19 +275,13 @@ subroutine ocn_tracer_ecosys_compute(activeTracers, ecosysTracers, forcingPool, do iCell=1,nCellsSolve BGC_input%number_of_active_levels(column) = maxLevelCell(iCell) BGC_forcing%dust_FLUX_IN(column) = dust_FLUX_IN(iCell) -!maltrud debug BGC_forcing%ShortWaveFlux_surface(column) = shortWaveHeatFlux(iCell) -! BGC_forcing%ShortWaveFlux_surface(column) = 200.0_RKIND zTop = 0.0_RKIND do iLevel=1,maxLevelCell(iCell) BGC_input%PotentialTemperature(iLevel,column) = activeTracers(indexTemperature,iLevel,iCell) BGC_input%Salinity(iLevel,column) = activeTracers(indexSalinity,iLevel,iCell) -!maltrud debug -! BGC_input%cell_center_depth(iLevel,column) = zMid(iLevel,iCell)*convertLengthScale BGC_input%cell_center_depth(iLevel,column) = -1.0_RKIND*zMid(iLevel,iCell)*convertLengthScale BGC_input%cell_thickness(iLevel,column) = layerThickness(iLevel,iCell)*convertLengthScale -!maltrud debug -! zBot = zTop - layerThickness(iLevel,iCell) zBot = zTop + layerThickness(iLevel,iCell) BGC_input%cell_bottom_depth(iLevel,column) = zBot*convertLengthScale zTop = zBot @@ -302,11 +295,6 @@ subroutine ocn_tracer_ecosys_compute(activeTracers, ecosysTracers, forcingPool, BGC_forcing%PO4_CLIM(iLevel,column) = 0.0_RKIND BGC_forcing%SiO3_CLIM(iLevel,column) = 0.0_RKIND -!maltrud NOT GOING TO WORK--do each separately -! do iTracer=1,nTracers -! BGC_input%BGC_tracers(iLevel,column,iTracer) = ecosysTracers(iTracer,iLevel,iCell) -! enddo - BGC_input%BGC_tracers(iLevel,column,BGC_indices%po4_ind) = ecosysTracers(ecosysIndices%po4_ind,iLevel,iCell) BGC_input%BGC_tracers(iLevel,column,BGC_indices%no3_ind) = ecosysTracers(ecosysIndices%no3_ind,iLevel,iCell) BGC_input%BGC_tracers(iLevel,column,BGC_indices%sio3_ind) = ecosysTracers(ecosysIndices%sio3_ind,iLevel,iCell) @@ -648,8 +636,6 @@ subroutine ocn_tracer_ecosys_surface_flux_compute(activeTracers, ecosysTracers, iLevelSurface = 1 do iCell=1,nCellsSolve -! NOTE surface values of BGC_input%BGC_tracers were set in previous call to source-sink routine - BGC_forcing%surfacePressure(column) = seaSurfacePressure(iCell)*PascalsToAtmospheres BGC_forcing%iceFraction(column) = iceFraction(iCell) BGC_forcing%windSpeedSquared10m(column) = windSpeedSquared10m(iCell)*mSquared_to_cmSquared @@ -657,13 +643,11 @@ subroutine ocn_tracer_ecosys_surface_flux_compute(activeTracers, ecosysTracers, BGC_forcing%atmCO2_ALT_CO2(column) = atmosphericCO2_ALT_CO2(iCell) BGC_forcing%surface_pH(column) = PH_PREV(iCell) BGC_forcing%surface_pH_alt_co2(column) = PH_PREV_ALT_CO2(iCell) -!maltrud debug -! BGC_forcing%surfaceDepth(column) = zMid(iLevelSurface,iCell) BGC_forcing%surfaceDepth(column) = -1.0_RKIND*zMid(iLevelSurface,iCell) BGC_forcing%SST(column) = activeTracers(indexTemperature,iLevelSurface,iCell) BGC_forcing%SSS(column) = activeTracers(indexSalinity,iLevelSurface,iCell) -!maltrud NOTE pass in total Fe and mult by parm_Fe_bioavail inside the flux routine +! NOTE pass in total Fe and mult by parm_Fe_bioavail inside the flux routine ! divide river Fe by bioavail since it is already the available to make it total BGC_forcing%depositionFlux(column,BGC_indices%no3_ind) = depositionFluxNO3(iCell) @@ -812,7 +796,7 @@ subroutine ocn_tracer_ecosys_init(domain,err)!{{{ call BGC_parms_init(BGC_indices, autotrophs) -!maltrud modify autotroph values here.... +! modify autotroph values here.... ! for example to change sp_kFe ! autotrophs(BGC_indices%sp_ind)%kFe = 0.05e-3_BGC_r8 From 3272877b4749250add4c902ff28d36195d815c75 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 23 Oct 2015 14:17:39 -0600 Subject: [PATCH 0388/1724] changes to support planar periodic meshes General strategy employed: 1. move particle outside periodic domain back inside domain 2. ensure computations are location to particle with respect to periodicity Low-level functions are modified to avoid large-scale changes. Some refractoring could occur to optimize this code (but was not pursued here to ensure readility of the code) Changes were in * ocn_vector_cell_center_to_vertex * get_validated_cell_id * particle_horizontal_movement --- .../mpas_ocn_lagrangian_particle_tracking.F | 107 +++++++++++++----- ...rangian_particle_tracking_interpolations.F | 28 +++-- 2 files changed, 102 insertions(+), 33 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F index 28b878b29f..94b33b4261 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -388,6 +388,7 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ #ifdef MPAS_DEBUG call mpas_timer_start("reconst_filter_LPT", .false., timerReconstFilter) #endif + ! need to handle periodicity within functions below for vertex reconstruction call ocn_vertex_reconstruction(filterNum, meshPool, lagrPartTrackScratchPool, lagrPartTrackCellsPool, & layerThickness % array, normalVelocity % array, & uVertexVelocity, vVertexVelocity, wVertexVelocity) @@ -538,7 +539,7 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ #ifdef MPAS_DEBUG call mpas_timer_start("particle_horizontal_movementLPT", .false., timerHorizMovement) #endif - call particle_horizontal_movement(xSubStep, diffSubStep, onSphere) + call particle_horizontal_movement(meshPool, xSubStep, diffSubStep) #ifdef MPAS_DEBUG call mpas_timer_stop("particle_horizontal_movementLPT", timerHorizMovement) #endif @@ -563,7 +564,7 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ write(stderrUnit, *) 'beginning of substeps' #endif call get_validated_cell_id(nCells, xCell,yCell,zCell , xVertex,yVertex,zVertex, & - xSubStep(1),xSubStep(2),xSubStep(3), onSphere, & + xSubStep(1),xSubStep(2),xSubStep(3), meshPool, & nCellVerticesArray, verticesOnCell, iCell, nCellVertices, cellsOnCell) #ifdef MPAS_DEBUG write(stderrUnit,*) 'iCell=',iCell @@ -629,7 +630,7 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ #ifdef MPAS_DEBUG call mpas_timer_start("particle_horizontal_movementLPT", .false., timerHorizMovement) #endif - call particle_horizontal_movement(particlePosition, diffParticlePosition, onSphere) + call particle_horizontal_movement(meshPool, particlePosition, diffParticlePosition) #ifdef MPAS_DEBUG call mpas_timer_stop("particle_horizontal_movementLPT", timerHorizMovement) #endif @@ -656,7 +657,7 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ write(stderrUnit,*) 'do sampling' #endif call get_validated_cell_id(nCells, xCell,yCell,zCell , xVertex,yVertex,zVertex, & - particlePosition(1),particlePosition(2),particlePosition(3), onSphere, & + particlePosition(1),particlePosition(2),particlePosition(3), meshPool, & nCellVerticesArray, verticesOnCell, iCell, nCellVertices, cellsOnCell) #ifdef MPAS_DEBUG call mpas_timer_stop("get_validated_cell_idLPT", timerValidatedCell_out) @@ -1059,7 +1060,7 @@ end subroutine ocn_finalize_lagrangian_particle_tracking!}}} ! Phillip Wolfram 06/18/2014 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine get_validated_cell_id(nCells, xCell,yCell,zCell , xVertex,yVertex,zVertex, & - xSubStep,ySubStep,zSubStep, onSphere, nCellVerticesArray, verticesOnCell, & + xSubStep,ySubStep,zSubStep, meshPool, nCellVerticesArray, verticesOnCell, & iCell, nCellVertices, cellsOnCell) implicit none @@ -1071,37 +1072,66 @@ subroutine get_validated_cell_id(nCells, xCell,yCell,zCell , xVertex,yVertex,zVe real (kind=RKIND), dimension(:), intent(in) :: xCell,yCell,zCell !< spatial location of cell centers real (kind=RKIND), dimension(:), intent(in) :: xVertex,yVertex,zVertex !< spatial location of cell vertices real (kind=RKIND), intent(in) :: xSubStep,ySubStep,zSubStep - logical, intent(in) :: onSphere + type (mpas_pool_type), intent(in), pointer :: meshPool ! meshPool pointer integer, dimension(:,:), intent(in) :: cellsOnCell ! cell connectivity !intent (out) integer, intent(inout) :: iCell integer, intent(out) :: nCellVertices - +#ifdef MPAS_DEBUG + logical, pointer :: is_periodic + real(kind=RKIND), pointer :: x_period, y_period + logical, pointer :: on_a_sphere + real(kind=RKIND), dimension(:), pointer :: xtmp, ytmp + integer :: i + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(meshPool, 'is_periodic', is_periodic) + call mpas_pool_get_config(meshPool, 'x_period', x_period) + call mpas_pool_get_config(meshPool, 'y_period', y_period) +#endif ! get cell index !#ifdef MPAS_DEBUG ! iCell = -1 !#endif call mpas_get_nearby_cell_index(nCells, xCell,yCell,zCell , & - xSubStep,ySubStep,zSubStep, onSphere, iCell, cellsOnCell, nCellVerticesArray) + xSubStep,ySubStep,zSubStep, meshPool, iCell, cellsOnCell, nCellVerticesArray) nCellVertices = nCellVerticesArray(iCell) #ifdef MPAS_DEBUG ! check to make sure the horizontal location is valid, otherwise report an error !write(stderrUnit,*) 'max verticesOnCell = ', maxval(verticesOnCell(:,iCell)), 'nVertices = ', size(xVertex) - if(.not. point_in_cell(nCellVertices, & - xVertex(verticesOnCell(1:nCellVertices,iCell)), & - yVertex(verticesOnCell(1:nCellVertices,iCell)), & - zVertex(verticesOnCell(1:nCellVertices,iCell)), & - xSubStep,ySubStep,zSubStep , onSphere)) then - write(stderrUnit,*) 'Point (', xSubStep,ySubStep,zSubStep ,') is horizontally outside cell ', iCell - write(stderrUnit,*) 'Cell (',& - xCell(iCell),yCell(iCell),zCell(iCell), ') with index ' , iCell - write(stderrUnit,*) 'xVertex = ', xVertex(verticesOnCell(1:nCellVertices,iCell)) - write(stderrUnit,*) 'yVertex = ', yVertex(verticesOnCell(1:nCellVertices,iCell)) - write(stderrUnit,*) 'zVertex = ', zVertex(verticesOnCell(1:nCellVertices,iCell)) + if (on_a_sphere .or. .not. is_periodic) then + if(.not. point_in_cell(nCellVertices, & + xVertex(verticesOnCell(1:nCellVertices,iCell)), & + yVertex(verticesOnCell(1:nCellVertices,iCell)), & + zVertex(verticesOnCell(1:nCellVertices,iCell)), & + xSubStep,ySubStep,zSubStep , on_a_sphere)) then + write(stderrUnit,*) 'Point (', xSubStep,ySubStep,zSubStep ,') is horizontally outside cell ', iCell + write(stderrUnit,*) 'Cell (',& + xCell(iCell),yCell(iCell),zCell(iCell), ') with index ' , iCell + write(stderrUnit,*) 'xVertex = ', xVertex(verticesOnCell(1:nCellVertices,iCell)) + write(stderrUnit,*) 'yVertex = ', yVertex(verticesOnCell(1:nCellVertices,iCell)) + write(stderrUnit,*) 'zVertex = ', zVertex(verticesOnCell(1:nCellVertices,iCell)) + end if + else + allocate(xtmp(nCellVertices), ytmp(nCellVertices)) + do i = 1, nCellVertices + xtmp(i) = mpas_fix_periodicity(xVertex(verticesOnCell(i,iCell)), xSubStep, x_period) + ytmp(i) = mpas_fix_periodicity(yVertex(verticesOnCell(i,iCell)), ySubStep, y_period) + end do + if(.not. point_in_cell(nCellVertices, xtmp, ytmp, & + zVertex(verticesOnCell(1:nCellVertices,iCell)), & + xSubStep,ySubStep,zSubStep , on_a_sphere)) then + write(stderrUnit,*) 'Point (', xSubStep,ySubStep,zSubStep ,') is horizontally outside cell ', iCell + write(stderrUnit,*) 'Cell (',& + xCell(iCell),yCell(iCell),zCell(iCell), ') with index ' , iCell + write(stderrUnit,*) 'xVertex = ', xtmp + write(stderrUnit,*) 'yVertex = ', ytmp + write(stderrUnit,*) 'zVertex = ', zVertex(verticesOnCell(1:nCellVertices,iCell)) + end if + deallocate(xtmp, ytmp) end if #endif @@ -1686,7 +1716,7 @@ subroutine initialize_particle_properties(domain, timeLevel, err)!{{{ write(stderrUnit,*) 'sampling initialization' #endif call get_validated_cell_id(nCells, xCell,yCell,zCell , xVertex,yVertex,zVertex, & - particlePosition(1),particlePosition(2),particlePosition(3), onSphere, & + particlePosition(1),particlePosition(2),particlePosition(3), meshPool, & nCellVerticesArray, verticesOnCell, iCell, nCellVertices, cellsOnCell) #ifdef MPAS_DEBUG call mpas_timer_stop("get_validated_cell_idLPT", timerValidatedCell_init) @@ -1951,10 +1981,17 @@ subroutine velocity_time_interpolation(particleVelocity, particleVelocityVert, & real(kind=RKIND), dimension(:), allocatable :: areaB real(kind=RKIND), dimension(:,:), allocatable :: vertCoords real(kind=RKIND), dimension(:,:), allocatable :: uvCell + logical, pointer :: on_a_sphere, is_periodic + real(kind=RKIND), pointer :: x_period, y_period #ifdef MPAS_DEBUG call mpas_timer_start("velocity_time_interpolationLPT", .false., timerVelTimeInterp) #endif + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(meshPool, 'is_periodic', is_periodic) + call mpas_pool_get_config(meshPool, 'x_period', x_period) + call mpas_pool_get_config(meshPool, 'y_period', y_period) + ! allocations for particular cell !{{{ allocate(vertCoords(3,nCellVertices), uvCell(3,nCellVertices), areaB(nCellVertices)) !}}} @@ -1963,9 +2000,15 @@ subroutine velocity_time_interpolation(particleVelocity, particleVelocityVert, & ! bit of error because the particle could be at the top ! of the cell or at the bottom of the cell) do aVertex = 1, nCellVertices - vertCoords(1,aVertex) = xVertex(verticesOnCell(aVertex,iCell)) - vertCoords(2,aVertex) = yVertex(verticesOnCell(aVertex,iCell)) - vertCoords(3,aVertex) = zVertex(verticesOnCell(aVertex,iCell)) + if (on_a_sphere .or. .not. is_periodic) then + vertCoords(1,aVertex) = xVertex(verticesOnCell(aVertex,iCell)) + vertCoords(2,aVertex) = yVertex(verticesOnCell(aVertex,iCell)) + vertCoords(3,aVertex) = zVertex(verticesOnCell(aVertex,iCell)) + else + vertCoords(1,aVertex) = mpas_fix_periodicity(xVertex(verticesOnCell(aVertex,iCell)), xSubStep(1), x_period) + vertCoords(2,aVertex) = mpas_fix_periodicity(yVertex(verticesOnCell(aVertex,iCell)), xSubStep(2), y_period) + vertCoords(3,aVertex) = zVertex(verticesOnCell(aVertex,iCell)) + end if areaB(aVertex) = areaBArray(iCell, aVertex) end do @@ -2158,7 +2201,7 @@ end function particle_horizontal_interpolation !}}} !> shell corresponding to pParticle. ! !----------------------------------------------------------------------- - subroutine particle_horizontal_movement(pParticle, dpParticle, onSphere) !{{{ + subroutine particle_horizontal_movement(meshPool, pParticle, dpParticle) !{{{ implicit none @@ -2166,7 +2209,7 @@ subroutine particle_horizontal_movement(pParticle, dpParticle, onSphere) !{{{ ! input variables !----------------------------------------------------------------- real (kind=RKIND), dimension(:), intent(in) :: dpParticle - logical, intent(in) :: onSphere + type (mpas_pool_type), intent(in), pointer :: meshPool !----------------------------------------------------------------- ! input / output variables @@ -2182,6 +2225,8 @@ subroutine particle_horizontal_movement(pParticle, dpParticle, onSphere) !{{{ real (kind=RKIND), dimension(size(pParticle)) :: pParticleInterp real (kind=RKIND) :: alpha real (kind=RKIND), parameter :: eps=1e-10_RKIND + logical, pointer :: onSphere, is_periodic + real(kind=RKIND), pointer :: x_period, y_period ! choosen based on the parameters, note that we loose about 6 - 7 units of precision because R is so large! ! therefore, eps = 1e-10 is conservative, if not too high! this just helps with numerical stability !dpParticle = -4.2428037617887103E-011 4.3076544298828060E-011 5.0760704444480953E-011 @@ -2189,6 +2234,10 @@ subroutine particle_horizontal_movement(pParticle, dpParticle, onSphere) !{{{ !pParticleTemp = 4444887.2990309987 -891565.00525021972 4476665.3916420965 !mpas_arc_length = 0.0000000000000000 lenPath = 7.8945399869363434E-011 + call mpas_pool_get_config(meshPool, 'on_a_sphere', onSphere) + call mpas_pool_get_config(meshPool, 'is_periodic', is_periodic) + call mpas_pool_get_config(meshPool, 'x_period', x_period) + call mpas_pool_get_config(meshPool, 'y_period', y_period) ! may need a condition to determine if we need to project back to the sphere if(onSphere) then @@ -2232,8 +2281,14 @@ subroutine particle_horizontal_movement(pParticle, dpParticle, onSphere) !{{{ ! we are just on a plane so there is no need for spherical interpolation to keep ! the new particle location on a spherical shell pParticle = pParticle + dpParticle - endif + ! periodic fix to make sure particle advection stays in domain + if (is_periodic) then + pParticle(1) = mpas_fix_periodicity(pParticle(1), x_period/2.0_RKIND, x_period) + pParticle(2) = mpas_fix_periodicity(pParticle(2), y_period/2.0_RKIND, y_period) + !pParticle(3) = pParticle(3) + end if + endif end subroutine particle_horizontal_movement!}}} diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_interpolations.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_interpolations.F index 6a3821bd37..181ae43230 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_interpolations.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_interpolations.F @@ -230,6 +230,8 @@ subroutine ocn_vector_cell_center_to_vertex(meshPool, boundaryVertex, boundaryCe real (kind=RKIND), dimension(:,:), allocatable :: pointVertex real (kind=RKIND), dimension(3) :: pointInterp real (kind=RKIND) :: xp,yp,zp , sumArea, kiteArea + logical, pointer :: is_periodic + real(kind=RKIND), pointer :: x_period, y_period uvReconstructX = 0.0_RKIND uvReconstructY = 0.0_RKIND @@ -244,17 +246,21 @@ subroutine ocn_vector_cell_center_to_vertex(meshPool, boundaryVertex, boundaryCe call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_array(meshPool, 'cellsOnVertex', cellsOnVertex) - + call mpas_pool_get_array(meshPool, 'xCell', xCell) call mpas_pool_get_array(meshPool, 'yCell', yCell) call mpas_pool_get_array(meshPool, 'zCell', zCell) - + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) call mpas_pool_get_array(meshPool, 'yVertex', yVertex) call mpas_pool_get_array(meshPool, 'zVertex', zVertex) - + call mpas_pool_get_array(meshPool, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_config(meshPool, 'is_periodic', is_periodic) + call mpas_pool_get_config(meshPool, 'x_period', x_period) + call mpas_pool_get_config(meshPool, 'y_period', y_period) + ! loop over all vertices do aVertex = 1, nVerticesSolve ! could precompute the list as an optimization @@ -262,15 +268,23 @@ subroutine ocn_vector_cell_center_to_vertex(meshPool, boundaryVertex, boundaryCe if(any(boundaryVertex(:,aVertex) < 1)) then ! get vertex location and cell center locations do aCell = 1, vertexDegree - pointVertex(1,aCell) = xCell(cellsOnVertex(aCell, aVertex)) - pointVertex(2,aCell) = yCell(cellsOnVertex(aCell, aVertex)) - pointVertex(3,aCell) = zCell(cellsOnVertex(aCell, aVertex)) + ! logical could be moved outside of code block as an optimization (then essentially would have two nearly identical code blocks...) + if (is_periodic) then + ! fix periodicity with respect to pointInterp (xVertex) + pointVertex(1,aCell) = mpas_fix_periodicity(xCell(cellsOnVertex(aCell, aVertex)), xVertex(aVertex), x_period) + pointVertex(2,aCell) = mpas_fix_periodicity(yCell(cellsOnVertex(aCell, aVertex)), yVertex(aVertex), y_period) + pointVertex(3,aCell) = zCell(cellsOnVertex(aCell, aVertex)) + else + pointVertex(1,aCell) = xCell(cellsOnVertex(aCell, aVertex)) + pointVertex(2,aCell) = yCell(cellsOnVertex(aCell, aVertex)) + pointVertex(3,aCell) = zCell(cellsOnVertex(aCell, aVertex)) + end if end do ! vertex point for reconstruction pointInterp(1) = xVertex(aVertex) pointInterp(2) = yVertex(aVertex) pointInterp(3) = zVertex(aVertex) - ! get interpolation constants (could be cached) + ! get interpolation constants (could be cached / optimized with areaBin) lambda = mpas_wachspress_coordinates(vertexDegree, pointVertex , pointInterp, meshPool) else lambda = 0.0_RKIND From 583eb404b77c5aa4122677329952e8c101059fa2 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 23 Oct 2015 14:18:08 -0600 Subject: [PATCH 0389/1724] enhanced debugging output debug output aids identification of IO halo errors --- .../analysis_members/mpas_ocn_particle_list.F | 34 ++++++++++++++++--- 1 file changed, 30 insertions(+), 4 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_particle_list.F b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F index f8104f248a..0f0f44709c 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_particle_list.F +++ b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F @@ -601,8 +601,9 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS #ifdef MPAS_DEBUG ! need to update IO processors as to the change also so that they know where to get data from!!! ! should uncomment for testing when multiple ioProcs are utilized (parallel IO) - write(stderrUnit,*) 'ioProcSendList = ', ioProcSendList - write(stderrUnit,*) 'ioProcRecvList = ', ioProcRecvList + write(stderrUnit,*) 'ioProcSendList before = ', ioProcSendList + write(stderrUnit,*) 'ioProcRecvList before = ', ioProcRecvList + write(stderrUnit,*) 'ioProcNeighs before = ', ioProcNeighs #endif ! proceed to update the halo @@ -618,6 +619,10 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS #ifdef _MPI call MPI_ISend(ioProcRecvList(i,:), nProcs, MPI_LOGICAL, ioProcNeighs(i), domain % dminfo % my_proc_id, & domain % dminfo % comm, sendRequestID(i), mpi_ierr) +#endif +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'ioProcNeigh= ', ioProcNeighs(i) + write(stderrUnit,*) 'send data = ', ioProcRecvList(i,:) #endif end do @@ -636,9 +641,16 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS ! aggregate results after wait, making sure that we have the most ! comprehensive list of ioProcs for receiving +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'ioProcNeigh= ', ioProcNeighs(i) + write(stderrUnit,*) 'recvList before = ', recvList + write(stderrUnit,*) 'completeList before = ', completeList +#endif completeList = completeList .or. recvList - !write(stderrUnit,*) 'recvList= ', recvList - !write(stderrUnit,*) 'completeList = ', completeList +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'recvList after = ', recvList + write(stderrUnit,*) 'completeList after = ', completeList +#endif end do ! wait to make sure (just in case) that all sends have completed @@ -670,6 +682,13 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS call removeValueFromIntList(ioProcNeighs, domain % dminfo % my_proc_id) deallocate(intArray, completeList, sendRequestID, recvRequestID) +#ifdef MPAS_DEBUG + ! need to update IO processors as to the change also so that they know where to get data from!!! + ! should uncomment for testing when multiple ioProcs are utilized (parallel IO) + write(stderrUnit,*) 'ioProcSendList after = ', ioProcSendList + write(stderrUnit,*) 'ioProcRecvList after = ', ioProcRecvList + write(stderrUnit,*) 'ioProcNeighs after = ', ioProcNeighs +#endif end subroutine mpas_particle_list_update_io_halos !}}} @@ -887,6 +906,12 @@ subroutine mpas_particle_list_write_halo_data(domain, err)!{{{ ! note: orderingVector can be a subset of indexToParticleIDNew because this index can include compute as well as IO particles ! however, it must be of the same size as indexToParticleIDOriginal call compute_ordering_vector(indexToParticleIDOriginal, indexToParticleIDNew, orderingVector) +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'write halo data' + write(stderrUnit,*) 'indexToParticleIDOriginal =', indexToParticleIDOriginal + write(stderrUnit,*) 'indexToParticleIDNew =', indexToParticleIDNew + write(stderrUnit,*) 'ordering vector=', orderingVector +#endif ! iterate over contents of pool and transfer call mpas_pool_begin_iteration(lagrPartTrackPool) @@ -902,6 +927,7 @@ subroutine mpas_particle_list_write_halo_data(domain, err)!{{{ write(stderrUnit,*) 'member name =', trim(dimItr % memberName) write(stderrUnit,*) 'particlelistSize= ', count_particlelist(particlelist) write(stderrUnit,*) 'memory arraysize= ', size(field1DRealPointer % array) + write(stderrUnit,*) trim(dimItr % memberName), ' = ', field1DRealPointer % array #endif !}}} allocate(Array1DRealPointer(count_particlelist(particlelist))) From 207837d0f102c3c9014d6e25216794f6952073a4 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Wed, 14 Oct 2015 19:45:29 -0600 Subject: [PATCH 0390/1724] added periodic planar test case The periodic planar test case provides a constant flow in the zonal direction of a zonally-periodic channel in order to test LIGHT in a periodic planar context. Particle file (16 processors) can be found at https://www.dropbox.com/s/aeu42st20rm8axj/particle_full.nc?dl=0 --- src/core_ocean/Makefile | 1 + src/core_ocean/Registry.xml | 1 + src/core_ocean/mode_init/Makefile | 5 +- src/core_ocean/mode_init/Registry.xml | 1 + .../mode_init/Registry_periodic_planar.xml | 20 + src/core_ocean/mode_init/mpas_ocn_init_mode.F | 4 + .../mode_init/mpas_ocn_init_periodic_planar.F | 408 ++++++++++++++++++ .../periodic_planar/20km/config_forward.xml | 77 ++++ .../periodic_planar/20km/config_init1.xml | 67 +++ .../periodic_planar/20km/config_init2.xml | 58 +++ .../ocean/templates/ocean/forcing_data.xml | 32 ++ 11 files changed, 673 insertions(+), 1 deletion(-) create mode 100644 src/core_ocean/mode_init/Registry_periodic_planar.xml create mode 100644 src/core_ocean/mode_init/mpas_ocn_init_periodic_planar.F create mode 100644 test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml create mode 100644 test_cases/ocean/ocean/periodic_planar/20km/config_init1.xml create mode 100644 test_cases/ocean/ocean/periodic_planar/20km/config_init2.xml create mode 100644 test_cases/ocean/templates/ocean/forcing_data.xml diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index e0c1599b32..e86be060eb 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -33,6 +33,7 @@ core_input_gen: (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.iso mode=init configuration=iso) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.ziso mode=init configuration=ziso) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.global_ocean mode=init configuration=global_ocean) + (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.periodic_planar mode=init configuration=periodic_planar) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean stream_list.ocean. mutable ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.forward stream_list.ocean.forward. mutable mode=forward ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis ) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index a820f1cc6c..086687a1c1 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -143,6 +143,7 @@ soma_value="soma" iso_value="iso" ziso_value="ziso" + periodic_planar_value="periodic_planar" /> + + + + + + + diff --git a/src/core_ocean/mode_init/mpas_ocn_init_mode.F b/src/core_ocean/mode_init/mpas_ocn_init_mode.F index 98bed5190f..3d9d8fe44d 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_mode.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_mode.F @@ -47,6 +47,7 @@ module ocn_init_mode use ocn_init_iso use ocn_init_soma use ocn_init_ziso + use ocn_init_periodic_planar implicit none private @@ -255,6 +256,7 @@ function ocn_init_mode_run(domain) result(iErr)!{{{ call ocn_init_setup_iso(domain, ierr) call ocn_init_setup_soma(domain, ierr) call ocn_init_setup_ziso(domain, ierr) + call ocn_init_setup_periodic_planar(domain, ierr) !call ocn_init_setup_TEMPLATE(domain, ierr) write(stderrUnit, *) ' Completed setup of: ' // trim(config_init_configuration) @@ -346,6 +348,8 @@ subroutine ocn_init_mode_validate_configuration(configPool, packagePool, ioconte iErr = ior(iErr, err_tmp) call ocn_init_validate_ziso(configPool, packagePool, iErr=err_tmp) iErr = ior(iErr, err_tmp) + call ocn_init_validate_periodic_planar(configPool, packagePool, iocontext, iErr=err_tmp) + iErr = ior(iErr, err_tmp) ! call ocn_config_TEMPLATE_validate(configPool, packagePool, iErr=err_tmp) ! iErr = ior(iErr, err_tmp) end subroutine ocn_init_mode_validate_configuration!}}} diff --git a/src/core_ocean/mode_init/mpas_ocn_init_periodic_planar.F b/src/core_ocean/mode_init/mpas_ocn_init_periodic_planar.F new file mode 100644 index 0000000000..d313098bce --- /dev/null +++ b/src/core_ocean/mode_init/mpas_ocn_init_periodic_planar.F @@ -0,0 +1,408 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ocn_init_periodic_planar +! +!> \brief MPAS ocean initialize case -- periodic_planar +!> \author Phillip J. Wolfram +!> \date 10/14/2015 +!> \details +!> This module contains the routines for initializing the +!> periodic_planar initial condition, which is a constant +!> velocity in a periodic domain. +! +!----------------------------------------------------------------------- + +module ocn_init_periodic_planar + + use mpas_kind_types + use mpas_io_units + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + use mpas_stream_manager + + use ocn_constants + use ocn_init_vertical_grids + use ocn_init_cell_markers + + implicit none + private + save + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: ocn_init_setup_periodic_planar, & + ocn_init_validate_periodic_planar + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + +!*********************************************************************** + +contains + +!*********************************************************************** +! +! routine ocn_init_setup_periodic_planar +! +!> \brief Setup for this initial condition +!> \author Phillip J. Wolfram +!> \date 10/14/2015 +!> \details +!> This routine sets up the initial conditions for this case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_setup_periodic_planar(domain, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: iErr + + ! local work variables + type (block_type), pointer :: block_ptr + type (mpas_pool_type), pointer :: meshPool, verticalMeshPool, statePool, forcingPool, tracersPool, scratchPool + + integer :: iCell, iEdge, iVertex, k, idx + real (kind=RKIND), dimension(:), pointer :: interfaceLocations + + ! Define config variable pointers + character (len=StrKIND), pointer :: config_init_configuration, config_vertical_grid + logical, pointer :: config_write_cull_cell_mask + + ! periodic_planar test case run-time configuration parameters + real (kind=RKIND), pointer :: config_periodic_planar_bottom_depth, config_periodic_planar_velocity_strength + + integer, pointer :: config_periodic_planar_vert_levels + + + ! Define dimension pointers + integer, pointer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, nVertLevelsP1 + integer, pointer :: index_temperature, index_salinity + + ! Define variable pointers + logical, pointer :: on_a_sphere + integer, dimension(:), pointer :: maxLevelCell + integer, dimension(:,:), pointer :: verticesOnEdge + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, xEdge, yEdge, xVertex, yVertex, refBottomDepth, refZMid, & + vertCoordMovementWeights, bottomDepth, & + fCell, fEdge, fVertex, dcEdge, dvEdge + real (kind=RKIND), dimension(:,:), pointer :: layerThickness, restingThickness, normalVelocity + real (kind=RKIND), dimension(:), pointer :: psiVertex + type (field1DReal), pointer :: psiVertexField + real (kind=RKIND), dimension(:,:,:), pointer :: activeTracers + + real (kind=RKIND) :: yMin, yMax, xMin, xMax, dcEdgeMin, dcEdgeMinGlobal + real (kind=RKIND) :: yMinGlobal, yMaxGlobal, yMidGlobal, xMinGlobal, xMaxGlobal + real(kind=RKIND), pointer :: y_period + character (len=StrKIND) :: streamID + integer :: directionProperty + + ! assume no error + iErr = 0 + + + ! test if periodic_planar is the desired configuration + call mpas_pool_get_config(ocnConfigs, 'config_init_configuration', config_init_configuration) + if(config_init_configuration .ne. trim('periodic_planar')) return + + write(stderrUnit,*) 'Starting initialization of planar periodic grid' + + ! get config variables !{{{ + call mpas_pool_get_config(domain % configs, 'config_write_cull_cell_mask', config_write_cull_cell_mask) + call mpas_pool_get_config(domain % configs, 'config_periodic_planar_bottom_depth', config_periodic_planar_bottom_depth) + call mpas_pool_get_config(domain % configs, 'config_periodic_planar_vert_levels', config_periodic_planar_vert_levels) + call mpas_pool_get_config(domain % configs, 'config_periodic_planar_velocity_strength', config_periodic_planar_velocity_strength) + call mpas_pool_get_config(domain % configs, 'config_vertical_grid', config_vertical_grid) + !}}} + + ! Determine vertical grid for configuration + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nVertLevelsP1', nVertLevelsP1) + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + + ! test if configure settings are invalid + if ( on_a_sphere ) call mpas_dmpar_global_abort('IERROR: The planar periodic configuration can only be applied to a planar mesh. Exiting...') + + ! Define interface locations + allocate(interfaceLocations(nVertLevelsP1)) + call ocn_generate_vertical_grid( config_vertical_grid, interfaceLocations ) + + ! assign config variables + nVertLevels = config_periodic_planar_vert_levels + nVertLevelsP1 = nVertLevels + 1 + + ! keep all cells on planar, periodic mesh (no culling) + + !-------------------------------------------------------------------- + ! Use this section to make boundaries non-periodic + !-------------------------------------------------------------------- + + ! Initalize min/max values to large positive and negative values + yMin = 1.0E10_RKIND + yMax = -1.0E10_RKIND + xMin = 1.0E10_RKIND + xMax = -1.0E10_RKIND + dcEdgeMin = 1.0E10_RKIND + + ! Determine local min and max values. + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + + yMin = min( yMin, minval(yCell(1:nCellsSolve))) + yMax = max( yMax, maxval(yCell(1:nCellsSolve))) + xMin = min( xMin, minval(xCell(1:nCellsSolve))) + xMax = max( xMax, maxval(xCell(1:nCellsSolve))) + dcEdgeMin = min( dcEdgeMin, minval(dcEdge(1:nEdgesSolve))) + + block_ptr => block_ptr % next + end do ! do while(associated(block_ptr)) + + + !-------------------------------------------------------------------- + ! Use this section to set initial values + !-------------------------------------------------------------------- + call mpas_pool_get_subpool(domain % blocklist % structs, 'scratch', scratchPool) + call mpas_pool_get_field(scratchPool, 'psiVertex', psiVertexField) + call mpas_allocate_scratch_field(psiVertexField, .false.) + + block_ptr => domain % blocklist + do while(associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block_ptr % structs, 'state', statePool) + call mpas_pool_get_subpool(block_ptr % structs, 'verticalMesh', verticalMeshPool) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_subpool(block_ptr % structs, 'forcing', forcingPool) + call mpas_pool_get_subpool(block_ptr % structs, 'scratch', scratchPool) + + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nVerticesSolve', nVerticesSolve) + + call mpas_pool_get_dimension(tracersPool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(tracersPool, 'index_salinity', index_salinity) + + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'xEdge', xEdge) + call mpas_pool_get_array(meshPool, 'yEdge', yEdge) + call mpas_pool_get_array(meshPool, 'xVertex', xVertex) + call mpas_pool_get_array(meshPool, 'yVertex', yVertex) + call mpas_pool_get_array(meshPool, 'refBottomDepth', refBottomDepth) + call mpas_pool_get_array(meshPool, 'vertCoordMovementWeights', vertCoordMovementWeights) + call mpas_pool_get_array(meshPool, 'bottomDepth', bottomDepth) + call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_array(meshPool, 'fCell', fCell) + call mpas_pool_get_array(meshPool, 'fEdge', fEdge) + call mpas_pool_get_array(meshPool, 'fVertex', fVertex) + + call mpas_pool_get_array(scratchPool, 'psiVertex', psiVertex) + call mpas_pool_get_array(meshPool, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel=1) + + call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, 1) + call mpas_pool_get_array(statePool, 'layerThickness', layerThickness, 1) + + call mpas_pool_get_array(verticalMeshPool, 'refZMid', refZMid) + call mpas_pool_get_array(verticalMeshPool, 'restingThickness', restingThickness) + + ! Determine global min and max values. + call mpas_dmpar_min_real(domain % dminfo, yMin, yMinGlobal) + call mpas_dmpar_max_real(domain % dminfo, yMax, yMaxGlobal) + call mpas_dmpar_min_real(domain % dminfo, xMin, xMinGlobal) + call mpas_dmpar_max_real(domain % dminfo, xMax, xMaxGlobal) + call mpas_dmpar_min_real(domain % dminfo, dcEdgeMin, dcEdgeMinGlobal) + + ! mark north / south boundaries + if(config_write_cull_cell_mask) then + call ocn_mark_north_boundary(meshPool, yMaxGlobal, dcEdgeMinGlobal, iErr) + call ocn_mark_south_boundary(meshPool, yMinGlobal, dcEdgeMinGlobal, iErr) + call mpas_pool_get_config(meshPool, 'y_period', y_period) + y_period = 0.0_RKIND + endif + call mpas_stream_mgr_begin_iteration(domain % streamManager) + do while (mpas_stream_mgr_get_next_stream(domain % streamManager, streamID, directionProperty)) + if ( directionProperty == MPAS_STREAM_OUTPUT .or. directionProperty == MPAS_STREAM_INPUT_OUTPUT ) then + call mpas_stream_mgr_add_att(domain % streamManager, 'y_period', 0.0_RKIND, streamID) + end if + end do + + ! Set refBottomDepth and refZMid + do k = 1, nVertLevels + refBottomDepth(k) = config_periodic_planar_bottom_depth * interfaceLocations(k+1) + refZMid(k) = - 0.5_RKIND * (interfaceLocations(k+1) + interfaceLocations(k)) * config_periodic_planar_bottom_depth + end do + + ! set bottomDepth and maxLevelCell !{{{{ + bottomDepth(:) = 0.0_RKIND + do iCell = 1, nCellsSolve + + bottomDepth(iCell) = config_periodic_planar_bottom_depth + + ! Determine maxLevelCell based on bottomDepth and refBottomDepth + ! Also set botomDepth based on refBottomDepth, since + ! above bottomDepth was set with continuous analytical functions, + ! and needs to be discrete + maxLevelCell(iCell) = nVertLevels + if (nVertLevels > 1) then + do k = 1, nVertLevels + if (bottomDepth(iCell) < refBottomDepth(k)) then + maxLevelCell(iCell) = k-1 + bottomDepth(iCell) = refBottomDepth(k-1) + exit + end if + end do + end if + + enddo ! Looping through with iCell !}}} + + ! Set vertCoordMovementWeights + vertCoordMovementWeights(:) = 1.0_RKIND + + do iCell = 1, nCellsSolve + + ! Set initial temperature + idx = index_temperature + do k = 1, nVertLevels + activeTracers(idx, k, iCell) = 0.0_RKIND + end do + + ! Set initial salinity + idx = index_salinity + do k = 1, nVertLevels + activeTracers(idx, k, iCell) = 0.0_RKIND + end do + + ! Set layerThickness and restingThickness + ! Uniform layer thickness + do k = 1, nVertLevels + layerThickness(k, iCell) = config_periodic_planar_bottom_depth * ( interfaceLocations(k+1) - interfaceLocations(k) ) + restingThickness(k, iCell) = layerThickness(k, iCell) + end do + + ! Set bottomDepth (above) + + ! Set maxLevelCell (above) + + end do ! do iCell + + ! Set Coriolis parameters, if other than zero + do iCell = 1, nCellsSolve + fCell(iCell) = 0.0_RKIND + end do + do iEdge = 1, nEdgesSolve + fEdge(iEdge) = 0.0_RKIND + end do + do iVertex = 1, nVerticesSolve + fVertex(iVertex) = 0.0_RKIND + end do + + ! Setup stream function for velocity + do iVertex = 1, nVerticesSolve ! need to loop over all vertices to ensure correct value for edges + psiVertex(iVertex) = yVertex(iVertex)*config_periodic_planar_velocity_strength + end do + + !boundaryVertex => block_ptr % mesh % boundaryVertex % array(1,:) + !!write(stdoutUnit,*) boundaryVertex(:) + !block_ptr % scratch % psiVertex % array = & + ! boundaryVertex * & + ! sum(boundaryVertex * block_ptr % scratch % psiVertex % array) & + ! /sum(boundaryVertex) & + ! + (1-boundaryVertex) * block_ptr % scratch % psiVertex % array + + ! Define normalVelocity as (grad psiVertex) + do iEdge = 1, nEdgesSolve + normalVelocity(:,iEdge) = -1.0_RKIND * (psiVertex(verticesOnEdge(1, iEdge)) - psiVertex(verticesOnEdge(2, iEdge)))/dvEdge(iEdge) + end do + + block_ptr => block_ptr % next + end do ! do while(associated(block_ptr)) + call mpas_deallocate_scratch_field(psiVertexField, .false.) + + write(stderrUnit,*) 'Finishing initialization of periodic_planar' + !-------------------------------------------------------------------- + + end subroutine ocn_init_setup_periodic_planar!}}} + +!*********************************************************************** +! +! routine ocn_init_validate_periodic_planar +! +!> \brief Validation for this initial condition +!> \author Phillip J. Wolfram +!> \date 10/14/2015 +!> \details +!> This routine validates the configuration options for this case. +! +!----------------------------------------------------------------------- + + subroutine ocn_init_validate_periodic_planar(configPool, packagePool, iocontext, iErr)!{{{ + + !-------------------------------------------------------------------- + + type (mpas_pool_type), intent(inout) :: configPool, packagePool + type (mpas_io_context_type), intent(inout) :: iocontext + integer, intent(out) :: iErr + + character (len=StrKIND), pointer :: config_init_configuration + integer, pointer :: config_vert_levels, config_periodic_planar_vert_levels + + iErr = 0 + + call mpas_pool_get_config(configPool, 'config_init_configuration', config_init_configuration) + if(config_init_configuration .ne. trim('periodic_planar')) return + + call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_periodic_planar_vert_levels', config_periodic_planar_vert_levels) + + if(config_vert_levels <= 0 .and. config_periodic_planar_vert_levels > 0) then + config_vert_levels = config_periodic_planar_vert_levels + else if (config_vert_levels <= 0) then + write(stderrUnit,*) 'IERROR: Validation failed for periodic_planar. Not given a usable value for vertical levels.' + iErr = 1 + end if + + !-------------------------------------------------------------------- + + end subroutine ocn_init_validate_periodic_planar!}}} + + +!*********************************************************************** + +end module ocn_init_periodic_planar + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! vim: foldmethod=marker diff --git a/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml b/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml new file mode 100644 index 0000000000..68fde9dfac --- /dev/null +++ b/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml @@ -0,0 +1,77 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + mesh.nc + + + init.nc + + + 0000-01-00_00:00:00 + + + 0000-01-00_00:00:00 + + + + + + + + + + + + + + + + 0000_02:46:40 + + + particle_full.nc + + + + + + 4 + + + 4 + ./ocean_model + namelist.ocean + streams.ocean + + + diff --git a/test_cases/ocean/ocean/periodic_planar/20km/config_init1.xml b/test_cases/ocean/ocean/periodic_planar/20km/config_init1.xml new file mode 100644 index 0000000000..0593cd7025 --- /dev/null +++ b/test_cases/ocean/ocean/periodic_planar/20km/config_init1.xml @@ -0,0 +1,67 @@ + + + + + + + + + + + + + + + + + + + + + + mesh.nc + + + output + 0000_00:00:01 + truncate + ocean.nc + + + + + + + + + + + + + + + + + + + + + + + + base_mesh.nc + mesh.nc + + + + 1 + ./ocean_model + namelist.ocean + streams.ocean + + + + ocean.nc + + + diff --git a/test_cases/ocean/ocean/periodic_planar/20km/config_init2.xml b/test_cases/ocean/ocean/periodic_planar/20km/config_init2.xml new file mode 100644 index 0000000000..4820cf1093 --- /dev/null +++ b/test_cases/ocean/ocean/periodic_planar/20km/config_init2.xml @@ -0,0 +1,58 @@ + + + + + + + + + + + + + + + + + + + mesh.nc + + + output + 0000_00:00:01 + truncate + init.nc + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + ./ocean_model + namelist.ocean + streams.ocean + + + + diff --git a/test_cases/ocean/templates/ocean/forcing_data.xml b/test_cases/ocean/templates/ocean/forcing_data.xml new file mode 100644 index 0000000000..d2a16b2cde --- /dev/null +++ b/test_cases/ocean/templates/ocean/forcing_data.xml @@ -0,0 +1,32 @@ + From 7ee083e48aeb370e945d9217f754f67ead9ee2dc Mon Sep 17 00:00:00 2001 From: Phillip Wolfram Date: Fri, 23 Oct 2015 16:50:27 -0600 Subject: [PATCH 0391/1724] z vertical level for isopycnally-const. particles Computes the vertical level (zLevelParticle) when running particles in isopycnally-constrained mode. Previously, code to do this was commented out and needed updating. --- .../mpas_ocn_lagrangian_particle_tracking.F | 57 +++++++++++-------- 1 file changed, 33 insertions(+), 24 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F index 94b33b4261..a4afce1fb8 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -350,6 +350,7 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ call mpas_pool_get_array(diagnosticsPool, 'zTop', zTop) call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) call mpas_pool_get_array(diagnosticsPool, 'vertVelocityTop', vertVelocityTop) + call mpas_pool_get_array(diagnosticsPool, 'potentialDensity', buoyancyTimeInterp) ! note, originally this was diagnostics % state % normalVelocity (without time level), but ! now there is a time level so selection of the correct time level appears to be tricky @@ -671,18 +672,11 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ !! the particle is in a cell that does not have the proper buoyancy target because this implies !! that the buoyancy tracking mode has completely failed. !! need to make sure it is validated for buoyancy particles -#ifdef MPAS_DEBUG - !call mpas_timer_start("mpas_get_vertical_idLPT", .false., timerVerticalID) -#endif - !iLevelBuoyancy = mpas_get_vertical_id(maxLevelCell(iCell), buoyancyInterp, buoyancyTimeInterp(:,iCell)) -#ifdef MPAS_DEBUG - !call mpas_timer_stop("mpas_get_vertical_idLPT", timerVerticalID) -#endif - !! interpolate the scalars now (assumes that scalar value is constant within a particular cell) - !call interp_cell_scalars(iLevelBuoyancy, maxLevelCell(iCell), buoyancyInterp, buoyancyTimeInterp(:,iCell), & - ! zMid(:,iCell), zLevelParticle) - !deallocate(buoyancyTimeInterp) - !!}}} + iLevelBuoyancy = mpas_get_vertical_id(maxLevelCell(iCell), buoyancyInterp, buoyancyTimeInterp(:,iCell)) + ! interpolate the scalars now (assumes that scalar value is constant within a particular cell) + call interp_cell_scalars(iLevelBuoyancy, maxLevelCell(iCell), buoyancyInterp, buoyancyTimeInterp(:,iCell), & + zMid(:,iCell), zLevelParticle) + !}}} else ! make sure final zLevelParticle is ok so that it can't extent past zMid range #ifdef MPAS_DEBUG @@ -1650,6 +1644,7 @@ subroutine initialize_particle_properties(domain, timeLevel, err)!{{{ call mpas_pool_get_array(diagnosticsPool, 'zTop', zTop) call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) call mpas_pool_get_array(diagnosticsPool, 'vertVelocityTop', vertVelocityTop) + call mpas_pool_get_array(diagnosticsPool, 'potentialDensity', buoyancyTimeInterp) call mpas_pool_get_field(statePool, 'normalVelocity', normalVelocity, timeLevel=timeLevel) call mpas_dmpar_exch_halo_field(normalVelocity) @@ -1723,7 +1718,11 @@ subroutine initialize_particle_properties(domain, timeLevel, err)!{{{ #endif if(verticalTreatment == 4) then !('buoyancySurface') !{{{ - ! pass + iLevelBuoyancy = mpas_get_vertical_id(maxLevelCell(iCell), buoyancyParticle, buoyancyTimeInterp(:,iCell)) + + ! interpolate the scalars now (assumes that scalar value is constant within a particular cell) + call interp_cell_scalars(iLevelBuoyancy, maxLevelCell(iCell), buoyancyParticle, buoyancyTimeInterp(:,iCell), & + zMid(:,iCell), zLevelParticle) else ! make sure final zLevelParticle is ok so that it can't extent past zMid range @@ -2330,20 +2329,30 @@ subroutine interp_cell_scalars(iLevel, nVertLevels, zInterp, zVals, & !{{{ integer :: aVertex, theVertex, iHigh, iLow real (kind=RKIND) :: eps=1e-14 - call get_bounding_indices(iLow, iHigh, zInterp, zVals, iLevel, nVertLevels) - - ! interpolate to vertical level now - if(abs(zVals(iHigh) - zVals(iLow)) < eps) then - ! we really can't distinguish between each of these points numerically, just take the - ! average of both - alpha = 0.5_RKIND + if(iLevel < 1) then + ! top level + if (iLevel == 0) then + phiInterp = phiVals(nVertLevels) + ! bottom level + else if (iLevel == -1) then + phiInterp = phiVals(1) + end if else + call get_bounding_indices(iLow, iHigh, zInterp, zVals, iLevel, nVertLevels) + ! interpolate to vertical level now - alpha = (zInterp - zVals(iLow))/(zVals(iHigh) - zVals(iLow)) - end if + if(abs(zVals(iHigh) - zVals(iLow)) < eps) then + ! we really can't distinguish between each of these points numerically, just take the + ! average of both + alpha = 0.5_RKIND + else + ! interpolate to vertical level now + alpha = (zInterp - zVals(iLow))/(zVals(iHigh) - zVals(iLow)) + end if - ! interpolate to the vertical level - phiInterp = alpha * phiVals(iHigh) + (1.0_RKIND - alpha) * phiVals(iLow) + ! interpolate to the vertical level + phiInterp = alpha * phiVals(iHigh) + (1.0_RKIND - alpha) * phiVals(iLow) + end if end subroutine interp_cell_scalars!}}} From 71a62da7b0f7f99a5704d575e1e1a49f6344eca2 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Thu, 29 Oct 2015 16:58:36 -0600 Subject: [PATCH 0392/1724] bug fix: changed parameters to test case runs The issue was that the particle decomposition was for sepecified to be 4 processors. However, it is static and is actually for 16 which prevented this test case from running properly. --- .../ocean/ocean/periodic_planar/20km/config_forward.xml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml b/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml index 1f967aac95..af470707ca 100644 --- a/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml +++ b/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml @@ -24,9 +24,9 @@ - + - + @@ -68,10 +68,10 @@ - 4 + 16 - 4 + 16 ./ocean_model namelist.ocean streams.ocean From 1258522f7261646c031dcce710be6fa6aaf8e377 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 29 Oct 2015 20:49:27 -0600 Subject: [PATCH 0393/1724] Added a vertical temperature/enthalpy solver and supporting code I translated a CISM module, glissade_therm.F90, to MPAS data structures. The new module is called mpas_li_thermal.F. It has the following public subroutines: (1) li_thermal_init: This subroutine initializes the temperature profile. The options (given by config_thermal_init) are 'linear' and 'file'. - If 'linear', then this subroutine constructs a simple (but somewhat realistic) linear temperature profile in each column, varying from surfaceAirTemperature at the upper surface to slightly below the pressure melting point temperature at the bed. - If 'file', then it is assumed that the temperature has already been read from an input file. - On restarts, this config setting is ignored and the temperature is read from the restart file. (2) li_thermal_solver: This subroutine solves for the evolution of the temperature/ enthalpy profile in each column over one timestep, given heat sources and sinks in the ice interior and at the bed. It is called at the beginning of the prognostic timestep, before the transport calculations. The thermal solver operates on all cells with thickness > config_thermal_thickness (= 1 m by default). The options (given by config_thermal_solver) are 'none', 'temperature' and 'enthalpy'. - The default for now is 'none', in which case the thermal solver does nothing. - The 'temperature' option is functionally equivalent to the Glissade temperature solver, which has been tested extensively. - Likewise, the 'enthalpy' option is equivalent to the Glissade enthalpy solver, which has been tested for long EISMINT-2 simulations and some Greenland simulations, but not as extensively as the temperature solver. In the enthalpy case, there is an additional tracer called 'waterfrac'. (3) li_heat_dissipation_sia: This subroutine computed the heat dissipation rate (deg/s) in the ice interior, assuming shallow-ice stresses. There is a similar subroutine in Glide. This subroutine differs from Glide, however, in that the heat dissipation is computed on cell edges (rather than vertices) before being averaged to cell centers. There are additional private subroutines with the following functions: - Compute melting at the bed. - Compute the pressure melting point temperature in the column and at the bed. - Given temperature and waterfrac, compute enthalpy; and given enthalpy, compute temperature and waterfrac. - Construct tridiagonal matrix elements in each column for the temperature or enthalpy solver, and solve the matrix. I added several new fields and config options in the Registry. Here is the current list of fields in the thermal state: - temperature - waterfrac - enthalpy - surfaceAirTemperature - surfaceTemperature - basalTemperature - surfaceConductiveFlux - basalConductiveFlux - basalHeatFlux - basalFrictionFlux - heatDissipation This code still needs to be tested in some simple cases to verify that the answers are the same (to a good approximation) as those given by CISM. --- src/core_landice/Registry.xml | 56 +- src/core_landice/mode_forward/Makefile | 7 + src/core_landice/mode_forward/mpas_li_core.F | 6 + .../mode_forward/mpas_li_diagnostic_vars.F | 17 + .../mode_forward/mpas_li_thermal.F | 2196 +++++++++++++++++ .../mpas_li_time_integration_fe.F | 6 +- src/core_landice/shared/mpas_li_constants.F | 14 +- 7 files changed, 2291 insertions(+), 11 deletions(-) create mode 100644 src/core_landice/mode_forward/mpas_li_thermal.F diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index feab344031..5286370d77 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -112,6 +112,21 @@ /> + + + + + + + - @@ -678,7 +694,6 @@ is the value of that variable from the *previous* time level! - - + + + - + + + + + + @@ -823,6 +859,10 @@ is the value of that variable from the *previous* time level! description="generic work array with dimensions of (nVertLevels nCells)" persistence="scratch" /> + block % next end do + ! initialize thermal solver + ! Note: This subroutine includes a loop over blocks + call li_thermal_init(domain, err_tmp) + err = ior(err, err_tmp) + ! initialize analysis driver call li_analysis_init(domain, err_tmp) err = ior(err, err_tmp) diff --git a/src/core_landice/mode_forward/mpas_li_diagnostic_vars.F b/src/core_landice/mode_forward/mpas_li_diagnostic_vars.F index b446152539..0b4f6da32f 100644 --- a/src/core_landice/mode_forward/mpas_li_diagnostic_vars.F +++ b/src/core_landice/mode_forward/mpas_li_diagnostic_vars.F @@ -354,6 +354,9 @@ subroutine diagnostic_solve_before_velocity(domain, err)!{{{ use mpas_geometry_utils, only: mpas_cells_to_points_using_baryweights use mpas_vector_operations, only: mpas_tangential_vector_1d + + !TODO - Move li_heat_dissipation_sia to a different module? + use li_thermal, only: li_heat_dissipation_sia !----------------------------------------------------------------- ! @@ -409,6 +412,7 @@ subroutine diagnostic_solve_before_velocity(domain, err)!{{{ real (kind=RKIND), dimension(:), pointer :: beta, betaSolve real (kind=RKIND), pointer :: config_sea_level, config_ice_density, config_ocean_density character (len=StrKIND), pointer :: config_velocity_solver, config_sia_tangent_slope_calculation + character (len=StrKIND), pointer :: config_thermal_solver logical, pointer :: config_adaptive_timestep_include_DCFL ! truly local variables real (kind=RKIND) :: thisThk @@ -476,6 +480,7 @@ subroutine diagnostic_solve_before_velocity(domain, err)!{{{ call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) call mpas_pool_get_config(liConfigs, 'config_ocean_density', config_ocean_density) call mpas_pool_get_config(liConfigs, 'config_velocity_solver', config_velocity_solver) + call mpas_pool_get_config(liConfigs, 'config_thermal_solver', config_thermal_solver) call mpas_pool_get_config(liConfigs, 'config_adaptive_timestep_include_DCFL', config_adaptive_timestep_include_DCFL) call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) @@ -585,6 +590,7 @@ subroutine diagnostic_solve_before_velocity(domain, err)!{{{ ! Do vertical remapping of layerThickness and tracers + !WHL - I think the last argument should be err_tmp. call vertical_remap(thickness, cellMask, meshPool, layerThickness, tracers, err) err = ior(err, err_tmp) @@ -669,6 +675,17 @@ subroutine diagnostic_solve_before_velocity(domain, err)!{{{ !print *,'dirichletMaskChanged', dirichletMaskChanged end if + ! Calculate heat dissipation, as needed by the thermal solver during the next time step. + !TODO - Make sure heat dissipation is computed for the FO solver. + + if (trim(config_thermal_solver) == 'temperature' .or. trim(config_thermal_solver) == 'enthalpy') then + + if (trim(config_velocity_solver) == 'sia') then + call li_heat_dissipation_sia(domain, err_tmp) + err = ior(err, err_tmp) + endif + + endif ! === error check if (err > 0) then diff --git a/src/core_landice/mode_forward/mpas_li_thermal.F b/src/core_landice/mode_forward/mpas_li_thermal.F new file mode 100644 index 0000000000..279622aebe --- /dev/null +++ b/src/core_landice/mode_forward/mpas_li_thermal.F @@ -0,0 +1,2196 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! + + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! li_thermal +! +!> \brief MPAS land ice vertical temperature/enthalpy solver +!> \author William Lipscomb +!> \date October 2015 +!> \details +!> This module contains solvers for the vertical temperature +!> and/or enthalpy profile. +! +!----------------------------------------------------------------------- + +module li_thermal + + use mpas_derived_types + use mpas_pool_routines + use mpas_constants + use mpas_dmpar + use li_setup + use li_mask + use li_constants + + + implicit none + private + + !-------------------------------------------------------------------- + ! + ! Public parameters + ! + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! + ! Public member functions + ! + !-------------------------------------------------------------------- + + public :: li_thermal_init, li_thermal_solver, li_heat_dissipation_sia + + !-------------------------------------------------------------------- + ! + ! Private module variables + ! + !-------------------------------------------------------------------- + + real (kind=RKIND), save :: rhoi ! ice density (kg m^{-3}), copied from config_ice_density + real (kind=RKIND), save :: rhoo ! ocean density (kg m^{-3}), copied from config_ocean_density + + !TODO - dups is from CISM. Choose a better name? + real (kind=RKIND), dimension(:,:), allocatable :: dups ! vertical grid quantities + + ! max and min allowed temperatures (Kelvin) + ! Note: kelvin_to_celsius = 273.15 (perhaps it should be called celsius_to_kelvin?) + + real (kind=RKIND), parameter :: & + maxtemp_threshold = 100._RKIND + kelvin_to_celsius, & + mintemp_threshold = -100._RKIND + kelvin_to_celsius + +!*********************************************************************** + contains +!*********************************************************************** + + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ! routine li_thermal_init +! +!> \brief MPAS land ice initialize vertical temperature +!> \author William Lipscomb +!> \date October 2015 +!> \details +!> This routine initializes the vertical temperature profile in each column +!> and computes some quantities required by the thermal solver. +!----------------------------------------------------------------------- + + subroutine li_thermal_init(domain, err) + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: & + domain !< Input/Output: domain object + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + + type (block_type), pointer :: block + + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: geometryPool + type (mpas_pool_type), pointer :: thermalPool + + ! config options + + logical, pointer :: & + config_print_thermal_info, & + config_do_restart + + character(len=StrKIND), pointer :: & + config_thermal_solver, & ! solver option ('temperature' or 'enthalpy') + config_thermal_init ! initialization option ('linear' or 'file') + + real (kind=RKIND), pointer :: & + config_ice_density, & ! ice density + config_ocean_density ! ocean density + + integer, pointer :: & + index_temperature, & + index_waterfrac + + integer, pointer :: & + nCellsSolve, & ! number of locally owned cells + nVertLevels ! number of vertical layers + + real (kind=RKIND), dimension(:), pointer :: & + layerCenterSigma, & ! sigma coordinate at midpoint of each layer + layerInterfaceSigma ! sigma coordinate at layer interfaces (including top and bottom) + + real (kind=RKIND), dimension(:), pointer :: & + thickness ! ice thickness + + real (kind=RKIND), dimension(:,:,:), pointer :: tracers + + real (kind=RKIND), dimension(:,:), pointer :: & + temperature, & ! interior ice temperature (K) + waterfrac, & ! interior water fraction (unitless) + enthalpy ! interior ice enthalpy (J m^{-3}) + + real (kind=RKIND), dimension(:), pointer :: & + surfaceTemperature, & ! surface ice temperature (K) + basalTemperature, & ! basal ice temperature (K) + surfaceAirTemperature ! surface air temperature (K) + + ! Note: The following fields are needed for halo updates + ! TODO - Are halo updates needed at initialization? + type (field1DReal), pointer :: & + surfaceTemperatureField, & + basalTemperatureField + + type (field2DReal), pointer :: & + temperatureField, & + waterfracField + + real (kind=RKIND), dimension(:), allocatable :: & + pmptemp ! pressure melting point temp in ice interior + + real (kind=RKIND) :: & + pmptemp_bed ! pressure melting point temp at bed + + real (kind=RKIND), parameter :: & + pmpt_offset = 2.0_RKIND ! offset of initial Tbed from pressure melting point temperature (K) + ! Note: pmtp_offset is positive for T < Tpmp + + integer :: k, iLayer + + integer :: iCell + + integer :: err_tmp + + !WHL - debug - for circular shelf test case + integer, parameter :: ncellsPerRow = 40 + integer, parameter :: nRows = 46 + integer :: i, iRow + + err = 0 + + ! get config options + call mpas_pool_get_config(liConfigs, 'config_thermal_solver', config_thermal_solver) + call mpas_pool_get_config(liConfigs, 'config_thermal_init', config_thermal_init) + call mpas_pool_get_config(liConfigs, 'config_print_thermal_info', config_print_thermal_info) + call mpas_pool_get_config(liConfigs, 'config_do_restart', config_do_restart) + + ! set some physical constants + ! (to avoid calling mpas_pool_get_config repeatedly in this module) + call mpas_pool_get_config(liConfigs, 'config_ice_density', config_ice_density) + call mpas_pool_get_config(liConfigs, 'config_ocean_density', config_ocean_density) + rhoi = config_ice_density + rhoo = config_ocean_density + + ! block loop + block => domain % blocklist + do while (associated(block)) + + write(stderrUnit,*) 'Get pools' + + ! get pools + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'thermal', thermalPool) + + ! get dimensions + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(thermalPool, 'index_temperature', index_temperature) + call mpas_pool_get_dimension(thermalPool, 'index_waterfrac', index_waterfrac) + + ! get fields from the mesh pool + call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) + call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) + + ! get fields from the geometry pool + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + + ! get fields from the thermal pool + call mpas_pool_get_array(thermalPool, 'tracers', tracers) +! call mpas_pool_get_array(thermalPool, 'temperature', temperature) +! call mpas_pool_get_array(thermalPool, 'waterfrac', waterfrac) + call mpas_pool_get_array(thermalPool, 'surfaceAirTemperature', surfaceAirTemperature) + call mpas_pool_get_array(thermalPool, 'surfaceTemperature', surfaceTemperature) + call mpas_pool_get_array(thermalPool, 'basalTemperature', basalTemperature) + + ! temporary init for surfaceAirTemperature + !TODO - Read surfaceAirTemperature from a file or create a simple field + surfaceAirTemperature(:) = kelvin_to_celsius ! 273.15 + + !TODO - Is there a better way to access the temperature and waterfrac arrays? + temperature => tracers(index_temperature,:,:) + waterfrac => tracers(index_waterfrac,:,:) + + if (config_print_thermal_info) then + + write(stderrUnit,*) 'Initialize thermal solver, config_thermal_init =', trim(config_thermal_init) + + !WHL - temporary debugging code - for circular shelf test case +! write(stderrUnit,*) ' ' +! write(stderrUnit,*) 'Surface ice temperature before init' +! do iRow = nRows, 1, -1 +! if (mod(iRow,2) == 0) then ! indent for even-numbered rows +! write(stderrUnit,'(a3)',advance='no') ' ' +! endif +! do i = nCellsPerRow/2 - 2, nCellsPerRow +! iCell = (iRow-1)*nCellsPerRow + i +! write(stderrUnit,'(f8.2)',advance='no') surfaceTemperature(iCell) +! enddo +! write(stderrUnit,*) ' ' +! enddo + + endif ! config_print_thermal_info + + ! Precompute some grid quantities used in the vertical temperature solve + ! (Commented-out lines are from CISM) + + allocate(dups(nVertLevels,2)) + dups(:,:) = 0.0_RKIND + + k = 1 + ! dups(k,1) = 1.0_RKIND/((sigma(k+1) - sigma(k)) * (stagsigma(k) - sigma(k)) ) + dups(k,1) = 1.0_RKIND/((layerInterfaceSigma(k+1) - layerInterfaceSigma(k)) * (layerCenterSigma(k) - layerInterfaceSigma(k)) ) + + do k = 2, nVertLevels + ! dups(k,1) = 1.0_RKIND/((sigma(k+1) - sigma(k)) * (sigma(k) - sigma(k-1)) ) + dups(k,1) = 1.0_RKIND/((layerInterfaceSigma(k+1) - layerInterfaceSigma(k)) * (layerCenterSigma(k) - layerCenterSigma(k-1)) ) + enddo + + do k = 1, nVertLevels-1 + ! dups(k,2) = 1.0_RKIND/((sigma(k+1) - sigma(k)) * (stagsigma(k+1) - stagsigma(k)) ) + dups(k,2) = 1.0_RKIND/((layerInterfaceSigma(k+1) - layerInterfaceSigma(k)) * (layerCenterSigma(k+1) - layerCenterSigma(k)) ) + end do + + k = nVertLevels + ! dups(k,2) = 1.0_RKIND/((sigma(k+1) - sigma(k)) * (sigma(k+1) - stagsigma(k)) ) + dups(k,2) = 1.0_RKIND/((layerInterfaceSigma(k+1) - layerInterfaceSigma(k)) * (layerInterfaceSigma(k+1) - layerCenterSigma(k)) ) + + if (config_print_thermal_info) then + write(stderrUnit,*) 'dups coefficients:' + do k = 1, nVertLevels + write(stderrUnit,*) k, dups(k,1), dups(k,2) + enddo + endif + + ! Initialize vertical temperature profile. + ! Three possibilities: + ! (1) Set up a linear temperature profile, with T = artm at the surface and T <= Tpmp + ! at the bed (config_thermal_init = 'linear'). + ! A parameter (pmpt_offset) controls how far below Tpmp the initial bed temp is set. + ! (2) Read ice temperature from an initial input file (config_thermal_init = 'file'). + ! (3) Read ice temperature from a restart file. + ! + ! The default is (1). + ! If restarting, we always do (3). + ! If (2) or (3), then the temperature should already have been read in, and there is + ! nothing to do here (except possibly to set waterfrac). + + if (config_do_restart) then + + ! nothing to do; temperature was read from the restart file + !TODO - Make sure waterfrac is also read, if needed + if (config_print_thermal_info) then + write(stderrUnit,*) 'Initialized ice temperature from the restart file' + endif + + elseif (trim(config_thermal_init) == 'file') then + + ! Temperature was read from the input file + if (config_print_thermal_info) then + write(stderrUnit,*) 'Initialized ice temperature from the input file' + endif + + ! If using the enthalpy solver, initialize waterfrac here + !TODO - Allow waterfrac to be read from the input file? + + if (trim(config_thermal_solver) == 'enthalpy') then + waterfrac(:,:) = 0.0_RKIND + endif + + elseif (trim(config_thermal_init) == 'linear') then + + ! set up a linear temperature profile in each column + ! T = surfaceAirTemperature at the ice surface, and T <= Tpmp at the bed + + allocate(pmptemp(nVertLevels)) + + ! initialize T = 273.15 K = 0 C everywhere + + temperature(:,:) = kelvin_to_celsius ! = 273.15 + + do iCell = 1, nCellsSolve + + ! set surface temperature to the air temperature (or 273.15, whichever is less) + surfaceTemperature(iCell) = min(surfaceAirTemperature(iCell), kelvin_to_celsius) + + ! compute the pressure melting point temperature in the column and at the bed + !TODO - Change pmp subroutine to return temperature in Kelvin + + call pressure_melting_point_column(layerCenterSigma(:), thickness(iCell), pmptemp(:)) + call pressure_melting_point(thickness(iCell), pmptemp_bed) + + pmptemp(:) = pmptemp(:) + kelvin_to_celsius + pmptemp_bed = pmptemp_bed + kelvin_to_celsius + + ! set the basal temperature to slightly below the pressure melting point temperature + basalTemperature(iCell) = pmptemp_bed - pmpt_offset + + ! set the interior temperatures + ! make sure T <= Tpmp - pmpt_offset in column interior + + temperature(:,iCell) = surfaceTemperature(iCell) + & + (basalTemperature(iCell) - surfaceTemperature(iCell)) * layerCenterSigma(:) + + temperature(:,iCell) = min(temperature(:,iCell), pmptemp(:) - pmpt_offset) + + enddo ! iCell + + ! initialize the water fraction to zero + waterfrac(:,:) = 0.0_RKIND + + if (config_print_thermal_info) then + write(stderrUnit,*) 'Initialized a linear temperature profile in each column' + endif + + endif ! restart file, input file, or linear + + ! clean up + if (allocated(pmptemp)) deallocate(pmptemp) + + block => block % next + enddo + + !TODO - Add a debug check for bad values + ! E.g., make sure the temperature read from a file is in Kelvin and not Celsius + + ! halo updates + + call mpas_pool_get_field(thermalPool, 'surfaceTemperature', surfaceTemperatureField) + call mpas_dmpar_exch_halo_field(surfaceTemperatureField) + + call mpas_pool_get_field(thermalPool, 'basalTemperature', basalTemperatureField) + call mpas_dmpar_exch_halo_field(basalTemperatureField) + + !TODO - Halo updates for components of the tracer array +!! call mpas_pool_get_field(thermalPool, 'temperature', temperatureField) +!! call mpas_dmpar_exch_halo_field(temperatureField) + + if (trim(config_thermal_solver) == 'enthalpy') then +!! call mpas_pool_get_field(thermalPool, 'waterfrac', waterfracField) +!! call mpas_dmpar_exch_halo_field(waterfracField) + endif + + ! === error check + if (err > 0) then + write (stderrUnit,*) "An error has occurred in li_thermal_init." + endif + + !-------------------------------------------------------------------- + end subroutine li_thermal_init + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ! routine li_thermal_solver +! +!> \brief MPAS land ice solver for vertical temperature/enthalpy +!> \author William Lipscomb +!> \date October 2015 +!> \details +!> This routine is the driver for the vertical temperature/enthalpy +!> calculation in each ice column. The following options are supported: +!> (1) Do nothing (config_thermal_solver = 'none') +!> (2) Standard prognostic temperature solve (config_thermal_solver = 'temperature') +!> (3) Prognostic solve for enthalpy (config_thermal_solver = 'enthalpy') + +!----------------------------------------------------------------------- + + subroutine li_thermal_solver(domain, deltat, err) + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + real (kind=RKIND), intent(in) :: deltat !< Input: time step + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: & + domain !< Input/Output: domain object + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + + type (block_type), pointer :: block + + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: geometryPool + type (mpas_pool_type), pointer :: thermalPool + type (mpas_pool_type), pointer :: velocityPool ! needed for mask subroutine + + integer, pointer :: & + nCellsSolve, & ! number of locally owned cells + nVertLevels, & ! number of vertical layers + nVertInterfaces ! number of vertical interfaces (including top and bottom) + + logical, pointer :: & + config_print_thermal_info ! if true, print debug info + + character(len=StrKIND), pointer :: & + config_thermal_solver ! option for thermal solver + + real(kind=RKIND), pointer :: & + config_thermal_thickness ! minimum thickness for temperature calculations + + integer, pointer :: & + config_stats_cell_ID ! global ID for diagnostic cell + + integer, dimension(:), pointer :: & + cellMask, & ! bit mask describing whether ice is floating, dynamically active, etc. + thermalCellMask, & ! mask for thermal calculations + ! = 1 where thickness > config_thermal_thickness, elsewhere = 0 + indexToCellID ! list of global cell IDs + + real (kind=RKIND), dimension(:), pointer :: & + layerCenterSigma, & ! sigma coordinate at midpoint of each layer + layerInterfaceSigma ! sigma coordinate at layer interfaces (including top and bottom) + + real (kind=RKIND), dimension(:), pointer :: & + surfaceTemperature, & ! surface ice temperature (K) + basalTemperature, & ! basal ice temperature (K) + surfaceAirTemperature, & ! surface air temperature (K) + basalHeatFlux, & ! basal heat flux into the ice (W m^{-2}, positive upward) + basalFrictionFlux, & ! basal frictional flux into the ice (W m^{-2}) + surfaceConductiveFlux, & ! conductive heat flux at the upper surface (W m^{-2}, positive downward) + basalConductiveFlux, & ! conductive heat flux at the lower surface (W m^{-2}, positive downward) + basalMassBal, & ! basal mass balance (kg m^{-2} s^{-1}); positive for freeze-on, negative for melting + basalWaterThickness, & ! basal water thickness (m) + thickness, & ! ice thickness (m) + bedTopography ! bed topography (m; negative below sea level) + + real (kind=RKIND), dimension(:,:), pointer :: & + temperature, & ! interior ice temperature (K) + waterfrac, & ! interior water fraction (unitless) + enthalpy, & ! interior ice enthalpy (J m^{-3}) + heatDissipation ! interior heat dissipation (deg/s) ! TODO - These are CISM units. Change? + + ! Note: The following fields are needed for halo updates + + type (field1DReal), pointer :: & + surfaceTemperatureField, & + basalTemperatureField + + type (field2DReal), pointer :: & + temperatureField, & + waterfracField + + real(kind=RKIND), dimension(:), allocatable :: & + subdiagonal, diagonal, superdiagonal, & ! tridiagonal matrix elements + rhs ! matrix right-hand side + + !TODO - Change name of alpha_enth? + real(kind=RKIND), dimension(:), allocatable :: & + alpha_enth ! diffusivity at interfaces (m2/s) for enthalpy solver + ! = coni / (rhoi*cp_ice) for cold ice !TODO - Change name of coni? + + !TODO - Get rid of these temporary arrays? + real(kind=RKIND), dimension(:), allocatable :: & + temp, enth ! like temperature/enthalpy, but including surface and bed + + real(kind=RKIND) :: & + depth, & ! depth within ice column + dTtop, dTbot, & ! temperature differences + denth_top, denth_bot, & ! enthalpy differences + columnHeatDissipation, & ! integrated heat dissipation in column + maxtemp, mintemp, & ! max and min temperatures in column + initialEnergy, & ! initial energy in ice column (J m^{-2}) + finalEnergy, & ! final energy in ice column (J m^{-2}) + deltaEnergy ! change in energy + + integer :: iCell, err_tmp + + logical :: verboseColumn + + integer :: k + + !WHL - debug - for circular shelf test case + integer, parameter :: ncellsPerRow = 40 + integer, parameter :: nRows = 46 + integer :: i, iRow + + err = 0 + + ! block loop + block => domain % blocklist + do while (associated(block)) + + ! get pools + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'thermal', thermalPool) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) + + ! get dimensions + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nVertInterfaces', nVertInterfaces) + + ! get fields from the mesh pool + call mpas_pool_get_array(meshPool, 'layerCenterSigma', layerCenterSigma) + call mpas_pool_get_array(meshPool, 'layerInterfaceSigma', layerInterfaceSigma) + call mpas_pool_get_array(meshPool, 'indexToCellID', indexToCellID) ! diagnostic only + + ! get fields from the geometry pool + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'bedTopography', bedTopography) + call mpas_pool_get_array(geometryPool, 'cellMask', cellMask) + call mpas_pool_get_array(geometryPool, 'basalMassBal', basalMassBal) + call mpas_pool_get_array(geometryPool, 'basalWaterThickness', basalWaterThickness) + + ! get fields from the thermal pool + call mpas_pool_get_array(thermalPool, 'surfaceTemperature', surfaceTemperature) + call mpas_pool_get_array(thermalPool, 'basalTemperature', basalTemperature) + call mpas_pool_get_array(thermalPool, 'temperature', temperature) + call mpas_pool_get_array(thermalPool, 'waterfrac', waterfrac) + call mpas_pool_get_array(thermalPool, 'enthalpy', enthalpy) + call mpas_pool_get_array(thermalPool, 'surfaceAirTemperature', surfaceAirTemperature) + call mpas_pool_get_array(thermalPool, 'surfaceConductiveFlux', surfaceConductiveFlux) + call mpas_pool_get_array(thermalPool, 'basalConductiveFlux', basalConductiveFlux) + call mpas_pool_get_array(thermalPool, 'basalHeatFlux', basalHeatFlux) + call mpas_pool_get_array(thermalPool, 'basalFrictionFlux', basalFrictionFlux) + call mpas_pool_get_array(thermalPool, 'heatDissipation', heatDissipation) + + ! get fields from the scratch pool + call mpas_pool_get_array(thermalPool, 'iceCellMask', thermalCellMask) + + ! get config variables + call mpas_pool_get_config(liConfigs, 'config_print_thermal_info', config_print_thermal_info) + call mpas_pool_get_config(liConfigs, 'config_thermal_solver', config_thermal_solver) + call mpas_pool_get_config(liConfigs, 'config_thermal_thickness', config_thermal_thickness) + call mpas_pool_get_config(liConfigs, 'config_stats_cell_ID', config_stats_cell_ID) + + if (config_print_thermal_info) then + write(stderrUnit,*) 'Solving for temperature, config_thermal_solver = ', config_thermal_solver + + !WHL - debug - for circular shelf test case +! write(stderrUnit,*) 'Surface ice temperature before thermal calc' +! do iRow = nRows, 1, -1 +! if (mod(iRow,2) == 0) then ! indent for even-numbered rows +! write(stderrUnit,'(a3)',advance='no') ' ' +! endif +! do i = nCellsPerRow/2 - 2, nCellsPerRow +! iCell = (iRow-1)*nCellsPerRow + i +! write(stderrUnit,'(f8.2)',advance='no') surfaceTemperature(iCell) +! enddo +! write(stderrUnit,*) ' ' +! enddo + + endif + + ! calculate masks - so we know where the ice is floating + call li_calculate_mask(meshPool, velocityPool, geometryPool, err_tmp) + err = ior(err, err_tmp) + + select case(config_thermal_solver) + + case ('none') + + ! Do nothing + + case ('temperature', 'enthalpy') + + ! Convert temperature from Kelvin to Celsius to avoid repeated use of kelvin_to_celsius below + ! (Convert back at the end.) + temperature(:,:) = temperature(:,:) - kelvin_to_celsius + + ! allocate some vertical arrays + allocate(subdiagonal(nVertInterfaces+1)) ! temperature/enthalpy in each layer, plus surface and basal temperature + allocate(diagonal(nVertInterfaces+1)) + allocate(superdiagonal(nVertInterfaces+1)) + allocate(rhs(nVertInterfaces+1)) + allocate(alpha_enth(nVertInterfaces)) + + !TODO - Get rid of these temporary arrasy? + allocate(temp(0:nVertInterfaces)) + allocate(enth(0:nVertInterfaces)) + + ! loop over locally owned cells + do iCell = 1, nCellsSolve + + if (config_print_thermal_info .and. indexToCellID(iCell) == config_stats_cell_ID) then + verboseColumn = .true. + else + verboseColumn = .false. + endif + + if (thickness(iCell) > config_thermal_thickness) then + + ! set thermal mask + thermalCellMask(iCell) = 1 + + ! Set surface temperature (Celsius) + + surfaceTemperature(iCell) = min(0.0_RKIND, surfaceAirTemperature(iCell) - kelvin_to_celsius) + + ! For floating ice, set the basal temperature to the freezing temperature of seawater + ! Values based on Ocean Water Freezing Point Calculator with S = 35 PSU + if (li_mask_is_floating_ice(cellMask(iCell))) then + depth = thickness(iCell) * rhoi/rhoo + basalTemperature(iCell) = oceanFreezingTempSurface + oceanFreezingTempDepthDependence * depth ! Celsius + endif + + if (trim(config_thermal_solver) == 'enthalpy') then + + ! Given temperature and waterfrac in ice interior, compute enthalpy + + call temperature_to_enthalpy(& + layerCenterSigma, & + thickness(iCell), & + temperature(:,iCell), & + waterfrac(:,iCell), & + enthalpy(:,iCell)) + + if (verboseColumn) then + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'Before prognostic enthalpy, iCell =', indexToCellID(iCell) + write(stderrUnit,*) 'thickness =', thickness(iCell) + write(stderrUnit,*) 'Temperature (C), waterfrac, enthalpy/(rhoi*cp_ice):' + write(stderrUnit,*) surfaceTemperature(iCell) + do k = 1, nVertLevels + write(stderrUnit,*) k, temperature(k,iCell), waterfrac(k,iCell), enthalpy(k,iCell)/(rhoi*cp_ice) + enddo + write(stderrUnit,*) basalTemperature(iCell) + endif + + ! compute initial internal energy in column (for energy conservation check) + initialEnergy = 0.0_RKIND + do k = 1, nVertLevels + initialEnergy = initialEnergy + enthalpy(k,iCell) * (layerInterfaceSigma(k+1) - layerInterfaceSigma(k)) * thickness(iCell) + enddo + + ! compute matrix elements using enthalpy gradient method + + temp(0) = surfaceTemperature(iCell) + temp(1:nVertLevels) = temperature(:,iCell) + temp(nVertInterfaces) = basalTemperature(iCell) + + enth(0) = surfaceTemperature(iCell) * rhoi*cp_ice + enth(1:nVertLevels) = enthalpy(:,iCell) + enth(nVertInterfaces) = basalTemperature(iCell) * rhoi*cp_ice + + call enthalpy_matrix_elements(& + deltat, & + nVertInterfaces, & ! CISM passes upn + layerCenterSigma, & ! CISM passes stagsigma + subdiagonal, & + diagonal, & + superdiagonal, & + rhs, & + dups, & + li_mask_is_floating_ice_int(cellMask(iCell)), & + thickness(iCell), & + temp(0:nVertInterfaces), & + waterfrac(:,iCell), & + enth(0:nVertInterfaces), & + heatDissipation(:,iCell), & +!! basalHeatFlux(iCell), & + -basalHeatFlux(iCell), & ! CISM subroutine assumes positive down, so flip sign + basalFrictionFlux(iCell), & + alpha_enth, & + verboseColumn) + + if (verboseColumn) then + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'After matrix elements, iCell =', indexToCellID(iCell) + write(stderrUnit,*) 'k, subd, diag, supd, rhs/(rhoi*ci):' + do k = 1, nVertInterfaces+1 + write(stderrUnit,*) k-1, subdiagonal(k), diagonal(k), superdiagonal(k), rhs(k)/(rhoi*cp_ice) + enddo + endif + + ! solve the tridiagonal system + ! Note: Enthalpy is indexed from 0 to nVertInterfaces, with indices 1 to nVertInterfaces-1 colocated + ! with layerCenterSigma values of the same index. + ! However, the matrix elements are indexed 1 to nVertInterfaces+1, with the first row + ! corresponding to the surface enthalpy, enthalpy(0). + + call tridiag_solver(& + subdiagonal, & + diagonal, & + superdiagonal, & + enth(0:nVertInterfaces), & + rhs) + + ! Compute conductive fluxes = (alpha/H * denth/dsigma) at upper and lower surfaces; positive down. + ! Here alpha = coni / (rhoi*shci) for cold ice, with a smaller value for temperate ice. + ! Assume implicit backward Euler time step. + ! Note: These fluxes should be computed before calling glissade_enth2temp (which might reset the bed enthalpy). + + ! commented-out code is from CISM +!! denth_top = enthalpy(1,ew,ns) - enthalpy(0,ew,ns) +!! denth_bot = enthalpy(upn,ew,ns) - enthalpy(upn-1,ew,ns) + +!! ucondflx(ew,ns) = -alpha_enth(1) /thck(ew,ns) * denth_top/( stagsigma(1)) +!! lcondflx(ew,ns) = -alpha_enth(upn)/thck(ew,ns) * denth_bot/(1.d0 - stagsigma(upn-1)) + + denth_top = enth(1) - enth(0) + denth_bot = enth(nVertInterfaces) - enth(nVertLevels) + + surfaceConductiveFlux(iCell) = -alpha_enth(1)/thickness(iCell) * denth_top/layerCenterSigma(1) + basalConductiveFlux(iCell) = -alpha_enth(nVertInterfaces)/thickness(iCell) * denth_bot/(1.0_RKIND - layerCenterSigma(nVertLevels)) + + ! copy the enthalpy back into the full array + enthalpy(:,iCell) = enth(1:nVertLevels) + + ! convert enthalpy back to temperature and waterfrac + + call enthalpy_to_temperature(& + layerCenterSigma, & + thickness(iCell), & + enthalpy(:,iCell), & + temperature(:,iCell), & + waterfrac(:,iCell)) + + if (verboseColumn) then + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'After prognostic enthalpy, iCell =', indexToCellID(iCell) + write(stderrUnit,*) 'thickness =', thickness(iCell) + write(stderrUnit,*) 'Temp, waterfrac, enthalpy/(rhoi*cp_ice):' + write(stderrUnit,*) surfaceTemperature(iCell) + do k = 1, nVertLevels + write(stderrUnit,*) k, temperature(k,iCell), waterfrac(k,iCell), enthalpy(k,iCell)/(rhoi*cp_ice) + enddo + write(stderrUnit,*) basalTemperature(iCell) + endif + + ! compute final internal energy in column (for energy conservation check) + finalEnergy = 0.0_RKIND + do k = 1, nVertLevels + finalEnergy = finalEnergy + enthalpy(k,iCell) * (layerInterfaceSigma(k+1) - layerInterfaceSigma(k)) * thickness(iCell) + enddo + + else ! temperature solver + + if (verboseColumn) then + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'Before prognostic temperature, iCell =', indexToCellID(iCell) + write(stderrUnit,*) 'thickness =', thickness(iCell) + write(stderrUnit,*) surfaceTemperature(iCell) + do k = 1, nVertLevels + write(stderrUnit,*) k, temperature(k,iCell) + enddo + write(stderrUnit,*) basalTemperature(iCell) + endif + + ! compute initial internal energy in column (for energy conservation check) + initialEnergy = 0.0_RKIND + do k = 1, nVertLevels + initialEnergy = initialEnergy + temperature(k,iCell) * (layerInterfaceSigma(k+1) - layerInterfaceSigma(k)) * thickness(iCell) + enddo + + ! compute matrix elements using enthalpy gradient method + !TODO - Get rid of temporary arrays? + + temp(0) = surfaceTemperature(iCell) + temp(1:nVertLevels) = temperature(:,iCell) + temp(nVertInterfaces) = basalTemperature(iCell) + + call temperature_matrix_elements(& + deltat, & + nVertInterfaces, & ! CISM passes upn + layerCenterSigma, & ! CISM passes stagsigma + subdiagonal, & + diagonal, & + superdiagonal, & + rhs, & + dups, & + li_mask_is_floating_ice_int(cellMask(iCell)), & + thickness(iCell), & + temp(0:nVertInterfaces), & + heatDissipation(:,iCell), & +!! basalHeatFlux(iCell), & + -basalHeatFlux(iCell), & ! CISM subroutine assumes positive down, so flip sign + basalFrictionFlux(iCell)) + + if (verboseColumn) then + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'After matrix elements, iCell =', indexToCellID(iCell) + write(stderrUnit,*) 'k, subd, diag, supd, rhs:' + do k = 1, nVertInterfaces+1 + write(stderrUnit,*) k-1, subdiagonal(k), diagonal(k), superdiagonal(k), rhs(k) + enddo + endif + + ! solve the tridiagonal system + ! Note: Temperature is indexed from 0 to nVertInterfaces, with indices 1 to nVertInterfaces-1 colocated + ! with layerCenterSigma values of the same index. + ! However, the matrix elements are indexed 1 to nVertInterfaces+1, with the first row + ! corresponding to the surface temperature, temp(0). + + call tridiag_solver(& + subdiagonal, & + diagonal, & + superdiagonal, & + temp(0:nVertInterfaces), & + rhs) + + ! Compute conductive flux = (k/H * dT/dsigma) at upper and lower surfaces; positive down + ! Assume implicit backward Euler time step. + + dTtop = temp(1) - temp(0) + dTbot = temp(nVertInterfaces) - temp(nVertInterfaces-1) + + surfaceConductiveFlux(iCell) = (-iceConductivity/thickness(iCell) ) * dTtop / layerCenterSigma(1) + basalConductiveFlux(iCell) = (-iceConductivity/thickness(iCell) ) * dTbot / (1.0_RKIND - layerCenterSigma(nVertLevels)) + + ! copy the temperature back into the full array + temperature(:,iCell) = temp(1:nVertLevels) + + if (verboseColumn) then + write(stderrUnit,*) ' ' + write(stderrUnit,*) 'After prognostic temperature, iCell =', indexToCellID(iCell) + write(stderrUnit,*) 'thickness =', thickness(iCell) + write(stderrUnit,*) surfaceTemperature(iCell) + do k = 1, nVertLevels + write(stderrUnit,*) k, temperature(k,iCell) + enddo + write(stderrUnit,*) basalTemperature(iCell) + endif + + ! compute final internal energy in column (for energy conservation check) + finalEnergy = 0.0_RKIND + do k = 1, nVertLevels + finalEnergy = finalEnergy + temperature(k,iCell) * (layerInterfaceSigma(k+1) - layerInterfaceSigma(k)) * thickness(iCell) + enddo + + endif ! temperature or enthalpy solver + + ! Convert temperature from Celsius back to Kelvin + temperature(:,iCell) = temperature(:,iCell) + kelvin_to_celsius + surfaceTemperature(iCell) = surfaceTemperature(iCell) + kelvin_to_celsius + basalTemperature(iCell) = basalTemperature(iCell) + kelvin_to_celsius + + ! Compute total dissipation rate in column (W/m^2) + columnHeatDissipation = 0.0_RKIND + do k = 1, nVertLevels + columnHeatDissipation = columnHeatDissipation & + + heatDissipation(k,iCell) * (layerCenterSigma(k+1) - layerCenterSigma(k)) + enddo + columnHeatDissipation = columnHeatDissipation * thickness(iCell)*rhoi*cp_ice + + ! Verify that the net input of energy into the column is equal to the change in internal energy. + + deltaEnergy = (surfaceConductiveFlux(iCell) - basalConductiveFlux(iCell) + columnHeatDissipation) * deltat + + !TODO - Confirm that this is a reasonable error threshold + if (abs((finalEnergy - initialEnergy - deltaEnergy) / deltat) > 1.0e-8_RKIND) then + + if (verboseColumn) then + print*, 'Ice thickness:', thickness(iCell) + print*, 'config_thermal_thickness:', config_thermal_thickness + print*, ' ' + print*, 'Interior fluxes:' + print*, 'sfc conductive flx (positive up)=', -surfaceConductiveFlux(iCell) + print*, 'bed conductive flx (positive up)=', -basalConductiveFlux(iCell) + print*, 'column heat dissipation =', columnHeatDissipation + print*, 'Net flux =', deltaEnergy/deltat + print*, ' ' + print*, 'deltaEnergy =', deltaEnergy + print*, 'initialEnergy =', initialEnergy + print*, 'finalEnergy =', finalEnergy + print*, ' ' + print*, 'Energy imbalance =', finalEnergy - initialEnergy - deltaEnergy + print*, ' ' + print*, 'Basal fluxes:' + print*, 'frictional =', basalFrictionFlux(iCell) + print*, 'geothermal =', basalHeatFlux(iCell) + print*, 'flux for bottom melting =', basalFrictionFlux(iCell) + basalHeatFlux(iCell) + basalConductiveFlux(iCell) + endif ! verboseColumn + + write(stderrUnit,*) 'li_thermal, energy conservation error: iCell, imbalance (W/m2):', & + indexToCellID(iCell), (finalEnergy - initialEnergy - deltaEnergy)/deltat + err = 1 + + endif ! energy conservation error + + else ! thickness <= config_thermal_thickness + + ! set thermal mask + thermalCellMask(iCell) = 0 + + ! Set temperature of thin ice to 0 C = 273.15 K + !TODO - For cells that have just crossed this thickness threshold, energy is not conserved here. + ! Keep track of the energy difference? + + surfaceTemperature(iCell) = kelvin_to_celsius + basalTemperature(iCell) = kelvin_to_celsius + temperature(:,iCell) = kelvin_to_celsius + waterfrac(:,iCell) = 0.0_RKIND + + endif ! thickness > config_thermal_thickness + + enddo ! iCell + + ! Calculate basal melt rate + ! For the standard temperature scheme, temperatures above the pressure melting point + ! are reset to Tpmp, with excess heat contributing to basal melt. + ! For the enthalpy scheme, internal meltwater in excess of the prescribed maximum + ! fraction (0.01 by default) is drained to the bed. + + call basal_melting(& + config_thermal_solver, & + deltat, & + nCellsSolve, & + nVertInterfaces, & + layerInterfaceSigma, & + layerCenterSigma, & + thermalCellMask, & + li_mask_is_floating_ice_int(cellMask), & + thickness, & + temperature, & + basalTemperature, & + waterfrac, & + enthalpy, & + basalFrictionFlux, & +!! basalHeatFlux, & + -basalHeatFlux, & !TODO - Switch sign convention in subroutine + basalConductiveFlux, & + basalWaterThickness, & + basalMassBal) + + ! Before exiting, check for temperatures that are physically unrealistic. + ! Thresholds are set at the top of this module. + + do iCell = 1, nCellsSolve + + maxtemp = maxval(temperature(:,iCell)) + mintemp = minval(temperature(:,iCell)) + + if (maxtemp > maxtemp_threshold) then + write(stderrUnit,*) 'maxtemp > 0: iCell, maxtemp =', iCell, maxtemp + write(stderrUnit,*) 'thickness =', thickness(iCell) + write(stderrUnit,*) 'temperature:' + do k = 1, nVertLevels + write(stderrUnit,*) k, temperature(k,iCell) + enddo + call mpas_dmpar_global_abort("An error has occurred in li_core_finalize. Aborting...") + endif + + if (mintemp < mintemp_threshold) then + write(stderrUnit,*) 'mintemp < mintemp_threshold: iCell, mintemp =', iCell, mintemp + write(stderrUnit,*) 'thickness =', thickness(iCell) + write(stderrUnit,*) 'temperature:' + do k = 1, nVertLevels + write(stderrUnit,*) k, temperature(k,iCell) + enddo + call mpas_dmpar_global_abort("An error has occurred in li_core_finalize. Aborting...") + endif + + enddo ! iCell + + ! clean up + if (allocated(subdiagonal)) deallocate(subdiagonal) + if (allocated(diagonal)) deallocate(diagonal) + if (allocated(superdiagonal)) deallocate(superdiagonal) + if (allocated(rhs)) deallocate(rhs) + if (allocated(alpha_enth)) deallocate(alpha_enth) + if (allocated(temp)) deallocate(temp) + if (allocated(enth)) deallocate(enth) + + end select + + block => block % next + enddo ! associated(block) + + ! halo updates + + call mpas_pool_get_field(thermalPool, 'surfaceTemperature', surfaceTemperatureField) + call mpas_dmpar_exch_halo_field(surfaceTemperatureField) + + call mpas_pool_get_field(thermalPool, 'basalTemperature', basalTemperatureField) + call mpas_dmpar_exch_halo_field(basalTemperatureField) + + !TODO - Halo updates for components of the tracer array +!! call mpas_pool_get_field(thermalPool, 'temperature', temperatureField) +!! call mpas_dmpar_exch_halo_field(temperatureField) + + if (trim(config_thermal_solver) == 'enthalpy') then +!! call mpas_pool_get_field(thermalPool, 'waterfrac', waterfracField) +!! call mpas_dmpar_exch_halo_field(waterfracField) + endif + + ! === error check + if (err > 0) then + write (stderrUnit,*) 'An error has occurred in li_thermal_solver' + endif + + + end subroutine li_thermal_solver + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| +! +! ! routine li_heat_dissipation_sia +! +!> \brief MPAS land ice heat dissipation for SIA velocity solver +!> \author William Lipscomb +!> \date October 2015 +!> \details +!> This routine computes heat dissipation in the ice interior for the +!> SIA velocity solver. +!----------------------------------------------------------------------- + + !TODO - Move this subroutine to another module? + subroutine li_heat_dissipation_sia(domain, err) + + ! Compute the dissipation source term associated with strain heating, + ! based on the shallow-ice approximation. + + !----------------------------------------------------------------- + ! input/output variables + !----------------------------------------------------------------- + type (domain_type), intent(inout) :: & + domain !< Input/Output: domain object + + !----------------------------------------------------------------- + ! output variables + !----------------------------------------------------------------- + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + + type (block_type), pointer :: block + + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: geometryPool + type (mpas_pool_type), pointer :: velocityPool + type (mpas_pool_type), pointer :: thermalPool + type (mpas_pool_type), pointer :: scratchPool + + integer, pointer :: & + nCells, & ! number of cells + nEdges, & ! number of edges + nVertLevels ! number of vertical layers + + integer, dimension(:), pointer :: & + nEdgesOnCell ! number of edges on each cell + + integer, dimension(:,:), pointer :: & + cellsOnEdge, & ! indices for 2 cells on each edge + edgesOnCell ! indices for edges on each cell + + real(kind=RKIND), dimension(:), pointer :: & + areaCell ! area of each cell + + real(kind=RKIND), dimension(:), pointer :: & + dcEdge, & ! distance between neighboring cells across edge + dvEdge ! distance between eighboring vertices along edge + + real(kind=RKIND), dimension(:), pointer :: & + layerCenterSigma ! vertical coordinate at center of each layer + + real(kind=RKIND), dimension(:), pointer :: & + thickness ! ice thickness in cells + + real(kind=RKIND), dimension(:), pointer :: & + slopeEdge ! surface slope at edges + + real(kind=RKIND), dimension(:,:), pointer :: & + flowParamA ! flow factor in each layer of each cell, Pa^(-n) s^(-1) + + real(kind=RKIND), dimension(:,:), pointer :: & + heatDissipation ! interior heat dissipation in each layer of each cell (deg/s) + ! output from this subroutine + + type (field2dReal), pointer :: heatDissipationEdgeField + + real (kind=RKIND), dimension(:,:), pointer :: & + heatDissipationEdge ! heat dissipation on edges + + real (kind=RKIND) :: & + thicknessEdge, & ! thickness averaged to edge + weightEdge ! edge weight for averaging to cell center + + real (kind=RKIND), dimension(:), allocatable :: & + flowParamAEdge ! flow parameter averaged to edge + + real (kind=RKIND), pointer :: n ! flow law exponent + + integer :: iCell, iCell1, iCell2, iEdge, iEdgeOnCell + + ! Here are notes from the Glimmer calculation of heat dissipation: + ! + ! "Two methods of doing this calculation: + ! 1. find dissipation at u-pts and then average + ! 2. find dissipation at H-pts by averaging quantities from u-pts + ! (2) works best for eismint divide (symmetry) but (1) may be better for full expts" + ! + ! Glimmer uses (2). + ! Here we use the C-grid variant of (1); we find the dissipation at edges and then average to cell centers. + ! The heating rate phi, defined on an edge, is given by + ! + ! phi = 2 * A(T) * (sigma * rhoi * g * H * |grad(s)|)^(n+1) + ! + ! where A(T) is the flow factor, sigma is the vertical coordinate of the layer, + ! H is the ice thickness averaged to the edge, and grad(s) is the surface elevation gradient. + ! + ! phi has units of W m^{-3}. + ! The heat dissipation in deg/s is given by phi / (rhoi * cp_ice). + + block => domain % blocklist + do while (associated(block)) + + ! get pools + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'geometry', geometryPool) + call mpas_pool_get_subpool(block % structs, 'velocity', velocityPool) + call mpas_pool_get_subpool(block % structs, 'thermal', thermalPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) + + ! get fields from the mesh pool + call mpas_pool_get_array(meshPool, 'nCells', nCells) + call mpas_pool_get_array(meshPool, 'nEdges', nEdges) + call mpas_pool_get_array(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) + call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + + ! get fields from the geometry pool + !TODO - Make sure slopeEdge is up to date. + call mpas_pool_get_array(geometryPool, 'thickness', thickness) + call mpas_pool_get_array(geometryPool, 'slopeEdge', slopeEdge) + + ! get fields from the velocity pool + call mpas_pool_get_array(geometryPool, 'flowParamA', flowParamA) + + ! get fields from the thermal pool + call mpas_pool_get_array(geometryPool, 'heatDissipation', heatDissipation) + + ! get scratch fields + call mpas_pool_get_field(scratchPool, 'workLevelEdge', heatDissipationEdgeField) + call mpas_allocate_scratch_field(heatDissipationEdgeField, .true.) + heatDissipationEdge => heatDissipationEdgeField % array + + ! get config parameters + call mpas_pool_get_config(liConfigs, 'config_flowLawExponent', n) + + allocate(flowParamAEdge(nVertLevels)) + + ! compute the heat dissipation on edges + + do iEdge = 1, nEdges + + ! identify the cells on this edge + iCell1 = cellsOnEdge(1,iEdge) + iCell2 = cellsOnEdge(2,iEdge) + + if (iCell1 >= 1 .and. iCell1 <= nCells .and. iCell2 >= 1 .and. iCell2 <= nCells) then ! both cells exist + + ! average the thickness and flow parameter to the edge + thicknessEdge = 0.5_RKIND * (thickness(iCell1) + thickness(iCell2)) + flowParamAEdge(:) = 0.5_RKIND * (flowParamA(:,iCell1) + flowParamA(:,iCell2)) + + ! compute the dissipation at each level + ! Note: n = config_flowLawExponent + !TODO - Verify that this equation gives the right answer + heatDissipationEdge(:,iEdge) = 2.0_RKIND * flowParamAEdge(:) * & + (layerCenterSigma(:) * rhoi * gravity * thicknessEdge * abs(slopeEdge)) ** (n+1.0_RKIND) + + else ! one neighbor cell does not exist + !TODO = Confirm that the dissipation is not needed at such edges + + heatDissipationEdge(:,iEdge) = 0.0_RKIND + + endif + + enddo ! iEdge + + + ! average the heat dissipation to cell centers + + do iCell = 1, nCells + + heatDissipation(:,iCell) = 0.0_RKIND + + do iEdgeOnCell = 1, nEdgesOnCell(iCell) + + iEdge = edgesOnCell(iEdgeOnCell,iCell) + + !TODO - Is this the preferred way of getting the edge weights? + weightEdge = 0.25_RKIND*dcEdge(iEdge)*dvEdge(iEdge) / areaCell(iCell) + + heatDissipation(:,iCell) = heatDissipation(:,iCell) + weightEdge * heatDissipationEdge(:,iEdge) + + enddo ! iEdgeOnCell + + enddo ! iCell + + ! convert units from W/m^3 to deg/s + !TODO - Confirm that deg/s are the desired units. Might want to go with W/m^3? + + heatDissipation(:,:) = heatDissipation(:,:) / (rhoi * cp_ice) + + enddo ! associated(block) + + end subroutine li_heat_dissipation_sia + + +!*********************************************************************** +!*********************************************************************** +! Private subroutines: +!*********************************************************************** +!*********************************************************************** + +!TODO - Add subroutine headers +! Clean up subroutines and code in MPAS style/ +! Change variable names to agree with the driver subroutine + + subroutine temperature_matrix_elements(dttem, & ! deltat + upn, stagsigma, & ! upn = nVertInterfaces; stagsigma = layerCenterSigma + subd, diag, & + supd, rhsd, & + dups, floating_mask, & + thck, temp, & + dissip, & + bheatflx, bfricflx) + + ! solve for tridiagonal entries of sparse matrix + + ! Note: Matrix elements (subd, supd, diag, rhsd) are indexed from 1 to upn+1, + ! whereas temperature is indexed from 0 to upn. + ! The first row of the matrix is the equation for temperature(0), + ! the last row is the equation for temperature(upn), and so on. + + real(kind=RKIND), intent(in) :: dttem ! time step (s) + integer, intent(in) :: upn ! number of layer interfaces + real(kind=RKIND), dimension(upn-1), intent(in) :: stagsigma ! sigma coordinate at temp nodes + real(kind=RKIND), dimension(:), intent(out) :: subd, diag, supd, rhsd + real(kind=RKIND), dimension(:,:), intent(in) :: dups ! vertical grid quantities + integer, intent(in) :: floating_mask + real(kind=RKIND), intent(in) :: thck ! ice thickness (m) + real(kind=RKIND), dimension(0:upn), intent(in) :: temp ! ice temperature (deg C) + real(kind=RKIND), dimension(upn-1), intent(in) :: dissip ! interior heat dissipation (deg/s) + real(kind=RKIND), intent(in) :: bheatflx ! geothermal flux (W m-2), positive down + real(kind=RKIND), intent(in) :: bfricflx ! basal friction heat flux (W m-2), >= 0 + + ! local variables + + real(kind=RKIND) :: pmptemp_bed ! pressure melting temp at bed + real(kind=RKIND) :: fact + real(kind=RKIND) :: dsigbot ! bottom layer thicknes in sigma coords + + ! Compute subdiagonal, diagonal, and superdiagonal matrix elements + + ! upper boundary: set to surface air temperature + + supd(1) = 0.0_RKIND + subd(1) = 0.0_RKIND + diag(1) = 1.0_RKIND + rhsd(1) = temp(0) + + ! ice interior, layers 1:upn-1 (matrix elements 2:upn) + + fact = dttem * iceConductivity / (rhoi*cp_ice) / thck**2 + subd(2:upn) = -fact * dups(1:upn-1,1) + supd(2:upn) = -fact * dups(1:upn-1,2) + diag(2:upn) = 1.0_RKIND - subd(2:upn) - supd(2:upn) + rhsd(2:upn) = temp(1:upn-1) + dissip(1:upn-1)*dttem + + ! basal boundary: + ! for grounded ice, a heat flux is applied + ! for floating ice, the basal temperature is held constant + + !Note: If T(upn) < T_pmp, then require dT/dsigma = H/k * (G + taub*ubas) + ! That is, net heat flux at lower boundary must equal zero. + ! If T(upn) >= Tpmp, then set T(upn) = Tpmp + + if (floating_mask == 1) then + + supd(upn+1) = 0.0_RKIND + subd(upn+1) = 0.0_RKIND + diag(upn+1) = 1.0_RKIND + rhsd(upn+1) = temp(upn) + + else ! grounded ice + + call pressure_melting_point(thck, pmptemp_bed) + + if (abs(temp(upn) - pmptemp_bed) < 0.001_RKIND) then + + ! hold basal temperature at pressure melting point + + supd(upn+1) = 0.0_RKIND + subd(upn+1) = 0.0_RKIND + diag(upn+1) = 1.0_RKIND + rhsd(upn+1) = pmptemp_bed + + else ! frozen at bed + ! maintain balance of heat sources and sinks + ! (conductive flux, geothermal flux, and basal friction) + + ! Note: bheatflx is generally <= 0, since defined as positive down. + + ! calculate dsigma for the bottom layer between the basal boundary and the temp. point above + dsigbot = 1.0_RKIND - stagsigma(upn-1) + + ! backward Euler flux basal boundary condition + subd(upn+1) = -1.0_RKIND + supd(upn+1) = 0.0_RKIND + diag(upn+1) = 1.0_RKIND + rhsd(upn+1) = (bfricflx - bheatflx) * dsigbot*thck / iceConductivity + + endif ! melting or frozen + + end if ! floating or grounded + + end subroutine temperature_matrix_elements + + + subroutine enthalpy_matrix_elements(dttem, & ! deltat + upn, stagsigma, & ! upn = nVertInterfaces; stagsigma = layerCenterSigma + subd, diag, & + supd, rhsd, & + dups, floating_mask, & + thck, & + temp, waterfrac, & + enthalpy, dissip, & + bheatflx, bfricflx, & + alpha_enth, & + verbose_column_in) + + ! solve for tridiagonal entries of sparse matrix + + ! Note: Matrix elements (subd, supd, diag, rhsd) are indexed from 1 to upn+1, + ! whereas temperature/enthalpy is indexed from 0 to upn. + ! The first row of the matrix is the equation for enthalpy(0), + ! the last row is the equation for enthalpy(upn), and so on. + + !I/O variables + real(kind=RKIND), intent(in) :: dttem ! time step (s) + integer, intent(in) :: upn ! number of vertical interfaces + real(kind=RKIND), dimension(upn-1), intent(in) :: stagsigma ! sigma coordinate at temp/enthalpy nodes + real(kind=RKIND), dimension(:,:), intent(in) :: dups ! vertical grid quantities + real(kind=RKIND), dimension(:), intent(out) :: subd, diag, supd, rhsd ! matrix elements + integer, intent(in) :: floating_mask + real(kind=RKIND), intent(in) :: thck ! ice thickness (m) + real(kind=RKIND), dimension(0:upn), intent(in) :: temp ! temperature (deg C) !TODO - Do units matter? K or C? + real(kind=RKIND), dimension(upn-1), intent(in) :: waterfrac ! water fraction (unitless) + real(kind=RKIND), dimension(0:upn), intent(in) :: enthalpy ! specific enthalpy (J/m^3) + real(kind=RKIND), dimension(upn-1), intent(in) :: dissip ! interior heat dissipation (deg/s) + real(kind=RKIND), intent(in) :: bheatflx ! geothermal flux (W m-2), positive down !TODO - Flip sign to positive up + real(kind=RKIND), intent(in) :: bfricflx ! basal friction heat flux (W m-2), >= 0 + real(kind=RKIND), dimension(:), intent(out) :: alpha_enth ! half-node diffusivity (m^2/s) for enthalpy + ! located halfway between temperature points + + logical, intent(in), optional :: verbose_column_in ! if true, print debug statements for this column + + ! local variables + real(kind=RKIND) :: dsigbot ! bottom layer thicknes in sigma coords. + real(kind=RKIND) :: alphai ! cold ice diffusivity + real(kind=RKIND) :: alpha0 ! temperate ice diffusivity + real(kind=RKIND) :: fact ! coefficient in tridiag matrix + real(kind=RKIND), dimension(1:upn-1) :: pmptemp ! pressure melting point temp in interior (deg C) + real(kind=RKIND) :: pmptemp_bed ! pressure melting point temp at bed (deg C) + real(kind=RKIND), dimension(0:upn) :: enth_T ! temperature part of specific enthalpy (J/m^3) + real(kind=RKIND) :: denth ! enthalpy difference between adjacent layers + real(kind=RKIND) :: denth_T ! difference in temperature component of enthalpy between adjacent layers + real(kind=RKIND) :: alpha_fact ! factor for averaging diffusivity, 0 <= fact <= 1 + logical :: verbose_column ! if true, print debug statements for this column + integer :: k + + logical, parameter :: & + alpha_harmonic_avg = .false. ! if true, take harmonic average of alpha in adjacent layers + ! if false, take arithmetic average + + if (present(verbose_column_in)) then + verbose_column = verbose_column_in + else + verbose_column = .false. + endif + + ! define diffusivities alpha_i and alpha_0 + !! alphai = coni / rhoi / cp_ice + alphai = iceConductivity / rhoi / cp_ice + alpha0 = alphai / 100.0_RKIND + + ! find pmptemp for this column (interior nodes and boundary) + call pressure_melting_point_column(stagsigma(1:upn-1), thck, pmptemp(1:upn-1)) + call pressure_melting_point(thck, pmptemp_bed) + + !WHL - debug + if (verbose_column) then + print*, ' ' + print*, 'Computing enthalpy matrix elements' + print*, 'k, temp, wfrac, enthalpy/(rhoi*ci), pmpt:' + k = 0 + print*, k, temp(k), 0.0_RKIND, enthalpy(k)/(rhoi*cp_ice) + do k = 1, upn-1 + print*, k, temp(k), waterfrac(k), & + enthalpy(k)/(rhoi*cp_ice), pmptemp(k) + enddo + k = upn + print*, k, temp(k), 0.0_RKIND, enthalpy(k)/(rhoi*cp_ice), pmptemp_bed + endif + + !-------------------------------------------------------------------- + !WHL - Commenting out the following and replacing it with a new way of computing alpha. + ! The commented-out code can result in sudden large changes in alpha that + ! lead to oscillations in the thickness, temperature and velocity fields. + ! These oscillations have a period of ~1 yr or more, spatial scale of + ! many grid cells, and amplitude of ~10 m in thickness, 1 deg in temperature, + ! and 2 m/s in velocity. + + ! create a column vector of size (0:upn) of diffusivity based on + ! previous timestep's temp. Boundary nodes need a value so half-node + ! diffusivity can be calculated at interior nodes (1:upn-1) + +! do k = 0,upn +! if (temp(k) < pmptemp(k)) then +! alpha(k) = alphai +! else +! alpha(k) = alpha0 +! endif +! end do + + ! Find half-node diffusivity using harmonic average between nodes. + ! The vector will be size (1:upn) - the first value is the half-node + ! between nodes 0 and 1, the last value is the half-node between + ! nodes upn-1 and upn. + +! do k = 1,upn +! alpha_enth(k) = 2.0_RKIND / ((1.0_RKIND/alpha(k-1)) + (1.0_RKIND/alpha(k))) +! end do + + ! end of commented-out method + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + !WHL - Trying a different approach to the diffusivity at layer interfaces. + ! Let d(enth)/dz = the gradient of enthalpy + ! Can write + ! d(enth)/dz = d(enth_T)/dz + d(enth_w)/dz, + ! where + ! enth_T = (1-phi_w) * rhoi*ci*T + ! enth_w = phi_w * rhoo*(L + ci*Tpmp) + ! + ! Now let f = d(enth_T)/z / d(enth)/dz + ! (f -> 0 if f is computed to be negative) + ! For cold ice, f = 1 and alpha = alphai + ! For temperate ice, f ~ 0 and alpha = alpha0 + ! At the interface between cold and temperate ice, + ! f ~ 0 if the temperate ice has large phi_w, but + ! f ~ 1 if the temperate ice has close to zero phi_w. + ! Two ways to average: + ! (1) arithmetic average: alpha = f*alphai + (1-f)*alpha0 + ! (2) harmonic average: alpha = 1 / (f/alphai + (1-f)/alpha0). + ! Both methods have the same asymptotic values at f = 0 or 1, + ! but the arithmetic average gives greater diffusivity for + ! intermediate values. + ! + ! Still to be determined which is more accurate. + ! The harmonic average allows large temperature gradients between the + ! bottom layer and the next layer up; the arithmetic average gives + ! smoother gradients. + !-------------------------------------------------------------------- + ! + ! At each temperature point, compute the temperature part of the enthalpy. + ! enth_T = enth for cold ice, enth_T < enth for temperate ice + + do k = 0, upn + enth_T(k) = (1.0_RKIND - waterfrac(k)) * rhoi*cp_ice*temp(k) + enddo + + !WHL - debug + if (verbose_column) then + print*, ' ' + print*, 'k, denth_T/(rhoi*cp_ice), denth/(rhoi*cp_ice), alpha_fact, alpha_enth(up):' + endif + + ! Compute factors relating the temperature gradient to the total enthalpy gradient. + ! Use these factors to average the diffusivity between adjacent temperature points. + do k = 1,upn + denth = enthalpy(k) - enthalpy(k-1) + denth_T = enth_T(k) - enth_T(k-1) ! = denth in cold ice, < denth in temperate ice + if (abs(denth) > 1.e-20_RKIND * rhoo*latent_heat_ice) then + alpha_fact = max(0.0_RKIND, denth_T/denth) + alpha_fact = min(1.0_RKIND, alpha_fact) + else + alpha_fact = 0.0_RKIND + endif + + if (alpha_harmonic_avg) then ! take a harmonic average + ! This gives slower cooling of temperate layers and allows + ! large temperature gradients between cold and temperate layers + alpha_enth(k) = 1.0_RKIND / ((alpha_fact/alphai) + (1.0_RKIND-alpha_fact)/alpha0) + else ! take an arithmetic average + ! This gives faster cooling of temperate layers and smaller gradients + alpha_enth(k) = alpha_fact*alphai + (1.0_RKIND-alpha_fact)*alpha0 + endif + + !WHL - debug + if (verbose_column) then + print*, k, denth_T/(rhoi*cp_ice), denth/(rhoi*cp_ice), alpha_fact, alpha_enth(k) + endif + + end do + + ! Compute subdiagonal, diagonal, and superdiagonal matrix elements + ! Assume backward Euler time stepping + + ! upper boundary: set to surface air temperature + supd(1) = 0.0_RKIND + subd(1) = 0.0_RKIND + diag(1) = 1.0_RKIND + rhsd(1) = min(0.0_RKIND,temp(0)) * rhoi*cp_ice + + ! ice interior, layers 1:upn-1 (matrix elements 2:upn) + + fact = dttem / thck**2 + + subd(2:upn) = -fact * alpha_enth(1:upn-1) * dups(1:upn-1,1) + supd(2:upn) = -fact * alpha_enth(2:upn) * dups(1:upn-1,2) + diag(2:upn) = 1.0_RKIND - subd(2:upn) - supd(2:upn) + rhsd(2:upn) = enthalpy(1:upn-1) + dissip(1:upn-1)*dttem * rhoi * cp_ice + + ! BDM I'm assuming that dissip has units of phi/rhoi/cp_ice. + ! For an enthalpy calc, we want just phi, hence dissip * rhoi * cp_ice + + ! basal boundary: + ! for grounded ice, a heat flux is applied + ! for floating ice, the basal temperature is held constant + + !NOTE: This lower BC is different from the one in glide_temp. + ! If T(upn) < T_pmp, then require dT/dsigma = H/k * (G + taub*ubas) + ! That is, net heat flux at lower boundary must equal zero. + ! If T(upn) >= Tpmp, then set T(upn) = Tpmp + + if (floating_mask == 1) then + + supd(upn+1) = 0.0_RKIND + subd(upn+1) = 0.0_RKIND + diag(upn+1) = 1.0_RKIND + rhsd(upn+1) = enthalpy(upn) + + else ! grounded ice + + !WHL - debug + if (verbose_column) then + k = upn-1 + print*, 'temp(upn-1), pmptemp(upn-1):', temp(k), pmptemp(k) + k = upn + print*, 'temp(upn), pmptemp(upn):', temp(k), pmptemp_bed + endif + + ! Positive-Thickness Basal Temperate Boundary Layer + + !WHL - Not sure whether this condition is ideal. + ! It implies that the enthalpy at the bed (upn) = enthalpy in layer (upn-1). + if (abs(temp(upn-1) - pmptemp(upn-1)) < 0.001_RKIND) then + + subd(upn+1) = -1.0_RKIND + supd(upn+1) = 0.0_RKIND + diag(upn+1) = 1.0_RKIND + rhsd(upn+1) = 0.0_RKIND + + !WHL - debug + if (verbose_column) then + print*, 'basal BC: branch 1 (finite-thck BL)' + endif + + !Zero-Thickness Basal Temperate Boundary Layer + elseif (abs(temp(upn) - pmptemp_bed) < 0.001_RKIND) then ! melting + + ! hold basal temperature at pressure melting point + supd(upn+1) = 0.0_RKIND + subd(upn+1) = 0.0_RKIND + diag(upn+1) = 1.0_RKIND + rhsd(upn+1) = pmptemp_bed * rhoi * cp_ice + + !WHL - debug + if (verbose_column) then + print*, 'basal BC: branch 2 (zero-thck BL)' + endif + + else + + !WHL - debug + if (verbose_column) then + print*, 'basal BC: branch 3 (cold ice)' + endif + + ! frozen at bed + ! maintain balance of heat sources and sinks + ! (conductive flux, geothermal flux, and basal friction) + + ! Note: The heat source due to basal sliding (bfricflx) is computed in subroutine calcbfric. + ! Also note that bheatflx is generally <= 0, since defined as positive down. + + ! calculate dsigma for the bottom layer between the basal boundary and the temp. point above + dsigbot = (1.0_RKIND - stagsigma(upn-1)) + + ! =====Backward Euler flux basal boundary condition===== + ! MJH: If Crank-Nicolson is desired for the b.c., it is necessary to + ! ensure that the i.c. temperature for the boundary satisfies the + ! b.c. - otherwise oscillations will occur because the C-N b.c. only + ! specifies the basal flux averaged over two consecutive time steps. + subd(upn+1) = -1.0_RKIND + supd(upn+1) = 0.0_RKIND + diag(upn+1) = 1.0_RKIND + rhsd(upn+1) = (bfricflx - bheatflx) * dsigbot*thck * rhoi*cp_ice/iceConductivity + ! BDM temp approach should work out to be dT/dsigma, so enthalpy approach + ! should just need dT/dsigma * rhoi * cp_ice for correct units + + endif ! melting or frozen + + end if ! floating or grounded + + end subroutine enthalpy_matrix_elements + + subroutine basal_melting(& + config_thermal_solver, & + dttem, & + nCellsSolve, & + upn, & + sigma, stagsigma, & + ice_mask, floating_mask, & + thck, & + temp, basalTemp, & + waterfrac, enthalpy, & + bfricflx, bheatflx, & + lcondflx, & + bwat, bmlt) + + ! Compute the rate of basal melting. + ! The basal melting computed here is applied to the ice thickness + ! by glissade_transport_driver, conserving mass and energy. + ! + ! For the standard prognostic temperature scheme, any internal temperatures + ! above the pressure melting point are reset to Tpmp. Excess energy + ! is applied toward melting with immediate drainage to the bed. + ! For the enthalpy scheme, any meltwater in excess of the maximum allowed + ! meltwater fraction (0.01 by default) is drained to the bed. + ! + !TODO - Deal with basal melting for floating ice + + !----------------------------------------------------------------- + ! Input/output arguments + !----------------------------------------------------------------- + + character(len=StrKIND), intent(in) :: & + config_thermal_solver ! thermal solver option (temperature or enthalpy) + + real(kind=RKIND), intent(in) :: dttem ! time step (s) + integer, intent(in) :: nCellsSolve ! number of locally owned cells + integer, intent(in) :: upn ! number of vertical interfaces + !TODO - change to nVertInterfaces + real(kind=RKIND), dimension(upn), intent(in) :: sigma ! vertical sigma coordinate + real(kind=RKIND), dimension(upn-1), intent(in) :: stagsigma ! staggered vertical coordinate for temperature + +!! real(kind=RKIND), dimension(0:,:,:), intent(inout) :: temp ! temperature (deg C) + real(kind=RKIND), dimension(:,:), intent(inout) :: temp ! temperature (deg C) in each layer + real(kind=RKIND), dimension(:), intent(inout) :: basalTemp ! basal temperature (deg C) + + real(kind=RKIND), dimension(:,:), intent(inout) :: waterfrac ! water fraction + + real(kind=RKIND), dimension(:,:), intent(in) :: enthalpy ! enthalpy +!! real(kind=RKIND), dimension(:), intent(in) :: basalEnthalpy ! basal enthalpy + + real(kind=RKIND), dimension(:), intent(in) :: & + thck, & ! ice thickness (m) + bfricflx, & ! basal frictional heating flux (W m-2), >= 0 + bheatflx, & ! geothermal heating flux (W m-2), positive down !TODO - Switch sign convention + lcondflx, & ! heat conducted from ice interior to bed (W m-2), positive down + bwat ! depth of basal water (m) + + integer, dimension(:), intent(in) :: & + ice_mask, &! = 1 where ice exists (thickness > config_thermal_thickness), else = 0 + floating_mask ! = 1 where ice is floating, else = 0 + + !TODO - Fix sign of bmlt before passing out + real(kind=RKIND), dimension(:), intent(out):: bmlt ! melt rate (m/s) + ! > 0 for melting, < 0 for freeze-on + + !----------------------------------------------------------------- + ! Local variables + !----------------------------------------------------------------- + + integer :: k, iCell + real(kind=RKIND), dimension(upn-1) :: pmptemp ! pressure melting point temp in ice interior + real(kind=RKIND) :: pmptemp_bed ! pressure melting point temp at bed + real(kind=RKIND) :: bflx ! heat flux available for basal melting (W/m^2) + real(kind=RKIND) :: layer_thck ! layer thickness (m) + real(kind=RKIND) :: melt_energy ! energy available for internal melting (J/m^2) + real(kind=RKIND) :: internal_melt_rate ! internal melt rate, transferred to bed (m/s) + real(kind=RKIND) :: melt_fact ! factor for bmlt calculation + real(kind=RKIND) :: hmlt ! melt thickness associated with excess meltwater + + real(kind=RKIND), parameter :: & + max_waterfrac = 0.01_RKIND ! maximum allowed water fraction; excess drains to bed + + real(kind=RKIND), parameter :: & + eps11 = 1.0e-11_RKIND ! small number + + bmlt(:) = 0.0_RKIND + melt_fact = 1.0_RKIND / (latent_heat_ice * rhoi) + + do iCell = 1, nCellsSolve + + if (ice_mask(iCell) == 1 .and. floating_mask(iCell) == 0) then ! ice is present and grounded + + !TODO - Switch sign conventions for bmlt and bheatflux + ! Compute basal melting + ! Note: bmlt > 0 for melting, < 0 for freeze-on + ! bfricflx >= 0 by definition + ! bheatflx is positive down, so usually bheatflx < 0 (with negative values contributing to melt) + ! lcondflx is positive down, so lcondflx < 0 for heat is flowing from the bed toward the surface + ! + ! This equation allows for freeze-on (bmlt < 0) if the conductive term + ! (lcondflx, positive down) is carrying enough heat away from the boundary. + ! But freeze-on requires a local water supply, bwat > 0. + ! When bwat = 0, we reset the bed temperature to a value slightly below the melting point. + ! + !TODO - For the enthalpy scheme, deal with the rare case that the bottom layer melts completely + ! and overlying layers with a different enthalpy also melt. + + bflx = bfricflx(iCell) + lcondflx(iCell) - bheatflx(iCell) ! W/m^2 + + if (abs(bflx) < eps11) then ! bflx might be slightly different from zero because of rounding errors; if so, then zero out + bflx = 0.0_RKIND + endif + + if (trim(config_thermal_solver) == 'enthalpy') then +!! bmlt(ew,ns) = bflx / (lhci*rhoi - enthalpy(upn,ew,ns)) + !Note: basalEnthalpy = rhoi*cp_ice*basalTemp + bmlt(iCell) = bflx / (latent_heat_ice*rhoi - rhoi*cp_ice*basalTemp(iCell)) + else ! temperature solver + bmlt(iCell) = bflx * melt_fact ! m/s (melt_fact = 1/(rhoi*latent_heat_ice) + endif + + ! Add internal melting + + if (trim(config_thermal_solver) == 'enthalpy') then + + ! Add internal melting associated with waterfrac > max_waterfrac (1%) + + !TODO - Any correction for rhoi/rhow here? Or melting ice that is already partly melted? + do k = 1, upn-1 + if (waterfrac(k,iCell) > max_waterfrac) then + ! compute melt rate associated with excess water + hmlt = (waterfrac(k,iCell) - max_waterfrac) * thck(iCell) * (sigma(k+1) - sigma(k)) ! m + internal_melt_rate = hmlt / dttem ! m/s + ! transfer meltwater to the bed + bmlt(iCell) = bmlt(iCell) + internal_melt_rate ! m/s + ! reset waterfrac to max value + waterfrac(k,iCell) = max_waterfrac + endif + enddo + + else ! temperature solver + + ! Add internal melting associated with T > Tpmp + + call pressure_melting_point_column(& + stagsigma, & + thck(iCell), & + pmptemp) + + do k = 1, upn-1 + if (temp(k,iCell) > pmptemp(k)) then + ! compute excess energy available for melting + layer_thck = thck(iCell) * (sigma(k+1) - sigma(k)) ! m + melt_energy = rhoi * cp_ice * (temp(k,iCell) - pmptemp(k)) * layer_thck ! J/m^2 + internal_melt_rate = melt_energy / (rhoi * latent_heat_ice * dttem) ! m/s + ! transfer internal melting to the bed + bmlt(iCell) = bmlt(iCell) + internal_melt_rate ! m/s + ! reset T to Tpmp + temp(k,iCell) = pmptemp(k) + endif + enddo + + endif ! config_thermal_solver + + ! Cap basal temp at pressure melting point, if necessary + + call pressure_melting_point(& + thck(iCell), & + pmptemp_bed) + + temp(upn,iCell) = min (temp(upn,iCell), pmptemp_bed) + + ! If freeze-on was computed above (bmlt < 0) and Tbed = Tpmp but no basal water is present, then set T(upn) < Tpmp. + ! Note: In the matrix element subroutines, we solve for Tbed (instead of holding it at Tpmp) when Tbed < -0.001. + ! With an offset here of 0.01, we will solve for T_bed at the next timestep. + ! Note: I don't think energy conservation is violated here, because no energy is associated with + ! the infinitesimally thin layer at the bed. + + if (bmlt(iCell) < 0.0_RKIND .and. bwat(iCell) == 0.0_RKIND .and. temp(upn,iCell) >= pmptemp_bed) then + temp(upn,iCell) = pmptemp_bed - 0.01_RKIND + endif + + endif ! ice is present and grounded + + enddo ! iCell + + end subroutine basal_melting + + + subroutine temperature_to_enthalpy(& + layerCenterSigma, & + thickness, & + temperature, & + waterfrac, & + enthalpy) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(in) :: & + layerCenterSigma !< Input: sigma coordinate at midpoint of each layer + + real (kind=RKIND), intent(in) :: & + thickness !< Input: ice thickness + + real (kind=RKIND), dimension(:), intent(in) :: & + temperature, & !< Input: interior ice temperature + waterfrac !< Input: interior water fraction + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(out) :: & + enthalpy !< Output: interior ice enthalpy + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(size(layerCenterSigma)) :: pmpTemperature + + integer :: k, nVertLevels + + nVertLevels = size(layerCenterSigma) + + ! Find pressure melting point temperature in column + + call pressure_melting_point_column(& + layerCenterSigma, & + thickness, & + pmpTemperature) + + ! Solve for enthalpy + + do k = 1, nVertLevels + enthalpy(k) = (1.0_RKIND - waterfrac(k)) * rhoi * cp_ice * temperature(k) & + + waterfrac(k) * rhoo * (cp_ice * pmpTemperature(k) + latent_heat_ice) + end do + + end subroutine temperature_to_enthalpy + + + subroutine enthalpy_to_temperature(& + layerCenterSigma, & + thickness, & + enthalpy, & + temperature, & + waterfrac) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(in) :: & + layerCenterSigma !< Input: sigma coordinate at midpoint of each layer + + real (kind=RKIND), intent(in) :: & + thickness !< Input: ice thickness + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(0:), intent(inout) :: & + enthalpy !< Input/output: interior ice enthalpy + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(0:), intent(out) :: & + temperature !< Output: interior ice temperature + + real (kind=RKIND), dimension(:), intent(out) :: & + waterfrac !< Output: interior water fraction + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(size(layerCenterSigma)) :: pmpTemperature + real (kind=RKIND) :: pmpTemperatureBed + real (kind=RKIND), dimension(0:size(layerCenterSigma)+1) :: pmpEnthalpy + + integer :: k, nVertLevels + + nVertLevels = size(layerCenterSigma) + + ! Commented-out code below is from CISM +! real(dp), dimension(size(stagsigma)) :: pmptemp ! (1:upn-1) +! real(dp) :: pmptemp_bed +! real(dp), dimension(0:size(stagsigma)+1) :: pmpenthalpy ! (0:upn) +! integer :: up, upn + +! upn = size(stagsigma) + 1 + + ! Find pressure melting point temperature in ice interior + call pressure_melting_point_column(& + layerCenterSigma, & + thickness, & + pmpTemperature) + + ! find pressure melting point temperature at bed + call pressure_melting_point(& + thickness, & + pmpTemperatureBed) + +! upn = size(stagsigma) + 1 + + ! find pressure melting point enthalpy in the column + pmpEnthalpy(0) = 0.0_RKIND + pmpEnthalpy(1:nVertLevels) = pmpTemperature(1:nVertLevels) * rhoi*cp_ice + pmpEnthalpy(nVertLevels+1) = pmpTemperatureBed * rhoi*cp_ice + +! call glissade_pressure_melting_point_column(thck, stagsigma(1:upn-1), pmptemp(1:upn-1)) +! call glissade_pressure_melting_point(thck, pmptemp_bed) +! pmpenthalpy(0) = 0.d0 +! pmpenthalpy(1:upn-1) = pmptemp(1:upn-1) * rhoi*shci +! pmpenthalpy(upn) = pmptemp_bed * rhoi*shci + + ! solve for temperature and waterfrac + + ! upper surface + if (enthalpy(0) >= pmpEnthalpy(0)) then ! temperature ice + temperature(0) = 0.0_RKIND + ! Reset enthalpy to be consistent with the surface temperature. + ! This is consistent with energy conservation because the top surface + ! is infinitesimally thin. + enthalpy(0) = pmpEnthalpy(0) + else ! cold ice + temperature(0) = enthalpy(0) / (rhoi*cp_ice) + endif + +! if (enthalpy(0) >= pmpenthalpy(0)) then ! temperate ice +! temp(0) = 0.d0 ! temperate ice + ! Reset enthalpy to be consistent with the surface temperature. + ! This is consistent with energy conservation because the top surface + ! is infinitesimally thin. +! enthalpy(0) = pmpenthalpy(0) +! else +! temp(0) = enthalpy(0) / (rhoi*shci) ! cold ice +! endif + + ! interior + do k = 1, nVertLevels + if (enthalpy(k) >= pmpEnthalpy(k)) then ! temperate ice + temperature(k) = pmpTemperature(k) + waterfrac(k) = (enthalpy(k) - pmpenthalpy(k)) / & + ((rhoo-rhoi)*cp_ice*pmpTemperature(k) + rhoo*latent_heat_ice) + else ! cold ice + temperature(k) = enthalpy(k) / (rhoi*cp_ice) + waterfrac(k) = 0.0_RKIND + endif + enddo ! k + +! do up = 1, upn-1 +! if (enthalpy(up) >= pmpenthalpy(up)) then ! temperate ice +! temp(up) = pmptemp(up) +! waterfrac(up) = (enthalpy(up)-pmpenthalpy(up)) / & +! ((rhow-rhoi) * shci * pmptemp(up) + rhow * lhci) +! else ! cold ice +! temp(up) = enthalpy(up) / (rhoi*shci) +! waterfrac(up) = 0.0d0 +! endif +! end do + + ! bed + k = nVertLevels + 1 + if (enthalpy(k) >= pmpEnthalpy(k)) then ! temperature ice + temperature(k) = 0.0_RKIND + ! Reset enthalpy to be consistent with the surface temperature. + ! This is consistent with energy conservation because the top surface + ! is infinitesimally thin. + enthalpy(k) = pmpEnthalpy(k) + else ! cold ice + temperature(k) = enthalpy(k) / (rhoi*cp_ice) + endif + +! if (enthalpy(upn) >= pmpenthalpy(upn)) then ! temperate ice +! temp(upn) = pmptemp_bed + ! Reset enthalpy to be consistent with the bed temperature. + ! This is consistent with energy conservation because the basal surface + ! is infinitesimally thin. +! enthalpy(upn) = pmpenthalpy(upn) +! else +! temp(upn) = enthalpy(upn) / (rhoi*shci) ! cold ice +! endif + + end subroutine enthalpy_to_temperature + + + subroutine pressure_melting_point_column(& + layerCenterSigma, & + thickness, & + pmpTemperature) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(in) :: & + layerCenterSigma !< Input: sigma coordinate at midpoint of each layer + + real (kind=RKIND), intent(in) :: & + thickness !< Input: ice thickness + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), dimension(:), intent(out) :: & + pmpTemperature !< Output: pressure melting point temperature + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + pmpTemperature(:) = - iceMeltingPointPressureDependence * rhoi * gravity * thickness * layerCenterSigma(:) + + end subroutine pressure_melting_point_column + + + subroutine pressure_melting_point(& + depth, & + pmpTemperature) + + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), intent(in) :: & + depth !< Input: depth in column + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), intent(out) :: & + pmpTemperature !< Output: pressure melting point temperature + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + pmpTemperature = - iceMeltingPointPressureDependence * rhoi * gravity * depth + + end subroutine pressure_melting_point + + + !TODO - Move the tridiag solver to a utility module? + subroutine tridiag_solver(a,b,c,x,y) + + real(kind=RKIND), dimension(:), intent(in) :: a !< Input: Lower diagonal; a(1) is ignored + real(kind=RKIND), dimension(:), intent(in) :: b !< Input: Main diagonal + real(kind=RKIND), dimension(:), intent(in) :: c !< Input: Upper diagonal; c(n) is ignored + real(kind=RKIND), dimension(:), intent(in) :: y !< Input: Right-hand side + real(kind=RKIND), dimension(:), intent(out) :: x !< Output: Unknown vector + + real(kind=RKIND),dimension(size(a)) :: aa + real(kind=RKIND),dimension(size(a)) :: bb + + integer :: n,i + + n = size(a) + + aa(1) = c(1)/b(1) + bb(1) = y(1)/b(1) + + do i = 2,n + aa(i) = c(i)/(b(i)-a(i)*aa(i-1)) + bb(i) = (y(i)-a(i)*bb(i-1)) / (b(i)-a(i)*aa(i-1)) + end do + + x(n) = bb(n) + + do i = n-1,1,-1 + x(i) = bb(i) - aa(i)*x(i+1) + end do + + end subroutine tridiag_solver + + !*********************************************************************** + + end module li_thermal + +!||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| + + + diff --git a/src/core_landice/mode_forward/mpas_li_time_integration_fe.F b/src/core_landice/mode_forward/mpas_li_time_integration_fe.F index 3a2082e7fc..c18e874afa 100644 --- a/src/core_landice/mode_forward/mpas_li_time_integration_fe.F +++ b/src/core_landice/mode_forward/mpas_li_time_integration_fe.F @@ -30,6 +30,7 @@ module li_time_integration_fe use li_velocity, only: li_velocity_solve use li_tendency use li_calving, only: li_calve_ice, li_restore_calving_front + use li_thermal, only: li_thermal_solver use li_diagnostic_vars use li_setup @@ -108,7 +109,10 @@ subroutine li_time_integrator_forwardeuler(domain, deltat, err) !!! procVertexMaskChanged = 0 ! === Implicit column physics (vertical temperature diffusion) =========== - !call () + call mpas_timer_start("calculate vertical therm") + call li_thermal_solver(domain, deltat, err_tmp) + err = ior(err, err_tmp) + call mpas_timer_stop("calculate vertical therm") ! === Calculate Tendencies ======================== call mpas_timer_start("calculate tendencies") diff --git a/src/core_landice/shared/mpas_li_constants.F b/src/core_landice/shared/mpas_li_constants.F index 7acf86aa61..04916622c7 100644 --- a/src/core_landice/shared/mpas_li_constants.F +++ b/src/core_landice/shared/mpas_li_constants.F @@ -36,13 +36,23 @@ module li_constants save ! physical constants - real (kind=RKIND), parameter, public :: cp_ice = 2009.0_RKIND !< heat capacity of ice (J/kg/K) - real (kind=RKIND), parameter, public :: latent_heat_ice = 335.0d3 !< Latent heat of melting of ice (J/kg) + real (kind=RKIND), parameter, public :: cp_ice = 2009.0_RKIND !< heat capacity of ice (J/kg/K) + real (kind=RKIND), parameter, public :: latent_heat_ice = 335.0d3 !< Latent heat of melting of ice (J/kg) real (kind=RKIND), parameter, public :: triple_point = 273.16_RKIND !< Triple point of water (K) #endif real (kind=RKIND), parameter, public :: idealGasConstant = 8.314_RKIND !< ideal gas constant (J mol^-1 K^-1) + real (kind=RKIND), parameter, public :: iceConductivity = 2.1_RKIND !< thermal conductivity of ice (W m^-1 K^-1) + + real (kind=RKIND), parameter, public :: & + oceanFreezingTempSurface = -1.92_RKIND, & !< Freezing temperature of seawater (deg C) at surface pressure, given S = 35 PSU + oceanFreezingTempDepthDependence = -7.53e-4_RKIND !< Rate of change of freezing temperature of seawater with depth (deg m^-1), given S = 35 PSU + !< These values are from the Ocean Water Freezing Point Calculator, + !< http://www.csgnetwork.com/h2ofreezecalc.html (25 Nov. 2014) + + real (kind=RKIND), parameter, public :: & + iceMeltingPointPressureDependence = 9.7456e-8_RKIND ! Dependence of ice melting point on pressure (K Pa^-1) ! conversion factors real (kind=RKIND), parameter, public :: kelvin_to_celsius = 273.15_RKIND !< factor to convert Kelvin to Celsius From 3fe6fd3725a9bc9b9b7991ff981c7b91b979cda5 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Fri, 30 Oct 2015 09:00:45 -0600 Subject: [PATCH 0394/1724] Add missing package to bulk forcing fields This commit adds a missing package to one of the fields used in bulk forcing. Previously if the bulk thickness flux namelist option was turned on but the active tracers bulk surface forcing was disabled, the model would die with a segfault. This allows thickness fluxes without tracer fluxes, and vice versa. --- src/core_ocean/Registry.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 086687a1c1..087dcac442 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -2445,7 +2445,7 @@ /> Date: Thu, 29 Oct 2015 15:28:09 -0600 Subject: [PATCH 0395/1724] Adding OpenMP support to the ocean core This commit adds OpenMP support on element loops to the ocean core. All do loops use the runtime schedule which can be controlled via the OMP_SCHEDULE environment variable at run time. --- src/core_ocean/Registry.xml | 201 +++++++-------- .../mode_analysis/mpas_ocn_analysis_mode.F | 1 - .../mode_forward/mpas_ocn_forward_mode.F | 18 +- .../mpas_ocn_time_integration_rk4.F | 199 +++++++++++---- .../mpas_ocn_time_integration_split.F | 210 +++++++++++++--- .../mode_init/Registry_global_ocean.xml | 2 +- .../mode_init/mpas_ocn_init_global_ocean.F | 7 +- src/core_ocean/shared/Makefile | 7 +- src/core_ocean/shared/mpas_ocn_diagnostics.F | 198 +++++++++++++-- .../shared/mpas_ocn_diagnostics_routines.F | 6 +- .../mpas_ocn_effective_density_in_land_ice.F | 5 + .../shared/mpas_ocn_equation_of_state.F | 5 +- .../shared/mpas_ocn_equation_of_state_jm.F | 140 ++++++++--- .../mpas_ocn_equation_of_state_linear.F | 10 + .../shared/mpas_ocn_frazil_forcing.F | 235 +++++++++--------- src/core_ocean/shared/mpas_ocn_gm.F | 130 +++++++--- .../mpas_ocn_high_freq_thickness_hmix_del2.F | 2 + .../shared/mpas_ocn_init_routines.F | 20 +- src/core_ocean/shared/mpas_ocn_sea_ice.F | 3 + .../shared/mpas_ocn_surface_bulk_forcing.F | 9 +- .../shared/mpas_ocn_surface_land_ice_fluxes.F | 21 +- src/core_ocean/shared/mpas_ocn_tendency.F | 73 ++++-- src/core_ocean/shared/mpas_ocn_test.F | 10 +- src/core_ocean/shared/mpas_ocn_thick_ale.F | 8 +- src/core_ocean/shared/mpas_ocn_thick_hadv.F | 2 + .../shared/mpas_ocn_thick_surface_flux.F | 2 + src/core_ocean/shared/mpas_ocn_thick_vadv.F | 2 + src/core_ocean/shared/mpas_ocn_time_average.F | 215 ---------------- .../shared/mpas_ocn_time_average_coupled.F | 40 +-- src/core_ocean/shared/mpas_ocn_tracer_TTD.F | 2 + .../shared/mpas_ocn_tracer_advection_mono.F | 59 +++-- .../shared/mpas_ocn_tracer_advection_std.F | 14 ++ .../mpas_ocn_tracer_exponential_decay.F | 2 + src/core_ocean/shared/mpas_ocn_tracer_hmix.F | 2 +- .../shared/mpas_ocn_tracer_hmix_del2.F | 3 + .../shared/mpas_ocn_tracer_hmix_del4.F | 28 ++- .../shared/mpas_ocn_tracer_hmix_redi.F | 28 +++ .../shared/mpas_ocn_tracer_ideal_age.F | 12 +- .../mpas_ocn_tracer_interior_restoring.F | 2 + .../shared/mpas_ocn_tracer_nonlocalflux.F | 2 + ..._ocn_tracer_short_wave_absorption_jerlov.F | 4 + .../mpas_ocn_tracer_surface_flux_to_tend.F | 2 + .../mpas_ocn_tracer_surface_restoring.F | 3 + src/core_ocean/shared/mpas_ocn_vel_coriolis.F | 2 + .../shared/mpas_ocn_vel_forcing_rayleigh.F | 3 +- .../mpas_ocn_vel_forcing_surface_stress.F | 3 +- src/core_ocean/shared/mpas_ocn_vel_hmix.F | 20 +- .../shared/mpas_ocn_vel_hmix_del2.F | 9 + .../shared/mpas_ocn_vel_hmix_del4.F | 48 +++- .../shared/mpas_ocn_vel_hmix_leith.F | 2 + .../shared/mpas_ocn_vel_pressure_grad.F | 10 + src/core_ocean/shared/mpas_ocn_vel_vadv.F | 4 + src/core_ocean/shared/mpas_ocn_vmix.F | 21 +- .../shared/mpas_ocn_vmix_coefs_const.F | 4 + .../shared/mpas_ocn_vmix_coefs_redi.F | 2 + .../shared/mpas_ocn_vmix_coefs_rich.F | 81 ++++-- .../shared/mpas_ocn_vmix_coefs_tanh.F | 4 + src/core_ocean/shared/mpas_ocn_vmix_cvmix.F | 11 +- 58 files changed, 1373 insertions(+), 795 deletions(-) delete mode 100644 src/core_ocean/shared/mpas_ocn_time_average.F diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 086687a1c1..3ebe46b5ea 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -5,9 +5,15 @@ + + @@ -20,6 +26,9 @@ + @@ -1336,39 +1345,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2271,80 +2242,6 @@ /> - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -2835,6 +2807,7 @@ + + + diff --git a/src/core_ocean/mode_analysis/mpas_ocn_analysis_mode.F b/src/core_ocean/mode_analysis/mpas_ocn_analysis_mode.F index 870c973a40..7f1e820bef 100644 --- a/src/core_ocean/mode_analysis/mpas_ocn_analysis_mode.F +++ b/src/core_ocean/mode_analysis/mpas_ocn_analysis_mode.F @@ -36,7 +36,6 @@ module ocn_analysis_mode use ocn_diagnostics use ocn_equation_of_state use ocn_constants - use ocn_time_average private diff --git a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F index e51dd78747..4496163fe8 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F +++ b/src/core_ocean/mode_forward/mpas_ocn_forward_mode.F @@ -67,8 +67,6 @@ module ocn_forward_mode use ocn_vmix - use ocn_time_average - use ocn_forcing use ocn_sea_ice @@ -298,6 +296,7 @@ function ocn_forward_mode_init(domain, startTimeStamp) result(ierr)!{{{ block => domain % blocklist do while (associated(block)) call ocn_init_routines_block(block, dt, ierr) + if(ierr.eq.1) then call mpas_dmpar_global_abort('ERROR: An error was encountered in ocn_init_routines_block') endif @@ -446,16 +445,10 @@ function ocn_forward_mode_run(domain) result(ierr)!{{{ call mpas_timer_stop('io_write') endif - block_ptr => domain % blocklist - do while(associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'average', averagePool) - call ocn_time_average_init(averagePool) - block_ptr => block_ptr % next - end do - ! During integration, time level 1 stores the model state at the beginning of the ! time step, and time level 2 stores the state advanced dt in time by timestep(...) itimestep = 0 + do while (.not. mpas_is_clock_stop_time(domain % clock)) call mpas_timer_start('io_read', .false.) call mpas_stream_mgr_read(domain % streamManager, ierr=ierr) @@ -490,7 +483,13 @@ function ocn_forward_mode_run(domain) result(ierr)!{{{ end do call mpas_timer_start("time integration", .false., timeIntTimer) + + !$omp parallel default(firstprivate) shared(domain, dt, timeStamp) + call ocn_timestep(domain, dt, timeStamp) + + !$omp end parallel + call mpas_timer_stop("time integration", timeIntTimer) ! Move time level 2 fields back into time level 1 for next time step @@ -533,6 +532,7 @@ function ocn_forward_mode_run(domain) result(ierr)!{{{ call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) call mpas_timer_stop('reset_io_alarms') end do + end function ocn_forward_mode_run!}}} !*********************************************************************** diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F index dc179a7243..396eb68872 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F @@ -23,6 +23,7 @@ module ocn_time_integration_rk4 use mpas_pool_routines use mpas_constants use mpas_dmpar + use mpas_threading use mpas_vector_reconstruction use mpas_spline_interpolation use mpas_timer @@ -34,7 +35,6 @@ module ocn_time_integration_rk4 use ocn_equation_of_state use ocn_vmix - use ocn_time_average use ocn_time_average_coupled use ocn_effective_density_in_land_ice @@ -73,12 +73,12 @@ module ocn_time_integration_rk4 subroutine ocn_time_integrator_rk4(domain, dt)!{{{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Advance model state forward in time by the specified time step using + ! Advance model state forward in time by the specified time step using ! 4th order Runge-Kutta ! - ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:)) + ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:)) ! plus mesh meta-data - ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains + ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains ! model state advanced forward in time by dt seconds !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -101,7 +101,6 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ type (mpas_pool_type), pointer :: verticalMeshPool type (mpas_pool_type), pointer :: forcingPool type (mpas_pool_type), pointer :: scratchPool - type (mpas_pool_type), pointer :: averagePool integer :: rk_step @@ -203,12 +202,12 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_subpool(block % structs, 'state', statePool) call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - - allocate(provisStatePool) + call mpas_pool_create_pool(provisStatePool) call mpas_pool_clone_pool(statePool, provisStatePool, 1) call mpas_pool_add_subpool(block % structs, 'provis_state', provisStatePool) + call mpas_threading_barrier() call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) @@ -224,8 +223,14 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - normalVelocityNew(:,:) = normalVelocityCur(:,:) - layerThicknessNew(:,:) = layerThicknessCur(:,:) + !$omp do schedule(runtime) private(k) + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + normalVelocityNew(k, iCell) = normalVelocityCur(k, iCell) + layerThicknessNew(k, iCell) = layerThicknessCur(k, iCell) + end do + end do + !$omp end do call mpas_pool_begin_iteration(tracersPool) do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) @@ -236,21 +241,27 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_array(tracersPool, trim(groupItr % memberName), tracersNew, 2) if ( associated(tracersCur) .and. associated(tracersNew) ) then + !$omp do schedule(runtime) private(k) do iCell = 1, nCells ! couple tracers to thickness do k = 1, maxLevelCell(iCell) - tracersNew(:,k,iCell) = tracersCur(:,k,iCell) * layerThicknessCur(k,iCell) + tracersNew(:, k, iCell) = tracersCur(:, k, iCell) * layerThicknessCur(k, iCell) end do end do + !$omp end do end if end if end do if (associated(highFreqThicknessCur)) then + !$omp workshare highFreqThicknessNew(:,:) = highFreqThicknessCur(:,:) + !$omp end workshare end if if (associated(lowFreqDivergenceCur)) then + !$omp workshare lowFreqDivergenceNew(:,:) = lowFreqDivergenceCur(:,:) + !$omp end workshare end if block => block % next @@ -287,18 +298,20 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ block => block % next end do + call mpas_threading_barrier() + ! Fourth-order Runge-Kutta, solving dy/dt = f(t,y) is typically written as follows - ! where h = delta t is the large time step. Here f(t,y) is the right hand side, + ! where h = delta t is the large time step. Here f(t,y) is the right hand side, ! called the tendencies in the code below. ! k_1 = h f(t_n , y_n) ! k_2 = h f(t_n + 1/2 h, y_n + 1/2 k_1) ! k_3 = h f(t_n + 1/2 h, y_n + 1/2 k_2) ! k_4 = h f(t_n + h, y_n + k_3) - ! y_{n+1} = y_n + 1/6 k_1 + 1/3 k_2 + 1/3 k_3 + 1/6 k_4 + ! y_{n+1} = y_n + 1/6 k_1 + 1/3 k_2 + 1/3 k_3 + 1/6 k_4 ! in index notation: ! k_{j+1} = h f(t_n + a_j h, y_n + a_j k_j) - ! y_{n+1} = y_n + sum ( b_j k_j ) + ! y_{n+1} = y_n + sum ( b_j k_j ) ! The coefficients of k_j are b_j = (1/6, 1/3, 1/3, 1/6) and are ! initialized here as delta t * b_j: @@ -321,8 +334,9 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ rk_substep_weights(4) = dt ! a_4 only used for ALE step, otherwise it is skipped. call mpas_timer_start("RK4-main loop") + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! BEGIN RK loop + ! BEGIN RK loop !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! do rk_step = 1, 4 call mpas_pool_get_subpool(domain % blocklist % structs, 'diagnostics', diagnosticsPool) @@ -335,6 +349,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ end if call mpas_timer_stop("RK4-boundary layer depth halo update") + call mpas_timer_start("RK4-diagnostic halo update") call mpas_pool_get_field(diagnosticsPool, 'normalizedRelativeVorticityEdge', normalizedRelativeVorticityEdgeField) @@ -347,9 +362,11 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_dmpar_exch_halo_field(relativeVorticityField) end if call mpas_timer_stop("RK4-diagnostic halo update") + call mpas_threading_barrier() + ! Compute tendencies for high frequency thickness - ! In RK4 notation, we are computing the right hand side f(t,y), + ! In RK4 notation, we are computing the right hand side f(t,y), ! which is the same as k_j / h. if (config_use_freq_filtered_thickness) then @@ -364,11 +381,13 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) call ocn_tend_freq_filtered_thickness(tendPool, provisStatePool, diagnosticsPool, meshPool, 1) + call mpas_threading_barrier() block => block % next end do call mpas_timer_stop("RK4-tendency computations") call mpas_timer_start("RK4-prognostic halo update") + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) call mpas_pool_get_field(tendPool, 'highFreqThickness', highFreqThicknessField) @@ -377,6 +396,8 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_dmpar_exch_halo_field(highFreqThicknessField) call mpas_dmpar_exch_halo_field(lowFreqDivergenceField) call mpas_timer_stop("RK4-prognostic halo update") + call mpas_threading_barrier() + ! Compute next substep state for high frequency thickness. ! In RK4 notation, we are computing y_n + a_j k_j. @@ -392,16 +413,21 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_array(provisStatePool, 'highFreqThickness', highFreqThicknessProvis, 1) call mpas_pool_get_array(tendPool, 'highFreqThickness', highFreqThicknessTend) + !$omp workshare highFreqThicknessProvis(:,:) = highFreqThicknessCur(:,:) + rk_substep_weights(rk_step) * highFreqThicknessTend(:,:) + !$omp end workshare + call mpas_threading_barrier() block => block % next end do endif + ! Compute tendencies for velocity, thickness, and tracers. - ! In RK4 notation, we are computing the right hand side f(t,y), + ! In RK4 notation, we are computing the right hand side f(t,y), ! which is the same as k_j / h. call mpas_timer_start("RK4-tendency computations") + block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) @@ -427,42 +453,49 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ ! advection of u uses u, while advection of layerThickness and tracers use normalTransportVelocity. if (associated(highFreqThicknessProvis)) then - call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, & + call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, scratchPool, & layerThicknessCur,layerThicknessEdge, normalVelocityProvis, & sshCur, rk_substep_weights(rk_step), & vertAleTransportTop, err, highFreqThicknessProvis) else - call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, & + call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, scratchPool, & layerThicknessCur,layerThicknessEdge, normalVelocityProvis, & sshCur, rk_substep_weights(rk_step), & vertAleTransportTop, err) endif + call mpas_threading_barrier() call ocn_tend_vel(tendPool, provisStatePool, forcingPool, diagnosticsPool, meshPool, scratchPool, 1) + call mpas_threading_barrier() if (associated(highFreqThicknessProvis)) then - call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, & + call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, scratchPool, & layerThicknessCur, layerThicknessEdge, normalTransportVelocity, & sshCur, rk_substep_weights(rk_step), & vertAleTransportTop, err, highFreqThicknessProvis) else - call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, & + call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, scratchPool, & layerThicknessCur, layerThicknessEdge, normalTransportVelocity, & sshCur, rk_substep_weights(rk_step), & vertAleTransportTop, err) endif + call mpas_threading_barrier() call ocn_tend_thick(tendPool, forcingPool, diagnosticsPool, meshPool) if (config_filter_btr_mode) then call ocn_filter_btr_mode_tend_vel(tendPool, provisStatePool, diagnosticsPool, meshPool, 1) endif + call mpas_threading_barrier() call ocn_tend_tracer(tendPool, provisStatePool, forcingPool, diagnosticsPool, meshPool, scratchPool, dt, 1) + call mpas_threading_barrier() block => block % next end do + call mpas_timer_stop("RK4-tendency computations") + ! Update halos for prognostic variables. call mpas_timer_start("RK4-prognostic halo update") @@ -486,11 +519,13 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ end do call mpas_timer_stop("RK4-prognostic halo update") + call mpas_threading_barrier() ! Compute next substep state for velocity, thickness, and tracers. ! In RK4 notation, we are computing y_n + a_j k_j. call mpas_timer_start("RK4-update diagnostic variables") + if (rk_step < 4) then block => domain % blocklist do while (associated(block)) @@ -526,9 +561,16 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) call mpas_pool_get_array(diagnosticsPool, 'normalGMBolusVelocity', normalGMBolusVelocity) - normalVelocityProvis(:,:) = normalVelocityCur(:,:) + rk_substep_weights(rk_step) * normalVelocityTend(:,:) + call mpas_threading_barrier() - layerThicknessProvis(:,:) = layerThicknessCur(:,:) + rk_substep_weights(rk_step) * layerThicknessTend(:,:) + !$omp do schedule(runtime) private(k) + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + normalVelocityProvis(k, iCell) = normalVelocityCur(k, iCell) + rk_substep_weights(rk_step) * normalVelocityTend(k, iCell) + layerThicknessProvis(k, iCell) = layerThicknessCur(k, iCell) + rk_substep_weights(rk_step) * layerThicknessTend(k, iCell) + end do + end do + !$omp end do call mpas_pool_begin_iteration(tracersPool) do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) @@ -543,46 +585,63 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ modifiedGroupName = trim(groupItr % memberName) // 'Tend' call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) if ( associated(tracersGroupProvis) .and. associated(tracersCur) .and. associated(tracersGroupTend) ) then + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) - tracersGroupProvis(:,k,iCell) = ( layerThicknessCur(k,iCell) * tracersCur(:,k,iCell) & - + rk_substep_weights(rk_step) * tracersGroupTend(:,k,iCell) & - ) / layerThicknessProvis(k,iCell) + tracersGroupProvis(:, k, iCell) = ( layerThicknessCur(k, iCell) * tracersCur(:, k, iCell) & + + rk_substep_weights(rk_step) * tracersGroupTend(:, k, iCell) & + ) / layerThicknessProvis(k, iCell) end do end do + !$omp end do end if end if end if end do if (associated(lowFreqDivergenceCur)) then + !$omp workshare lowFreqDivergenceProvis(:,:) = lowFreqDivergenceCur(:,:) + rk_substep_weights(rk_step) * lowFreqDivergenceTend(:,:) + !$omp end workshare end if if (config_prescribe_velocity) then + !$omp workshare normalVelocityProvis(:,:) = normalVelocityCur(:,:) + !$omp end workshare end if if (config_prescribe_thickness) then + !$omp workshare layerThicknessProvis(:,:) = layerThicknessCur(:,:) + !$omp end workshare end if + call mpas_threading_barrier() call ocn_diagnostic_solve(dt, provisStatePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 1) + call mpas_threading_barrier() ! ------------------------------------------------------------------ ! Accumulating various parametrizations of the transport velocity ! ------------------------------------------------------------------ + !$omp master ! FIXME: workshare causes seg fault normalTransportVelocity(:,:) = normalVelocityProvis(:,:) + !$omp end master + call mpas_threading_barrier() ! Compute normalGMBolusVelocity, relativeSlope and RediDiffVertCoef if respective flags are turned on if (config_use_standardGM) then call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) end if + call mpas_threading_barrier() if (config_use_standardGM) then + !$omp workshare normalTransportVelocity(:,:) = normalTransportVelocity(:,:) + normalGMBolusVelocity(:,:) + !$omp end workshare end if + call mpas_threading_barrier() ! ------------------------------------------------------------------ ! End: Accumulating various parametrizations of the transport velocity ! ------------------------------------------------------------------ @@ -590,14 +649,17 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ block => block % next end do end if + call mpas_timer_stop("RK4-update diagnostic variables") + call mpas_threading_barrier() ! Accumulate update. ! In RK4 notation, we are computing b_j k_j and adding it to an accumulating sum so that we have - ! y_{n+1} = y_n + sum ( b_j k_j ) + ! y_{n+1} = y_n + sum ( b_j k_j ) ! after the fourth iteration. call mpas_timer_start("RK4-RK4 accumulate update") + block => domain % blocklist do while (associated(block)) call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) @@ -626,9 +688,14 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) - normalVelocityNew(:,:) = normalVelocityNew(:,:) + rk_weights(rk_step) * normalVelocityTend(:,:) - - layerThicknessNew(:,:) = layerThicknessNew(:,:) + rk_weights(rk_step) * layerThicknessTend(:,:) + !$omp do schedule(runtime) private(k) + do iCell = 1, nCells + do k = 1, maxLevelCell(iCell) + normalVelocityNew(k, iCell) = normalVelocityNew(k, iCell) + rk_weights(rk_step) * normalVelocityTend(k, iCell) + layerThicknessNew(k, iCell) = layerThicknessNew(k, iCell) + rk_weights(rk_step) * layerThicknessTend(k, iCell) + end do + end do + !$omp end do call mpas_pool_begin_iteration(tracersPool) do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) @@ -642,33 +709,43 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ modifiedGroupName = trim(groupItr % memberName) // 'Tend' call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) if ( associated(tracersNew) .and. associated(tracersGroupTend) ) then + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) - tracersNew(:,k,iCell) = tracersNew(:,k,iCell) + rk_weights(rk_step) * tracersGroupTend(:,k,iCell) + tracersNew(:, k, iCell) = tracersNew(:, k, iCell) + rk_weights(rk_step) * tracersGroupTend(:, k, iCell) end do end do + !$omp end do end if end if end if end do if (associated(highFreqThicknessNew)) then - highFreqThicknessNew(:,:) = highFreqThicknessNew(:,:) + rk_weights(rk_step) * highFreqThicknessTend(:,:) + !$omp workshare + highFreqThicknessNew(:,:) = highFreqThicknessNew(:,:) + rk_weights(rk_step) * highFreqThicknessTend(:,:) + !$omp end workshare end if if (associated(lowFreqDivergenceNew)) then - lowFreqDivergenceNew(:,:) = lowFreqDivergenceNew(:,:) + rk_weights(rk_step) * lowFreqDivergenceTend(:,:) + !$omp workshare + lowFreqDivergenceNew(:,:) = lowFreqDivergenceNew(:,:) + rk_weights(rk_step) * lowFreqDivergenceTend(:,:) + !$omp end workshare end if block => block % next end do + call mpas_timer_stop("RK4-RK4 accumulate update") + call mpas_threading_barrier() end do !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! END RK loop + ! END RK loop !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call mpas_timer_stop("RK4-main loop") + call mpas_threading_barrier() ! ! A little clean up at the end: rescale tracer fields and compute diagnostics for new state @@ -699,20 +776,24 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ if ( groupItr % memberType == MPAS_POOL_FIELD ) then call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersNew, 2) if ( associated(tracersNew) ) then + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) tracersNew(:, k, iCell) = tracersNew(:, k, iCell) / layerThicknessNew(k, iCell) end do end do + !$omp end do end if end if end do call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) + block => block % next end do call mpas_timer_start("RK4-implicit vert mix") + block => domain % blocklist do while(associated(block)) call mpas_pool_get_subpool(block % structs, 'state', statePool) @@ -725,29 +806,36 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityNew, 2) call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) - ! Call ocean diagnostic solve in preparation for vertical mixing. Note + ! Call ocean diagnostic solve in preparation for vertical mixing. Note ! it is called again after vertical mixing, because u and tracers change. - ! For Richardson vertical mixing, only density, layerThicknessEdge, and kineticEnergyCell need to + ! For Richardson vertical mixing, only density, layerThicknessEdge, and kineticEnergyCell need to ! be computed. For kpp, more variables may be needed. Either way, this ! could be made more efficient by only computing what is needed for the - ! implicit vmix routine that follows. + ! implicit vmix routine that follows. call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) + call mpas_threading_barrier() - call ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, err, 2) + call ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, scratchPool, err, 2) + call mpas_threading_barrier() ! ------------------------------------------------------------------ ! Accumulating various parametrizations of the transport velocity ! ------------------------------------------------------------------ + !$omp master ! FIXME: workshare causes seg fault normalTransportVelocity(:,:) = normalVelocityNew(:,:) + !$omp end master ! Compute normalGMBolusVelocity, slopeRelative and RediDiffVertCoef if respective flags are turned on ! QC Note: this routine is called here to get updated k33. normalTransportVelocity probably does not need to be updated at all here. if (config_use_standardGM) then call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) end if + call mpas_threading_barrier() if (config_use_standardGM) then + !$omp workshare normalTransportVelocity(:,:) = normalTransportVelocity(:,:) + normalGMBolusVelocity(:,:) + !$omp end workshare end if ! ------------------------------------------------------------------ ! End: Accumulating various parametrizations of the transport velocity @@ -756,9 +844,9 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ block => block % next end do - ! Update halo on u and tracers, which were just updated for implicit vertical mixing. If not done, + ! Update halo on u and tracers, which were just updated for implicit vertical mixing. If not done, ! this leads to lack of volume conservation. It is required because halo updates in RK4 are only - ! conducted on tendencies, not on the velocity and tracer fields. So this update is required to + ! conducted on tendencies, not on the velocity and tracer fields. So this update is required to ! communicate the change due to implicit vertical mixing across the boundary. call mpas_timer_start("RK4-implicit vert mix halos") call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) @@ -781,6 +869,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_timer_stop("RK4-implicit vert mix halos") call mpas_timer_stop("RK4-implicit vert mix") + call mpas_threading_barrier() block => domain % blocklist do while (associated(block)) @@ -790,7 +879,6 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) - call mpas_pool_get_subpool(block % structs, 'average', averagePool) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, 1) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityNew, 2) @@ -818,15 +906,21 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_get_array(diagnosticsPool, 'surfaceVelocity', surfaceVelocity) call mpas_pool_get_array(diagnosticsPool, 'SSHGradient', SSHGradient) + if (config_prescribe_velocity) then + !$omp workshare normalVelocityNew(:,:) = normalVelocityCur(:,:) + !$omp end workshare end if if (config_prescribe_thickness) then + !$omp workshare layerThicknessNew(:,:) = layerThicknessCur(:,:) + !$omp end workshare end if call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) + call mpas_threading_barrier() ! Update the effective desnity in land ice if we're coupling to land ice call ocn_effective_density_in_land_ice_update(meshPool, forcingPool, statePool, scratchPool, err) @@ -834,42 +928,52 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ ! ------------------------------------------------------------------ ! Accumulating various parameterizations of the transport velocity ! ------------------------------------------------------------------ + !$omp master ! FIXME: workshare causes seg fault normalTransportVelocity(:,:) = normalVelocityNew(:,:) + !$omp end master + call mpas_threading_barrier() ! Compute normalGMBolusVelocity and the tracer transport velocity if (config_use_standardGM) then call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) end if + call mpas_threading_barrier() if (config_use_standardGM) then + !$omp workshare normalTransportVelocity(:,:) = normalTransportVelocity(:,:) + normalGMBolusVelocity(:,:) + !$omp end workshare end if ! ------------------------------------------------------------------ ! End: Accumulating various parameterizations of the transport velocity ! ------------------------------------------------------------------ - call mpas_reconstruct(meshPool, normalVelocityNew, & - velocityX, velocityY, velocityZ, & - velocityZonal, velocityMeridional, & + !$omp master + call mpas_reconstruct(meshPool, normalVelocityNew, & + velocityX, velocityY, velocityZ, & + velocityZonal, velocityMeridional, & includeHalos = .true.) call mpas_reconstruct(meshPool, gradSSH, & gradSSHX, gradSSHY, gradSSHZ, & - gradSSHZonal, gradSSHMeridional & - ) + gradSSHZonal, gradSSHMeridional) + !$omp end master + call mpas_threading_barrier() + !$omp workshare surfaceVelocity(indexSurfaceVelocityZonal, :) = velocityZonal(1, :) surfaceVelocity(indexSurfaceVelocityMeridional, :) = velocityMeridional(1, :) SSHGradient(indexSSHGradientZonal, :) = gradSSHZonal(1, :) SSHGradient(indexSSHGradientMeridional, :) = gradSSHMeridional(1, :) + !$omp end workshare - call ocn_time_average_accumulate(averagePool, statePool, diagnosticsPool, 2) call ocn_time_average_coupled_accumulate(diagnosticsPool, statePool, forcingPool, 2) if (config_use_standardGM) then call ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) end if + call mpas_threading_barrier() block => block % next end do @@ -884,6 +988,8 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_timer_stop("RK4-cleaup phase") + call mpas_threading_barrier() + block => domain % blocklist do while(associated(block)) call mpas_pool_get_subpool(block % structs, 'provis_state', provisStatePool) @@ -893,6 +999,7 @@ subroutine ocn_time_integrator_rk4(domain, dt)!{{{ call mpas_pool_remove_subpool(block % structs, 'provis_state') block => block % next end do + call mpas_threading_barrier() end subroutine ocn_time_integrator_rk4!}}} diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F index 9a8d259eb8..771e82787d 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F @@ -28,6 +28,7 @@ module ocn_time_integration_split use mpas_vector_reconstruction use mpas_spline_interpolation use mpas_timer + use mpas_threading use ocn_tendency use ocn_diagnostics @@ -35,7 +36,6 @@ module ocn_time_integration_split use ocn_equation_of_state use ocn_vmix - use ocn_time_average use ocn_time_average_coupled use ocn_effective_density_in_land_ice @@ -72,7 +72,7 @@ module ocn_time_integration_split !> \author Mark Petersen, Doug Jacobsen, Todd Ringler !> \date September 2011 !> \details -!> This routine integrates a single time step (dt) using a +!> This routine integrates a master time step (dt) using a !> split explicit time integrator. ! !----------------------------------------------------------------------- @@ -101,7 +101,6 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ type (mpas_pool_type), pointer :: tendPool type (mpas_pool_type), pointer :: tracersTendPool type (mpas_pool_type), pointer :: forcingPool - type (mpas_pool_type), pointer :: averagePool type (mpas_pool_type), pointer :: scratchPool type (dm_info) :: dminfo @@ -117,6 +116,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ vertViscTopOfEdge, vertDiffTopOfCell real (kind=RKIND), dimension(:,:,:), pointer :: tracersGroup real (kind=RKIND), dimension(:), allocatable:: uTemp + real (kind=RKIND), dimension(:), pointer :: btrvel_temp + type (field1DReal), pointer :: btrvel_tempField real (kind=RKIND), dimension(:,:), allocatable:: tracersTemp integer :: tsIter @@ -197,6 +198,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ type (mpas_pool_iterator_type) :: groupItr character (len=StrKIND) :: modifiedGroupName character (len=StrKIND) :: configName + integer :: threadNum call mpas_timer_start("se timestep", .false., timer_main) @@ -236,6 +238,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! call mpas_timer_start("se prep", .false., timer_prep) + block => domain % blocklist do while (associated(block)) call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) @@ -269,6 +272,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) ! Initialize * variables that are used to compute baroclinic tendencies below. + + !$omp do schedule(runtime) private(k) do iEdge = 1, nEdges do k = 1, nVertLevels !maxLevelEdgeTop % array(iEdge) @@ -283,21 +288,24 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ normalVelocityNew(k,iEdge) = normalVelocityCur(k,iEdge) normalBaroclinicVelocityNew(k,iEdge) = normalBaroclinicVelocityCur(k,iEdge) - - ! DWJ-POOL What's this for? -! block % diagnostics % layerThicknessEdge % array(k,iEdge) & -! = block % diagnostics % layerThicknessEdge % array(k,iEdge) end do end do + !$omp end do + !$omp workshare sshNew(:) = sshCur(:) + !$omp end workshare + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) layerThicknessNew(k,iCell) = layerThicknessCur(k,iCell) end do end do + !$omp end do + + threadnum = mpas_threading_get_thread_num() call mpas_pool_begin_iteration(tracersPool) do while ( mpas_pool_get_next_member(tracersPool, groupItr)) @@ -306,28 +314,35 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(tracersPool, groupItr % memberName, tracersGroupNew, 2) if ( associated(tracersGroupCur) .and. associated(tracersGroupNew) ) then + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) tracersGroupNew(:,k,iCell) = tracersGroupCur(:,k,iCell) end do end do + !$omp end do end if end if end do if (associated(highFreqThicknessNew)) then + !$omp workshare highFreqThicknessNew(:,:) = highFreqThicknessCur(:,:) + !$omp end workshare end if if (associated(lowFreqDivergenceNew)) then + !$omp workshare lowFreqDivergenceNew(:,:) = lowFreqDivergenceCur(:,:) + !$omp end workshare endif block => block % next end do call mpas_timer_stop("se prep", timer_prep) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! BEGIN large iteration loop !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -340,6 +355,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_subpool(domain % blocklist % structs, 'diagnostics', diagnosticsPool) + call mpas_threading_barrier() ! --- update halos for diagnostic ocean boundayr layer depth call mpas_timer_start("se halo diag obd", .false., timer_halo_diagnostic) if (config_use_cvmix_kpp) then @@ -360,6 +376,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_dmpar_exch_halo_field(relativeVorticityField) end if call mpas_timer_stop("se halo diag", timer_halo_diagnostic) + call mpas_threading_barrier() !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! @@ -369,6 +386,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ if (config_use_freq_filtered_thickness) then call mpas_timer_start("se freq-filtered-thick computations") + block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) @@ -383,6 +401,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ end do call mpas_timer_stop("se freq-filtered-thick computations") + call mpas_threading_barrier() + call mpas_timer_start("se freq-filtered-thick halo update") call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) @@ -393,6 +413,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_dmpar_exch_halo_field(highFreqThicknessField) call mpas_dmpar_exch_halo_field(lowFreqDivergenceField) call mpas_timer_stop("se freq-filtered-thick halo update") + call mpas_threading_barrier() block => domain % blocklist do while (associated(block)) @@ -411,20 +432,22 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(tendPool, 'highFreqThickness', highFreqThicknessTend) + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) ! this is h^{hf}_{n+1} highFreqThicknessNew(k,iCell) = highFreqThicknessCur(k,iCell) + dt * highFreqThicknessTend(k,iCell) end do end do + !$omp end do + block => block % next end do endif - ! compute velocity tendencies, T(u*,w*,p*) - call mpas_timer_start("se bcl vel", .false., timer_bcl_vel) + call mpas_timer_start("se_bcl_vel", .false., timer_bcl_vel) block => domain % blocklist do while (associated(block)) @@ -450,11 +473,11 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! compute vertAleTransportTop. Use u (rather than normalTransportVelocity) for momentum advection. ! Use the most recent time level available. if (associated(highFreqThicknessNew)) then - call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, & + call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, scratchPool, & layerThicknessCur, layerThicknessEdge, normalVelocityCur, & sshCur, dt, vertAleTransportTop, err, highFreqThicknessNew) else - call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, & + call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, scratchPool, & layerThicknessCur, layerThicknessEdge, normalVelocityCur, & sshCur, dt, vertAleTransportTop, err) endif @@ -502,11 +525,12 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(diagnosticsPool, 'layerThicknessEdge', layerThicknessEdge) call mpas_pool_get_array(diagnosticsPool, 'barotropicForcing', barotropicForcing) - allocate(uTemp(nVertLevels)) - ! Put f*normalBaroclinicVelocity^{perp} in normalVelocityNew as a work variable call ocn_fuperp(statePool, meshPool, 2) + allocate(uTemp(nVertLevels)) + + !$omp do schedule(runtime) private(cell1, cell2, k, normalThicknessFluxSum, thicknessSum) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -547,12 +571,15 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ enddo enddo ! iEdge + !$omp end do deallocate(uTemp) block => block % next end do + call mpas_threading_barrier() + call mpas_timer_start("se halo normalBaroclinicVelocity", .false., timer_halo_normalBaroclinicVelocity) call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) call mpas_pool_get_field(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocityField, 2) @@ -560,21 +587,23 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_dmpar_exch_halo_field(normalBaroclinicVelocityField) call mpas_timer_stop("se halo normalBaroclinicVelocity", timer_halo_normalBaroclinicVelocity) + call mpas_threading_barrier() + end do ! do j=1,config_n_bcl_iter - call mpas_timer_stop("se bcl vel", timer_bcl_vel) + call mpas_timer_stop("se_bcl_vel", timer_bcl_vel) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! END baroclinic iterations on linear Coriolis term !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Stage 2: Barotropic velocity (2D) prediction, explicitly subcycled ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - call mpas_timer_start("se btr vel", .false., timer_btr_vel) + call mpas_timer_start("se_btr_vel", .false., timer_btr_vel) oldBtrSubcycleTime = 1 newBtrSubcycleTime = 2 @@ -601,10 +630,13 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) ! For Split_Explicit unsplit, simply set normalBarotropicVelocityNew=0, normalBarotropicVelocitySubcycle=0, and uNew=normalBaroclinicVelocityNew - normalBarotropicVelocityNew(:) = 0.0 + !$omp workshare + normalBarotropicVelocityNew(:) = 0.0 normalVelocityNew(:,:) = normalBaroclinicVelocityNew(:,:) + !$omp end workshare + !$omp do schedule(runtime) private(k) do iEdge = 1, nEdges do k = 1, nVertLevels @@ -616,7 +648,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ enddo end do ! iEdge - + !$omp end do + block => block % next end do ! block @@ -642,14 +675,19 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityNew, 2) if (config_filter_btr_mode) then + !$omp workshare barotropicForcing(:) = 0.0 + !$omp end workshare endif + !$omp do schedule(runtime) do iCell = 1, nCells ! sshSubcycleOld = sshOld sshSubcycleCur(iCell) = sshCur(iCell) end do + !$omp end do + !$omp do schedule(runtime) do iEdge = 1, nEdges ! normalBarotropicVelocitySubcycleOld = normalBarotropicVelocityOld @@ -661,6 +699,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! barotropicThicknessFlux = 0 barotropicThicknessFlux(iEdge) = 0.0 end do + !$omp end do block => block % next end do ! block @@ -699,6 +738,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(diagnosticsPool, 'barotropicForcing', barotropicForcing) + !$omp do schedule(runtime) private(cell1, cell2, CoriolisTerm, i, eoe) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) @@ -719,10 +759,13 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ * (sshSubcycleCur(cell2) - sshSubcycleCur(cell1) ) & / dcEdge(iEdge) + barotropicForcing(iEdge))) * edgeMask(1, iEdge) end do + !$omp end do block => block % next end do ! block + call mpas_threading_barrier() + ! boundary update on normalBarotropicVelocityNew call mpas_timer_start("se halo normalBarotropicVelocity", .false., timer_halo_normalBarotropicVelocity) call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) @@ -731,6 +774,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_field(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleField, newBtrSubcycleTime) call mpas_dmpar_exch_halo_field(normalBarotropicVelocitySubcycleField) call mpas_timer_stop("se halo normalBarotropicVelocity", timer_halo_normalBarotropicVelocity) + + call mpas_threading_barrier() endif ! config_btr_gam1_velWt1>1.0e-12 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -766,8 +811,10 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleNew, newBtrSubcycleTime) call mpas_pool_get_array(diagnosticsPool, 'barotropicThicknessFlux', barotropicThicknessFlux) - + + !$omp workshare sshTend(:) = 0.0 + !$omp end workshare if (config_btr_solve_SSH2) then ! If config_btr_solve_SSH2=.true., then do NOT accumulate barotropicThicknessFlux in this SSH predictor @@ -783,6 +830,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! config_btr_gam1_velWt1=0.5 flux = 1/2*(normalBarotropicVelocityNew+normalBarotropicVelocityOld)*H ! config_btr_gam1_velWt1= 0 flux = normalBarotropicVelocityOld*H + !$omp do schedule(runtime) private(i, iEdge, cell1, cell2, sshEdge, thicknessSum, flux) do iCell = 1, nCells do i = 1, nEdgesOnCell(iCell) iEdge = edgesOnCell(i, iCell) @@ -812,7 +860,9 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ end do end do + !$omp end do + !$omp do schedule(runtime) private(cell1, cell2, sshEdge, thicknessSum, flux) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -837,15 +887,20 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ barotropicThicknessFlux(iEdge) = barotropicThicknessFlux(iEdge) + barotropicThicknessFlux_coeff * flux end do + !$omp end do ! SSHnew = SSHold + dt/J*(-div(Flux)) + !$omp do schedule(runtime) do iCell = 1, nCells sshSubcycleNew(iCell) = sshSubcycleCur(iCell) + dt / config_n_btr_subcycles * sshTend(iCell) / areaCell(iCell) end do - + !$omp end do + block => block % next end do ! block + call mpas_threading_barrier() + ! boundary update on SSHnew call mpas_timer_start("se halo ssh", .false., timer_halo_ssh) call mpas_pool_get_subpool(domain % blocklist % structs, 'state', statePool) @@ -853,6 +908,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_field(statePool, 'sshSubcycle', sshSubcycleField, newBtrSubcycleTime) call mpas_dmpar_exch_halo_field(sshSubcycleField) call mpas_timer_stop("se halo ssh", timer_halo_ssh) + call mpas_threading_barrier() !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Barotropic subcycle: VELOCITY CORRECTOR STEP @@ -868,6 +924,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleCur, oldBtrSubcycleTime) call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleNew, newBtrSubcycleTime) @@ -884,9 +941,16 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(diagnosticsPool, 'barotropicForcing', barotropicForcing) - allocate(utemp(nEdges+1)) + call mpas_pool_get_field(scratchPool, 'btrvel_temp', btrvel_tempField) + call mpas_allocate_scratch_field(btrvel_tempField, .true.) + call mpas_threading_barrier() + btrvel_temp => btrvel_tempField % array + + !$omp workshare + btrvel_temp(:) = normalBarotropicVelocitySubcycleNew(:) + !$omp end workshare - uTemp(:) = normalBarotropicVelocitySubcycleNew(:) + !$omp do schedule(runtime) private(cell1, cell2, eoe, CoriolisTerm, i, sshCell1, sshCell2) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -897,7 +961,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ eoe = edgesOnEdge(i,iEdge) CoriolisTerm = CoriolisTerm + weightsOnEdge(i,iEdge) & !* normalBarotropicVelocitySubcycleNew(eoe) & - * uTemp(eoe) * fEdge(eoe) + * btrvel_temp(eoe) * fEdge(eoe) end do ! In this final solve for velocity, SSH is a linear @@ -910,10 +974,16 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ + dt / config_n_btr_subcycles *(CoriolisTerm - gravity *(sshCell2 - sshCell1) / dcEdge(iEdge) & + barotropicForcing(iEdge))) * edgeMask(1,iEdge) end do - deallocate(uTemp) + !$omp end do + + call mpas_threading_barrier() + call mpas_deallocate_scratch_field(btrvel_tempField, .true.) + call mpas_threading_barrier() block => block % next end do ! block + + call mpas_threading_barrier() ! boundary update on normalBarotropicVelocityNew call mpas_timer_start("se halo normalBarotropicVelocity", .false., timer_halo_normalBarotropicVelocity) @@ -924,6 +994,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_dmpar_exch_halo_field(normalBarotropicVelocitySubcycleField) call mpas_timer_stop("se halo normalBarotropicVelocity", timer_halo_normalBarotropicVelocity) + + call mpas_threading_barrier() end do !do BtrCorIter=1,config_n_btr_cor_iter !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -960,14 +1032,16 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(statePool, 'normalBarotropicVelocitySubcycle', normalBarotropicVelocitySubcycleNew, newBtrSubcycleTime) call mpas_pool_get_array(diagnosticsPool, 'barotropicThicknessFlux', barotropicThicknessFlux) - + !$omp workshare sshTend(:) = 0.0 + !$omp end workshare ! config_btr_gam3_velWt2 sets the forward weighting of velocity in the SSH computation ! config_btr_gam3_velWt2= 1 flux = normalBarotropicVelocityNew*H ! config_btr_gam3_velWt2=0.5 flux = 1/2*(normalBarotropicVelocityNew+normalBarotropicVelocityOld)*H ! config_btr_gam3_velWt2= 0 flux = normalBarotropicVelocityOld*H + !$omp do schedule(runtime) private(i, iEdge, cell1, cell2, sshCell1, sshCell2, sshEdge, thicknessSum, flux) do iCell = 1, nCells do i = 1, nEdgesOnCell(iCell) iEdge = edgesOnCell(i, iCell) @@ -1002,7 +1076,9 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ end do end do + !$omp end do + !$omp do schedule(runtime) private(cell1, cell2, sshCell1, sshCell2, sshEdge, thicknessSum, flux) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -1028,15 +1104,20 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ barotropicThicknessFlux(iEdge) = barotropicThicknessFlux(iEdge) + flux end do + !$omp end do ! SSHnew = SSHold + dt/J*(-div(Flux)) + !$omp do schedule(runtime) do iCell = 1, nCells sshSubcycleNew(iCell) = sshSubcycleCur(iCell) & + dt / config_n_btr_subcycles * sshTend(iCell) / areaCell(iCell) end do - + !$omp end do + block => block % next end do ! block + + call mpas_threading_barrier() ! boundary update on SSHnew call mpas_timer_start("se halo ssh", .false., timer_halo_ssh) @@ -1047,6 +1128,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_dmpar_exch_halo_field(sshSubcycleField) call mpas_timer_stop("se halo ssh", timer_halo_ssh) + + call mpas_threading_barrier() endif ! config_btr_solve_SSH2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1067,9 +1150,13 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! This accumulates the sum. ! If the Barotropic Coriolis iteration is limited to one, this could ! be merged with the above code. + + !$omp do schedule(runtime) do iEdge = 1, nEdges normalBarotropicVelocityNew(iEdge) = normalBarotropicVelocityNew(iEdge) + normalBarotropicVelocitySubcycleNew(iEdge) end do ! iEdge + !$omp end do + block => block % next end do ! block @@ -1094,7 +1181,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocityNew, 2) call mpas_pool_get_array(diagnosticsPool, 'barotropicThicknessFlux', barotropicThicknessFlux) - + + !$omp do schedule(runtime) do iEdge = 1, nEdges barotropicThicknessFlux(iEdge) = barotropicThicknessFlux(iEdge) & / (config_n_btr_subcycles * config_btr_subcycle_loop_factor) @@ -1102,10 +1190,12 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ normalBarotropicVelocityNew(iEdge) = normalBarotropicVelocityNew(iEdge) & / (config_n_btr_subcycles * config_btr_subcycle_loop_factor + 1) end do - + !$omp end do + block => block % next end do ! block - + + call mpas_threading_barrier() ! boundary update on F call mpas_timer_start("se halo F", .false., timer_halo_f) @@ -1116,6 +1206,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_dmpar_exch_halo_field(barotropicThicknessFluxField) call mpas_timer_stop("se halo F", timer_halo_f) + call mpas_threading_barrier() ! Check that you can compute SSH using the total sum or the individual increments ! over the barotropic subcycles. @@ -1156,6 +1247,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ useVelocityCorrection = 0 endif + !$omp do schedule(runtime) private(k, normalThicknessFluxSum, thicknessSum, normalVelocityCorrection) do iEdge = 1, nEdges ! velocity for normalVelocityCorrectionection is normalBarotropicVelocity + normalBaroclinicVelocity + uBolus @@ -1188,6 +1280,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ enddo end do ! iEdge + !$omp end do deallocate(uTemp) @@ -1196,7 +1289,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ endif ! split_explicit - call mpas_timer_stop("se btr vel", timer_btr_vel) + call mpas_timer_stop("se_btr_vel", timer_btr_vel) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! @@ -1214,6 +1307,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) @@ -1229,11 +1323,11 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! Use time level 1 values of layerThickness and layerThicknessEdge because ! layerThickness has not yet been computed for time level 2. if (associated(highFreqThicknessNew)) then - call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, & + call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, scratchPool, & layerThicknessCur, layerThicknessEdge, normalTransportVelocity, & sshCur, dt, vertAleTransportTop, err, highFreqThicknessNew) else - call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, & + call ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, scratchPool, & layerThicknessCur, layerThicknessEdge, normalTransportVelocity, & sshCur, dt, vertAleTransportTop, err) endif @@ -1243,6 +1337,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ block => block % next end do + call mpas_threading_barrier() + ! update halo for thickness tendencies call mpas_timer_start("se halo thickness", .false., timer_halo_thickness) call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) @@ -1253,6 +1349,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_dmpar_exch_halo_field(layerThicknessField) call mpas_timer_stop("se halo thickness", timer_halo_thickness) + call mpas_threading_barrier() + block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'tend', tendPool) @@ -1262,11 +1360,14 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) call ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, meshPool, scratchPool, dt, 2) block => block % next end do + call mpas_threading_barrier() + ! update halo for tracer tendencies call mpas_timer_start("se halo tracers", .false., timer_halo_tracers) call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tendPool) @@ -1284,6 +1385,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ end do call mpas_timer_stop("se halo tracers", timer_halo_tracers) + call mpas_threading_barrier() + block => domain % blocklist do while (associated(block)) call mpas_pool_get_dimension(block % dimensions, 'nCells', nCells) @@ -1338,6 +1441,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! Only need T & S for earlier iterations, ! then all the tracers needed the last time through. + + !$omp do schedule(runtime) private(k, temp_h, temp) do iCell = 1, nCells ! sshNew is a pointer, defined above. do k = 1, maxLevelCell(iCell) @@ -1357,8 +1462,10 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ end do end do end do ! iCell + !$omp end do if (config_use_freq_filtered_thickness) then + !$omp do schedule(runtime) private(k, temp) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) @@ -1375,8 +1482,10 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ lowFreqDivergenceNew(k,iCell) = 0.5 * (lowFreqDivergenceCur(k,iCell) + temp) end do end do + !$omp end do end if + !$omp do schedule(runtime) private(k) do iEdge = 1, nEdges do k = 1, nVertLevels @@ -1389,6 +1498,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ enddo end do ! iEdge + !$omp end do ! Efficiency note: We really only need this to compute layerThicknessEdge, density, pressure, and SSH ! in this diagnostics solve. @@ -1401,12 +1511,14 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! elseif (split_explicit_step == config_n_ts_iter) then + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) ! this is h_{n+1} layerThicknessNew(k,iCell) = layerThicknessCur(k,iCell) + dt * layerThicknessTend(k,iCell) end do end do + !$omp end do call mpas_pool_begin_iteration(tracersPool) do while ( mpas_pool_get_next_member(tracersPool, groupItr) ) @@ -1421,17 +1533,20 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ modifiedGroupName = trim(groupItr % memberName) // 'Tend' call mpas_pool_get_array(tracersTendPool, modifiedGroupName, tracersGroupTend) + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) tracersGroupNew(:,k,iCell) = (tracersGroupCur(:,k,iCell) * layerThicknessCur(k,iCell) + dt * tracersGroupTend(:,k,iCell) ) & / layerThicknessNew(k,iCell) end do end do + !$omp end do end if end if end do if (config_use_freq_filtered_thickness) then + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) @@ -1441,6 +1556,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ lowFreqDivergenceNew(k,iCell) = lowFreqDivergenceCur(k,iCell) + dt * lowFreqDivergenceTend(k,iCell) end do end do + !$omp end do end if ! Recompute final u to go on to next step. @@ -1452,11 +1568,13 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ ! note that normalBaroclinicVelocity is recomputed at the beginning of the next timestep due to Imp Vert mixing, ! so normalBaroclinicVelocity does not have to be recomputed here. + !$omp do schedule(runtime) private(k) do iEdge = 1, nEdges do k = 1, maxLevelEdgeTop(iEdge) normalVelocityNew(k,iEdge) = normalBarotropicVelocityNew(iEdge) + 2 * normalBaroclinicVelocityNew(k,iEdge) - normalBaroclinicVelocityCur(k,iEdge) end do end do ! iEdges + !$omp end do endif ! split_explicit_step @@ -1491,6 +1609,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ end do call mpas_timer_start("se implicit vert mix") + block => domain % blocklist do while(associated(block)) call mpas_pool_get_subpool(block % structs, 'state', statePool) @@ -1512,11 +1631,13 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ if (config_use_standardGM) then call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) end if - call ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, err, 2) + call ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, scratchPool, err, 2) block => block % next end do + call mpas_threading_barrier() + ! Update halo on u and tracers, which were just updated for implicit vertical mixing. If not done, ! this leads to lack of volume conservation. It is required because halo updates in stage 3 are only ! conducted on tendencies, not on the velocity and tracer fields. So this update is required to @@ -1543,6 +1664,8 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_timer_stop("se implicit vert mix") + call mpas_threading_barrier() + block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', statePool) @@ -1551,7 +1674,6 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) - call mpas_pool_get_subpool(block % structs, 'average', averagePool) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityCur, 1) call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocityNew, 2) @@ -1581,11 +1703,15 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call mpas_pool_get_dimension(diagnosticsPool, 'index_SSHGradientMeridional', indexSSHGradientMeridional) if (config_prescribe_velocity) then + !$omp workshare normalVelocityNew(:,:) = normalVelocityCur(:,:) + !$omp end workshare end if if (config_prescribe_thickness) then + !$omp workshare layerThicknessNew(:,:) = layerThicknessCur(:,:) + !$omp end workshare end if call ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnosticsPool, scratchPool, tracersPool, 2) @@ -1598,24 +1724,30 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) end if + call mpas_threading_barrier() + !$omp master call mpas_reconstruct(meshPool, normalVelocityNew, & velocityX, velocityY, velocityZ, & velocityZonal, velocityMeridional, & - includeHalos = .true. ) + includeHalos = .true.) call mpas_reconstruct(meshPool, gradSSH, & gradSSHX, gradSSHY, gradSSHZ, & gradSSHZonal, gradSSHMeridional & ) + !$omp end master + call mpas_threading_barrier() + !$omp workshare surfaceVelocity(indexSurfaceVelocityZonal, :) = velocityZonal(1, :) surfaceVelocity(indexSurfaceVelocityMeridional, :) = velocityMeridional(1, :) SSHGradient(indexSSHGradientZonal, :) = gradSSHZonal(1, :) SSHGradient(indexSSHGradientMeridional, :) = gradSSHMeridional(1, :) + !$omp end workshare - call ocn_time_average_accumulate(averagePool, statePool, diagnosticsPool, 2) call ocn_time_average_coupled_accumulate(diagnosticsPool, statePool, forcingPool, 2) + call mpas_threading_barrier() if (config_use_standardGM) then call ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) @@ -1633,6 +1765,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ end if call mpas_timer_stop("se timestep", timer_main) + call mpas_threading_barrier() deallocate(n_bcl_iter) @@ -1698,8 +1831,8 @@ subroutine ocn_time_integration_split_init(domain)!{{{ ! This is only done upon start-up. if (trim(config_time_integrator) == 'unsplit_explicit') then call mpas_pool_get_array(statePool, 'normalBarotropicVelocity', normalBarotropicVelocity) - normalBarotropicVelocity(:) = 0.0 + normalBarotropicVelocity(:) = 0.0 normalBaroclinicVelocity(:,:) = normalVelocity(:,:) elseif (trim(config_time_integrator) == 'split_explicit') then @@ -1751,9 +1884,10 @@ subroutine ocn_time_integration_split_init(domain)!{{{ if (config_filter_btr_mode) then ! filter normalBarotropicVelocity out of initial condition - normalVelocity(:,:) = normalBaroclinicVelocity(:,:) + normalVelocity(:,:) = normalBaroclinicVelocity(:,:) normalBarotropicVelocity(:) = 0.0 + endif endif diff --git a/src/core_ocean/mode_init/Registry_global_ocean.xml b/src/core_ocean/mode_init/Registry_global_ocean.xml index 22f55c95dd..c33edb1ecf 100644 --- a/src/core_ocean/mode_init/Registry_global_ocean.xml +++ b/src/core_ocean/mode_init/Registry_global_ocean.xml @@ -148,7 +148,7 @@ possible_values="Any positive real number." /> - + iocontext iocontext_ptr => iocontext @@ -1755,6 +1757,7 @@ subroutine ocn_init_validate_global_ocean(configPool, packagePool, iocontext, iE if(config_init_configuration .ne. trim('global_ocean')) return call mpas_pool_get_config(configPool, 'config_vert_levels', config_vert_levels) + call mpas_pool_get_config(configPool, 'config_global_ocean_depth_file', config_global_ocean_depth_file) call mpas_pool_get_config(configPool, 'config_global_ocean_depth_dimname', config_global_ocean_depth_dimname) call mpas_pool_get_config(configPool, 'config_global_ocean_temperature_file', config_global_ocean_temperature_file) diff --git a/src/core_ocean/shared/Makefile b/src/core_ocean/shared/Makefile index 31310d236d..27ddcce2c7 100644 --- a/src/core_ocean/shared/Makefile +++ b/src/core_ocean/shared/Makefile @@ -52,15 +52,14 @@ OBJS = mpas_ocn_init_routines.o \ mpas_ocn_effective_density_in_land_ice.o \ mpas_ocn_frazil_forcing.o \ mpas_ocn_forcing_restoring.o \ - mpas_ocn_time_average.o \ mpas_ocn_time_average_coupled.o \ mpas_ocn_sea_ice.o all: $(OBJS) -mpas_ocn_init_routines.o: mpas_ocn_constants.o mpas_ocn_time_average.o mpas_ocn_diagnostics.o mpas_ocn_gm.o +mpas_ocn_init_routines.o: mpas_ocn_constants.o mpas_ocn_diagnostics.o mpas_ocn_gm.o -mpas_ocn_tendency.o: mpas_ocn_time_average.o mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_restoring.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_surface_bulk_forcing.o mpas_ocn_surface_land_ice_fluxes.o mpas_ocn_tracer_surface_flux_to_tend.o mpas_ocn_tracer_interior_restoring.o mpas_ocn_tracer_exponential_decay.o mpas_ocn_tracer_ideal_age.o mpas_ocn_tracer_TTD.o mpas_ocn_vmix.o mpas_ocn_constants.o mpas_ocn_frazil_forcing.o +mpas_ocn_tendency.o: mpas_ocn_high_freq_thickness_hmix_del2.o mpas_ocn_tracer_surface_restoring.o mpas_ocn_thick_surface_flux.o mpas_ocn_tracer_short_wave_absorption.o mpas_ocn_tracer_advection.o mpas_ocn_tracer_hmix.o mpas_ocn_tracer_nonlocalflux.o mpas_ocn_surface_bulk_forcing.o mpas_ocn_surface_land_ice_fluxes.o mpas_ocn_tracer_surface_flux_to_tend.o mpas_ocn_tracer_interior_restoring.o mpas_ocn_tracer_exponential_decay.o mpas_ocn_tracer_ideal_age.o mpas_ocn_tracer_TTD.o mpas_ocn_vmix.o mpas_ocn_constants.o mpas_ocn_frazil_forcing.o mpas_ocn_diagnostics_routines.o: mpas_ocn_constants.o @@ -68,8 +67,6 @@ mpas_ocn_diagnostics.o: mpas_ocn_thick_ale.o mpas_ocn_diagnostics_routines.o mpa mpas_ocn_thick_ale.o: mpas_ocn_constants.o -mpas_ocn_time_average.o: - mpas_ocn_time_average_coupled.o: mpas_ocn_constants.o mpas_ocn_thick_hadv.o: mpas_ocn_constants.o diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics.F b/src/core_ocean/shared/mpas_ocn_diagnostics.F index d794d914e5..2aecf69f4c 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics.F @@ -24,6 +24,7 @@ module ocn_diagnostics use mpas_pool_routines use mpas_constants use mpas_timer + use mpas_threading use mpas_vector_reconstruction use ocn_constants @@ -242,9 +243,12 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ! ! initialize layerThicknessEdge to avoid divide by zero and NaN problems. + !$omp workshare layerThicknessEdge = -1.0e34 + !$omp end workshare coef_3rd_order = config_coef_3rd_order + !$omp do schedule(runtime) private(cell1, cell2, k) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -252,11 +256,14 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic layerThicknessEdge(k,iEdge) = 0.5 * (layerThickness(k,cell1) + layerThickness(k,cell2)) end do end do + !$omp end do ! ! set the velocity and height at dummy address ! used -1e34 so error clearly occurs if these values are used. ! + + !$omp workshare normalVelocity(:,nEdges+1) = -1e34 layerThickness(:,nCells+1) = -1e34 activeTracers(indexTemperature,:,nCells+1) = -1e34 @@ -266,10 +273,18 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic vertVelocityTop(:,:)=0.0 kineticEnergyCell(:,:) = 0.0 tangentialVelocity(:,:) = 0.0 + !$omp end workshare + + call mpas_threading_barrier() call ocn_relativeVorticity_circulation(relativeVorticity, circulation, meshPool, normalVelocity, err) + call mpas_threading_barrier() + !$omp workshare relativeVorticityCell(:,:) = 0.0 + !$omp end workshare + + !$omp do schedule(runtime) private(invAreaCell1, i, j, k, iVertex) do iCell = 1, nCells invAreaCell1 = 1.0 / areaCell(iCell) @@ -281,11 +296,14 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic end do end do end do + !$omp end do ! ! Compute divergence, kinetic energy, and vertical velocity ! allocate(div_hu(nVertLevels),div_huTransport(nVertLevels),div_huGMBolus(nVertLevels)) + + !$omp do schedule(runtime) private(invAreaCell1, iEdge, r_tmp, i, k) do iCell = 1, nCells div_hu(:) = 0.0 div_huTransport(:) = 0.0 @@ -313,8 +331,11 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic vertGMBolusVelocityTop(k,iCell) = vertGMBolusVelocityTop(k+1,iCell) - div_huGMBolus(k) end do end do + !$omp end do + deallocate(div_hu,div_huTransport,div_huGMBolus) + !$omp do schedule(runtime) private(eoe, i, k) do iEdge = 1, nEdges ! Compute v (tangential) velocities do i = 1, nEdgesOnEdge(iEdge) @@ -324,6 +345,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic end do end do end do + !$omp end do ! ! Compute kinetic energy @@ -332,10 +354,16 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic call mpas_pool_get_field(scratchPool, 'kineticEnergyVertexOnCells', kineticEnergyVertexOnCellsField) call mpas_allocate_scratch_field(kineticEnergyVertexField, .true.) call mpas_allocate_scratch_field(kineticEnergyVertexOnCellsField, .true.) + call mpas_threading_barrier() + kineticEnergyVertex => kineticEnergyVertexField % array kineticEnergyVertexOnCells => kineticEnergyVertexOnCellsField % array + + !$omp workshare kineticEnergyVertex(:,:) = 0.0; kineticEnergyVertexOnCells(:,:) = 0.0 + !$omp end workshare + !$omp do schedule(runtime) private(i, iEdge, r_tmp, k) do iVertex = 1, nVertices*ke_vertex_flag do i = 1, vertexDegree iEdge = edgesOnVertex(i, iVertex) @@ -345,7 +373,9 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic end do end do end do + !$omp end do + !$omp do schedule(runtime) private(invAreaCell1, i, j, iVertex, k) do iCell = 1, nCells*ke_vertex_flag invAreaCell1 = 1.0 / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) @@ -356,16 +386,20 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic end do end do end do - + !$omp end do + ! ! Compute kinetic energy in each cell by blending kineticEnergyCell and kineticEnergyVertexOnCells ! + !$omp do schedule(runtime) private(k) do iCell = 1, nCells * ke_vertex_flag do k = 1, nVertLevels kineticEnergyCell(k,iCell) = 5.0 / 8.0 * kineticEnergyCell(k,iCell) + 3.0 / 8.0 * kineticEnergyVertexOnCells(k,iCell) end do end do + !$omp end do + call mpas_threading_barrier() call mpas_deallocate_scratch_field(kineticEnergyVertexField, .true.) call mpas_deallocate_scratch_field(kineticEnergyVertexOnCellsField, .true.) @@ -376,8 +410,12 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic call mpas_pool_get_field(scratchPool, 'normalizedPlanetaryVorticityVertex', normalizedPlanetaryVorticityVertexField) call mpas_allocate_scratch_field(normalizedRelativeVorticityVertexField, .true.) call mpas_allocate_scratch_field(normalizedPlanetaryVorticityVertexField, .true.) + call mpas_threading_barrier() + normalizedPlanetaryVorticityVertex => normalizedPlanetaryVorticityVertexField % array normalizedRelativeVorticityVertex => normalizedRelativeVorticityVertexField % array + + !$omp do schedule(runtime) private(invAreaTri1, k, layerThicknessVertex, i) do iVertex = 1, nVertices invAreaTri1 = 1.0 / areaTriangle(iVertex) do k = 1, maxLevelVertexBot(iVertex) @@ -391,9 +429,13 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic normalizedPlanetaryVorticityVertex(k,iVertex) = fVertex(iVertex) / layerThicknessVertex end do end do + !$omp end do + !$omp workshare normalizedRelativeVorticityEdge(:,:) = 0.0 normalizedPlanetaryVorticityEdge(:,:) = 0.0 + !$omp end workshare + !$omp do schedule(runtime) private(vertex1, vertex2, k) do iEdge = 1, nEdges vertex1 = verticesOnEdge(1, iEdge) vertex2 = verticesOnEdge(2, iEdge) @@ -402,8 +444,12 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic normalizedPlanetaryVorticityEdge(k, iEdge) = 0.5 * (normalizedPlanetaryVorticityVertex(k, vertex1) + normalizedPlanetaryVorticityVertex(k, vertex2)) end do end do + !$omp end do + !$omp workshare normalizedRelativeVorticityCell(:,:) = 0.0 + !$omp end workshare + !$omp do schedule(runtime) private(invAreaCell1, i, j, iVertex, k) do iCell = 1, nCells invAreaCell1 = 1.0 / areaCell(iCell) @@ -416,6 +462,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic end do end do end do + !$omp end do ! Diagnostics required for the Anticipated Potential Vorticity Method (apvm). if (config_apvm_scale_factor>1e-10) then @@ -424,9 +471,12 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic call mpas_pool_get_field(scratchPool, 'vorticityGradientTangentialComponent', vorticityGradientTangentialComponentField) call mpas_allocate_scratch_field(vorticityGradientNormalComponentField, .true.) call mpas_allocate_scratch_field(vorticityGradientTangentialComponentField, .true.) + call mpas_threading_barrier() + vorticityGradientNormalComponent => vorticityGradientNormalComponentField % array vorticityGradientTangentialComponent => vorticityGradientTangentialComponentField % array + !$omp do schedule(runtime) private(cell1, cell2, vertex1, vertex2, invLength, k) do iEdge = 1,nEdges cell1 = cellsOnEdge(1, iEdge) cell2 = cellsOnEdge(2, iEdge) @@ -450,10 +500,12 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic enddo enddo + !$omp end do ! ! Modify PV edge with upstream bias. ! + !$omp do schedule(runtime) private(k) do iEdge = 1,nEdges do k = 1,maxLevelEdgeBot(iEdge) normalizedRelativeVorticityEdge(k,iEdge) = normalizedRelativeVorticityEdge(k,iEdge) & @@ -462,10 +514,15 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic + tangentialVelocity(k,iEdge) * vorticityGradientTangentialComponent(k,iEdge) ) enddo enddo + !$omp end do + + call mpas_threading_barrier() call mpas_deallocate_scratch_field(vorticityGradientNormalComponentField, .true.) call mpas_deallocate_scratch_field(vorticityGradientTangentialComponentField, .true.) endif + + call mpas_threading_barrier() call mpas_deallocate_scratch_field(normalizedRelativeVorticityVertexField, .true.) call mpas_deallocate_scratch_field(normalizedPlanetaryVorticityVertexField, .true.) @@ -473,27 +530,31 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ! equation of state ! call mpas_timer_start("equation of state", .false., diagEOSTimer) + call mpas_threading_barrier() ! compute in-place density if (config_pressure_gradient_type.eq.'Jacobian_from_TS') then ! only compute EOS derivatives if needed. call mpas_pool_get_array(diagnosticsPool, 'inSituThermalExpansionCoeff',inSituThermalExpansionCoeff) call mpas_pool_get_array(diagnosticsPool, 'inSituSalineContractionCoeff', inSituSalineContractionCoeff) - call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 0, 'relative', density, err, & + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, scratchPool, 0, 'relative', density, err, & inSituThermalExpansionCoeff, inSituSalineContractionCoeff, timeLevelIn=timeLevel) else - call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 0, 'relative', density, err, & + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, scratchPool, 0, 'relative', density, err, & timeLevelIn=timeLevel) endif + call mpas_threading_barrier() ! compute potentialDensity, the density displaced adiabatically to the mid-depth of top layer. - call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 1, 'absolute', potentialDensity, err, timeLevelIn=timeLevel) + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, scratchPool, 1, 'absolute', potentialDensity, err, timeLevelIn=timeLevel) ! compute displacedDensity, density displaced adiabatically to the mid-depth one layer deeper. ! That is, layer k has been displaced to the depth of layer k+1. - call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 1, 'relative', displacedDensity, err, timeLevelIn=timeLevel) + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, scratchPool, 1, 'relative', displacedDensity, err, timeLevelIn=timeLevel) + call mpas_threading_barrier() call mpas_timer_stop("equation of state", diagEOSTimer) + call mpas_threading_barrier() ! ! Pressure @@ -504,7 +565,10 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ! use Montgomery Potential when layers are isopycnal. ! However, one may use 'pressure_and_zmid' when layers are isopycnal as well. ! Compute pressure at top of each layer, and then Montgomery Potential. + allocate(pTop(nVertLevels)) + + !$omp do schedule(runtime) private(k) do iCell = 1, nCells ! assume atmospheric pressure at the surface is zero for now. @@ -523,10 +587,13 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic end do end do + !$omp end do + deallocate(pTop) else + !$omp do schedule(runtime) private(k) do iCell = 1, nCells ! Pressure for generalized coordinates. ! Pressure at top surface may be due to atmospheric pressure @@ -562,6 +629,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ssh(iCell) = zTop(1,iCell) end do + !$omp end do endif @@ -569,6 +637,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ! Brunt-Vaisala frequency (this has units of s^{-2}) ! coef = -gravity / rho_sw + !$omp do schedule(runtime) private(k) do iCell = 1, nCells BruntVaisalaFreqTop(1,iCell) = 0.0 do k = 2, maxLevelCell(iCell) @@ -576,11 +645,13 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic / (zMid(k-1,iCell) - zMid(k,iCell)) end do end do + !$omp end do ! ! Gradient Richardson number ! RiTopOfCell = 100.0 + !$omp do schedule(runtime) private(invAreaCell1, k, shearSquared, i, iEdge, factor, delU2, shearMean) do iCell=1,nCells invAreaCell1 = 1.0 / areaCell(iCell) do k=2,maxLevelCell(iCell) @@ -597,6 +668,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic end do RiTopOfCell(1,iCell) = RiTopOfCell(2,iCell) end do + !$omp end do ! ! extrapolate tracer values to ocean surface @@ -604,17 +676,22 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic ! at present, just copy k=1 tracer values onto surface values ! field will be updated below is better approximations are available + !$omp workshare !TDR need to consider how to handel tracersSurfaceValues - tracersSurfaceValue(:,:) = activeTracers(:,1,:) normalVelocitySurfaceLayer(:) = normalVelocity(1,:) + !$omp end workshare ! ! average tracer values over the ocean surface layer ! the ocean surface layer is generally assumed to be about 0.1 of the boundary layer depth if(config_use_cvmix_kpp) then + + !$omp workshare tracersSurfaceLayerValue(:,:) = 0.0 indexSurfaceLayerDepth(:) = -9.e30 + !$omp end workshare + !$omp do schedule(runtime) private(surfaceLayerDepth, sumSurfaceLayer, k, rSurfaceLayer) do iCell=1,nCells surfaceLayerDepth = config_cvmix_kpp_surface_layer_averaging sumSurfaceLayer=0.0 @@ -634,17 +711,22 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic tracersSurfaceLayerValue(:,iCell) = tracersSurfaceLayerValue(:,iCell) + fraction(rSurfaceLayer)*activeTracers(:,k,iCell)*layerThickness(k,iCell) tracersSurfaceLayerValue(:,iCell) = tracersSurfaceLayerValue(:,iCell) / surfaceLayerDepth enddo + !$omp end do ! ! average normal velocity values over the ocean surface layer ! the ocean surface layer is generally assumed to be about 0.1 of the boundary layer depth ! + !$omp workshare normalVelocitySurfaceLayer(:) = 0.0_RKIND + !$omp end workshare + !$omp do schedule(runtime) private(cell1, cell2, surfaceLayerDepth, sumSurfaceLayer, k, rSurfaceLayer) do iEdge=1,nEdges cell1=cellsOnEdge(1,iEdge) cell2=cellsOnEdge(2,iEdge) surfaceLayerDepth = config_cvmix_kpp_surface_layer_averaging sumSurfaceLayer=0.0 + rSurfaceLayer = min(1, maxLevelEdgeTop(iEdge)) do k=1,maxLevelEdgeTop(iEdge) rSurfaceLayer = k sumSurfaceLayer = sumSurfaceLayer + layerThicknessEdge(k,iEdge) @@ -663,6 +745,7 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic normalVelocitySurfaceLayer(iEdge) = normalVelocitySurfaceLayer(iEdge) / surfaceLayerDepth end if enddo + !$omp end do ! ! compute fields used as intent(in) to CVMix/KPP @@ -670,7 +753,9 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic endif ! compute the attenuation coefficient for surface fluxes + !$omp workshare surfaceFluxAttenuationCoefficient(:) = config_flux_attenuation_coefficient + !$omp end workshare ! ! compute fields needed to compute land-ice fluxes, either in the ocean model or in the coupler @@ -679,12 +764,16 @@ subroutine ocn_diagnostic_solve(dt, statePool, forcingPool, meshPool, diagnostic diagnosticsPool, timeLevel) call mpas_timer_stop("land_ice_diagnostic_fields") + !$omp do schedule(runtime) private(cell1, cell2) do iEdge = 1, nEdges cell1 = cellsOnEdge(1, iEdge) cell2 = cellsOnEdge(2, iEdge) gradSSH(1, iEdge) = (ssh(cell2) - ssh(cell1)) / dcEdge(iEdge) end do + !$omp end do + + call mpas_threading_barrier() @@ -702,7 +791,7 @@ end subroutine ocn_diagnostic_solve!}}} !> cell. ! !----------------------------------------------------------------------- - subroutine ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, oldLayerThickness, layerThicknessEdge, & + subroutine ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, scratchPool, oldLayerThickness, layerThicknessEdge, & normalVelocity, oldSSH, dt, vertAleTransportTop, err, newHighFreqThickness)!{{{ !----------------------------------------------------------------- @@ -717,6 +806,8 @@ subroutine ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, oldLayerT type (mpas_pool_type), intent(in) :: & verticalMeshPool !< Input: vertical mesh information + type (mpas_pool_type), intent(in) :: scratchPool !< Input: scratch variables + real (kind=RKIND), dimension(:,:), intent(in) :: & oldLayerThickness !< Input: layer thickness at old time @@ -760,11 +851,18 @@ subroutine ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, oldLayerT real (kind=RKIND) :: flux, invAreaCell real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell - real (kind=RKIND), dimension(:), allocatable :: & + !real (kind=RKIND), dimension(:), allocatable :: & + ! div_hu_btr !> barotropic divergence of (thickness*velocity) + real (kind=RKIND), dimension(:), pointer :: & div_hu_btr !> barotropic divergence of (thickness*velocity) - real (kind=RKIND), dimension(:,:), allocatable :: & + type (field1DReal), pointer :: div_hu_btrField + !real (kind=RKIND), dimension(:,:), allocatable :: & + ! ALE_Thickness, & !> ALE thickness at new time + ! div_hu !> divergence of (thickness*velocity) + real (kind=RKIND), dimension(:,:), pointer :: & ALE_Thickness, & !> ALE thickness at new time div_hu !> divergence of (thickness*velocity) + type (field2DReal), pointer :: ALE_ThicknessField, div_huField character (len=StrKIND), pointer :: config_vert_coord_movement @@ -788,12 +886,26 @@ subroutine ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, oldLayerT return end if - allocate(div_hu(nVertLevels,nCells), div_hu_btr(nCells), ALE_Thickness(nVertLevels,nCells)) + + !allocate(div_hu(nVertLevels,nCells), div_hu_btr(nCells), ALE_Thickness(nVertLevels,nCells)) + call mpas_pool_get_field(scratchPool, 'div_hu', div_huField) + call mpas_pool_get_field(scratchPool, 'div_hu_btr', div_hu_btrField) + call mpas_pool_get_field(scratchPool, 'ALE_Thickness', ALE_ThicknessField) + call mpas_allocate_scratch_field(div_huField, .true.) + call mpas_allocate_scratch_field(div_hu_btrField, .true.) + call mpas_allocate_scratch_field(ALE_ThicknessField, .true.) + + call mpas_threading_barrier() + + div_hu => div_huField % array + div_hu_btr => div_hu_btrField % array + ALE_Thickness => ALE_ThicknessField % array ! ! thickness-weighted divergence and barotropic divergence ! ! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3. + !$omp do schedule(runtime) private(invAreaCell, i, iEdge, k, flux) do iCell = 1, nCells div_hu(:,iCell) = 0.0 div_hu_btr(iCell) = 0.0 @@ -807,8 +919,8 @@ subroutine ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, oldLayerT div_hu_btr(iCell) = div_hu_btr(iCell) - flux end do end do - - enddo + end do + !$omp end do ! ! Compute desired thickness at new time @@ -819,6 +931,8 @@ subroutine ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, oldLayerT call ocn_ALE_thickness(meshPool, verticalMeshPool, oldSSH, div_hu_btr, dt, ALE_thickness, err) endif + call mpas_threading_barrier() + ! ! Vertical transport through layer interfaces ! @@ -826,6 +940,7 @@ subroutine ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, oldLayerT ! Here we are using solving the continuity equation for vertAleTransportTop ($w^t$), ! and using ALE_Thickness for thickness at the new time. + !$omp do schedule(runtime) private(k) do iCell = 1,nCells vertAleTransportTop(1,iCell) = 0.0 vertAleTransportTop(maxLevelCell(iCell)+1,iCell) = 0.0 @@ -834,8 +949,12 @@ subroutine ocn_vert_transport_velocity_top(meshPool, verticalMeshPool, oldLayerT - (ALE_Thickness(k,iCell) - oldLayerThickness(k,iCell))/dt end do end do + !$omp end do - deallocate(div_hu, div_hu_btr, ALE_Thickness) + call mpas_threading_barrier() + call mpas_deallocate_scratch_field(div_huField, .true.) + call mpas_deallocate_scratch_field(div_hu_btrField, .true.) + call mpas_deallocate_scratch_field(ALE_ThicknessField, .true.) end subroutine ocn_vert_transport_velocity_top!}}} @@ -875,6 +994,7 @@ subroutine ocn_fuperp(statePool, meshPool, timeLevelIn)!{{{ end if call mpas_timer_start("ocn_fuperp") + call mpas_threading_barrier() call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) call mpas_pool_get_array(statePool, 'normalBaroclinicVelocity', normalBaroclinicVelocity, timeLevel) @@ -890,9 +1010,12 @@ subroutine ocn_fuperp(statePool, meshPool, timeLevelIn)!{{{ call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + !DWJ: ADD OMP (Only needed for split explicit) + ! ! Put f*normalBaroclinicVelocity^{perp} in u as a work variable ! + !$omp do schedule(runtime) private(cell1, cell2, k, eoe) do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -906,7 +1029,9 @@ subroutine ocn_fuperp(statePool, meshPool, timeLevelIn)!{{{ end do end do end do + !$omp end do + call mpas_threading_barrier() call mpas_timer_stop("ocn_fuperp") end subroutine ocn_fuperp!}}} @@ -939,7 +1064,6 @@ subroutine ocn_filter_btr_mode_vel(statePool, diagnosticsPool, meshPool, timeLev call mpas_timer_start("ocn_filter_btr_mode_vel") - if (present(timeLevelIn)) then timeLevel = timeLevelIn else @@ -954,6 +1078,7 @@ subroutine ocn_filter_btr_mode_vel(statePool, diagnosticsPool, meshPool, timeLev call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + !$omp do schedule(runtime) private(normalThicknessFluxSum, thicknessSum, k, vertSum) do iEdge = 1, nEdges ! thicknessSum is initialized outside the loop because on land boundaries @@ -972,6 +1097,9 @@ subroutine ocn_filter_btr_mode_vel(statePool, diagnosticsPool, meshPool, timeLev normalVelocity(k,iEdge) = normalVelocity(k,iEdge) - vertSum enddo enddo ! iEdge + !$omp end do + + call mpas_threading_barrier() call mpas_timer_stop("ocn_filter_btr_mode_vel") @@ -1021,6 +1149,7 @@ subroutine ocn_filter_btr_mode_tend_vel(tendPool, statePool, diagnosticsPool, me call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + !$omp do schedule(runtime) private(normalThicknessFluxSum, thicknessSum, vertSum, k) do iEdge = 1, nEdges ! thicknessSum is initialized outside the loop because on land boundaries @@ -1039,6 +1168,7 @@ subroutine ocn_filter_btr_mode_tend_vel(tendPool, statePool, diagnosticsPool, me tend_normalVelocity(k,iEdge) = tend_normalVelocity(k,iEdge) - vertSum enddo enddo ! iEdge + !$omp end do call mpas_timer_stop("ocn_filter_btr_mode_tend_vel") @@ -1145,7 +1275,6 @@ subroutine ocn_compute_KPP_input_fields(statePool, forcingPool, meshPool, diagno integer, pointer :: indexTempFlux, indexSaltFlux real (kind=RKIND) :: numerator, denominator, turbulentVelocitySquared real (kind=RKIND) :: buoyContribution, shearContribution, factor, deltaVelocitySquared, delU2, invAreaCell - real (kind=RKIND), dimension(:), allocatable :: buoySmoothed, shearSmoothed type (field2DReal), pointer :: densitySurfaceDisplacedField, thermalExpansionCoeffField, salineContractionCoeffField @@ -1202,18 +1331,17 @@ subroutine ocn_compute_KPP_input_fields(statePool, forcingPool, meshPool, diagno call mpas_allocate_scratch_field(densitySurfaceDisplacedField, .true.) call mpas_allocate_scratch_field(thermalExpansionCoeffField, .true.) call mpas_allocate_scratch_field(salineContractionCoeffField, .true.) + call mpas_threading_barrier() + densitySurfaceDisplaced => densitySurfaceDisplacedField % array thermalExpansionCoeff => thermalExpansionCoeffField % array salineContractionCoeff => salineContractionCoeffField % array - ! allocate local work space - allocate(buoySmoothed(nVertLevels)) - allocate(shearSmoothed(nVertLevels)) - ! compute EOS by displacing SST/SSS to every vertical layer in column - call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 0, 'surfaceDisplaced', densitySurfaceDisplaced, err, & + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, scratchPool, 0, 'surfaceDisplaced', densitySurfaceDisplaced, err, & thermalExpansionCoeff, salineContractionCoeff, timeLevel) + !$omp do schedule(runtime) private(invAreaCell, deltaVelocitySquared, i, iEdge, factor, delU2, k, buoyContribution, shearContribution) do iCell = 1, nCells invAreaCell = 1.0 / areaCell(iCell) @@ -1255,17 +1383,15 @@ subroutine ocn_compute_KPP_input_fields(statePool, forcingPool, meshPool, diagno enddo + !$omp end do + call mpas_threading_barrier() ! deallocate scratch space call mpas_deallocate_scratch_field(densitySurfaceDisplacedField, .true.) call mpas_deallocate_scratch_field(thermalExpansionCoeffField, .true.) call mpas_deallocate_scratch_field(salineContractionCoeffField, .true.) - ! deallocate local work space - deallocate(buoySmoothed) - deallocate(shearSmoothed) - end subroutine ocn_compute_KPP_input_fields!}}} @@ -1410,6 +1536,7 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & call mpas_pool_get_field(scratchPool, 'boundaryLayerSalinityScratch', boundaryLayerSalinityField) call mpas_allocate_scratch_field(boundaryLayerTemperatureField, .true.) call mpas_allocate_scratch_field(boundaryLayerSalinityField, .true.) + call mpas_threading_barrier() blTempScratch => boundaryLayerTemperatureField % array blSaltScratch => boundaryLayerSalinityField % array @@ -1418,6 +1545,7 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & end if ! Compute top drag + !$omp do schedule(runtime) private(cell1, cell2, velocityMagnitude, landIceEdgeFraction) do iEdge = 1, nEdges cell1 = cellsOnEdge(1, iEdge) cell2 = cellsOnEdge(2, iEdge) @@ -1430,8 +1558,10 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & * velocityMagnitude * normalVelocity(1,iEdge) end do + !$omp end do ! compute top drag magnitude and friction velocity at cell centers + !$omp do schedule(runtime) do iCell = 1, nCells ! the magnitude of the top drag is CD*u**2 = CD*(2*KE) topDragMagnitude(iCell) = rho_sw * landIceFraction(iCell) & @@ -1441,10 +1571,12 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & landIceFrictionVelocity(iCell) = sqrt(config_land_ice_flux_topDragCoeff* (2.0_RKIND * kineticEnergyCell(1,iCell) & + config_land_ice_flux_rms_tidal_velocity)) end do + !$omp end do ! average temperature and salinity over horizontal neighbors and the sub-ice-shelf boundary layer + !$omp do schedule(runtime) private(blThickness, iLevel, dz) do iCell = 1, nCells blThickness = 0.0_RKIND blTempScratch(iCell) = 0.0_RKIND @@ -1461,6 +1593,9 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & blSaltScratch(iCell) = blSaltScratch(iCell)/blThickness end if end do + !$omp end do + + !$omp do schedule(runtime) private(weightSum, i, cell2) do iCell = 1, nCells landIceBoundaryLayerTracers(indexBLT, iCell) = blTempScratch(iCell) landIceBoundaryLayerTracers(indexBLS, iCell) = blSaltScratch(iCell) @@ -1478,14 +1613,18 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & landIceBoundaryLayerTracers(:, iCell) = landIceBoundaryLayerTracers(:, iCell)/weightSum end if end do + !$omp end do if(jenkinsOn) then + !$omp do schedule(runtime) do iCell = 1, nCells ! transfer coefficients from namelist landIceTracerTransferVelocities(indexHeatTrans, iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_heat_transfer_coefficient landIceTracerTransferVelocities(indexSaltTrans, iCell) = landIceFrictionVelocity(iCell)*config_land_ice_flux_jenkins_salt_transfer_coefficient end do + !$omp end do else if(hollandJenkinsOn) then + !$omp do schedule(runtime) private(h_nu, Gamma_turb) do iCell = 1, nCells ! friction-velocity dependent non-dimensional transfer coefficients from ! Holland and Jenkins 1999, (14)-(16) with eta_* = 1 @@ -1500,22 +1639,25 @@ subroutine ocn_compute_land_ice_flux_input_fields(meshPool, statePool, & landIceTracerTransferVelocities(indexHeatTrans, iCell) = 1.0_RKIND/(Gamma_turb + 12.5_RKIND*Pr**(2.0_RKIND/3.0_RKIND) - 6.0_RKIND) landIceTracerTransferVelocities(indexSaltTrans, iCell) = 1.0_RKIND/(Gamma_turb + 12.5_RKIND*Sc**(2.0_RKIND/3.0_RKIND) - 6.0_RKIND) end do + !$omp end do end if + call mpas_threading_barrier() call mpas_deallocate_scratch_field(boundaryLayerTemperatureField, .true.) call mpas_deallocate_scratch_field(boundaryLayerSalinityField, .true.) ! recompute the spatially-varying attenuation coefficient based on landIceFraction + !$omp do schedule(runtime) do iCell = 1, nCells surfaceFluxAttenuationCoefficient(iCell) = landIceFraction(iCell)*config_land_ice_flux_attenuation_coefficient & + (1.0_RKIND - landIceFraction(iCell))*surfaceFluxAttenuationCoefficient(iCell) end do + !$omp end do !-------------------------------------------------------------------- end subroutine ocn_compute_land_ice_flux_input_fields!}}} - !*********************************************************************** ! ! routine ocn_reconstruct_gm_vectors @@ -1567,6 +1709,8 @@ subroutine ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) !{{{ call mpas_pool_get_array(diagnosticsPool, 'GMStreamFuncZonal', GMStreamFuncZonal) call mpas_pool_get_array(diagnosticsPool, 'GMStreamFuncMeridional', GMStreamFuncMeridional) + !$omp sections + !$omp section call mpas_reconstruct(meshPool, normalTransportVelocity, & transportVelocityX, & transportVelocityY, & @@ -1575,6 +1719,7 @@ subroutine ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) !{{{ transportVelocityMeridional & ) + !$omp section call mpas_reconstruct(meshPool, normalGMBolusVelocity, & GMBolusVelocityX, & GMBolusVelocityY, & @@ -1583,6 +1728,7 @@ subroutine ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) !{{{ GMBolusVelocityMeridional & ) + !$omp section call mpas_reconstruct(meshPool, relativeSlopeTopOfEdge, & relativeSlopeTopOfCellX, & relativeSlopeTopOfCellY, & @@ -1591,6 +1737,7 @@ subroutine ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) !{{{ relativeSlopeTopOfCellMeridional & ) + !$omp section call mpas_reconstruct(meshPool, gmStreamFuncTopOfEdge, & GMStreamFuncX, & GMStreamFuncY, & @@ -1598,6 +1745,7 @@ subroutine ocn_reconstruct_gm_vectors(diagnosticsPool, meshPool) !{{{ GMStreamFuncZonal, & GMStreamFuncMeridional & ) + !$omp end sections end subroutine ocn_reconstruct_gm_vectors!}}} diff --git a/src/core_ocean/shared/mpas_ocn_diagnostics_routines.F b/src/core_ocean/shared/mpas_ocn_diagnostics_routines.F index d69309f4ff..f19c27fa6a 100644 --- a/src/core_ocean/shared/mpas_ocn_diagnostics_routines.F +++ b/src/core_ocean/shared/mpas_ocn_diagnostics_routines.F @@ -122,8 +122,12 @@ subroutine ocn_relativeVorticity_circulation(relativeVorticity, circulation, mes err = 0 + !$omp workshare circulation(:,:) = 0.0 relativeVorticity(:,:) = 0.0 + !$omp end workshare + + !$omp do schedule(runtime) private(invAreaTri1, i, iEdge, k, r_tmp) do iVertex = 1, nVertices invAreaTri1 = 1.0 / areaTriangle(iVertex) do i = 1, vertexDegree @@ -136,7 +140,7 @@ subroutine ocn_relativeVorticity_circulation(relativeVorticity, circulation, mes end do end do end do - + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_effective_density_in_land_ice.F b/src/core_ocean/shared/mpas_ocn_effective_density_in_land_ice.F index 44f582bf43..ad056970c6 100644 --- a/src/core_ocean/shared/mpas_ocn_effective_density_in_land_ice.F +++ b/src/core_ocean/shared/mpas_ocn_effective_density_in_land_ice.F @@ -145,6 +145,7 @@ subroutine ocn_effective_density_in_land_ice_update(meshPool, forcingPool, state call mpas_allocate_scratch_field(effectiveDensityField, .true.) effectiveDensityScratch => effectiveDensityField % array + !$omp do schedule(runtime) do iCell = 1, nCells ! TODO: should only apply to floating land ice, once wetting/drying is supported if(landIceFraction(iCell) >= 0.5) then @@ -155,6 +156,9 @@ subroutine ocn_effective_density_in_land_ice_update(meshPool, forcingPool, state effectiveDensityScratch(iCell) = effectiveDensityCur(iCell) end if end do + !$omp end do + + !$omp do schedule(runtime) private(weightSum, i, cell2) do iCell = 1, nCells ! smooth/extrapolate by averaging with nearest neighbors weightSum = 1.0_RKIND @@ -167,6 +171,7 @@ subroutine ocn_effective_density_in_land_ice_update(meshPool, forcingPool, state end do effectiveDensityNew(iCell) = effectiveDensityNew(iCell)/weightSum end do + !$omp end do call mpas_deallocate_scratch_field(effectiveDensityField, .true.) !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_equation_of_state.F b/src/core_ocean/shared/mpas_ocn_equation_of_state.F index 5755fdccbd..b61e6912d8 100644 --- a/src/core_ocean/shared/mpas_ocn_equation_of_state.F +++ b/src/core_ocean/shared/mpas_ocn_equation_of_state.F @@ -72,7 +72,7 @@ module ocn_equation_of_state ! !----------------------------------------------------------------------- - subroutine ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, k_displaced, displacement_type, density, err, & + subroutine ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, scratchPool, k_displaced, displacement_type, density, err, & thermalExpansionCoeff, salineContractionCoeff, timeLevelIn)!{{{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! This module contains routines necessary for computing the density @@ -96,6 +96,7 @@ subroutine ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, k type (mpas_pool_type), intent(in) :: statePool type (mpas_pool_type), intent(inout) :: diagnosticsPool type (mpas_pool_type), intent(in) :: meshPool + type (mpas_pool_type), intent(in) :: scratchPool !< Input/Output: Scratch structure integer, intent(in), optional :: timeLevelIn type (mpas_pool_type), pointer :: tracersPool integer :: k_displaced @@ -135,7 +136,7 @@ subroutine ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, k elseif (jmEos) then - call ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_type, indexT, indexS, activeTracers, density, err, & + call ocn_equation_of_state_jm_density(meshPool, scratchPool, k_displaced, displacement_type, indexT, indexS, activeTracers, density, err, & tracersSurfaceValue, thermalExpansionCoeff, salineContractionCoeff) endif diff --git a/src/core_ocean/shared/mpas_ocn_equation_of_state_jm.F b/src/core_ocean/shared/mpas_ocn_equation_of_state_jm.F index e769be8dc0..9f7678b046 100644 --- a/src/core_ocean/shared/mpas_ocn_equation_of_state_jm.F +++ b/src/core_ocean/shared/mpas_ocn_equation_of_state_jm.F @@ -80,7 +80,7 @@ module ocn_equation_of_state_jm ! !----------------------------------------------------------------------- - subroutine ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_type, & + subroutine ocn_equation_of_state_jm_density(meshPool, scratchPool, k_displaced, displacement_type, & indexT, indexS, tracers, density, err, & tracersSurfaceLayerValue, thermalExpansionCoeff, salineContractionCoeff)!{{{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -107,6 +107,7 @@ subroutine ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_ implicit none type (mpas_pool_type), intent(in) :: meshPool + type (mpas_pool_type), intent(in) :: scratchPool !< Input/Output: Scratch structure integer, intent(in) :: k_displaced, indexT, indexS character(len=*), intent(in) :: displacement_type real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers @@ -117,7 +118,6 @@ subroutine ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_ thermalExpansionCoeff, &! Thermal expansion coefficient (alpha), defined as $-1/\rho d\rho/dT$ (note negative sign) salineContractionCoeff ! Saline contraction coefficient (beta), defined as $1/\rho d\rho/dS$ - type (dm_info) :: dminfo integer :: iEdge, iCell, iVertex, k, k_displaced_local integer, pointer :: nCells, nEdges, nVertices, nVertLevels integer, dimension(:), pointer :: maxLevelCell @@ -137,14 +137,20 @@ subroutine ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_ refBottomDepth, pRefEOS real (kind=RKIND), dimension(:), allocatable :: & p, p2 ! temporary pressure scalars - real (kind=RKIND), dimension(:,:), allocatable :: & + real (kind=RKIND), dimension(:,:), pointer :: & TQ,SQ, &! adjusted T,S BULK_MOD, &! Bulk modulus SQR,DENOMK, &! work arrays RHO_S, &! density at the surface WORK1, WORK2, WORK3, WORK4, T2 - real (kind=RKIND), dimension(:,:,:), allocatable :: & - tracerTS + type (field2DReal), pointer :: & + TQField,SQField, &! adjusted T,S + BULK_MODField, &! Bulk modulus + SQRField,DENOMKField, &! work arrays + RHO_SField, &! density at the surface + WORK1Field, WORK2Field, WORK3Field, WORK4Field, T2Field + real (kind=RKIND), dimension(:), allocatable :: & + tracerTemp, tracerSalt !----------------------------------------------------------------------- ! @@ -225,28 +231,9 @@ subroutine ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_ call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(meshPool, 'nCells', nCells) -! allocate local T,S tracer field - allocate(tracerTS(2,nVertLevels,nCells+1)) + allocate(tracerTemp(nVertLevels)) + allocate(tracerSalt(nVertLevels)) -! fill tracerTS - if (displacement_type == 'surfaceDisplaced') then - if(present(tracersSurfaceLayerValue)) then - do k=1,nVertLevels - tracerTS(1,k,:) = tracersSurfaceLayerValue(indexT,:) - tracerTS(2,k,:) = tracersSurfaceLayerValue(indexS,:) - enddo - displacement_type_local = 'relative' - k_displaced_local = 0 - else - write (stderrUnit,*) 'Abort: tracersSurfaceLayerValue must be present' - call mpas_dmpar_abort(dminfo) - endif - else - tracerTS(1,:,:) = tracers(indexT,:,:) - tracerTS(2,:,:) = tracers(indexS,:,:) - displacement_type_local = trim(displacement_type) - k_displaced_local = k_displaced - endif ! Jackett and McDougall tmin = -2.0 ! valid pot. temp. range @@ -260,9 +247,43 @@ subroutine ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_ ! integrating using hydrostatic balance. allocate(pRefEOS(nVertLevels),p(nVertLevels),p2(nVertLevels)) - allocate(TQ(nVertLevels,nCells),SQ(nVertLevels,nCells),BULK_MOD(nVertLevels,nCells),SQR(nVertLevels,nCells),DENOMK(nVertLevels,nCells), RHO_S(nVertLevels,nCells), & - WORK1(nVertLevels,nCells), WORK2(nVertLevels,nCells), WORK3(nVertLevels,nCells), WORK4(nVertLevels,nCells), T2(nVertLevels,nCells)) - + call mpas_pool_get_field(scratchPool, 'TQ', TQField) + call mpas_pool_get_field(scratchPool, 'SQ', SQField) + call mpas_pool_get_field(scratchPool, 'BULK_MOD', BULK_MODField) + call mpas_pool_get_field(scratchPool, 'SQR', SQRField) + call mpas_pool_get_field(scratchPool, 'DENOMK', DENOMKField) + call mpas_pool_get_field(scratchPool, 'RHO_S', RHO_SField) + call mpas_pool_get_field(scratchPool, 'WORK1', WORK1Field) + call mpas_pool_get_field(scratchPool, 'WORK2', WORK2Field) + call mpas_pool_get_field(scratchPool, 'WORK3', WORK3Field) + call mpas_pool_get_field(scratchPool, 'WORK4', WORK4Field) + call mpas_pool_get_field(scratchPool, 'T2', T2Field) + + call mpas_allocate_scratch_field(TQField, .true.) + call mpas_allocate_scratch_field(SQField, .true.) + call mpas_allocate_scratch_field(BULK_MODField, .true.) + call mpas_allocate_scratch_field(SQRField, .true.) + call mpas_allocate_scratch_field(DENOMKField, .true.) + call mpas_allocate_scratch_field(RHO_SField, .true.) + call mpas_allocate_scratch_field(WORK1Field, .true.) + call mpas_allocate_scratch_field(WORK2Field, .true.) + call mpas_allocate_scratch_field(WORK3Field, .true.) + call mpas_allocate_scratch_field(WORK4Field, .true.) + call mpas_allocate_scratch_field(T2Field, .true.) + + call mpas_threading_barrier() + + TQ => TQField % array + SQ => SQField % array + BULK_MOD => BULK_MODField % array + SQR => SQRField % array + DENOMK => DENOMKField % array + RHO_S => RHO_SField % array + WORK1 => WORK1Field % array + WORK2 => WORK2Field % array + WORK3 => WORK3Field % array + WORK4 => WORK4Field % array + T2 => T2Field % array ! This could be put in the init routine. ! Note I am using refBottomDepth, so pressure on top level does @@ -286,14 +307,25 @@ subroutine ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_ ! referenced to level k_displaced for all k ! NOTE: k_displaced = 0 or > nVertLevels is incompatible with 'absolute' ! so abort if necessary + if (displacement_type == 'surfaceDisplaced') then + if(present(tracersSurfaceLayerValue)) then + displacement_type_local = 'relative' + k_displaced_local = 0 + else + call mpas_dmpar_global_abort('ERROR: tracersSurfaceLayerValue must be present when displacement_type is ''surfaceDisplaced'' in JM EOS') + endif + else + displacement_type_local = trim(displacement_type) + k_displaced_local = k_displaced + endif if (displacement_type_local == 'absolute' .and. & (k_displaced_local <= 0 .or. k_displaced_local > nVertLevels) ) then write (stderrUnit,*) 'Abort: In equation_of_state_jm', & ' k_displaced must be between 1 and nVertLevels for ', & - 'displacement_type = absolute' - call mpas_dmpar_abort(dminfo) + 'displacement_type = absolute.' + call mpas_dmpar_global_abort('ERROR: k_displaced value invalide for JM EOS') endif if (k_displaced_local == 0) then @@ -315,10 +347,29 @@ subroutine ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_ enddo endif + !$omp do schedule(runtime) private(k) do iCell=1,nCells + if (displacement_type == 'surfaceDisplaced') then + if(present(tracersSurfaceLayerValue)) then + do k=1,nVertLevels + tracerTemp(k) = tracersSurfaceLayerValue(indexT,iCell) + tracerSalt(k) = tracersSurfaceLayerValue(indexS,iCell) + enddo + displacement_type_local = 'relative' + k_displaced_local = 0 + else + write (stderrUnit,*) 'Abort: tracersSurfaceLayerValue must be present' + call mpas_dmpar_global_abort('ERROR: tracersSurfaceLayerValue must be present in JM EOS call') + endif + else + tracerTemp(:) = tracers(indexT,:,iCell) + tracerSalt(:) = tracers(indexS,:,iCell) + displacement_type_local = trim(displacement_type) + k_displaced_local = k_displaced + endif do k=1,maxLevelCell(iCell) - SQ(k,iCell) = max(min(tracerTS(2,k,iCell),smax),smin) - TQ(k,iCell) = max(min(tracerTS(1,k,iCell),tmax),tmin) + SQ(k,iCell) = max(min(tracerSalt(k),smax),smin) + TQ(k,iCell) = max(min(tracerTemp(k),tmax),tmin) SQR(k,iCell) = sqrt(SQ(k,iCell)) T2(k,iCell) = TQ(k,iCell)*TQ(k,iCell) @@ -359,8 +410,10 @@ subroutine ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_ end do end do + !$omp end do if (present(thermalExpansionCoeff)) then + !$omp do schedule(runtime) private(k, DRDT0, DKDT, DRHODT) do iCell=1,nCells do k=1,maxLevelCell(iCell) DRDT0 = unt1 + 2.0*unt2*TQ(k,iCell) + & @@ -386,9 +439,11 @@ subroutine ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_ end do end do + !$omp end do endif if (present(salineContractionCoeff)) then + !$omp do schedule(runtime) private(k, DRDS0, DKDS, DRHODS) do iCell=1,nCells do k=1,maxLevelCell(iCell) DRDS0 = 2.0*uns2t0*SQ(k,iCell) + WORK1(k,iCell) + 1.5*WORK2(k,iCell) @@ -401,11 +456,26 @@ subroutine ocn_equation_of_state_jm_density(meshPool, k_displaced, displacement_ end do end do + !$omp end do endif deallocate(pRefEOS,p,p2) - deallocate(tracerTS) - deallocate(TQ,SQ,T2,BULK_MOD,SQR,DENOMK,RHO_S, WORK1, WORK2, WORK3, WORK4) + deallocate(tracerTemp) + deallocate(tracerSalt) + + call mpas_threading_barrier() + + call mpas_deallocate_scratch_field(TQField, .true.) + call mpas_deallocate_scratch_field(SQField, .true.) + call mpas_deallocate_scratch_field(BULK_MODField, .true.) + call mpas_deallocate_scratch_field(SQRField, .true.) + call mpas_deallocate_scratch_field(DENOMKField, .true.) + call mpas_deallocate_scratch_field(RHO_SField, .true.) + call mpas_deallocate_scratch_field(WORK1Field, .true.) + call mpas_deallocate_scratch_field(WORK2Field, .true.) + call mpas_deallocate_scratch_field(WORK3Field, .true.) + call mpas_deallocate_scratch_field(WORK4Field, .true.) + call mpas_deallocate_scratch_field(T2Field, .true.) end subroutine ocn_equation_of_state_jm_density!}}} diff --git a/src/core_ocean/shared/mpas_ocn_equation_of_state_linear.F b/src/core_ocean/shared/mpas_ocn_equation_of_state_linear.F index 7de9681a47..a8aef34373 100644 --- a/src/core_ocean/shared/mpas_ocn_equation_of_state_linear.F +++ b/src/core_ocean/shared/mpas_ocn_equation_of_state_linear.F @@ -142,6 +142,7 @@ subroutine ocn_equation_of_state_linear_density(meshPool, k_displaced, displacem ! if surfaceDisplaced, then compute density at all levels based on surface values if (displacement_type_local == 'surfaceDisplaced') then + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) ! Linear equation of state @@ -150,12 +151,14 @@ subroutine ocn_equation_of_state_linear_density(meshPool, k_displaced, displacem + config_eos_linear_beta * (tracersSurfaceLayerValue(indexS,iCell) - config_eos_linear_Sref) end do end do + !$omp end do endif ! if absolute, then compute density at all levels based on pressure of k_displaced value ! but since linear EOS does not (at present) have a pressure dependency, this just returns density if (displacement_type_local == 'absolute') then + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) ! Linear equation of state @@ -164,11 +167,13 @@ subroutine ocn_equation_of_state_linear_density(meshPool, k_displaced, displacem + config_eos_linear_beta * (tracers(indexS,k,iCell) - config_eos_linear_Sref) end do end do + !$omp end do endif ! if relative, then compute density at all levels based on k+k_displaced pressure value ! but since (at present) linear EOS has not dependence on pressure, it returns density if (displacement_type_local == 'relative') then + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) ! Linear equation of state @@ -177,22 +182,27 @@ subroutine ocn_equation_of_state_linear_density(meshPool, k_displaced, displacem + config_eos_linear_beta * (tracers(indexS,k,iCell) - config_eos_linear_Sref) end do end do + !$omp end do endif if (present(thermalExpansionCoeff)) then + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) thermalExpansionCoeff(k,iCell) = config_eos_linear_alpha / density(k,iCell) end do end do + !$omp end do endif if (present(salineContractionCoeff)) then + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) salineContractionCoeff(k,iCell) = config_eos_linear_beta / density(k,iCell) end do end do + !$omp end do endif end subroutine ocn_equation_of_state_linear_density!}}} diff --git a/src/core_ocean/shared/mpas_ocn_frazil_forcing.F b/src/core_ocean/shared/mpas_ocn_frazil_forcing.F index 0e38b19b71..e73ac44975 100644 --- a/src/core_ocean/shared/mpas_ocn_frazil_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_frazil_forcing.F @@ -173,11 +173,13 @@ subroutine ocn_frazil_forcing_layer_thickness(meshPool, forcingPool, layerThickn call mpas_pool_get_array(forcingPool, 'frazilLayerThicknessTendency', frazilLayerThicknessTendency) ! Build surface fluxes at cell centers + !$omp do schedule(runtime) private(k) do iCell = 1, nCells - do k = 1, maxLevelCell(iCell) - layerThicknessTend(k,iCell) = layerThicknessTend(k,iCell) + frazilLayerThicknessTendency(k,iCell) - end do + do k = 1, maxLevelCell(iCell) + layerThicknessTend(k,iCell) = layerThicknessTend(k,iCell) + frazilLayerThicknessTendency(k,iCell) + end do end do + !$omp end do end subroutine ocn_frazil_forcing_layer_thickness!}}} @@ -249,12 +251,14 @@ subroutine ocn_frazil_forcing_active_tracers(meshPool, tracersPool, forcingPool, call mpas_pool_get_array(forcingPool, 'frazilSalinityTendency', frazilSalinityTendency) ! add to surface fluxes at cell centers + !$omp do schedule(runtime) private(k) do iCell = 1, nCells - do k = 1, maxLevelCell(iCell) - activeTracersTend(indexTemperature,k,iCell) = activeTracersTend(indexTemperature,k,iCell) + frazilTemperatureTendency(k,iCell) - activeTracersTend(indexSalinity,k,iCell) = activeTracersTend(indexSalinity,k,iCell) + frazilSalinityTendency(k,iCell) - end do + do k = 1, maxLevelCell(iCell) + activeTracersTend(indexTemperature,k,iCell) = activeTracersTend(indexTemperature,k,iCell) + frazilTemperatureTendency(k,iCell) + activeTracersTend(indexSalinity,k,iCell) = activeTracersTend(indexSalinity,k,iCell) + frazilSalinityTendency(k,iCell) + end do end do + !$omp end do end subroutine ocn_frazil_forcing_active_tracers!}}} @@ -404,115 +408,116 @@ subroutine ocn_frazil_forcing_build_arrays(domain, meshPool, forcingPool, diagno frazilLayerThicknessTendency = 0.0_RKIND ! loop over all columns - do iCell=1,nCells - - ! find deepest level where frazil can be created - kBottomFrazil=maxLevelCell(iCell) - do k=maxLevelCell(iCell), 1, -1 - if(-zMid(k,iCell).lt.config_frazil_maximum_depth) then - kBottomFrazil=k - exit - endif - enddo - - ! find minimum temperature between 1:kBottomFrazil - columnTemperatureMin = 1.0e30_RKIND - do k=1,kBottomFrazil - if(activeTracers(indexTemperature,k,iCell).lt.columnTemperatureMin) columnTemperatureMin=activeTracers(indexTemperature,k,iCell) - enddo - - ! test min temperature agains max freezing temperature to see if we should even consider creating frazil - if(columnTemperatureMin.gt.config_frazil_maximum_freezing_temperature) cycle - - ! initialize the sum of new frazil ice created - sumNewFrazilIceThickness = 0.0_RKIND - - ! loop from maximum depth of frazil creation to surface - do k = kBottomFrazil, 1, -1 - - ! get freezing temperature - oceanFreezingTemperature = ocn_freezing_temperature(activeTracers(indexSalinity,k,iCell)) - - potential = layerThickness(k,iCell) * config_specific_heat_sea_water & - * rho_sw * (activeTracers(indexTemperature,k,iCell) - oceanFreezingTemperature) - freezingEnergy = max(0.0_RKIND, -potential) - meltingEnergy = max(0.0_RKIND, potential) - - if (freezingEnergy > 0) then - - ! new frazil ice formation measured in meters - newFrazilIceThickness = freezingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) - - ! limit the frazil formed appropriately - newFrazilIceThickness = min(newFrazilIceThickness, layerThickness(k,iCell) * config_frazil_fractional_thickness_limit) - + !$omp do schedule(runtime) private(kBottomFrazil, k, columnTemperatureMin, sumNewFrazilIceThickness, oceanFreezingTemperature, & + !$omp potential, freezingEnergy, meltingEnergy, newFrazilIceThickness, meltedFrazilIceThickness) + do iCell=1,nCells + + ! find deepest level where frazil can be created + kBottomFrazil=maxLevelCell(iCell) + do k=maxLevelCell(iCell), 1, -1 + if(-zMid(k,iCell).lt.config_frazil_maximum_depth) then + kBottomFrazil=k + exit + endif + enddo + + ! find minimum temperature between 1:kBottomFrazil + columnTemperatureMin = 1.0e30_RKIND + do k=1,kBottomFrazil + if(activeTracers(indexTemperature,k,iCell).lt.columnTemperatureMin) columnTemperatureMin=activeTracers(indexTemperature,k,iCell) + enddo + + ! test min temperature agains max freezing temperature to see if we should even consider creating frazil + if(columnTemperatureMin.gt.config_frazil_maximum_freezing_temperature) cycle + + ! initialize the sum of new frazil ice created + sumNewFrazilIceThickness = 0.0_RKIND + + ! loop from maximum depth of frazil creation to surface + do k = kBottomFrazil, 1, -1 + + ! get freezing temperature + oceanFreezingTemperature = ocn_freezing_temperature(activeTracers(indexSalinity,k,iCell)) + + potential = layerThickness(k,iCell) * config_specific_heat_sea_water & + * rho_sw * (activeTracers(indexTemperature,k,iCell) - oceanFreezingTemperature) + + freezingEnergy = max(0.0_RKIND, -potential) + meltingEnergy = max(0.0_RKIND, potential) + + if (freezingEnergy > 0) then + + ! new frazil ice formation measured in meters + newFrazilIceThickness = freezingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) + + ! limit the frazil formed appropriately + newFrazilIceThickness = min(newFrazilIceThickness, layerThickness(k,iCell) * config_frazil_fractional_thickness_limit) + + ! compute tendency to thickness, temperature and salinity + ! layerTendency is scaled so that mass of ice created == mass of ocean water removed + + ! layer thickness decreased due to creation of frazil + ! note: -- this has to be density (not rho_sw) to keep buoyancy equal + frazilLayerThicknessTendency(k,iCell) = - newFrazilIceThickness * config_frazil_sea_ice_density / density(k,iCell) / dt + + ! salt is extracted with the frazil + frazilSalinityTendency(k,iCell) = - newFrazilIceThickness * config_frazil_ice_reference_salinity / dt + + ! ocean fluid temperature is warmed due to creation of frazil + frazilTemperatureTendency(k,iCell) = + ( newFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density ) & + / (config_specific_heat_sea_water * rho_sw) / dt + + ! keep track of sum of frazil ice + sumNewFrazilIceThickness = sumNewFrazilIceThickness + newFrazilIceThickness + + else + + ! ocean water is warm enough to melt frazil + + ! test to see if there is frazil to be melted + if (sumNewFrazilIceThickness > 0.0_RKIND) then + + ! Frazil melting + meltedFrazilIceThickness = meltingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) + + ! limit melting by what there is to melt + meltedFrazilIceThickness = min(meltedFrazilIceThickness, sumNewFrazilIceThickness) + + ! limit melting by fraction of layer thickness + meltedFrazilIceThickness = min(meltedFrazilIceThickness, layerThickness(k,iCell)*config_frazil_fractional_thickness_limit) + ! compute tendency to thickness, temperature and salinity - ! layerTendency is scaled so that mass of ice created == mass of ocean water removed - - ! layer thickness decreased due to creation of frazil - ! note: -- this has to be density (not rho_sw) to keep buoyancy equal - frazilLayerThicknessTendency(k,iCell) = - newFrazilIceThickness * config_frazil_sea_ice_density / density(k,iCell) / dt - - ! salt is extracted with the frazil - frazilSalinityTendency(k,iCell) = - newFrazilIceThickness * config_frazil_ice_reference_salinity / dt - - ! ocean fluid temperature is warmed due to creation of frazil - frazilTemperatureTendency(k,iCell) = & - + ( newFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density ) & - / (config_specific_heat_sea_water * rho_sw) / dt - - ! keep track of sum of frazil ice - sumNewFrazilIceThickness = sumNewFrazilIceThickness + newFrazilIceThickness - - else - - ! ocean water is warm enough to melt frazil - - ! test to see if there is frazil to be melted - if (sumNewFrazilIceThickness > 0.0_RKIND) then - - ! Frazil melting - meltedFrazilIceThickness = meltingEnergy / (config_frazil_heat_of_fusion * config_frazil_sea_ice_density) - - ! limit melting by what there is to melt - meltedFrazilIceThickness = min(meltedFrazilIceThickness, sumNewFrazilIceThickness) - - ! limit melting by fraction of layer thickness - meltedFrazilIceThickness = min(meltedFrazilIceThickness, layerThickness(k,iCell)*config_frazil_fractional_thickness_limit) - - ! compute tendency to thickness, temperature and salinity - - ! layer thickness increases due to melting of frazil - ! note -- scaling by local ocean density to mimimize surface pressure forcing errors - frazilLayerThicknessTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_sea_ice_density / density(k,iCell) / dt - - ! salt is released into ocean with the melting frazil - frazilSalinityTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_ice_reference_salinity / dt - - ! ocean fluid temperature is cooled due to melting of frazil - frazilTemperatureTendency(k,iCell) = & - - ( meltedFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density ) & - / (config_specific_heat_sea_water * rho_sw) / dt - - ! keep track of new frazil ice - sumNewFrazilIceThickness = sumNewFrazilIceThickness - meltedFrazilIceThickness - - endif ! if (sumNewFrazilIceThickness > 0.0_RKIND) - - endif ! if (freezingEnergy < 0) - - enddo ! do k=kBottom,1-1 - - ! accumulate frazil mass to column total - ! note: the accumulatedFrazilIceMass (at both time levels) is reset to zero after being sent to the coupler - accumulatedFrazilIceMassNew(iCell) = accumulatedFrazilIceMassOld(iCell) + sumNewFrazilIceThickness*config_frazil_sea_ice_density - - ! sea surface pressure due to the net production of frazil ice - frazilSurfacePressure(iCell) = accumulatedFrazilIceMassNew(iCell) * gravity - - enddo ! do iCell = 1, nCells - - call mpas_timer_stop("frazil", timer_frazil) + + ! layer thickness increases due to melting of frazil + ! note -- scaling by local ocean density to mimimize surface pressure forcing errors + frazilLayerThicknessTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_sea_ice_density / density(k,iCell) / dt + + ! salt is released into ocean with the melting frazil + frazilSalinityTendency(k,iCell) = + meltedFrazilIceThickness * config_frazil_ice_reference_salinity / dt + + ! ocean fluid temperature is cooled due to melting of frazil + frazilTemperatureTendency(k,iCell) = - ( meltedFrazilIceThickness * config_frazil_heat_of_fusion * config_frazil_sea_ice_density ) & + / (config_specific_heat_sea_water * rho_sw) / dt + + ! keep track of new frazil ice + sumNewFrazilIceThickness = sumNewFrazilIceThickness - meltedFrazilIceThickness + + endif ! if (sumNewFrazilIceThickness > 0.0_RKIND) + + endif ! if (freezingEnergy < 0) + + enddo ! do k=kBottom,1-1 + + ! accumulate frazil mass to column total + ! note: the accumulatedFrazilIceMass (at both time levels) is reset to zero after being sent to the coupler + accumulatedFrazilIceMassNew(iCell) = accumulatedFrazilIceMassOld(iCell) + sumNewFrazilIceThickness*config_frazil_sea_ice_density + + ! sea surface pressure due to the net production of frazil ice + frazilSurfacePressure(iCell) = accumulatedFrazilIceMassNew(iCell) * gravity + + enddo ! do iCell = 1, nCells + + call mpas_timer_stop("frazil", timer_frazil) end subroutine ocn_frazil_forcing_build_arrays!}}} diff --git a/src/core_ocean/shared/mpas_ocn_gm.F b/src/core_ocean/shared/mpas_ocn_gm.F index d6fb0fd50a..5b1e80e731 100644 --- a/src/core_ocean/shared/mpas_ocn_gm.F +++ b/src/core_ocean/shared/mpas_ocn_gm.F @@ -11,6 +11,7 @@ module ocn_gm use mpas_pool_routines use mpas_timer use mpas_constants + use mpas_threading use ocn_constants @@ -97,19 +98,17 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) gradZMidTopOfEdge, relativeSlopeTopOfEdge, relativeSlopeTopOfCell, k33, gmStreamFuncTopOfEdge, BruntVaisalaFreqTop, gmStreamFuncTopOfCell, & dDensityDzTopOfEdge, dDensityDzTopOfCell, relativeSlopeTapering, relativeSlopeTaperingCell, areaCellSum real(kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge, tridiagA, tridiagB, tridiagC, rightHandSide - integer, dimension(:), pointer :: maxLevelEdgeTop, maxLevelCell - integer, dimension(:,:), pointer :: cellsOnEdge - integer :: k, iEdge, cell1, cell2, iCell, N + integer, dimension(:), pointer :: maxLevelEdgeTop, maxLevelCell, nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell + integer :: i, k, iEdge, cell1, cell2, iCell, N real(kind=RKIND) :: h1, h2, areaEdge, c, BruntVaisalaFreqTopEdge, rtmp, maxSlopeK33 ! Dimensions - integer, pointer :: nCells, nEdges + integer, pointer :: nCells, nEdges, nVertLevels type (field2DReal), pointer :: gradDensityEdgeField, gradDensityTopOfEdgeField, gradDensityConstZTopOfEdgeField, & gradZMidEdgeField, gradZMidTopOfEdgeField, dDensityDzTopOfCellField, dDensityDzTopOfEdgeField,areaCellSumField - type (field1DReal), pointer :: rightHandSideField, tridiagAField, tridiagBField, tridiagCField - call mpas_pool_get_array(diagnosticsPool, 'density', density) call mpas_pool_get_array(diagnosticsPool, 'displacedDensity', displacedDensity) call mpas_pool_get_array(diagnosticsPool, 'zMid', zMid) @@ -133,9 +132,12 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) call mpas_pool_get_array(meshPool, 'areaCell', areaCell) call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_field(scratchPool, 'gradDensityEdge', gradDensityEdgeField) call mpas_pool_get_field(scratchPool, 'gradDensityTopOfEdge', gradDensityTopOfEdgeField) @@ -144,10 +146,6 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) call mpas_pool_get_field(scratchPool, 'dDensityDzTopOfEdge', dDensityDzTopOfEdgeField) call mpas_pool_get_field(scratchPool, 'gradZMidEdge', gradZMidEdgeField) call mpas_pool_get_field(scratchPool, 'gradZMidTopOfEdge', gradZMidTopOfEdgeField) - call mpas_pool_get_field(scratchPool, 'rightHandSide', rightHandSideField) - call mpas_pool_get_field(scratchPool, 'tridiagA', tridiagAField) - call mpas_pool_get_field(scratchPool, 'tridiagB', tridiagBField) - call mpas_pool_get_field(scratchPool, 'tridiagC', tridiagCField) call mpas_pool_get_field(scratchPool, 'areaCellSum', areaCellSumField) call mpas_allocate_scratch_field(gradDensityEdgeField, .True.) @@ -157,12 +155,10 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) call mpas_allocate_scratch_field(dDensityDzTopOfEdgeField, .True.) call mpas_allocate_scratch_field(gradZMidEdgeField, .True.) call mpas_allocate_scratch_field(gradZMidTopOfEdgeField, .True.) - call mpas_allocate_scratch_field(rightHandSideField, .True.) - call mpas_allocate_scratch_field(tridiagAField, .True.) - call mpas_allocate_scratch_field(tridiagBField, .True.) - call mpas_allocate_scratch_field(tridiagCField, .True.) call mpas_allocate_scratch_field(areaCellSumField, .True.) + call mpas_threading_barrier() + gradDensityEdge => gradDensityEdgeField % array gradDensityTopOfEdge => gradDensityTopOfEdgeField % array gradDensityConstZTopOfEdge => gradDensityConstZTopOfEdgeField % array @@ -170,14 +166,16 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) dDensityDzTopOfEdge => dDensityDzTopOfEdgeField % array gradZMidEdge => gradZMidEdgeField % array gradZMidTopOfEdge => gradZMidTopOfEdgeField % array - rightHandSide => rightHandSideField % array - tridiagA => tridiagAField % array - tridiagB => tridiagBField % array - tridiagC => tridiagCField % array areaCellSum => areaCellSumField % array + allocate(rightHandSide(nVertLevels)) + allocate(tridiagA(nVertLevels)) + allocate(tridiagB(nVertLevels)) + allocate(tridiagC(nVertLevels)) + ! Assign a huge value to the scratch variables which may manifest itself when ! there is a bug. + !$omp workshare gradDensityEdge(:,:) = huge(0D0) gradDensityTopOfEdge(:,:) = huge(0D0) dDensityDzTopOfCell(:,:) = huge(0D0) @@ -191,6 +189,7 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) relativeSlopeTaperingCell(:,:) = 0.0_RKIND k33(:,:) = 0.0_RKIND normalGMBolusVelocity(:,:) = 0.0_RKIND + !$omp end workshare !-------------------------------------------------------------------- ! @@ -202,6 +201,7 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) ! Compute vertical derivative of density (dDensityDzTopOfCell) at cell center and layer interface ! Note that displacedDensity is used from the upper cell, so that the EOS reference level for ! pressure is the same for both displacedDensity(k-1,iCell) and density(k,iCell). + !$omp do schedule(runtime) private(k, rtmp) do iCell = 1, nCells do k = 2, maxLevelCell(iCell) rtmp = (displacedDensity(k-1,iCell) - density(k,iCell)) / (zMid(k-1,iCell) - zMid(k,iCell)) @@ -214,8 +214,10 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) dDensityDzTopOfCell(1,iCell) = 0.0_RKIND dDensityDzTopOfCell(maxLevelCell(iCell)+1,iCell) = 0.0_RKIND end do + !$omp end do ! Interpolate dDensityDzTopOfCell to edge and layer interface + !$omp do schedule(runtime) private(k, cell1, cell2) do iEdge = 1, nEdges do k = 1, maxLevelEdgeTop(iEdge)+1 cell1 = cellsOnEdge(1,iEdge) @@ -223,6 +225,7 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) dDensityDzTopOfEdge(k,iEdge) = 0.5_RKIND * (dDensityDzTopOfCell(k,cell1) + dDensityDzTopOfCell(k,cell2)) end do end do + !$omp end do !-------------------------------------------------------------------- ! @@ -234,6 +237,7 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) ! Compute density gradient (gradDensityEdge) and gradient of zMid (gradZMidEdge) ! along the constant coordinate surface. ! The computed variables lives at edge and mid-layer depth + !$omp do schedule(runtime) private(cell1, cell2, k) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -243,8 +247,10 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) gradZMidEdge(k,iEdge) = (zMid(k,cell2) - zMid(k,cell1)) / dcEdge(iEdge) end do end do + !$omp end do ! Interpolate gradDensityEdge and gradZMidEdge to layer interface + !$omp do schedule(runtime) private(k, h1, h2) do iEdge = 1, nEdges ! The interpolation can only be carried out on non-boundary edges if (maxLevelEdgeTop(iEdge) .GE. 1) then @@ -265,6 +271,7 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) gradZMidTopOfEdge(maxLevelEdgeTop(iEdge)+1,iEdge) = gradZMidEdge(maxLevelEdgeTop(iEdge),iEdge) end if end do + !$omp end do !-------------------------------------------------------------------- ! @@ -272,6 +279,7 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) ! !-------------------------------------------------------------------- + !$omp do schedule(runtime) private(k) do iEdge = 1, nEdges if (maxLevelEdgeTop(iEdge) .GE. 1) then do k = 1, maxLevelEdgeTop(iEdge)+1 @@ -279,6 +287,7 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) end do end if end do + !$omp end do !-------------------------------------------------------------------- ! @@ -289,7 +298,11 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) ! Compute relativeSlopeTopOfEdge at edge and layer interface ! set relativeSlopeTopOfEdge to zero for horizontal land/water edges. + !$omp workshare relativeSlopeTopOfEdge = 0.0_RKIND + !$omp end workshare + + !$omp do schedule(runtime) private(k) do iEdge = 1, nEdges ! Beside a full land cell (e.g. missing cell) maxLevelEdgeTop=0, so relativeSlopeTopOfEdge at that edge will remain zero. @@ -305,50 +318,61 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) relativeSlopeTopOfEdge( maxLevelEdgeTop(iEdge)+1, iEdge ) = relativeSlopeTopOfEdge( max(1,maxLevelEdgeTop(iEdge)), iEdge ) end do + !$omp end do ! slope can be unbounded in regions of neutral stability, reset to the large, but bounded, value ! values is hardwrite to 1.0, this is equivalent to a slope of 45 degrees + !$omp workshare where(relativeSlopeTopOfEdge < -1.0_RKIND) relativeSlopeTopOfEdge = -1.0_RKIND where(relativeSlopeTopOfEdge > 1.0_RKIND) relativeSlopeTopOfEdge = 1.0_RKIND ! average relative slope to cell centers ! do this by computing (relative slope)^2, then taking sqrt areaCellSum = 1.0e-34_RKIND - do iEdge = 1, nEdges - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - ! contribution of cell area from this edge: - areaEdge = 0.25_RKIND * dcEdge(iEdge) * dvEdge(iEdge) + !$omp end workshare - do k = 1, maxLevelEdgeTop(iEdge) - - ! only one component is summed (thus the weighting by a factor of 2.0) - rtmp = 2.0_RKIND * areaEdge * relativeSlopeTopOfEdge(k,iEdge)**2 - relativeSlopeTopOfCell(k,cell1) = relativeSlopeTopOfCell(k,cell1) + rtmp - relativeSlopeTopOfCell(k,cell2) = relativeSlopeTopOfCell(k,cell2) + rtmp - - areaCellSum(k,cell1) = areaCellSum(k,cell1) + areaEdge - areaCellSum(k,cell2) = areaCellSum(k,cell2) + areaEdge - - end do + !$omp do schedule(runtime) private(i, iEdge, areaEdge, rtmp) + do iCell = 1, nCells + do i = 1, nEdgesOnCell(iCell) + iEdge = edgesOnCell(i, iCell) + + !contribution of cell area from this edge * 2.0 + areaEdge = 0.5_RKIND * dcEdge(iEdge) * dvEdge(iEdge) + do k = 1, maxLevelEdgeTop(iEdge) + rtmp = areaEdge * relativeSlopeTopOfEdge(k, iEdge)**2 + relativeSlopeTopOfCell(k, iCell) = relativeSlopeTopOfCell(k, iCell) + rtmp + areaCellSum(k, iCell) = areaCellSum(k, iCell) + areaEdge + end do + end do end do + !$omp end do + + !$omp do schedule(runtime) private(k) do iCell=1,nCells do k = 1, maxLevelCell(iCell) relativeSlopeTopOfCell(k,iCell) = sqrt(relativeSlopeTopOfCell(k,iCell)/areaCellSum(k,iCell)) end do end do + !$omp end do ! Compute tapering function ! Compute k33 at cell center and layer interface + + !$omp workshare k33(:,:) = 0.0_RKIND + !$omp end workshare + + !$omp do schedule(runtime) private(k) do iCell=1,nCells do k = 2, maxLevelCell(iCell) relativeSlopeTaperingCell(k,iCell) = min(1.0_RKIND, config_max_relative_slope**2 / (relativeSlopeTopOfCell(k,iCell)**2+epsGM)) k33(k,iCell) = relativeSlopeTaperingCell(k,iCell) * (relativeSlopeTopOfCell(k,iCell))**2 end do end do + !$omp end do ! average tapering function to layer edges + !$omp do schedule(runtime) private(cell1, cell2, k) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -356,13 +380,20 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) relativeSlopeTapering(k,iEdge) = 0.5_RKIND * (relativeSlopeTaperingCell(k,cell1) + relativeSlopeTaperingCell(k,cell2)) enddo enddo + !$omp end do ! k33 is still non-dimensional measuring the limited (relative slope)^2 of neutral surfaces. ! scale k33 by config_Redi_kappa so it has units of diffusivity + !$omp workshare k33 = config_Redi_kappa * k33 + !$omp end workshare ! allow disabling of K33 for testing - if(config_disable_redi_k33) k33=0.0_RKIND + if(config_disable_redi_k33) then + !$omp workshare + k33=0.0_RKIND + !$omp end workshare + end if !-------------------------------------------------------------------- ! @@ -370,8 +401,13 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) ! !-------------------------------------------------------------------- + !$omp workshare gmStreamFuncTopOfEdge(:,:) = 0.0_RKIND + !$omp end workshare + c = config_gravWaveSpeed_trunc**2 + + !$omp do schedule(runtime) private(cell1, cell2, k, BruntVaisalaFreqTopEdge, N) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) @@ -411,18 +447,24 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) ! Call the tridiagonal solver call tridiagonal_solve(tridiagA, tridiagB, tridiagC, rightHandSide, gmStreamFuncTopOfEdge(2:maxLevelEdgeTop(iEdge),iEdge), N) end if - end do + !$omp end do ! Compute normalGMBolusVelocity from the stream function + !$omp do schedule(runtime) private(k) do iEdge = 1, nEdges do k = 1, maxLevelEdgeTop(iEdge) normalGMBolusVelocity(k,iEdge) = (gmStreamFuncTopOfEdge(k,iEdge) - gmStreamFuncTopOfEdge(k+1,iEdge)) / layerThicknessEdge(k,iEdge) end do end do + !$omp end do ! Interpolate gmStreamFuncTopOfEdge to cell centers for visualization + !$omp workshare gmStreamFuncTopOfCell(:,:) = 0.0_RKIND + !$omp end workshare + + !$omp do schedule(runtime) private(cell1, cell2, areaEdge, k, rtmp) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -433,11 +475,21 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) gmStreamFuncTopOfCell(k,cell1) = gmStreamFuncTopOfCell(k,cell1) + rtmp gmStreamFuncTopOfCell(k,cell2) = gmStreamFuncTopOfCell(k,cell2) + rtmp end do - end do + !$omp end do + + !$omp do schedule(runtime) do iCell = 1, nCells gmStreamFuncTopOfCell(:, iCell) = gmStreamFuncTopOfCell(:,iCell) / areaCell(iCell) end do + !$omp end do + + deallocate(rightHandSide) + deallocate(tridiagA) + deallocate(tridiagB) + deallocate(tridiagC) + + call mpas_threading_barrier() ! Deallocate scratch variables call mpas_deallocate_scratch_field(gradDensityEdgeField, .true.) @@ -447,10 +499,6 @@ subroutine ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) call mpas_deallocate_scratch_field(dDensityDzTopOfEdgeField, .true.) call mpas_deallocate_scratch_field(gradZMidEdgeField, .true.) call mpas_deallocate_scratch_field(gradZMidTopOfEdgeField, .true.) - call mpas_deallocate_scratch_field(rightHandSideField, .true.) - call mpas_deallocate_scratch_field(tridiagAField, .true.) - call mpas_deallocate_scratch_field(tridiagBField, .true.) - call mpas_deallocate_scratch_field(tridiagCField, .true.) end subroutine ocn_gm_compute_Bolus_velocity!}}} diff --git a/src/core_ocean/shared/mpas_ocn_high_freq_thickness_hmix_del2.F b/src/core_ocean/shared/mpas_ocn_high_freq_thickness_hmix_del2.F index 61a75aae2d..030896d431 100644 --- a/src/core_ocean/shared/mpas_ocn_high_freq_thickness_hmix_del2.F +++ b/src/core_ocean/shared/mpas_ocn_high_freq_thickness_hmix_del2.F @@ -137,6 +137,7 @@ subroutine ocn_high_freq_thickness_hmix_del2_tend(meshPool, highFreqThickness, t call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + !$omp do schedule(runtime) private(invAreaCell, i, iEdge, cell1, cell2, r_tmp, k, hhf_turb_flux, flux) do iCell = 1, nCells invAreaCell = 1.0 / areaCell(iCell) do i = 1, nEdgesOncell(iCell) @@ -158,6 +159,7 @@ subroutine ocn_high_freq_thickness_hmix_del2_tend(meshPool, highFreqThickness, t end do end do + !$omp end do end subroutine ocn_high_freq_thickness_hmix_del2_tend!}}} diff --git a/src/core_ocean/shared/mpas_ocn_init_routines.F b/src/core_ocean/shared/mpas_ocn_init_routines.F index 15b74043bc..84108be6f8 100644 --- a/src/core_ocean/shared/mpas_ocn_init_routines.F +++ b/src/core_ocean/shared/mpas_ocn_init_routines.F @@ -33,7 +33,6 @@ module ocn_init_routines use mpas_vector_reconstruction use mpas_tracer_advection_helpers - use ocn_time_average use ocn_diagnostics use ocn_gm use ocn_constants @@ -131,6 +130,7 @@ subroutine ocn_init_routines_compute_max_level(domain)!{{{ min( maxLevelCell(cellsOnEdge(1,iEdge)), & maxLevelCell(cellsOnEdge(2,iEdge)) ) end do + maxLevelEdgeTop(nEdges+1) = 0 ! maxLevelEdgeBot is the maximum (deepest) of the surrounding cells @@ -139,6 +139,7 @@ subroutine ocn_init_routines_compute_max_level(domain)!{{{ max( maxLevelCell(cellsOnEdge(1,iEdge)), & maxLevelCell(cellsOnEdge(2,iEdge)) ) end do + maxLevelEdgeBot(nEdges+1) = 0 ! maxLevelVertexBot is the maximum (deepest) of the surrounding cells @@ -150,6 +151,7 @@ subroutine ocn_init_routines_compute_max_level(domain)!{{{ maxLevelCell(cellsOnVertex(i,iVertex))) end do end do + maxLevelVertexBot(nVertices+1) = 0 ! maxLevelVertexTop is the minimum (shallowest) of the surrounding cells @@ -161,11 +163,14 @@ subroutine ocn_init_routines_compute_max_level(domain)!{{{ maxLevelCell(cellsOnVertex(i,iVertex))) end do end do + maxLevelVertexTop(nVertices+1) = 0 ! set boundary edge boundaryEdge(:,1:nEdges+1)=1 edgeMask(:,1:nEdges+1)=0 + + do iEdge = 1, nEdges boundaryEdge(1:maxLevelEdgeTop(iEdge),iEdge)=0 edgeMask(1:maxLevelEdgeTop(iEdge),iEdge)=1 @@ -178,6 +183,8 @@ subroutine ocn_init_routines_compute_max_level(domain)!{{{ cellMask(:,1:nCells+1) = 0 boundaryVertex(:,1:nVertices+1) = 0 vertexMask(:,1:nVertices+1) = 0 + + do iEdge = 1, nEdges do k = 1, nVertLevels if (boundaryEdge(k,iEdge).eq.1) then @@ -331,6 +338,7 @@ subroutine ocn_init_routines_compute_mesh_scaling(meshPool, scaleHmixWithMesh, m meshScalingDel2(:) = 1.0 meshScalingDel4(:) = 1.0 meshScaling(:) = 1.0 + if (scaleHmixWithMesh) then do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) @@ -495,7 +503,7 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ real (kind=RKIND), intent(in) :: dt integer, intent(out) :: err - type (mpas_pool_type), pointer :: meshPool, averagePool, statePool, tracersPool + type (mpas_pool_type), pointer :: meshPool, statePool, tracersPool type (mpas_pool_type), pointer :: forcingPool, diagnosticsPool, scratchPool integer :: i, iEdge, iCell, k integer :: err1 @@ -531,7 +539,6 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ call mpas_pool_get_subpool(block % structs, 'forcing', forcingPool) call mpas_pool_get_subpool(block % structs, 'diagnostics', diagnosticsPool) call mpas_pool_get_subpool(block % structs, 'scratch', scratchPool) - call mpas_pool_get_subpool(block % structs, 'average', averagePool) call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) @@ -576,8 +583,6 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ boundaryCell) err = ior(err, err1) - call ocn_time_average_init(averagePool) - if (.not. config_do_restart) then do iCell=1,nCells boundaryLayerDepth(iCell) = layerThickness(1, iCell) * 0.5 @@ -593,6 +598,7 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ layerThickness(:, nCells+1) = 0.0 + do iEdge=1, nEdges normalVelocity(maxLevelEdgeTop(iEdge)+1:maxLevelEdgeBot(iEdge), iEdge) = 0.0 @@ -616,14 +622,18 @@ subroutine ocn_init_routines_block(block, dt, err)!{{{ ! ------------------------------------------------------------------ normalTransportVelocity(:,:) = normalVelocity(:,:) + ! Compute normalGMBolusVelocity, relativeSlope and RediDiffVertCoef if respective flags are turned on if (config_use_standardGM) then + !$omp parallel call ocn_gm_compute_Bolus_velocity(diagnosticsPool, meshPool, scratchPool) + !$omp end parallel end if if (config_use_standardGM) then normalTransportVelocity(:,:) = normalTransportVelocity(:,:) + normalGMBolusVelocity(:,:) end if + ! ------------------------------------------------------------------ ! End: Accumulating various parametrizations of the transport velocity ! ------------------------------------------------------------------ diff --git a/src/core_ocean/shared/mpas_ocn_sea_ice.F b/src/core_ocean/shared/mpas_ocn_sea_ice.F index 73a3b862d6..8b47bf8aff 100644 --- a/src/core_ocean/shared/mpas_ocn_sea_ice.F +++ b/src/core_ocean/shared/mpas_ocn_sea_ice.F @@ -131,8 +131,10 @@ subroutine ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, laye allocate(iceTracer(nTracers)) iceTracer = 0.0_RKIND iceTracer(indexSalinity) = sea_ice_salinity * ppt_to_salt + density_ice = rho_ice + !$omp do schedule(runtime) private(maxLevel, netEnergyChange, k, freezingTemp, availableEnergyChange, energyChange, temperatureChange, thicknessChange, iceThicknessChange, iTracer) do iCell = 1, nCellsSolve ! Check performance of these two loop definitions ! do iCell = nCellsSolve, 1, -1 maxLevel = min(maxLevelCell(iCell), verticalLevelCap) @@ -233,6 +235,7 @@ subroutine ocn_sea_ice_formation(meshPool, indexTemperature, indexSalinity, laye seaIceEnergy(iCell) = seaIceEnergy(iCell) + energyChange end if end do + !$omp end do deallocate(iceTracer) diff --git a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F index 7c357484de..b3667a1c51 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F @@ -180,6 +180,7 @@ subroutine ocn_surface_bulk_forcing_vel(meshPool, forcingPool, surfaceStress, su call mpas_pool_get_array(forcingPool, 'windStressMeridional', windStressMeridional) ! Convert CESM wind stress to MPAS-O wind stress + !$omp do schedule(runtime) private(cell1, cell2, zonalAverage, meridionalAverage) do iEdge = 1, nEdges cell1 = cellsOnEdge(1, iEdge) cell2 = cellsOnEdge(2, iEdge) @@ -189,12 +190,14 @@ subroutine ocn_surface_bulk_forcing_vel(meshPool, forcingPool, surfaceStress, su surfaceStress(iEdge) = surfaceStress(iEdge) + cos(angleEdge(iEdge)) * zonalAverage + sin(angleEdge(iEdge)) * meridionalAverage end do - + !$omp end do ! Build surface fluxes at cell centers + !$omp do schedule(runtime) do iCell = 1, nCells surfaceStressMagnitude(iCell) = surfaceStressMagnitude(iCell) + sqrt(windStressZonal(iCell)**2 + windStressMeridional(iCell)**2) end do + !$omp end do end subroutine ocn_surface_bulk_forcing_vel!}}} @@ -265,11 +268,13 @@ subroutine ocn_surface_bulk_forcing_thick(meshPool, forcingPool, surfaceThicknes ! Build surface fluxes at cell centers + !$omp do schedule(runtime) do iCell = 1, nCells surfaceThicknessFlux(iCell) = surfaceThicknessFlux(iCell) + ( snowFlux(iCell) + rainFlux(iCell) + evaporationFlux(iCell) & + seaIceFreshWaterFlux(iCell) + iceRunoffFlux(iCell) & + riverRunoffFlux(iCell) ) / rho_sw end do + !$omp end do end subroutine ocn_surface_bulk_forcing_thick!}}} @@ -382,6 +387,7 @@ subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracer ! Build surface fluxes at cell centers ! CLEANUP + !$omp do schedule(runtime) do iCell = 1, nCells tracersSurfaceFlux(1, iCell) = tracersSurfaceFlux(1, iCell) & + (latentHeatFlux(iCell) + sensibleHeatFlux(iCell) + longWaveHeatFluxUp(iCell) + longWaveHeatFluxDown(iCell) & @@ -390,6 +396,7 @@ subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracer tracersSurfaceFlux(2, iCell) = tracersSurfaceFlux(2, iCell) & + seaIceSalinityFlux(iCell) * sflux_factor end do + !$omp end do ! TRACER-CLEAN-UP ! Do we want this here still? diff --git a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F index d6c7a019ec..c9aaa3e71a 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F +++ b/src/core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F @@ -177,14 +177,18 @@ subroutine ocn_surface_land_ice_fluxes_vel(meshPool, diagnosticsPool, surfaceStr call mpas_pool_get_array(diagnosticsPool, 'topDrag', topDrag) call mpas_pool_get_array(diagnosticsPool, 'topDragMagnitude', topDragMagnitude) + !$omp do schedule(runtime) do iEdge = 1, nEdges surfaceStress(iEdge) = surfaceStress(iEdge) + topDrag(iEdge) end do + !$omp end do ! Build surface stress magnitude at cell centers + !$omp do schedule(runtime) do iCell = 1, nCells surfaceStressMagnitude(iCell) = surfaceStressMagnitude(iCell) + topDragMagnitude(iCell) end do + !$omp end do !-------------------------------------------------------------------- @@ -248,9 +252,11 @@ subroutine ocn_surface_land_ice_fluxes_thick(meshPool, forcingPool, surfaceThick call mpas_pool_get_array(forcingPool, 'landIceFreshwaterFlux', landIceFreshwaterFlux) ! Build surface fluxes at cell centers + !$omp do schedule(runtime) do iCell = 1, nCells surfaceThicknessFlux(iCell) = surfaceThicknessFlux(iCell) + landIceFreshwaterFlux(iCell) / rho_sw end do + !$omp end do end subroutine ocn_surface_land_ice_fluxes_thick!}}} @@ -312,9 +318,11 @@ subroutine ocn_surface_land_ice_fluxes_active_tracers(meshPool, forcingPool, tra call mpas_pool_get_array(forcingPool, 'landIceHeatFlux', landIceHeatFlux) ! add to surface fluxes at cell centers + !$omp do schedule(runtime) do iCell = 1, nCells tracersSurfaceFlux(1, iCell) = tracersSurfaceFlux(1, iCell) + landIceHeatFlux(iCell)/(rho_sw*cp_sw) end do + !$omp end do end subroutine ocn_surface_land_ice_fluxes_active_tracers!}}} @@ -452,6 +460,7 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & end if if(isomipOn) then + !$omp do schedule(runtime) private(heatFlux) do iCell = 1, nCellsSolve ! linearized equaiton for the S and p dependent potential freezing temperature landIceInterfaceTracers(indexIT,iCell) = Tf0 & @@ -477,6 +486,7 @@ subroutine ocn_surface_land_ice_fluxes_build_arrays(meshPool, diagnosticsPool, & heatFluxToLandIce(iCell) = 0.0_RKIND end do + !$omp end do end if if(jenkinsOn .or. hollandJenkinsOn) then @@ -726,6 +736,8 @@ subroutine compute_melt_fluxes( & coupled = present(iceTemperature) .and. present(iceTemperatureDistance) & .and. present(kappa_land_ice) Tlatent = latent_heat_fusion_mks/cp_sw + + !$omp do schedule(runtime) private(iceHeatFluxCoeff, nu, iceDeltaT, T0, transferVelocityRatio, a, b, c) do iCell = 1, nCells if(coupled) then iceHeatFluxCoeff = rho_land_ice*cp_land_ice*kappa_land_ice/iceTemperatureDistance(iCell) @@ -746,9 +758,9 @@ subroutine compute_melt_fluxes( & ! The positive root is the one we want (salinity is strictly positive) outInterfaceSalinity(iCell) = (-b + sqrt(b**2 - 4.0_RKIND*a*c*oceanSalinity(iCell)))/(2.0_RKIND*a) if (outInterfaceSalinity(iCell) .le. 0.0_RKIND) then - write(stderrUnit, *) "ERROR: interfaceSalinity <= 0", outInterfaceSalinity(iCell), oceanSalinity(iCell), a, b, c + write(stderrUnit, *) "ERROR: interfaceSalinity <= 0", outInterfaceSalinity(iCell), oceanSalinity(iCell), a, b, c err = 1 - return + call mpas_dmpar_global_abort('ERROR: interfaceSalinity is negative...') end if outInterfaceTemperature(iCell) = dTf_dS*outInterfaceSalinity(iCell)+T0 @@ -773,6 +785,7 @@ subroutine compute_melt_fluxes( & - iceHeatFluxCoeff*(iceTemperature(iCell) - outInterfaceTemperature(iCell)) end if end do + !$omp end do !-------------------------------------------------------------------- @@ -870,6 +883,7 @@ subroutine compute_HJ99_melt_fluxes( & err = 0 cpRatio = cp_land_ice/cp_sw + !$omp do schedule(runtime) private(T0, transferVelocityRatio, Tlatent, eta, TlatentStar, a, b, c) do iCell = 1, nCells T0 = Tf0 + dTf_dp*interfacePressure(iCell) transferVelocityRatio = (rho_fw/rho_sw)*oceanSaltTransferVelocity(iCell)/oceanHeatTransferVelocity(iCell) @@ -887,7 +901,7 @@ subroutine compute_HJ99_melt_fluxes( & outInterfaceSalinity(iCell) = (-b + sqrt(b**2 - 4.0_RKIND*a*c*oceanSalinity(iCell)))/(2.0_RKIND*a) if (outInterfaceSalinity(iCell) .le. 0.0_RKIND) then err = 1 - return + call mpas_dmpar_global_abort('ERROR: interfaceSalinity is negative...') end if outInterfaceTemperature(iCell) = dTf_dS*outInterfaceSalinity(iCell)+T0 @@ -905,6 +919,7 @@ subroutine compute_HJ99_melt_fluxes( & ! (surface?) ice temperature outIceHeatFlux(iCell) = -cp_land_ice*outFreshwaterFlux(iCell)*iceTemperature(iCell) end do + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index 8758fb0553..c1ee171e61 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -24,6 +24,7 @@ module ocn_tendency use mpas_pool_routines use mpas_constants use mpas_timer + use mpas_threading use ocn_constants @@ -120,8 +121,6 @@ subroutine ocn_tend_thick(tendPool, forcingPool, diagnosticsPool, meshPool)!{{{ logical, pointer :: config_disable_thick_all_tend - call mpas_timer_start("ocn_tend_thick") - call mpas_pool_get_config(ocnConfigs, 'config_disable_thick_all_tend', config_disable_thick_all_tend) call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity', normalTransportVelocity) @@ -136,11 +135,15 @@ subroutine ocn_tend_thick(tendPool, forcingPool, diagnosticsPool, meshPool)!{{{ ! ! height tendency: start accumulating tendency terms ! - tend_layerThickness = 0.0 + !$omp workshare + tend_layerThickness(:,:) = 0.0 surfaceThicknessFlux(:) = 0.0_RKIND + !$omp end workshare if(config_disable_thick_all_tend) return + call mpas_timer_start("ocn_tend_thick") + ! Build suface mass flux array from bulk call mpas_timer_start("bulk_thick", .false.) call ocn_surface_bulk_forcing_thick(meshPool, forcingPool, surfaceThicknessFlux, err) @@ -230,10 +233,6 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP logical, pointer :: config_disable_vel_all_tend character (len=StrKIND), pointer :: config_pressure_gradient_type - call mpas_timer_start("ocn_tend_vel") - - call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) - if (present(timeLevelIn)) then timeLevel = timeLevelIn else @@ -243,6 +242,8 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP call mpas_pool_get_config(ocnConfigs, 'config_disable_vel_all_tend', config_disable_vel_all_tend) call mpas_pool_get_config(ocnConfigs, 'config_pressure_gradient_type', config_pressure_gradient_type) + call mpas_pool_get_subpool(statePool, 'tracers', tracersPool) + call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) call mpas_pool_get_array(tracersPool, 'activeTracers', activeTracers, timeLevel) call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) @@ -273,12 +274,16 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP ! ! velocity tendency: start accumulating tendency terms ! + !$omp workshare tend_normalVelocity(:,:) = 0.0 surfaceStress(:) = 0.0_RKIND surfaceStressMagnitude(:) = 0.0_RKIND + !$omp end workshare if(config_disable_vel_all_tend) return + call mpas_timer_start("ocn_tend_vel") + ! Build bulk forcing suface stress call mpas_timer_start("bulk_ws", .false.) call ocn_surface_bulk_forcing_vel(meshPool, forcingPool, surfaceStress, surfaceStressMagnitude, err) @@ -329,22 +334,23 @@ subroutine ocn_tend_vel(tendPool, statePool, forcingPool, diagnosticsPool, meshP ! strictly only valid for config_mom_del2 == constant ! call mpas_timer_start("hmix", .false., velHmixTimer) - call ocn_vel_hmix_tend(meshPool, divergence, relativeVorticity, normalVelocity, tangentialVelocity, viscosity, & - tend_normalVelocity, scratchPool, err) + call ocn_vel_hmix_tend(meshPool, scratchPool, divergence, relativeVorticity, normalVelocity, tangentialVelocity, viscosity, & + tend_normalVelocity, err) call mpas_timer_stop("hmix", velHmixTimer) ! ! velocity tendency: forcing and bottom drag ! - call mpas_timer_start("forcings", .false., velForceTimer) call ocn_vel_forcing_tend(meshPool, normalVelocity, surfaceFluxAttenuationCoefficient, surfaceStress, layerThicknessEdge, tend_normalVelocity, err) call mpas_timer_stop("forcings", velForceTimer) + ! ! velocity tendency: vertical mixing d/dz( nu_v du/dz)) ! call mpas_timer_stop("ocn_tend_vel") + call mpas_threading_barrier() end subroutine ocn_tend_vel!}}} @@ -434,9 +440,13 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me integer :: err, iEdge, k, timeLevel ! - ! start timers + ! set time level of optional argument is present ! - call mpas_timer_start("ocn_tend_tracer") + if (present(timeLevelIn)) then + timeLevel = timeLevelIn + else + timeLevel = 1 + end if ! ! get tracers pools @@ -445,22 +455,12 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me call mpas_pool_get_subpool(tendPool, 'tracersTend', tracersTendPool) call mpas_pool_get_subpool(forcingPool, 'tracersSurfaceFlux', tracersSurfaceFluxPool) - ! - ! set time level of optional argument is present - ! - if (present(timeLevelIn)) then - timeLevel = timeLevelIn - else - timeLevel = 1 - end if - ! ! get dimensions ! call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(tracersPool, 'index_temperature', indexTemperature) ! @@ -487,20 +487,30 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me call mpas_pool_get_array(tendPool, 'layerThickness', tend_layerThickness) call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) + + if(config_disable_tr_all_tend) return + + call mpas_timer_start("ocn_tend_tracer") + + !allocate(normalThicknessFlux(nVertLevels, nEdges+1)) call mpas_pool_get_field(scratchPool, 'normalThicknessFlux', normalThicknessFluxField) call mpas_allocate_scratch_field(normalThicknessFluxField, .true.) - normalThicknessFlux => normalThicknessFluxField % array + call mpas_threading_barrier() - if(config_disable_tr_all_tend) return + normalThicknessFlux => normalThicknessFluxField % array ! ! transport velocity for the tracer. ! + !$omp do schedule(runtime) private(k) do iEdge = 1, nEdges do k = 1, nVertLevels normalThicknessFlux(k, iEdge) = normalTransportVelocity(k, iEdge) * layerThicknessEdge(k, iEdge) end do end do + !$omp end do ! ! begin iterate over tracer categories @@ -544,8 +554,10 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! ! initialize tracer surface flux and tendency to zero. ! + !$omp workshare tracerGroupTend(:,:,:) = 0.0 tracerGroupSurfaceFlux(:,:) = 0.0 + !$omp end workshare ! ! fill components of surface tracer flux @@ -705,6 +717,8 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! call mpas_timer_stop("ocn_tend_tracer") + call mpas_threading_barrier() + call mpas_deallocate_scratch_field(normalThicknessFluxField, .true.) end subroutine ocn_tend_tracer!}}} @@ -747,6 +761,7 @@ subroutine ocn_tend_freq_filtered_thickness(tendPool, statePool, diagnosticsPool real (kind=RKIND), pointer :: config_thickness_filter_timescale, config_highFreqThick_restore_time call mpas_timer_start("ocn_tend_freq_filtered_thickness") + err = 0 if (present(timeLevelIn)) then @@ -779,17 +794,21 @@ subroutine ocn_tend_freq_filtered_thickness(tendPool, statePool, diagnosticsPool call mpas_pool_get_array(tendPool, 'lowFreqDivergence', tend_lowFreqDivergence) call mpas_pool_get_array(tendPool, 'highFreqThickness', tend_highFreqThickness) - allocate(div_hu(nVertLevels)) - ! ! Low Frequency Divergence and high frequency thickness Tendency ! + !$omp workshare tend_lowFreqDivergence = 0.0 tend_highFreqThickness = 0.0 + !$omp end workshare ! Convert restore time from days to seconds thickness_filter_timescale_sec = config_thickness_filter_timescale*86400.0 highFreqThick_restore_time_sec = config_highFreqThick_restore_time*86400.0 + + allocate(div_hu(nVertLevels)) + + !$omp do schedule(runtime) private(div_hu_btr, invAreaCell, i, iEdge, k, totalThickness) do iCell = 1, nCells div_hu(:) = 0.0 div_hu_btr = 0.0 @@ -818,8 +837,8 @@ subroutine ocn_tend_freq_filtered_thickness(tendPool, statePool, diagnosticsPool + use_highFreqThick_restore*( -2.0 * pii / highFreqThick_restore_time_sec * highFreqThickness(k,iCell) ) end do - end do + !$omp end do deallocate(div_hu) diff --git a/src/core_ocean/shared/mpas_ocn_test.F b/src/core_ocean/shared/mpas_ocn_test.F index 4d771e3d45..e85f1fed34 100644 --- a/src/core_ocean/shared/mpas_ocn_test.F +++ b/src/core_ocean/shared/mpas_ocn_test.F @@ -199,6 +199,7 @@ subroutine ocn_prep_test_tensor(domain,err)!{{{ call mpas_allocate_scratch_field(divTensorLonLatRCellSolutionField, .false.) call mpas_allocate_scratch_field(outerProductEdgeField, .false.) + call mpas_test_tensor(domain, config_tensor_test_function, & edgeSignOnCellField, & edgeTangentVectorsField, & @@ -216,6 +217,7 @@ subroutine ocn_prep_test_tensor(domain,err)!{{{ divTensorLonLatRCellSolutionField, & outerProductEdgeField ) + call mpas_deallocate_scratch_field(normalVelocityTestField, .false.) call mpas_deallocate_scratch_field(tangentialVelocityTestField, .false.) call mpas_deallocate_scratch_field(strainRateR3CellField, .false.) @@ -328,6 +330,7 @@ subroutine ocn_init_gm_test_functions(diagnosticsPool, meshPool, scratchPool)!{{ c1 = R*(1-exp(-zBot/L))/(exp(zBot/L) - exp(-zBot/L)) c2 = R-c1 + !$omp do schedule(runtime) private(k, zTop) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) @@ -343,11 +346,12 @@ subroutine ocn_init_gm_test_functions(diagnosticsPool, meshPool, scratchPool)!{{ end do k = maxLevelCell(iCell)+1 - ! placed at top interface, cell center. - zTop = zBot - yGMStreamFuncSolution(k,iCell) = c1*exp(zTop/L) + c2*exp(-zTop/L) - R; + ! placed at top interface, cell center. + zTop = zBot + yGMStreamFuncSolution(k,iCell) = c1*exp(zTop/L) + c2*exp(-zTop/L) - R; end do + !$omp end do end subroutine ocn_init_gm_test_functions!}}} diff --git a/src/core_ocean/shared/mpas_ocn_thick_ale.F b/src/core_ocean/shared/mpas_ocn_thick_ale.F index 02f4960631..64ed35e9c5 100644 --- a/src/core_ocean/shared/mpas_ocn_thick_ale.F +++ b/src/core_ocean/shared/mpas_ocn_thick_ale.F @@ -151,11 +151,12 @@ subroutine ocn_ALE_thickness(meshPool, verticalMeshPool, oldSSH, div_hu_btr, dt, ! ! ALE thickness alteration due to SSH (z-star) ! + !$omp do schedule(runtime) private(kMax, newSSH, thicknessSum, k) do iCell = 1, nCells kMax = maxLevelCell(iCell) newSSH = oldSSH(iCell) - dt*div_hu_btr(iCell) - thicknessSum = 1e-14 + thicknessSum = 1e-14_RKIND do k = 1, kMax SSH_ALE_Thickness(k) = newSSH * vertCoordMovementWeights(k) * restingThickness(k, iCell) thicknessSum = thicknessSum + vertCoordMovementWeights(k) * restingThickness(k, iCell) @@ -167,8 +168,10 @@ subroutine ocn_ALE_thickness(meshPool, verticalMeshPool, oldSSH, div_hu_btr, dt, restingThickness(1:kMax,iCell) & + SSH_ALE_Thickness(1:kMax) enddo + !$omp end do if (thicknessFilterActive) then + !$omp do schedule(runtime) private(kMax) do iCell = 1, nCells kMax = maxLevelCell(iCell) @@ -176,6 +179,7 @@ subroutine ocn_ALE_thickness(meshPool, verticalMeshPool, oldSSH, div_hu_btr, dt, ALE_Thickness(1:kMax, iCell) & + newHighFreqThickness(1:kMax,iCell) enddo + !$omp end do end if ! @@ -183,6 +187,7 @@ subroutine ocn_ALE_thickness(meshPool, verticalMeshPool, oldSSH, div_hu_btr, dt, ! if (config_use_min_max_thickness) then + !$omp do schedule(runtime) private(kMax, remainder, k, newThickness) do iCell = 1, nCells kMax = maxLevelCell(iCell) @@ -208,6 +213,7 @@ subroutine ocn_ALE_thickness(meshPool, verticalMeshPool, oldSSH, div_hu_btr, dt, ALE_Thickness(1:kMax, iCell) = ALE_Thickness(1:kMax, iCell) + min_ALE_thickness_down(1:kMax) + min_ALE_thickness_up(1:kMax) enddo + !$omp end do endif ! config_use_min_max_thickness diff --git a/src/core_ocean/shared/mpas_ocn_thick_hadv.F b/src/core_ocean/shared/mpas_ocn_thick_hadv.F index 9b6433133b..cb29d573d6 100644 --- a/src/core_ocean/shared/mpas_ocn_thick_hadv.F +++ b/src/core_ocean/shared/mpas_ocn_thick_hadv.F @@ -143,6 +143,7 @@ subroutine ocn_thick_hadv_tend(meshPool, normalVelocity, layerThicknessEdge, ten call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) + !$omp do schedule(runtime) private(invAreaCell, i, iEdge, k, flux) do iCell = 1, nCells invAreaCell = 1.0 / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) @@ -153,6 +154,7 @@ subroutine ocn_thick_hadv_tend(meshPool, normalVelocity, layerThicknessEdge, ten end do end do end do + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F b/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F index 7a7cf59fb4..49963bb4a1 100644 --- a/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F +++ b/src/core_ocean/shared/mpas_ocn_thick_surface_flux.F @@ -127,6 +127,7 @@ subroutine ocn_thick_surface_flux_tend(meshPool, transmissionCoefficients, layer call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + !$omp do schedule(runtime) private(remainingFlux, k) do iCell = 1, nCells remainingFlux = 1.0_RKIND do k = 1, maxLevelCell(iCell) @@ -139,6 +140,7 @@ subroutine ocn_thick_surface_flux_tend(meshPool, transmissionCoefficients, layer tend(maxLevelCell(iCell), iCell) = tend(maxLevelCell(iCell), iCell) + remainingFlux * surfaceThicknessFlux(iCell) end if end do + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_thick_vadv.F b/src/core_ocean/shared/mpas_ocn_thick_vadv.F index ba1f5a096d..d409271f36 100644 --- a/src/core_ocean/shared/mpas_ocn_thick_vadv.F +++ b/src/core_ocean/shared/mpas_ocn_thick_vadv.F @@ -126,11 +126,13 @@ subroutine ocn_thick_vadv_tend(meshPool, vertAleTransportTop, tend, err)!{{{ call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevels) + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) tend(k,iCell) = tend(k,iCell) + vertAleTransportTop(k+1,iCell) - vertAleTransportTop(k,iCell) end do end do + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_time_average.F b/src/core_ocean/shared/mpas_ocn_time_average.F deleted file mode 100644 index 82aa016364..0000000000 --- a/src/core_ocean/shared/mpas_ocn_time_average.F +++ /dev/null @@ -1,215 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! -module ocn_time_average - - use mpas_derived_types - use mpas_pool_routines - - implicit none - save - public - - contains - - subroutine ocn_time_average_init(averagePool)!{{{ - type (mpas_pool_type), intent(inout) :: averagePool - - real (kind=RKIND), pointer :: nAverage - - real (kind=RKIND), dimension(:), pointer :: avgSSH, varSSH - real (kind=RKIND), dimension(:,:), pointer :: & - avgNormalVelocity, avgVelocityZonal, avgVelocityMeridional, avgVertVelocityTop, & - varNormalVelocity, varVelocityZonal, varVelocityMeridional, & - avgNormalTransportVelocity, avgTransportVelocityZonal, avgTransportVelocityMeridional, avgVertTransportVelocityTop, & - avgNormalGMBolusVelocity, avgGMBolusVelocityZonal, avgGMBolusVelocityMeridional, avgVertGMBolusVelocityTop - - call mpas_pool_get_array(averagePool, 'nAverage', nAverage) - call mpas_pool_get_array(averagePool, 'avgSSH', avgSSH) - call mpas_pool_get_array(averagePool, 'varSSH', varSSH) - call mpas_pool_get_array(averagePool, 'avgNormalVelocity', avgNormalVelocity) - call mpas_pool_get_array(averagePool, 'avgVelocityZonal', avgVelocityZonal) - call mpas_pool_get_array(averagePool, 'avgVelocityMeridional', avgVelocityMeridional) - call mpas_pool_get_array(averagePool, 'avgVertVelocityTop', avgVertVelocityTop) - call mpas_pool_get_array(averagePool, 'varNormalVelocity', varNormalVelocity) - call mpas_pool_get_array(averagePool, 'varVelocityZonal', varVelocityZonal) - call mpas_pool_get_array(averagePool, 'varVelocityMeridional', varVelocityMeridional) - call mpas_pool_get_array(averagePool, 'avgNormalTransportVelocity', avgNormalTransportVelocity) - call mpas_pool_get_array(averagePool, 'avgTransportVelocityZonal', avgTransportVelocityZonal) - call mpas_pool_get_array(averagePool, 'avgTransportVelocityMeridional', avgTransportVelocityMeridional) - call mpas_pool_get_array(averagePool, 'avgVertTransportVelocityTop', avgVertTransportVelocityTop) - call mpas_pool_get_array(averagePool, 'avgNormalGMBolusVelocity', avgNormalGMBolusVelocity) - call mpas_pool_get_array(averagePool, 'avgGMBolusVelocityZonal', avgGMBolusVelocityZonal) - call mpas_pool_get_array(averagePool, 'avgGMBolusVelocityMeridional', avgGMBolusVelocityMeridional) - call mpas_pool_get_array(averagePool, 'avgVertGMBolusVelocityTop', avgVertGMBolusVelocityTop) - - nAverage = 0 - - avgSSH = 0.0 - varSSH = 0.0 - avgNormalVelocity = 0.0 - avgVelocityZonal = 0.0 - avgVelocityMeridional = 0.0 - avgVertVelocityTop = 0.0 - varNormalVelocity = 0.0 - varVelocityZonal = 0.0 - varVelocityMeridional = 0.0 - avgNormalTransportVelocity = 0.0 - avgTransportVelocityZonal = 0.0 - avgTransportVelocityMeridional = 0.0 - avgVertTransportVelocityTop = 0.0 - avgNormalGMBolusVelocity = 0.0 - avgGMBolusVelocityZonal = 0.0 - avgGMBolusVelocityMeridional = 0.0 - avgVertGMBolusVelocityTop = 0.0 - - end subroutine ocn_time_average_init!}}} - - subroutine ocn_time_average_accumulate(averagePool, statePool, diagnosticsPool, timeLevelIn)!{{{ - type (mpas_pool_type), intent(inout) :: averagePool - type (mpas_pool_type), intent(in) :: statePool - type (mpas_pool_type), intent(in) :: diagnosticsPool - integer, intent(in), optional :: timeLevelIn - - real (kind=RKIND), pointer :: nAverage, old_nAverage - - real (kind=RKIND), dimension(:), pointer :: ssh - real (kind=RKIND), dimension(:,:), pointer :: & - velocityZonal, velocityMeridional, normalVelocity, vertVelocityTop, & - transportVelocityZonal, transportVelocityMeridional, normalTransportVelocity, vertTransportVelocityTop, & - GMBolusVelocityZonal, GMBolusVelocityMeridional, normalGMBolusVelocity, vertGMBolusVelocityTop - - real (kind=RKIND), dimension(:), pointer :: avgSSH, varSSH - real (kind=RKIND), dimension(:,:), pointer :: & - avgNormalVelocity, avgVelocityZonal, avgVelocityMeridional, avgVertVelocityTop, & - varNormalVelocity, varVelocityZonal, varVelocityMeridional, & - avgNormalTransportVelocity, avgTransportVelocityZonal, avgTransportVelocityMeridional, avgVertTransportVelocityTop, & - avgNormalGMBolusVelocity, avgGMBolusVelocityZonal, avgGMBolusVelocityMeridional, avgVertGMBolusVelocityTop - - real (kind=RKIND), dimension(:), pointer :: old_avgSSH, old_varSSH - real (kind=RKIND), dimension(:,:), pointer :: & - old_avgNormalVelocity, old_avgVelocityZonal, old_avgVelocityMeridional, old_avgVertVelocityTop, & - old_varNormalVelocity, old_varVelocityZonal, old_varVelocityMeridional, & - old_avgNormalTransportVelocity, old_avgTransportVelocityZonal, old_avgTransportVelocityMeridional, old_avgVertTransportVelocityTop, & - old_avgNormalGMBolusVelocity, old_avgGMBolusVelocityZonal, old_avgGMBolusVelocityMeridional, old_avgVertGMBolusVelocityTop - - integer :: timeLevel - - if (present(timeLevelIn)) then - timeLevel = timeLevelIn - else - timeLevel = 1 - end if - - call mpas_pool_get_array(statePool, 'normalVelocity', normalVelocity, timeLevel) - call mpas_pool_get_array(statePool, 'ssh', ssh, timeLevel) - - call mpas_pool_get_array(diagnosticsPool, 'velocityZonal', velocityZonal) - call mpas_pool_get_array(diagnosticsPool, 'velocityMeridional', velocityMeridional) - call mpas_pool_get_array(diagnosticsPool, 'vertVelocityTop', vertVelocityTop) - call mpas_pool_get_array(diagnosticsPool, 'normalTransportVelocity ', normalTransportVelocity) - call mpas_pool_get_array(diagnosticsPool, 'transportVelocityZonal', transportVelocityZonal) - call mpas_pool_get_array(diagnosticsPool, 'transportVelocityMeridional', transportVelocityMeridional) - call mpas_pool_get_array(diagnosticsPool, 'vertTransportVelocityTop', vertTransportVelocityTop) - call mpas_pool_get_array(diagnosticsPool, 'normalGMBolusVelocity', normalGMBolusVelocity) - call mpas_pool_get_array(diagnosticsPool, 'GMBolusVelocityZonal', GMBolusVelocityZonal) - call mpas_pool_get_array(diagnosticsPool, 'GMBolusVelocityMeridional', GMBolusVelocityMeridional) - call mpas_pool_get_array(diagnosticsPool, 'vertGMBolusVelocityTop', vertGMBolusVelocityTop) - - call mpas_pool_get_array(averagePool, 'nAverage', nAverage) - call mpas_pool_get_array(averagePool, 'avgSSH', avgSSH) - call mpas_pool_get_array(averagePool, 'varSSH', varSSH) - call mpas_pool_get_array(averagePool, 'avgNormalVelocity', avgNormalVelocity) - call mpas_pool_get_array(averagePool, 'avgVelocityZonal', avgVelocityZonal) - call mpas_pool_get_array(averagePool, 'avgVelocityMeridional', avgVelocityMeridional) - call mpas_pool_get_array(averagePool, 'avgVertVelocityTop', avgVertVelocityTop) - call mpas_pool_get_array(averagePool, 'varNormalVelocity', varNormalVelocity) - call mpas_pool_get_array(averagePool, 'varVelocityZonal', varVelocityZonal) - call mpas_pool_get_array(averagePool, 'varVelocityMeridional', varVelocityMeridional) - call mpas_pool_get_array(averagePool, 'avgNormalTransportVelocity', avgNormalTransportVelocity) - call mpas_pool_get_array(averagePool, 'avgTransportVelocityZonal', avgTransportVelocityZonal) - call mpas_pool_get_array(averagePool, 'avgTransportVelocityMeridional', avgTransportVelocityMeridional) - call mpas_pool_get_array(averagePool, 'avgVertTransportVelocityTop', avgVertTransportVelocityTop) - call mpas_pool_get_array(averagePool, 'avgNormalGMBolusVelocity', avgNormalGMBolusVelocity) - call mpas_pool_get_array(averagePool, 'avgGMBolusVelocityZonal', avgGMBolusVelocityZonal) - call mpas_pool_get_array(averagePool, 'avgGMBolusVelocityMeridional', avgGMBolusVelocityMeridional) - call mpas_pool_get_array(averagePool, 'avgVertGMBolusVelocityTop', avgVertGMBolusVelocityTop) - - avgSSH = avgSSH + ssh - varSSH = varSSH + ssh**2 - avgNormalVelocity = avgNormalVelocity + normalVelocity - avgVelocityZonal = avgVelocityZonal + velocityZonal - avgVelocityMeridional = avgVelocityMeridional + velocityMeridional - avgVertVelocityTop = avgVertVelocityTop + vertVelocityTop - varNormalVelocity = varNormalVelocity + normalVelocity**2 - varVelocityZonal = varVelocityZonal + velocityZonal**2 - varVelocityMeridional = varVelocityMeridional + velocityMeridional**2 - avgNormalTransportVelocity = avgNormalTransportVelocity + normalTransportVelocity - avgTransportVelocityZonal = avgTransportVelocityZonal + transportVelocityZonal - avgTransportVelocityMeridional = avgTransportVelocityMeridional + transportVelocityMeridional - avgVertTransportVelocityTop = avgVertTransportVelocityTop + vertTransportVelocityTop - avgNormalGMBolusVelocity = avgNormalGMBolusVelocity + normalGMBolusVelocity - avgGMBolusVelocityZonal = avgGMBolusVelocityZonal + GMBolusVelocityZonal - avgGMBolusVelocityMeridional = avgGMBolusVelocityMeridional + GMBolusVelocityMeridional - avgVertGMBolusVelocityTop = avgVertGMBolusVelocityTop + vertGMBolusVelocityTop - - nAverage = nAverage + 1 - end subroutine ocn_time_average_accumulate!}}} - - subroutine ocn_time_average_normalize(averagePool)!{{{ - type (mpas_pool_type), intent(inout) :: averagePool - - real (kind=RKIND), pointer :: nAverage - - real (kind=RKIND), dimension(:), pointer :: avgSSH, varSSH - real (kind=RKIND), dimension(:,:), pointer :: & - avgNormalVelocity, avgVelocityZonal, avgVelocityMeridional, avgVertVelocityTop, & - varNormalVelocity, varVelocityZonal, varVelocityMeridional, & - avgNormalTransportVelocity, avgTransportVelocityZonal, avgTransportVelocityMeridional, avgVertTransportVelocityTop, & - avgNormalGMBolusVelocity, avgGMBolusVelocityZonal, avgGMBolusVelocityMeridional, avgVertGMBolusVelocityTop - - call mpas_pool_get_array(averagePool, 'nAverage', nAverage) - call mpas_pool_get_array(averagePool, 'avgSSH', avgSSH) - call mpas_pool_get_array(averagePool, 'varSSH', varSSH) - call mpas_pool_get_array(averagePool, 'avgNormalVelocity', avgNormalVelocity) - call mpas_pool_get_array(averagePool, 'avgVelocityZonal', avgVelocityZonal) - call mpas_pool_get_array(averagePool, 'avgVelocityMeridional', avgVelocityMeridional) - call mpas_pool_get_array(averagePool, 'avgVertVelocityTop', avgVertVelocityTop) - call mpas_pool_get_array(averagePool, 'varNormalVelocity', varNormalVelocity) - call mpas_pool_get_array(averagePool, 'varVelocityZonal', varVelocityZonal) - call mpas_pool_get_array(averagePool, 'varVelocityMeridional', varVelocityMeridional) - call mpas_pool_get_array(averagePool, 'avgNormalTransportVelocity', avgNormalTransportVelocity) - call mpas_pool_get_array(averagePool, 'avgTransportVelocityZonal', avgTransportVelocityZonal) - call mpas_pool_get_array(averagePool, 'avgTransportVelocityMeridional', avgTransportVelocityMeridional) - call mpas_pool_get_array(averagePool, 'avgVertTransportVelocityTop', avgVertTransportVelocityTop) - call mpas_pool_get_array(averagePool, 'avgNormalGMBolusVelocity', avgNormalGMBolusVelocity) - call mpas_pool_get_array(averagePool, 'avgGMBolusVelocityZonal', avgGMBolusVelocityZonal) - call mpas_pool_get_array(averagePool, 'avgGMBolusVelocityMeridional', avgGMBolusVelocityMeridional) - call mpas_pool_get_array(averagePool, 'avgVertGMBolusVelocityTop', avgVertGMBolusVelocityTop) - - if(nAverage > 0) then - avgSSH = avgSSH / nAverage - varSSH = varSSH / nAverage - avgNormalVelocity = avgNormalVelocity / nAverage - avgVelocityZonal = avgVelocityZonal / nAverage - avgVelocityMeridional = avgVelocityMeridional / nAverage - avgVertVelocityTop = avgVertVelocityTop / nAverage - varNormalVelocity = varNormalVelocity / nAverage - varVelocityZonal = varVelocityZonal / nAverage - varVelocityMeridional = varVelocityMeridional / nAverage - avgNormalTransportVelocity = avgNormalTransportVelocity / nAverage - avgTransportVelocityZonal = avgTransportVelocityZonal / nAverage - avgTransportVelocityMeridional = avgTransportVelocityMeridional / nAverage - avgVertTransportVelocityTop = avgVertTransportVelocityTop / nAverage - avgNormalGMBolusVelocity = avgNormalGMBolusVelocity / nAverage - avgGMBolusVelocityZonal = avgGMBolusVelocityZonal / nAverage - avgGMBolusVelocityMeridional = avgGMBolusVelocityMeridional / nAverage - avgVertGMBolusVelocityTop = avgVertGMBolusVelocityTop / nAverage - end if - end subroutine ocn_time_average_normalize!}}} - -end module ocn_time_average diff --git a/src/core_ocean/shared/mpas_ocn_time_average_coupled.F b/src/core_ocean/shared/mpas_ocn_time_average_coupled.F index 2ec389bab4..f4b2dd4e8d 100644 --- a/src/core_ocean/shared/mpas_ocn_time_average_coupled.F +++ b/src/core_ocean/shared/mpas_ocn_time_average_coupled.F @@ -58,9 +58,11 @@ subroutine ocn_time_average_coupled_init(forcingPool)!{{{ call mpas_pool_get_array(forcingPool, 'avgSSHGradient', avgSSHGradient) call mpas_pool_get_array(forcingPool, 'nAccumulatedCoupled', nAccumulatedCoupled) + !$omp workshare avgTracersSurfaceValue(:,:) = 0.0_RKIND avgSurfaceVelocity(:,:) = 0.0_RKIND avgSSHGradient(:,:) = 0.0_RKIND + !$omp end workshare call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_mode', config_land_ice_flux_mode) if(trim(config_land_ice_flux_mode) == 'coupled') then @@ -68,9 +70,11 @@ subroutine ocn_time_average_coupled_init(forcingPool)!{{{ call mpas_pool_get_array(forcingPool, 'avgLandIceTracerTransferVelocities', avgLandIceTracerTransferVelocities) call mpas_pool_get_array(forcingPool, 'avgEffectiveDensityInLandIce', avgEffectiveDensityInLandIce) + !$omp workshare avgLandIceBoundaryLayerTracers(:,:) = 0.0_RKIND avgLandIceTracerTransferVelocities(:,:) = 0.0_RKIND avgEffectiveDensityInLandIce(:) = 0.0_RKIND + !$omp end workshare end if nAccumulatedCoupled = 0 @@ -119,8 +123,7 @@ subroutine ocn_time_average_coupled_accumulate(diagnosticsPool, statePool, forci call mpas_pool_get_array(forcingPool, 'nAccumulatedCoupled', nAccumulatedCoupled) - - + !$omp workshare avgTracersSurfaceValue(:,:) = avgTracersSurfaceValue(:,:) * nAccumulatedCoupled + tracersSurfaceValue(:,:) avgTracersSurfaceValue(index_temperature,:) = avgTracersSurfaceValue(index_temperature,:) + T0_Kelvin avgTracersSurfaceValue(:,:) = avgTracersSurfaceValue(:,:) / ( nAccumulatedCoupled + 1 ) @@ -129,6 +132,7 @@ subroutine ocn_time_average_coupled_accumulate(diagnosticsPool, statePool, forci avgSSHGradient(index_SSHzonal,:) = ( avgSSHGradient(index_SSHzonal,:) * nAccumulatedCoupled + gradSSHZonal(1,:) ) / ( nAccumulatedCoupled + 1 ) avgSSHGradient(index_SSHmeridional,:) = ( avgSSHGradient(index_SSHmeridional,:) * nAccumulatedCoupled + gradSSHMeridional(1,:) ) / ( nAccumulatedCoupled + 1 ) + !$omp end workshare call mpas_pool_get_config(ocnConfigs, 'config_land_ice_flux_mode', config_land_ice_flux_mode) if(trim(config_land_ice_flux_mode) == 'coupled') then @@ -140,46 +144,18 @@ subroutine ocn_time_average_coupled_accumulate(diagnosticsPool, statePool, forci call mpas_pool_get_array(forcingPool, 'avgLandIceTracerTransferVelocities', avgLandIceTracerTransferVelocities) call mpas_pool_get_array(forcingPool, 'avgEffectiveDensityInLandIce', avgEffectiveDensityInLandIce) + !$omp workshare avgLandIceBoundaryLayerTracers(:,:) = ( avgLandIceBoundaryLayerTracers(:,:) * nAccumulatedCoupled & + landIceBoundaryLayerTracers(:,:) ) / ( nAccumulatedCoupled + 1 ) avgLandIceTracerTransferVelocities(:,:) = ( avgLandIceTracerTransferVelocities(:,:) * nAccumulatedCoupled & + landIceTracerTransferVelocities(:,:) ) / ( nAccumulatedCoupled + 1) avgEffectiveDensityInLandIce(:) = ( avgEffectiveDensityInLandIce(:) * nAccumulatedCoupled & + effectiveDensityInLandIce(:) ) / ( nAccumulatedCoupled + 1) + !$omp end workshare end if nAccumulatedCoupled = nAccumulatedCoupled + 1 end subroutine ocn_time_average_coupled_accumulate!}}} -!*********************************************************************** -! -! routine ocn_time_average_coupled_normalize -! -!> \brief Coupled time averager normalization -!> \author Doug Jacobsen -!> \date 06/08/2013 -!> \details -!> This routine normalizes the coupled time averaging fields -! -!----------------------------------------------------------------------- - subroutine ocn_time_average_coupled_normalize(forcingPool)!{{{ - - type (mpas_pool_type), intent(inout) :: forcingPool - -! real (kind=RKIND), dimension(:,:), pointer :: avgTracersSurfaceValue, avgSurfaceVelocity, avgSSHGradient - -! avgTracersSurfaceValue => forcing % avgTracersSurfaceValue % array -! avgSurfaceVelocity => forcing % avgSurfaceVelocity % array -! avgSSHGradient => forcing % avgSSHGradient % array - -! if(forcing % nAccumulatedCoupled % scalar > 0) then -! avgTracersSurfaceValue = avgTracersSurfaceValue / forcing % nAccumulatedCoupled % scalar -! avgSurfaceVelocity = avgSurfaceVelocity / forcing % nAccumulatedCoupled % scalar -! avgSSHGradient = avgSSHGradient / forcing % nAccumulatedCoupled % scalar -! forcing % nAccumulatedCoupled % scalar = 0 -! end if - - end subroutine ocn_time_average_coupled_normalize!}}} - end module ocn_time_average_coupled diff --git a/src/core_ocean/shared/mpas_ocn_tracer_TTD.F b/src/core_ocean/shared/mpas_ocn_tracer_TTD.F index 473b801f83..b3f30d588f 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_TTD.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_TTD.F @@ -120,7 +120,9 @@ subroutine ocn_tracer_TTD_compute(nTracers, nCellsSolve, maxLevelCell, layerThic ! zero tracers at surface to TTDMask at top-most layer ! TTDMask should be 1 within region of interest and zero elsewhere + !$omp workshare tracers(:,1,:) = TTDMask(:,:) + !$omp end workshare !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_tracer_advection_mono.F b/src/core_ocean/shared/mpas_ocn_tracer_advection_mono.F index a64a588679..3715535f97 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_advection_mono.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_advection_mono.F @@ -22,6 +22,7 @@ module ocn_tracer_advection_mono use mpas_derived_types use mpas_pool_routines use mpas_io_units + use mpas_threading use mpas_tracer_advection_helpers @@ -134,7 +135,7 @@ subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAd call mpas_allocate_scratch_field(fluxIncomingField, .true.) call mpas_allocate_scratch_field(fluxOutgoingField, .true.) call mpas_allocate_scratch_field(highOrderVertFluxField, .true.) - + call mpas_threading_barrier() ! Setup high order horizontal flux field high_order_horiz_flux => highOrderHorizFluxField % array @@ -152,15 +153,18 @@ subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAd ! allocate nVertLevels+1 and nCells arrays high_order_vert_flux => highOrderVertFluxField % array + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k=1, maxLevelCell(iCell) inv_h_new(k, iCell) = 1.0 / (layerThickness(k, iCell) + dt * tend_layerThickness(k, iCell)) end do end do + !$omp end do ! Loop over tracers. One tracer is advected at a time. It is copied into a temporary array in order to improve locality do iTracer = 1, num_tracers ! Initialize variables for use in this iTracer iteration + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k=1, maxLevelCell(iCell) tracer_cur(k,iCell) = tracers(iTracer,k,iCell) @@ -172,11 +176,15 @@ subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAd end if end do ! k loop end do ! iCell loop + !$omp end do + !$omp workshare high_order_vert_flux = 0.0_RKIND high_order_horiz_flux = 0.0_RKIND + !$omp end workshare ! Compute the high order vertical flux. Also determine bounds on tracer_cur. + !$omp do schedule(runtime) private(k, verticalWeightK, verticalWeightKm1, i) do iCell = 1, nCells k = 1 tracer_max(k,iCell) = max(tracer_cur(k,iCell),tracer_cur(k+1,iCell)) @@ -220,8 +228,10 @@ subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAd end do ! k loop end do ! i loop over nEdgesOnCell end do ! iCell Loop + !$omp end do ! Compute the high order horizontal flux + !$omp do schedule(runtime) private(cell1, cell2, k, tracer_weight, i, iCell) do iEdge = 1, nEdges cell1 = cellsOnEdge(1, iEdge) cell2 = cellsOnEdge(2, iEdge) @@ -244,19 +254,16 @@ subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAd end do ! k loop end do ! i loop over nAdvCellsForEdge end do ! iEdge loop + !$omp end do ! low order upwind vertical flux (monotonic and diffused) ! Remove low order flux from the high order flux. ! Store left over high order flux in high_order_vert_flux array. ! Upwind fluxes are accumulated in upwind_tendency + !$omp do schedule(runtime) private(k, flux_upwind) do iCell = 1, nCells do k = 2, maxLevelCell(iCell) - ! dwj 02/03/12 and Atmosphere are different in vertical - if(positiveDzDk) then - flux_upwind = max(0.0_RKIND,w(k,iCell))*tracer_cur(k-1,iCell) + min(0.0_RKIND,w(k,iCell))*tracer_cur(k,iCell) - else - flux_upwind = min(0.0_RKIND,w(k,iCell))*tracer_cur(k-1,iCell) + max(0.0_RKIND,w(k,iCell))*tracer_cur(k,iCell) - end if + flux_upwind = min(0.0_RKIND,w(k,iCell))*tracer_cur(k-1,iCell) + max(0.0_RKIND,w(k,iCell))*tracer_cur(k,iCell) upwind_tendency(k-1,iCell) = upwind_tendency(k-1,iCell) + flux_upwind upwind_tendency(k ,iCell) = upwind_tendency(k ,iCell) - flux_upwind high_order_vert_flux(k,iCell) = high_order_vert_flux(k,iCell) - flux_upwind @@ -267,21 +274,17 @@ subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAd ! flux_outgoing contains the total remaining high order flux out of iCell ! it is negative do k = 1, maxLevelCell(iCell) - ! dwj 02/03/12 and Atmosphere are different in vertical - if(positiveDzDk) then - flux_incoming (k,iCell) = -(min(0.0_RKIND,high_order_vert_flux(k+1,iCell))-max(0.0_RKIND,high_order_vert_flux(k,iCell))) - flux_outgoing(k,iCell) = -(max(0.0_RKIND,high_order_vert_flux(k+1,iCell))-min(0.0_RKIND,high_order_vert_flux(k,iCell))) - else - flux_incoming (k, iCell) = max(0.0_RKIND, high_order_vert_flux(k+1, iCell)) - min(0.0_RKIND, high_order_vert_flux(k, iCell)) - flux_outgoing(k, iCell) = min(0.0_RKIND, high_order_vert_flux(k+1, iCell)) - max(0.0_RKIND, high_order_vert_flux(k, iCell)) - end if + flux_incoming (k, iCell) = max(0.0_RKIND, high_order_vert_flux(k+1, iCell)) - min(0.0_RKIND, high_order_vert_flux(k, iCell)) + flux_outgoing(k, iCell) = min(0.0_RKIND, high_order_vert_flux(k+1, iCell)) - max(0.0_RKIND, high_order_vert_flux(k, iCell)) end do ! k Loop end do ! iCell Loop + !$omp end do ! low order upwind horizontal flux (monotinc and diffused) ! Remove low order flux from the high order flux ! Store left over high order flux in high_order_horiz_flux array ! Upwind fluxes are accumulated in upwind_tendency + !$omp do schedule(runtime) private(cell1, cell2, invAreaCell1, invAreaCell2, k, flux_upwind) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -294,7 +297,9 @@ subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAd high_order_horiz_flux(k,iEdge) = high_order_horiz_flux(k,iEdge) - flux_upwind end do ! k loop end do ! iEdge loop + !$omp end do + !$omp do schedule(runtime) private(invAreaCell1, i, iEdge, cell1, cell2, k, flux_upwind) do iCell = 1, nCells invAreaCell1 = 1.0_RKIND / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) @@ -312,10 +317,12 @@ subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAd end do end do end do + !$omp end do ! Build the factors for the FCT ! Computed using the bounds that were computed previously, and the bounds on the newly updated value ! Factors are placed in the flux_incoming and flux_outgoing arrays + !$omp do schedule(runtime) private(k, tracer_max_new, tracer_min_new, tracer_upwind_new, scale_factor) do iCell = 1, nCells do k = 1, maxLevelCell(iCell) tracer_min_new = (tracer_cur(k,iCell)*layerThickness(k,iCell) + dt*(upwind_tendency(k,iCell)+flux_outgoing(k,iCell))) * inv_h_new(k,iCell) @@ -329,8 +336,10 @@ subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAd flux_outgoing(k,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) end do ! k loop end do ! iCell loop + !$omp end do ! rescale the high order horizontal fluxes + !$omp do schedule(runtime) private(cell1, cell2, k, flux) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -341,24 +350,22 @@ subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAd high_order_horiz_flux(k,iEdge) = flux end do ! k loop end do ! iEdge loop + !$omp end do ! rescale the high order vertical flux + !$omp do schedule(runtime) private(k, flux) do iCell = 1, nCellsSolve do k = 2, maxLevelCell(iCell) flux = high_order_vert_flux(k,iCell) - ! dwj 02/03/12 and Atmosphere are different in vertical. - if(positiveDzDk) then - flux = max(0.0_RKIND,flux) * min(flux_outgoing(k-1,iCell), flux_incoming(k ,iCell)) & - + min(0.0_RKIND,flux) * min(flux_outgoing(k ,iCell), flux_incoming(k-1,iCell)) - else - flux = max(0.0_RKIND,flux) * min(flux_outgoing(k ,iCell), flux_incoming(k-1,iCell)) & - + min(0.0_RKIND,flux) * min(flux_outgoing(k-1,iCell), flux_incoming(k ,iCell)) - end if + flux = max(0.0_RKIND,flux) * min(flux_outgoing(k ,iCell), flux_incoming(k-1,iCell)) & + + min(0.0_RKIND,flux) * min(flux_outgoing(k-1,iCell), flux_incoming(k ,iCell)) high_order_vert_flux(k,iCell) = flux end do ! k loop end do ! iCell loop + !$omp end do ! Accumulate the scaled high order horizontal tendencies + !$omp do schedule(runtime) private(invAreaCell1, i, iEdge, k) do iCell = 1, nCells invAreaCell1 = 1.0 / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) @@ -372,8 +379,10 @@ subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAd end do end do end do + !$omp end do ! Accumulate the scaled high order vertical tendencies, and the upwind tendencies + !$omp do schedule(runtime) private(k) do iCell = 1, nCellsSolve do k = 1,maxLevelCell(iCell) tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + verticalDivergenceFactor(k) * (high_order_vert_flux(k+1, iCell) - high_order_vert_flux(k, iCell)) + upwind_tendency(k,iCell) @@ -387,9 +396,11 @@ subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAd end if end do ! k loop end do ! iCell loop + !$omp end do if (monotonicityCheck) then !build min and max bounds on old and new tracer for check on monotonicity. + !$omp do schedule(runtime) private(k) do iCell = 1, nCellsSolve do k = 1, maxLevelCell(iCell) if(tracer_new(k,iCell) < tracer_min(k, iCell)-eps) then @@ -401,9 +412,11 @@ subroutine ocn_tracer_advection_mono_tend(tracers, adv_coefs, adv_coefs_3rd, nAd end if end do end do + !$omp end do end if end do ! iTracer loop + call mpas_threading_barrier() call mpas_deallocate_scratch_field(highOrderHorizFluxField, .true.) call mpas_deallocate_scratch_field(tracerNewField, .true.) call mpas_deallocate_scratch_field(tracerCurField, .true.) diff --git a/src/core_ocean/shared/mpas_ocn_tracer_advection_std.F b/src/core_ocean/shared/mpas_ocn_tracer_advection_std.F index 0688962776..99c1929c1e 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_advection_std.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_advection_std.F @@ -22,6 +22,7 @@ module ocn_tracer_advection_std use mpas_derived_types use mpas_pool_routines use mpas_io_units + use mpas_threading use mpas_tracer_advection_helpers @@ -116,6 +117,7 @@ subroutine ocn_tracer_advection_std_tend(tracers, adv_coefs, adv_coefs_3rd, nAdv call mpas_allocate_scratch_field(highOrderHorizFluxField, .true.) call mpas_allocate_scratch_field(tracerCurField, .true.) call mpas_allocate_scratch_field(highOrderVertFluxField, .true.) + call mpas_threading_barrier() high_order_horiz_flux => highOrderHorizFluxField % array tracer_cur => tracerCurField % array @@ -124,12 +126,15 @@ subroutine ocn_tracer_advection_std_tend(tracers, adv_coefs, adv_coefs_3rd, nAdv ! Loop over tracers. One tracer is advected at a time. It is copied into a temporary array in order to improve locality do iTracer = 1, num_tracers ! Initialize variables for use in this iTracer iteration + !$omp workshare tracer_cur(:, :) = tracers(iTracer, :, :) high_order_vert_flux = 0.0_RKIND high_order_horiz_flux = 0.0_RKIND + !$omp end workshare ! Compute the high order vertical flux. Also determine bounds on tracer_cur. + !$omp do schedule(runtime) private(k, verticalWeightK, verticalWeightKm1) do iCell = 1, nCells k = max(1, min(maxLevelCell(iCell), 2)) verticalWeightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) @@ -155,8 +160,10 @@ subroutine ocn_tracer_advection_std_tend(tracers, adv_coefs, adv_coefs_3rd, nAdv verticalWeightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell)) high_order_vert_flux(k,iCell) = w(k,iCell)*(verticalWeightK*tracer_cur(k,iCell)+verticalWeightKm1*tracer_cur(k-1,iCell)) end do ! iCell Loop + !$omp end do ! Compute the high order horizontal flux + !$omp do schedule(runtime) private(cell1, cell2, k, tracer_weight, i, iCell) do iEdge = 1, nEdges cell1 = cellsOnEdge(1, iEdge) cell2 = cellsOnEdge(2, iEdge) @@ -179,8 +186,10 @@ subroutine ocn_tracer_advection_std_tend(tracers, adv_coefs, adv_coefs_3rd, nAdv end do ! k loop end do ! i loop over nAdvCellsForEdge end do ! iEdge loop + !$omp end do ! Accumulate the scaled high order horizontal tendencies + !$omp do schedule(runtime) private(invAreaCell1, i, iEdge, k) do iCell = 1, nCells invAreaCell1 = 1.0 / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) @@ -190,18 +199,23 @@ subroutine ocn_tracer_advection_std_tend(tracers, adv_coefs, adv_coefs_3rd, nAdv end do end do end do + !$omp end do ! Accumulate the scaled high order vertical tendencies. + !$omp do schedule(runtime) private(k) do iCell = 1, nCellsSolve do k = 1,maxLevelCell(iCell) tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + verticalDivergenceFactor(k) * (high_order_vert_flux(k+1, iCell) - high_order_vert_flux(k, iCell)) end do ! k loop end do ! iCell loop + !$omp end do end do ! iTracer loop + call mpas_threading_barrier() call mpas_deallocate_scratch_field(highOrderHorizFluxField, .true.) call mpas_deallocate_scratch_field(tracerCurField, .true.) call mpas_deallocate_scratch_field(highOrderVertFluxField, .true.) + deallocate(verticalDivergenceFactor) end subroutine ocn_tracer_advection_std_tend!}}} diff --git a/src/core_ocean/shared/mpas_ocn_tracer_exponential_decay.F b/src/core_ocean/shared/mpas_ocn_tracer_exponential_decay.F index b2ea46ea3b..1b8027475f 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_exponential_decay.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_exponential_decay.F @@ -118,6 +118,7 @@ subroutine ocn_tracer_exponential_decay_compute(nTracers, nCellsSolve, maxLevelC err = 0 + !$omp do schedule(runtime) private(iLevel, iTracer) do iCell=1,nCellsSolve do iLevel=1,maxLevelCell(iCell) do iTracer=1,nTracers @@ -128,6 +129,7 @@ subroutine ocn_tracer_exponential_decay_compute(nTracers, nCellsSolve, maxLevelC enddo enddo enddo + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_tracer_hmix.F b/src/core_ocean/shared/mpas_ocn_tracer_hmix.F index 9af772a45e..944302d201 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_hmix.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_hmix.F @@ -143,7 +143,7 @@ subroutine ocn_tracer_hmix_tend(meshPool, scratchPool, layerThicknessEdge, zMid, call ocn_tracer_hmix_del2_tend(meshPool, layerThicknessEdge, tracers, tend, err1) call mpas_timer_stop("del2", del2Timer) call mpas_timer_start("del4", .false., del4Timer) - call ocn_tracer_hmix_del4_tend(meshPool, layerThicknessEdge, tracers, tend, err2) + call ocn_tracer_hmix_del4_tend(meshPool, scratchPool, layerThicknessEdge, tracers, tend, err2) call mpas_timer_stop("del4", del4Timer) call mpas_timer_start("redi", .false., rediTimer) call ocn_tracer_hmix_redi_tend(meshPool, scratchPool, layerThicknessEdge, zMid, tracers, & diff --git a/src/core_ocean/shared/mpas_ocn_tracer_hmix_del2.F b/src/core_ocean/shared/mpas_ocn_tracer_hmix_del2.F index ddb199307b..61410c2742 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_hmix_del2.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_hmix_del2.F @@ -24,6 +24,7 @@ module ocn_tracer_hmix_del2 use mpas_derived_types use mpas_pool_routines + use mpas_threading use ocn_constants @@ -145,6 +146,7 @@ subroutine ocn_tracer_hmix_del2_tend(meshPool, layerThicknessEdge, tracers, tend ! ! compute a boundary mask to enforce insulating boundary conditions in the horizontal ! + !$omp do schedule(runtime) private(invAreaCell, i, iEdge, cell1, cell2, r_tmp, k, iTracer, tracer_turb_flux, flux) do iCell = 1, nCells invAreaCell = 1.0 / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) @@ -168,6 +170,7 @@ subroutine ocn_tracer_hmix_del2_tend(meshPool, layerThicknessEdge, tracers, tend end do end do + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_tracer_hmix_del4.F b/src/core_ocean/shared/mpas_ocn_tracer_hmix_del4.F index 7db07db729..17fcb58da5 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_hmix_del4.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_hmix_del4.F @@ -24,6 +24,7 @@ module ocn_tracer_hmix_del4 use mpas_derived_types use mpas_pool_routines + use mpas_threading use ocn_constants implicit none @@ -73,7 +74,7 @@ module ocn_tracer_hmix_del4 ! !----------------------------------------------------------------------- - subroutine ocn_tracer_hmix_del4_tend(meshPool, layerThicknessEdge, tracers, tend, err)!{{{ + subroutine ocn_tracer_hmix_del4_tend(meshPool, scratchPool, layerThicknessEdge, tracers, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -87,6 +88,8 @@ subroutine ocn_tracer_hmix_del4_tend(meshPool, layerThicknessEdge, tracers, tend type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: scratchPool !< Input: scratch variables + real (kind=RKIND), dimension(:,:,:), intent(in) :: & tracers !< Input: tracer quantities @@ -122,7 +125,9 @@ subroutine ocn_tracer_hmix_del4_tend(meshPool, layerThicknessEdge, tracers, tend real (kind=RKIND) :: invAreaCell1, invAreaCell2, tracer_turb_flux, flux, invdcEdge, r_tmp1, r_tmp2 - real (kind=RKIND), dimension(:,:,:), allocatable :: delsq_tracer + !real (kind=RKIND), dimension(:,:,:), allocatable :: delsq_tracer + real (kind=RKIND), dimension(:,:,:), pointer :: delsq_tracer + type (field3DReal), pointer :: delsq_tracerField real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, meshScalingDel4 @@ -159,11 +164,21 @@ subroutine ocn_tracer_hmix_del4_tend(meshPool, layerThicknessEdge, tracers, tend call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) - allocate(delsq_tracer(num_tracers,nVertLevels, nCells+1)) + !allocate(delsq_tracer(num_tracers,nVertLevels, nCells+1)) + call mpas_pool_get_field(scratchPool, 'delsq_tracer', delsq_tracerField) + + call mpas_allocate_scratch_field(delsq_tracerField, .true.) + + call mpas_threading_barrier() + delsq_tracer => delsq_tracerField % array + + !$omp workshare delsq_tracer(:,:,:) = 0.0 + !$omp end workshare ! first del2: div(h \nabla \phi) at cell center + !$omp do schedule(runtime) private(invAreaCell1, i, iEdge, invdcEdge, cell1, cell2, k, iTracer, r_tmp1, r_tmp2) do iCell = 1, nCells invAreaCell1 = 1.0 / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) @@ -183,8 +198,10 @@ subroutine ocn_tracer_hmix_del4_tend(meshPool, layerThicknessEdge, tracers, tend end do end do end do + !$omp end do ! second del2: div(h \nabla [delsq_tracer]) at cell center + !$omp do schedule(runtime) private(invAreaCell1, i, iEdge, cell1, cell2, invdcEdge, k, iTracer, tracer_turb_flux, flux) do iCell = 1, nCells invAreaCell1 = 1.0 / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) @@ -205,8 +222,11 @@ subroutine ocn_tracer_hmix_del4_tend(meshPool, layerThicknessEdge, tracers, tend end do end do end do + !$omp end do + + call mpas_threading_barrier() + call mpas_deallocate_scratch_field(delsq_tracerField, .true.) - deallocate(delsq_tracer) !-------------------------------------------------------------------- end subroutine ocn_tracer_hmix_del4_tend!}}} diff --git a/src/core_ocean/shared/mpas_ocn_tracer_hmix_redi.F b/src/core_ocean/shared/mpas_ocn_tracer_hmix_redi.F index 59aa3b7a73..1131199cbf 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_hmix_redi.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_hmix_redi.F @@ -24,6 +24,7 @@ module ocn_tracer_hmix_redi use mpas_derived_types use mpas_pool_routines + use mpas_threading use ocn_constants @@ -186,6 +187,7 @@ subroutine ocn_tracer_hmix_redi_tend(meshPool, scratchPool, layerThicknessEdge, call mpas_allocate_scratch_field(dTracerdZTopOfCellField, .true.) call mpas_allocate_scratch_field(dTracerdZTopOfEdgeField, .true.) call mpas_allocate_scratch_field(areaCellSumField, .True.) + call mpas_threading_barrier() gradTracerEdge => gradTracerEdgeField % array gradTracerTopOfEdge => gradTracerTopOfEdgeField % array @@ -194,15 +196,18 @@ subroutine ocn_tracer_hmix_redi_tend(meshPool, scratchPool, layerThicknessEdge, dTracerdZTopOfEdge => dTracerdZTopOfEdgeField % array areaCellSum => areaCellSumField % array + !$omp workshare gradTracerEdge = 0.0 gradTracerTopOfEdge = 0.0 gradHTracerSlopedTopOfCell = 0.0 dTracerdZTopOfCell = 0.0 dTracerdZTopOfEdge = 0.0 + !$omp end workshare ! this is the "standard" del2 term, but forced to use config_redi_kappa if(.not.config_disable_redi_horizontal_term1) then + !$omp do schedule(runtime) private(invAreaCell, i, iEdge, cell1, cell2, r_tmp, k, s_tmp, iTracer, tracer_turb_flux, flux) do iCell = 1, nCells invAreaCell = 1.0 / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) @@ -230,12 +235,16 @@ subroutine ocn_tracer_hmix_redi_tend(meshPool, scratchPool, layerThicknessEdge, end do end do + !$omp end do endif ! Compute vertical derivative of tracers at cell center and top of layer do iTracer = 1, num_tracers + ! Sync threads before starting on tracers + call mpas_threading_barrier() + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 2, maxLevelCell(iCell) dTracerdZTopOfCell(k,iCell) = (tracers(iTracer,k-1,iCell) - tracers(iTracer,k,iCell)) / (zMid(k-1,iCell) - zMid(k,iCell)) @@ -247,9 +256,11 @@ subroutine ocn_tracer_hmix_redi_tend(meshPool, scratchPool, layerThicknessEdge, dTracerdZTopOfCell(1,iCell) = 0.0 dTracerdZTopOfCell(maxLevelCell(iCell)+1,iCell) = 0.0 end do + !$omp end do ! Compute tracer gradient (gradTracerEdge) along the constant coordinate surface. ! The computed variables lives at edge and mid-layer depth + !$omp do schedule(runtime) private(cell1, cell2, k) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -258,8 +269,10 @@ subroutine ocn_tracer_hmix_redi_tend(meshPool, scratchPool, layerThicknessEdge, gradTracerEdge(k,iEdge) = (tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) / dcEdge(iEdge) end do end do + !$omp end do ! Interpolate dTracerdZTopOfCell to edge and top of layer + !$omp do schedule(runtime) private(cell1, cell2, k) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -268,8 +281,10 @@ subroutine ocn_tracer_hmix_redi_tend(meshPool, scratchPool, layerThicknessEdge, end do dTracerdZTopOfEdge(maxLevelEdgeTop(iEdge)+1,iEdge) = 0.0 end do + !$omp end do ! Interpolate gradTracerEdge to edge and top of layer + !$omp do schedule(runtime) private(k, h1, h2) do iEdge = 1, nEdges do k = 2, maxLevelEdgeTop(iEdge) h1 = layerThicknessEdge(k-1,iEdge) @@ -284,9 +299,11 @@ subroutine ocn_tracer_hmix_redi_tend(meshPool, scratchPool, layerThicknessEdge, gradTracerTopOfEdge(1,iEdge) = gradTracerEdge(1,iEdge) gradTracerTopOfEdge(maxLevelEdgeTop(iEdge)+1,iEdge) = gradTracerEdge(max(maxLevelEdgeTop(iEdge),1),iEdge) end do + !$omp end do ! Compute \nabla\cdot(relativeSlope d\phi/dz) if(.not.config_disable_redi_horizontal_term2) then + !$omp do schedule(runtime) private(invAreaCell, i, iEdge, k, s_tmpU, s_tmpD, flux) do iCell = 1, nCells invAreaCell = 1.0_RKIND / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) @@ -301,14 +318,18 @@ subroutine ocn_tracer_hmix_redi_tend(meshPool, scratchPool, layerThicknessEdge, end do end do end do + !$omp end do endif ! Compute dz * d(relativeSlope\cdot\nabla\phi)/dz (so the dz cancel out) + !$omp workshare gradHTracerSlopedTopOfCell = 0.0 + !$omp end workshare ! Compute relativeSlope\cdot\nabla\phi (variable gradHTracerSlopedTopOfCell) at non-boundary edges areaCellSum = 1.0e-34 + !$omp do schedule(runtime) private(i, iedge, areaEdge, k, r_tmp) do iCell = 1, nCells do i = 1, nEdgesOnCell(iCell) iEdge = edgesOnCell(i, iCell) @@ -320,14 +341,18 @@ subroutine ocn_tracer_hmix_redi_tend(meshPool, scratchPool, layerThicknessEdge, end do end do end do + !$omp end do + !$omp do schedule(runtime) private(k) do iCell=1,nCells do k = 1, maxLevelCell(iCell) gradHTracerSlopedTopOfCell(k,iCell) = gradHTracerSlopedTopOfCell(k,iCell)/areaCellSum(k,iCell) end do end do + !$omp end do if(.not.config_disable_redi_horizontal_term3) then + !$omp do schedule(runtime) private(k, s_tmp) do iCell = 1, nCells ! impose no-flux boundary conditions at top and bottom of column gradHTracerSlopedTopOfCell(1,iCell) = 0.0 @@ -338,9 +363,12 @@ subroutine ocn_tracer_hmix_redi_tend(meshPool, scratchPool, layerThicknessEdge, (gradHTracerSlopedTopOfCell(k,iCell) - gradHTracerSlopedTopOfCell(k+1,iCell)) end do end do + !$omp end do endif + end do ! iTracer + call mpas_threading_barrier() call mpas_deallocate_scratch_field(gradTracerEdgeField, .true.) call mpas_deallocate_scratch_field(gradTracerTopOfEdgeField, .true.) call mpas_deallocate_scratch_field(gradHTracerSlopedTopOfCellField, .true.) diff --git a/src/core_ocean/shared/mpas_ocn_tracer_ideal_age.F b/src/core_ocean/shared/mpas_ocn_tracer_ideal_age.F index 362b01a55e..a881f8a52f 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_ideal_age.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_ideal_age.F @@ -118,19 +118,21 @@ subroutine ocn_tracer_ideal_age_compute(nTracers, nCellsSolve, maxLevelCell, lay err = 0 - ! zero tracers at surface to zero where idealAgeMask == zero - ! idealAgeMask should be equal to 1.0 elsewhere - tracers(:,1,:) = idealAgeMask(:,:) * tracers(:,1,:) - - ! add a tendency increment equivalent to "dt" to entire domain + !$omp do schedule(runtime) private(iLevel, iTracer) do iCell=1,nCellsSolve do iLevel=1,maxLevelCell(iCell) do iTracer=1,nTracers + ! zero tracers at surface to zero where idealAgeMask == zero + ! idealAgeMask should be equal to 1.0 elsewhere + tracers(iTracer, iLevel, iCell) = idealAgeMask(iTracer, iCell) * tracers(iTracer, iLevel, iCell) + + ! add a tendency increment equivalent to "dt" to entire domain tracer_tend(iTracer, iLevel, iCell) = tracer_tend(iTracer, iLevel, iCell) + & layerThickness(iLevel,iCell) * c1 enddo enddo enddo + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_tracer_interior_restoring.F b/src/core_ocean/shared/mpas_ocn_tracer_interior_restoring.F index 5c8262df99..c97a8b8f53 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_interior_restoring.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_interior_restoring.F @@ -118,6 +118,7 @@ subroutine ocn_tracer_interior_restoring_compute(nTracers, nCellsSolve, maxLevel err = 0 + !$omp do schedule(runtime) private(iLevel, iTracer) do iCell=1,nCellsSolve do iLevel=1,maxLevelCell(iCell) do iTracer=1,nTracers @@ -128,6 +129,7 @@ subroutine ocn_tracer_interior_restoring_compute(nTracers, nCellsSolve, maxLevel enddo enddo enddo + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F b/src/core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F index b8245d1275..1303a53bba 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F @@ -122,6 +122,7 @@ subroutine ocn_tracer_nonlocalflux_tend(meshPool, vertNonLocalFlux, surfaceTrace call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + !$omp do schedule(runtime) private(k, iTracer, fluxTopOfCell, fluxBottomOfCell) do iCell = 1, nCells do k = 2, maxLevelCell(iCell)-1 @@ -150,6 +151,7 @@ subroutine ocn_tracer_nonlocalflux_tend(meshPool, vertNonLocalFlux, surfaceTrace end do end do + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F b/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F index 0d973cfdef..86a262c1d1 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F @@ -142,6 +142,7 @@ subroutine ocn_tracer_short_wave_absorption_jerlov_tend(meshPool, index_temperat weights(1) = 1.0_RKIND if ( config_fixed_jerlov_weights ) then + !$omp do schedule(runtime) private(depth, k) do iCell = 1, nCells depth = 0.0_RKIND do k = 1, maxLevelCell(iCell) @@ -151,7 +152,9 @@ subroutine ocn_tracer_short_wave_absorption_jerlov_tend(meshPool, index_temperat tend(index_temperature, k, iCell) = tend(index_temperature, k, iCell) + penetrativeTemperatureFlux(iCell)*(weights(k) - weights(k+1)) end do end do + !$omp end do else + !$omp do schedule(runtime) private(depth, k) do iCell = 1, nCells depth = 0.0_RKIND do k = 1, maxLevelCell(iCell) @@ -161,6 +164,7 @@ subroutine ocn_tracer_short_wave_absorption_jerlov_tend(meshPool, index_temperat tend(index_temperature, k, iCell) = tend(index_temperature, k, iCell) + penetrativeTemperatureFlux(iCell)*(weights(k) - weights(k+1)) end do end do + !$omp end do end if deallocate(weights) diff --git a/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F b/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F index 3b8a59ae30..abe3b46ddd 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F @@ -127,6 +127,7 @@ subroutine ocn_tracer_surface_flux_tend(meshPool, fractionAbsorbed, layerThickne call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) + !$omp do schedule(runtime) private(remainingFlux, k, iTracer) do iCell = 1, nCells remainingFlux = 1.0_RKIND do k = 1, maxLevelCell(iCell) @@ -143,6 +144,7 @@ subroutine ocn_tracer_surface_flux_tend(meshPool, fractionAbsorbed, layerThickne end do end if end do + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F b/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F index 09e9e1441c..8ebc34edc9 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_surface_restoring.F @@ -115,6 +115,8 @@ subroutine ocn_tracer_surface_restoring_compute(nTracers, nCellsSolve, tracers, err = 0 iLevel = 1 ! base surface flux restoring on tracer fields in the top layer + + !$omp do schedule(runtime) private(iTracer) do iCell=1,nCellsSolve do iTracer=1,nTracers tracersSurfaceFlux(iTracer, iCell) = tracersSurfaceFlux(iTracer, iCell) - & @@ -122,6 +124,7 @@ subroutine ocn_tracer_surface_restoring_compute(nTracers, nCellsSolve, tracers, (tracers(iTracer, iLevel, iCell) - tracersSurfaceRestoringValue(iTracer,iCell)) enddo enddo + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_vel_coriolis.F b/src/core_ocean/shared/mpas_ocn_vel_coriolis.F index a181b9720f..cffc779881 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_coriolis.F +++ b/src/core_ocean/shared/mpas_ocn_vel_coriolis.F @@ -135,6 +135,7 @@ subroutine ocn_vel_coriolis_tend(meshPool, normalizedRelativeVorticityEdge, norm call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + !$omp do schedule(runtime) private(cell1, cell2, invLength, k, q, j, eoe, workVorticity) do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -156,6 +157,7 @@ subroutine ocn_vel_coriolis_tend(meshPool, normalizedRelativeVorticityEdge, norm end do end do + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_vel_forcing_rayleigh.F b/src/core_ocean/shared/mpas_ocn_vel_forcing_rayleigh.F index 529a6e5f5a..2fad79f086 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_forcing_rayleigh.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing_rayleigh.F @@ -126,6 +126,7 @@ subroutine ocn_vel_forcing_rayleigh_tend(meshPool, normalVelocity, tend, err)!{{ call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + !$omp do schedule(runtime) private(k) do iEdge = 1, nEdgesSolve do k = 1, maxLevelEdgeTop(iEdge) @@ -133,7 +134,7 @@ subroutine ocn_vel_forcing_rayleigh_tend(meshPool, normalVelocity, tend, err)!{{ enddo enddo - + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F b/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F index f5f41ebba9..ff68ca627f 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F +++ b/src/core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F @@ -137,6 +137,7 @@ subroutine ocn_vel_forcing_surface_stress_tend(meshPool, surfaceFluxAttenuationC call mpas_pool_get_array(meshPool, 'edgeMask', edgeMask) call mpas_pool_get_array(meshPool, 'cellsOnEdge', cellsOnEdge) + !$omp do schedule(runtime) private(zTop, transmissionCoeffBot, remainingStress, k, transmissionCoeffTop) do iEdge = 1, nEdgesSolve zTop = 0.0_RKIND cell1 = cellsOnEdge(1,iEdge) @@ -165,7 +166,7 @@ subroutine ocn_vel_forcing_surface_stress_tend(meshPool, surfaceFluxAttenuationC / rho_sw / layerThicknessEdge(maxLevelEdgeTop(iEdge), iEdge) end if enddo - + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_vel_hmix.F b/src/core_ocean/shared/mpas_ocn_vel_hmix.F index 5f85a1a78d..1b5d4f9bdf 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_hmix.F +++ b/src/core_ocean/shared/mpas_ocn_vel_hmix.F @@ -25,6 +25,7 @@ module ocn_vel_hmix use mpas_derived_types use mpas_pool_routines use mpas_timer + use mpas_threading use ocn_vel_hmix_del2 use ocn_vel_hmix_leith use ocn_vel_hmix_del4 @@ -80,8 +81,8 @@ module ocn_vel_hmix ! !----------------------------------------------------------------------- - subroutine ocn_vel_hmix_tend(meshPool, divergence, relativeVorticity, normalVelocity, tangentialVelocity, viscosity, & - tend, scratchPool, err)!{{{ + subroutine ocn_vel_hmix_tend(meshPool, scratchPool, divergence, relativeVorticity, normalVelocity, tangentialVelocity, viscosity, & + tend, err)!{{{ !----------------------------------------------------------------- ! @@ -92,6 +93,8 @@ subroutine ocn_vel_hmix_tend(meshPool, divergence, relativeVorticity, normalVelo type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information + type (mpas_pool_type), intent(inout) :: scratchPool !< Input: scratch variables + real (kind=RKIND), dimension(:,:), intent(in) :: & divergence !< Input: velocity divergence @@ -116,9 +119,6 @@ subroutine ocn_vel_hmix_tend(meshPool, divergence, relativeVorticity, normalVelo real (kind=RKIND), dimension(:,:), intent(inout) :: & tend !< Input/Output: velocity tendency - type (mpas_pool_type), intent(inout) :: & - scratchPool !< Input: Scratch structure - !----------------------------------------------------------------- ! ! output variables @@ -153,21 +153,29 @@ subroutine ocn_vel_hmix_tend(meshPool, divergence, relativeVorticity, normalVelo call mpas_timer_stop("del2", del2Timer) err = ior(err1, err) + call mpas_threading_barrier() + call mpas_timer_start("del2_tensor", .false., del2TensorTimer) call ocn_vel_hmix_del2_tensor_tend(meshPool, normalVelocity, tangentialVelocity, viscosity, scratchPool, tend, err1) call mpas_timer_stop("del2_tensor", del2TensorTimer) err = ior(err1, err) + call mpas_threading_barrier() + call mpas_timer_start("leith", .false., leithTimer) call ocn_vel_hmix_leith_tend(meshPool, divergence, relativeVorticity, viscosity, tend, err1) call mpas_timer_stop("leith", leithTimer) err = ior(err1, err) + call mpas_threading_barrier() + call mpas_timer_start("del4", .false., del4Timer) - call ocn_vel_hmix_del4_tend(meshPool, divergence, relativeVorticity, tend, err1) + call ocn_vel_hmix_del4_tend(meshPool, scratchPool, divergence, relativeVorticity, tend, err1) call mpas_timer_stop("del4", del4Timer) err = ior(err1, err) + call mpas_threading_barrier() + call mpas_timer_start("del4_tensor", .false., del4TensorTimer) call ocn_vel_hmix_del4_tensor_tend(meshPool, normalVelocity, tangentialVelocity, viscosity, scratchPool, tend, err1) call mpas_timer_stop("del4_tensor", del4TensorTimer) diff --git a/src/core_ocean/shared/mpas_ocn_vel_hmix_del2.F b/src/core_ocean/shared/mpas_ocn_vel_hmix_del2.F index 38b9fe317b..2662665ee3 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_hmix_del2.F +++ b/src/core_ocean/shared/mpas_ocn_vel_hmix_del2.F @@ -22,6 +22,7 @@ module ocn_vel_hmix_del2 use mpas_derived_types use mpas_pool_routines + use mpas_threading use mpas_vector_operations use mpas_matrix_operations use mpas_tensor_operations @@ -152,6 +153,7 @@ subroutine ocn_vel_hmix_del2_tend(meshPool, divergence, relativeVorticity, visco call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + !$omp do schedule(runtime) private(cell1, cell2, vertex1, vertex2, invLength1, invLength2, k, u_diffusion, visc2) do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -178,6 +180,7 @@ subroutine ocn_vel_hmix_del2_tend(meshPool, divergence, relativeVorticity, visco end do end do + !$omp end do !-------------------------------------------------------------------- @@ -295,6 +298,7 @@ subroutine ocn_vel_hmix_del2_tensor_tend(meshPool, normalVelocity, tangentialVel call mpas_allocate_scratch_field(divTensorR3CellField, .true.) call mpas_allocate_scratch_field(outerProductEdgeField, .true.) call mpas_allocate_scratch_field(normalVectorEdgeField, .true.) + call mpas_threading_barrier() strainRateR3Cell => strainRateR3CellField % array strainRateR3Edge => strainRateR3EdgeField % array @@ -309,6 +313,7 @@ subroutine ocn_vel_hmix_del2_tensor_tend(meshPool, normalVelocity, tangentialVel call mpas_matrix_cell_to_edge(strainRateR3Cell, meshPool, .true., strainRateR3Edge) ! The following loop could possibly be reduced to nEdgesSolve + !$omp do schedule(runtime) private(visc2, k) do iEdge = 1, nEdges visc2 = config_mom_del2_tensor * meshScalingDel2(iEdge) do k = 1, maxLevelEdgeTop(iEdge) @@ -320,6 +325,7 @@ subroutine ocn_vel_hmix_del2_tensor_tend(meshPool, normalVelocity, tangentialVel strainRateR3Edge(:,k,iEdge) = 0.0 end do end do + !$omp end do ! may change boundaries to false later call mpas_divergence_of_tensor_R3Cell(strainRateR3Edge, meshPool, edgeSignOnCell, .true., divTensorR3Cell) @@ -327,12 +333,15 @@ subroutine ocn_vel_hmix_del2_tensor_tend(meshPool, normalVelocity, tangentialVel call mpas_vector_R3Cell_to_normalVectorEdge(divTensorR3Cell, meshPool, .true., normalVectorEdge) ! The following loop could possibly be reduced to nEdgesSolve + !$omp do schedule(runtime) private(k) do iEdge = 1, nEdges do k = 1, maxLevelEdgeTop(iEdge) tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * normalVectorEdge(k,iEdge) end do end do + !$omp end do + call mpas_threading_barrier() call mpas_deallocate_scratch_field(strainRateR3CellField, .true.) call mpas_deallocate_scratch_field(strainRateR3EdgeField, .true.) call mpas_deallocate_scratch_field(divTensorR3CellField, .true.) diff --git a/src/core_ocean/shared/mpas_ocn_vel_hmix_del4.F b/src/core_ocean/shared/mpas_ocn_vel_hmix_del4.F index 88ddb80cef..a0575657c2 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_hmix_del4.F +++ b/src/core_ocean/shared/mpas_ocn_vel_hmix_del4.F @@ -22,6 +22,7 @@ module ocn_vel_hmix_del4 use mpas_derived_types use mpas_pool_routines + use mpas_threading use mpas_vector_operations use mpas_matrix_operations use mpas_tensor_operations @@ -77,7 +78,7 @@ module ocn_vel_hmix_del4 ! !----------------------------------------------------------------------- - subroutine ocn_vel_hmix_del4_tend(meshPool, divergence, relativeVorticity, tend, err)!{{{ + subroutine ocn_vel_hmix_del4_tend(meshPool, scratchPool, divergence, relativeVorticity, tend, err)!{{{ !----------------------------------------------------------------- ! @@ -88,6 +89,8 @@ subroutine ocn_vel_hmix_del4_tend(meshPool, divergence, relativeVorticity, tend, real (kind=RKIND), dimension(:,:), intent(in) :: & divergence !< Input: velocity divergence + type (mpas_pool_type), intent(in) :: scratchPool !< Input: scratch variables + real (kind=RKIND), dimension(:,:), intent(in) :: & relativeVorticity !< Input: relative vorticity @@ -131,8 +134,8 @@ subroutine ocn_vel_hmix_del4_tend(meshPool, divergence, relativeVorticity, tend, real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaTriangle, & meshScalingDel4, areaCell - real (kind=RKIND), dimension(:,:), allocatable :: delsq_divergence, & - delsq_circulation, delsq_relativeVorticity, delsq_u + real (kind=RKIND), dimension(:,:), pointer :: delsq_divergence, delsq_relativeVorticity, delsq_u + type (field2DReal), pointer :: delsq_uField, delsq_divergenceField, delsq_relativeVorticityField real (kind=RKIND), pointer :: config_mom_del4 @@ -166,15 +169,26 @@ subroutine ocn_vel_hmix_del4_tend(meshPool, divergence, relativeVorticity, tend, call mpas_pool_get_array(meshPool, 'edgeSignOnVertex', edgeSignOnVertex) call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) - allocate(delsq_u(nVertLEvels, nEdges+1)) - allocate(delsq_divergence(nVertLevels, nCells+1)) - allocate(delsq_relativeVorticity(nVertLevels, nVertices+1)) + call mpas_pool_get_field(scratchPool, 'delsq_u', delsq_uField) + call mpas_pool_get_field(scratchPool, 'delsq_divergence', delsq_divergenceField) + call mpas_pool_get_field(scratchPool, 'delsq_relativeVorticity', delsq_relativeVorticityField) + call mpas_allocate_scratch_field(delsq_uField, .true.) + call mpas_allocate_scratch_field(delsq_divergenceField, .true.) + call mpas_allocate_scratch_field(delsq_relativeVorticityField, .true.) + call mpas_threading_barrier() + + delsq_u => delsq_uField % array + delsq_divergence => delsq_divergenceField % array + delsq_relativeVorticity => delsq_relativeVorticityField % array + !$omp workshare delsq_u(:,:) = 0.0 delsq_relativeVorticity(:,:) = 0.0 delsq_divergence(:,:) = 0.0 + !$omp end workshare !Compute delsq_u + !$omp do schedule(runtime) private(cell1, cell2, vertex1, vertex2, invDcEdge, invDvEdge) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -191,8 +205,10 @@ subroutine ocn_vel_hmix_del4_tend(meshPool, divergence, relativeVorticity, tend, -( relativeVorticity(k,vertex2) - relativeVorticity(k,vertex1)) * invDcEdge * sqrt(3.0) end do end do + !$omp end do ! Compute delsq_relativeVorticity + !$omp do schedule(runtime) private(invAreaTri1, i, iEdge, k) do iVertex = 1, nVertices invAreaTri1 = 1.0 / areaTriangle(iVertex) do i = 1, vertexDegree @@ -202,8 +218,10 @@ subroutine ocn_vel_hmix_del4_tend(meshPool, divergence, relativeVorticity, tend, end do end do end do + !$omp end do ! Compute delsq_divergence + !$omp do schedule(runtime) private(invAreaCell1, i, iEdge, k) do iCell = 1, nCells invAreaCell1 = 1.0 / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) @@ -213,9 +231,11 @@ subroutine ocn_vel_hmix_del4_tend(meshPool, divergence, relativeVorticity, tend, end do end do end do + !$omp end do ! Compute - \kappa \nabla^4 u ! as \nabla div(\nabla^2 u) + k \times \nabla ( k \cross curl(\nabla^2 u) ) + !$omp do schedule(runtime) private(cell1, cell2, vertex1, vertex2, invDcEdge, invDvEdge, r_tmp, u_diffusion) do iEdge=1,nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -233,10 +253,12 @@ subroutine ocn_vel_hmix_del4_tend(meshPool, divergence, relativeVorticity, tend, tend(k,iEdge) = tend(k,iEdge) - edgeMask(k, iEdge) * u_diffusion * r_tmp end do end do + !$omp end do - deallocate(delsq_u) - deallocate(delsq_divergence) - deallocate(delsq_relativeVorticity) + call mpas_threading_barrier() + call mpas_deallocate_scratch_field(delsq_uField, .true.) + call mpas_deallocate_scratch_field(delsq_divergenceField, .true.) + call mpas_deallocate_scratch_field(delsq_relativeVorticityField, .true.) !-------------------------------------------------------------------- @@ -358,6 +380,7 @@ subroutine ocn_vel_hmix_del4_tensor_tend(meshPool, normalVelocity, tangentialVel call mpas_allocate_scratch_field(outerProductEdgeField, .true.) call mpas_allocate_scratch_field(normalVectorEdgeField, .true.) call mpas_allocate_scratch_field(tangentialVectorEdgeField, .true.) + call mpas_threading_barrier() strainRateR3Cell => strainRateR3CellField % array strainRateR3Edge => strainRateR3EdgeField % array @@ -375,6 +398,7 @@ subroutine ocn_vel_hmix_del4_tensor_tend(meshPool, normalVelocity, tangentialVel call mpas_matrix_cell_to_edge(strainRateR3Cell, meshPool, .true., strainRateR3Edge) ! The following loop could possibly be reduced to nEdgesSolve + !$omp do schedule(runtime) private(visc4_sqrt, k) do iEdge = 1, nEdges visc4_sqrt = sqrt(config_mom_del4_tensor * meshScalingDel4(iEdge)) do k = 1, maxLevelEdgeTop(iEdge) @@ -385,6 +409,7 @@ subroutine ocn_vel_hmix_del4_tensor_tend(meshPool, normalVelocity, tangentialVel strainRateR3Edge(:,k,iEdge) = 0.0 end do end do + !$omp end do ! may change boundaries to false later call mpas_divergence_of_tensor_R3Cell(strainRateR3Edge, meshPool, edgeSignOnCell, .true., divTensorR3Cell) @@ -400,6 +425,7 @@ subroutine ocn_vel_hmix_del4_tensor_tend(meshPool, normalVelocity, tangentialVel call mpas_matrix_cell_to_edge(strainRateR3Cell, meshPool, .true., strainRateR3Edge) ! The following loop could possibly be reduced to nEdgesSolve + !$omp do schedule(runtime) private(visc4_sqrt, k) do iEdge = 1, nEdges visc4_sqrt = sqrt(config_mom_del4_tensor * meshScalingDel4(iEdge)) viscosity(:,iEdge) = viscosity(:,iEdge) + config_mom_del4_tensor * meshScalingDel4(iEdge) @@ -411,6 +437,7 @@ subroutine ocn_vel_hmix_del4_tensor_tend(meshPool, normalVelocity, tangentialVel strainRateR3Edge(:,k,iEdge) = 0.0 end do end do + !$omp end do ! may change boundaries to false later call mpas_divergence_of_tensor_R3Cell(strainRateR3Edge, meshPool, edgeSignOnCell, .true., divTensorR3Cell) @@ -418,12 +445,15 @@ subroutine ocn_vel_hmix_del4_tensor_tend(meshPool, normalVelocity, tangentialVel call mpas_vector_R3Cell_to_normalVectorEdge(divTensorR3Cell, meshPool, .true., normalVectorEdge) ! The following loop could possibly be reduced to nEdgesSolve + !$omp do schedule(runtime) private(k) do iEdge = 1,nEdges do k = 1,maxLevelEdgeTop(iEdge) tend(k,iEdge) = tend(k,iEdge) - edgeMask(k, iEdge) * normalVectorEdge(k,iEdge) end do end do + !$omp end do + call mpas_threading_barrier() call mpas_deallocate_scratch_field(strainRateR3CellField, .true.) call mpas_deallocate_scratch_field(strainRateR3EdgeField, .true.) call mpas_deallocate_scratch_field(divTensorR3CellField, .true.) diff --git a/src/core_ocean/shared/mpas_ocn_vel_hmix_leith.F b/src/core_ocean/shared/mpas_ocn_vel_hmix_leith.F index b883a24187..ca052c050f 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_hmix_leith.F +++ b/src/core_ocean/shared/mpas_ocn_vel_hmix_leith.F @@ -158,6 +158,7 @@ subroutine ocn_vel_hmix_leith_tend(meshPool, divergence, relativeVorticity, visc call mpas_pool_get_array(meshPool, 'dcEdge', dcEdge) call mpas_pool_get_array(meshPool, 'dvEdge', dvEdge) + !$omp do schedule(runtime) private(cell1, cell2, vertex1, vertex2, invLength_dc, invLength_dv, k, u_diffusion, visc2) do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -189,6 +190,7 @@ subroutine ocn_vel_hmix_leith_tend(meshPool, divergence, relativeVorticity, visc end do end do + !$omp end do !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_vel_pressure_grad.F b/src/core_ocean/shared/mpas_ocn_vel_pressure_grad.F index b4303b29b5..f9b0827f5c 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_pressure_grad.F +++ b/src/core_ocean/shared/mpas_ocn_vel_pressure_grad.F @@ -154,6 +154,7 @@ subroutine ocn_vel_pressure_grad_tend(meshPool, pressure, montgomeryPotential, z ! pressure for generalized coordinates ! -1/density_0 (grad p_k + density g grad z_k^{mid}) + !$omp do schedule(runtime) private(cell1, cell2, invdcEdge, k) do iEdge=1,nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -165,12 +166,14 @@ subroutine ocn_vel_pressure_grad_tend(meshPool, pressure, montgomeryPotential, z - gdensity0Inv * 0.5*(density(k,cell1)+density(k,cell2)) * ( zMid(k,cell2) - zMid(k,cell1) ) ) end do end do + !$omp end do elseif (config_pressure_gradient_type.eq.'MontgomeryPotential') then ! For pure isopycnal coordinates, this is just grad(M), ! the gradient of Montgomery Potential + !$omp do schedule(runtime) private(cell1, cell2, invdcEdge, k) do iEdge=1,nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -181,6 +184,7 @@ subroutine ocn_vel_pressure_grad_tend(meshPool, pressure, montgomeryPotential, z - ( montgomeryPotential(k,cell2) - montgomeryPotential(k,cell1) ) ) end do end do + !$omp end do elseif (config_pressure_gradient_type.eq.'MontgomeryPotential_and_density') then @@ -190,6 +194,7 @@ subroutine ocn_vel_pressure_grad_tend(meshPool, pressure, montgomeryPotential, z ! Where rho is the potential density. ! See Bleck (2002) equation 1, and last equation in Appendix A. + !$omp do schedule(runtime) private(cell1, cell2, invdcEdge, k) do iEdge=1,nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -201,11 +206,13 @@ subroutine ocn_vel_pressure_grad_tend(meshPool, pressure, montgomeryPotential, z + 0.5*(pressure(k,cell1)+pressure(k,cell2)) * ( 1.0/potentialDensity(k,cell2) - 1.0/potentialDensity(k,cell1) ) ) end do end do + !$omp end do elseif (config_pressure_gradient_type.eq.'Jacobian_from_density') then allocate(JacobianDxDs(nVertLevels)) + !$omp do schedule(runtime) private(cell1, cell2, invdcEdge, k, pGrad) do iEdge=1,nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -234,6 +241,7 @@ subroutine ocn_vel_pressure_grad_tend(meshPool, pressure, montgomeryPotential, z end do end do + !$omp end do deallocate(JacobianDxDs) @@ -241,6 +249,7 @@ subroutine ocn_vel_pressure_grad_tend(meshPool, pressure, montgomeryPotential, z allocate(JacobianDxDs(nVertLevels),JacobianTz(nVertLevels),JacobianSz(nVertLevels), T1(nVertLevels), T2(nVertLevels), S1(nVertLevels), S2(nVertLevels)) + !$omp do schedule(runtime) private(cell1, cell2, invdcEdge, kMax, k, pGrad, alpha, beta) do iEdge=1,nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -288,6 +297,7 @@ subroutine ocn_vel_pressure_grad_tend(meshPool, pressure, montgomeryPotential, z end do end do + !$omp end do deallocate(JacobianDxDs,JacobianTz,JacobianSz, T1, T2, S1, S2) diff --git a/src/core_ocean/shared/mpas_ocn_vel_vadv.F b/src/core_ocean/shared/mpas_ocn_vel_vadv.F index b39ead11b0..587e470b2b 100644 --- a/src/core_ocean/shared/mpas_ocn_vel_vadv.F +++ b/src/core_ocean/shared/mpas_ocn_vel_vadv.F @@ -130,6 +130,8 @@ subroutine ocn_vel_vadv_tend(meshPool, normalVelocity, layerThicknessEdge, vertA allocate(w_dudzTopEdge(nVertLevels+1)) w_dudzTopEdge = 0.0 + + !$omp do schedule(runtime) private(cell1, cell2, k, vertAleTransportTopEdge) do iEdge = 1, nEdgesSolve cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -149,6 +151,8 @@ subroutine ocn_vel_vadv_tend(meshPool, normalVelocity, layerThicknessEdge, vertA tend(k,iEdge) = tend(k,iEdge) - edgeMask(k, iEdge) * 0.5 * (w_dudzTopEdge(k) + w_dudzTopEdge(k+1)) enddo enddo + !$omp end do + deallocate(w_dudzTopEdge) !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_vmix.F b/src/core_ocean/shared/mpas_ocn_vmix.F index 2cb3ab05bb..047c71d685 100644 --- a/src/core_ocean/shared/mpas_ocn_vmix.F +++ b/src/core_ocean/shared/mpas_ocn_vmix.F @@ -83,7 +83,7 @@ module ocn_vmix ! !----------------------------------------------------------------------- - subroutine ocn_vmix_coefs(meshPool, statePool, diagnosticsPool, err, timeLevelIn)!{{{ + subroutine ocn_vmix_coefs(meshPool, statePool, diagnosticsPool, scratchPool, err, timeLevelIn)!{{{ !----------------------------------------------------------------- ! @@ -93,6 +93,8 @@ subroutine ocn_vmix_coefs(meshPool, statePool, diagnosticsPool, err, timeLevelIn type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information + + type (mpas_pool_type), intent(in) :: scratchPool !< Input/Output: Scratch structure integer, intent(in), optional :: timeLevelIn !< Input: Time level for state pool @@ -143,12 +145,14 @@ subroutine ocn_vmix_coefs(meshPool, statePool, diagnosticsPool, err, timeLevelIn call mpas_pool_get_array(diagnosticsPool, 'vertViscTopOfEdge', vertViscTopOfEdge) call mpas_pool_get_array(diagnosticsPool, 'vertDiffTopOfCell', vertDiffTopOfCell) + !$omp workshare vertViscTopOfEdge = 0.0_RKIND vertDiffTopOfCell = 0.0_RKIND + !$omp end workshare call ocn_vmix_coefs_const_build(meshPool, statePool, diagnosticsPool, err1, timeLevel) call ocn_vmix_coefs_tanh_build(meshPool, statePool, diagnosticsPool, err2, timeLevel) - call ocn_vmix_coefs_rich_build(meshPool, statePool, diagnosticsPool, err3, timeLevel) + call ocn_vmix_coefs_rich_build(meshPool, statePool, diagnosticsPool, scratchPool, err3, timeLevel) call ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err4, timeLevel) call ocn_vmix_coefs_redi_build(meshPool, statePool, diagnosticsPool, err5, timeLevel) @@ -246,6 +250,7 @@ subroutine ocn_vel_vmix_tend_implicit(meshPool, dt, kineticEnergyCell, vertViscT allocate(A(nVertLevels),B(nVertLevels),C(nVertLevels),velTemp(nVertLevels)) A(1)=0 + !$omp do schedule(runtime) private(N, cell1, cell2, k) do iEdge = 1, nEdges N = maxLevelEdgeTop(iEdge) if (N .gt. 0) then @@ -291,6 +296,7 @@ subroutine ocn_vel_vmix_tend_implicit(meshPool, dt, kineticEnergyCell, vertViscT end if end do + !$omp end do deallocate(A,B,C,velTemp) @@ -374,6 +380,7 @@ subroutine ocn_tracer_vmix_tend_implicit(meshPool, dt, vertDiffTopOfCell, layerT allocate(A(nVertLevels),B(nVertLevels),C(nVertLevels),tracersTemp(num_tracers,nVertLevels)) + !$omp do schedule(runtime) private(N, k) do iCell = 1, nCells ! Compute A(k), B(k), C(k) for tracers N = maxLevelCell(iCell) @@ -403,6 +410,7 @@ subroutine ocn_tracer_vmix_tend_implicit(meshPool, dt, vertDiffTopOfCell, layerT tracers(:,1:N,iCell) = tracersTemp(:,1:N) tracers(:,N+1:nVertLevels,iCell) = -1e34 end do + !$omp end do deallocate(A, B, C, tracersTemp) @@ -424,11 +432,12 @@ end subroutine ocn_tracer_vmix_tend_implicit!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, err, timeLevelIn)!{{{ + subroutine ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, scratchPool, err, timeLevelIn)!{{{ real (kind=RKIND), intent(in) :: dt type (mpas_pool_type), intent(in) :: meshPool type (mpas_pool_type), intent(inout) :: diagnosticsPool type (mpas_pool_type), intent(inout) :: statePool + type (mpas_pool_type), intent(in) :: scratchPool !< Input/Output: Scratch structure integer, intent(out) :: err integer, intent(in), optional :: timeLevelIn @@ -472,11 +481,14 @@ subroutine ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, err, time call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_dimension(meshPool, 'nEdges', nEdges) - call ocn_vmix_coefs(meshPool, statePool, diagnosticsPool, err, timeLevel) + call ocn_vmix_coefs(meshPool, statePool, diagnosticsPool, scratchPool, err, timeLevel) ! if using CVMix, then viscosity has to be averaged from cell centers to cell edges if ( config_use_cvmix ) then + !$omp workshare vertViscTopOfEdge(:,:) = 0.0 + !$omp end workshare + !$omp do schedule(runtime) private(cell1, cell2, k) do iEdge=1,nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -484,6 +496,7 @@ subroutine ocn_vmix_implicit(dt, meshPool, diagnosticsPool, statePool, err, time vertViscTopOfEdge(k,iEdge) = 0.5*(vertViscTopOfCell(k,cell2)+vertViscTopOfCell(k,cell1)) enddo enddo + !$omp end do endif ! diff --git a/src/core_ocean/shared/mpas_ocn_vmix_coefs_const.F b/src/core_ocean/shared/mpas_ocn_vmix_coefs_const.F index f11ba0e409..6906154c86 100644 --- a/src/core_ocean/shared/mpas_ocn_vmix_coefs_const.F +++ b/src/core_ocean/shared/mpas_ocn_vmix_coefs_const.F @@ -199,7 +199,9 @@ subroutine ocn_vel_vmix_coefs_const(meshPool, vertViscTopOfEdge, err)!{{{ if ( .not. constViscOn ) return + !$omp workshare vertViscTopOfEdge = vertViscTopOfEdge + constVisc + !$omp end workshare !-------------------------------------------------------------------- @@ -254,7 +256,9 @@ subroutine ocn_tracer_vmix_coefs_const(meshPool, vertDiffTopOfCell, err)!{{{ if ( .not. constDiffOn ) return + !$omp workshare vertDiffTopOfCell = vertDiffTopOfCell + constDiff + !$omp end workshare !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_vmix_coefs_redi.F b/src/core_ocean/shared/mpas_ocn_vmix_coefs_redi.F index 5b1495c8a4..347de3a97a 100644 --- a/src/core_ocean/shared/mpas_ocn_vmix_coefs_redi.F +++ b/src/core_ocean/shared/mpas_ocn_vmix_coefs_redi.F @@ -185,7 +185,9 @@ subroutine ocn_tracer_vmix_coefs_redi(meshPool, vertDiffTopOfCell, vertRediDiff, if(.not.rediDiffOn) return + !$omp workshare vertDiffTopOfCell = vertDiffTopOfCell + vertRediDiff + !$omp end workshare !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F b/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F index 31fed48b4a..8bd633d64c 100644 --- a/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F +++ b/src/core_ocean/shared/mpas_ocn_vmix_coefs_rich.F @@ -25,6 +25,7 @@ module ocn_vmix_coefs_rich use mpas_pool_routines use mpas_constants use mpas_timer + use mpas_threading use ocn_constants use ocn_equation_of_state @@ -74,7 +75,7 @@ module ocn_vmix_coefs_rich !> and activeTracers based user choices of mixing parameterization. ! !----------------------------------------------------------------------- - subroutine ocn_vmix_coefs_rich_build(meshPool, statePool, diagnosticsPool, err, timeLevelIn)!{{{ + subroutine ocn_vmix_coefs_rich_build(meshPool, statePool, diagnosticsPool, scratchPool, err, timeLevelIn)!{{{ !----------------------------------------------------------------- ! @@ -85,6 +86,8 @@ subroutine ocn_vmix_coefs_rich_build(meshPool, statePool, diagnosticsPool, err, type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: scratchPool !< Input/Output: Scratch structure + integer, intent(in), optional :: timeLevelIn !< Input: Time level for state pool !----------------------------------------------------------------- @@ -161,15 +164,15 @@ subroutine ocn_vmix_coefs_rich_build(meshPool, statePool, diagnosticsPool, err, call mpas_timer_start("eos rich", .false., richEOSTimer) ! compute in-place density - call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 0, 'relative', density, err, timeLevelIn=timeLevel) + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, scratchPool, 0, 'relative', density, err, timeLevelIn=timeLevel) ! compute displacedDensity, density displaced adiabatically to the mid-depth one layer deeper. ! That is, layer k has been displaced to the depth of layer k+1. - call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, 1, 'relative', displacedDensity, err, timeLevelIn=timeLevel) + call ocn_equation_of_state_density(statePool, diagnosticsPool, meshPool, scratchPool, 1, 'relative', displacedDensity, err, timeLevelIn=timeLevel) call mpas_timer_stop("eos rich", richEOSTimer) - call ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, normalVelocity, layerThickness, layerThicknessEdge, & + call ocn_vmix_get_rich_numbers(meshPool, scratchPool, indexTemperature, indexSalinity, normalVelocity, layerThickness, layerThicknessEdge, & density, displacedDensity, activeTracers, RiTopOfEdge, RiTopOfCell, err1) call ocn_vel_vmix_coefs_rich(meshPool, RiTopOfEdge, layerThicknessEdge, vertViscTopOfEdge, err2) @@ -251,6 +254,7 @@ subroutine ocn_vel_vmix_coefs_rich(meshPool, RiTopOfEdge, layerThicknessEdge, ve call mpas_pool_get_array(meshPool, 'maxLevelEdgeTop', maxLevelEdgeTop) + !$omp do schedule(runtime) private(k) do iEdge = 1, nEdges do k = 2, maxLevelEdgeTop(iEdge) ! efficiency note: these if statements are inside iEdge and k loops. @@ -267,6 +271,7 @@ subroutine ocn_vel_vmix_coefs_rich(meshPool, RiTopOfEdge, layerThicknessEdge, ve end if end do end do + !$omp end do !-------------------------------------------------------------------- @@ -346,6 +351,7 @@ subroutine ocn_tracer_vmix_coefs_rich(meshPool, RiTopOfCell, layerThickness, ver call mpas_pool_get_array(meshPool, 'maxLevelCell', maxLevelCell) coef = -gravity / rho_sw / 2.0_RKIND + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 2, maxLevelCell(iCell) ! efficiency note: these if statements are inside iEdge and k loops. @@ -364,7 +370,7 @@ subroutine ocn_tracer_vmix_coefs_rich(meshPool, RiTopOfCell, layerThickness, ver end if end do end do - + !$omp end do !-------------------------------------------------------------------- @@ -383,7 +389,7 @@ end subroutine ocn_tracer_vmix_coefs_rich!}}} ! !----------------------------------------------------------------------- - subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, normalVelocity, layerThickness, layerThicknessEdge, & !{{{ + subroutine ocn_vmix_get_rich_numbers(meshPool, scratchPool, indexTemperature, indexSalinity, normalVelocity, layerThickness, layerThicknessEdge, & !{{{ density, displacedDensity, activeTracers, RiTopOfEdge, RiTopOfCell, err) !----------------------------------------------------------------- @@ -395,6 +401,8 @@ subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, type (mpas_pool_type), intent(in) :: & meshPool !< Input: mesh information + type (mpas_pool_type), intent(in) :: scratchPool !< Input: scratch variables + integer, intent(in) :: indexTemperature !< Input: index for temperature integer, intent(in) :: indexSalinity !< Input: index for salinity @@ -438,8 +446,11 @@ subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, real (kind=RKIND) :: coef, invAreaCell real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell - real (kind=RKIND), dimension(:,:), allocatable :: ddensityTopOfCell, du2TopOfCell, & - ddensityTopOfEdge, du2TopOfEdge + real (kind=RKIND), dimension(:,:), pointer :: ddensityTopOfCell, du2TopOfCell, & + ddensityTopOfEdge, du2TopOfEdge + type (field2DReal), pointer :: ddensityTopOfCellField, du2TopOfCellField, & + ddensityTopOfEdgeField, du2TopOfEdgeField + err = 0 if ( ( .not. richViscOn ) .and. ( .not. richDiffOn ) ) return @@ -459,20 +470,41 @@ subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(meshPool, 'edgeSignOnCell', edgeSignOnCell) - allocate( & - ddensityTopOfCell(nVertLevels+1,nCells+1), ddensityTopOfEdge(nVertLevels+1,nEdges), & - du2TopOfCell(nVertLevels+1,nCells+1), du2TopOfEdge(nVertLevels+1,nEdges)) + call mpas_pool_get_field(scratchPool, 'ddensityTopOfCell', ddensityTopOfCellField) + call mpas_pool_get_field(scratchPool, 'ddensityTopOfEdge', ddensityTopOfEdgeField) + call mpas_pool_get_field(scratchPool, 'du2TopOfCell', du2TopOfCellField) + call mpas_pool_get_field(scratchPool, 'du2TopOfEdge', du2TopOfEdgeField) + call mpas_allocate_scratch_field(ddensityTopOfCellField, .true.) + call mpas_allocate_scratch_field(ddensityTopOfEdgeField, .true.) + call mpas_allocate_scratch_field(du2TopOfCellField, .true.) + call mpas_allocate_scratch_field(du2TopOfEdgeField, .true.) + call mpas_threading_barrier() + + ddensityTopOfCell => ddensityTopOfCellField % array + ddensityTopOfEdge => ddensityTopOfEdgeField % array + du2TopOfCell => du2TopOfCellField % array + du2TopOfEdge => du2TopOfEdgeField % array ! ddensityTopOfCell(k) = $\rho^*_{k-1}-\rho_k$, where $\rho^*$ has been adiabatically displaced to level k. - ddensityTopOfCell = 0.0_RKIND + !$omp workshare + ddensityTopOfCell = 0.0 + ddensityTopOfEdge = 0.0 + du2TopOfEdge=0.0 + du2TopOfCell = 0.0 + RiTopOfEdge = 0.0 + RiTopOfCell = 0.0 + !$omp end workshare + + !$omp do schedule(runtime) private(k) do iCell = 1, nCells do k = 2, maxLevelCell(iCell) ddensityTopOfCell(k,iCell) = displacedDensity(k-1,iCell) - density(k,iCell) end do end do + !$omp end do ! interpolate ddensityTopOfCell to ddensityTopOfEdge - ddensityTopOfEdge = 0.0_RKIND + !$omp do schedule(runtime) private(cell1, cell2, k) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -482,17 +514,19 @@ subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, ddensityTopOfCell(k,cell2))/2 end do end do + !$omp end do ! du2TopOfEdge(k) = $u_{k-1}-u_k$ - du2TopOfEdge=0.0_RKIND + !$omp do schedule(runtime) private(k) do iEdge = 1, nEdges do k = 2, maxLevelEdgeTop(iEdge) du2TopOfEdge(k,iEdge) = (normalVelocity(k-1,iEdge) - normalVelocity(k,iEdge))**2 end do end do + !$omp end do ! interpolate du2TopOfEdge to du2TopOfCell - du2TopOfCell = 0.0_RKIND + !$omp do schedule(runtime) private(invAreaCell, i, iEdge, k) do iCell = 1, nCells invAreaCell = 1.0_RKIND / areaCell(iCell) do i = 1, nEdgesOnCell(iCell) @@ -503,11 +537,13 @@ subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, end do end do end do + !$omp end do ! compute RiTopOfEdge using ddensityTopOfEdge and du2TopOfEdge ! coef = -g/density_0/2 - RiTopOfEdge = 0.0_RKIND - coef = -gravity / rho_sw / 2.0_RKIND + coef = -gravity / rho_sw / 2.0 + + !$omp do schedule(runtime) private(k) do iEdge = 1, nEdges do k = 2, maxLevelEdgeTop(iEdge) RiTopOfEdge(k,iEdge) = coef * ddensityTopOfEdge(k,iEdge) & @@ -515,10 +551,11 @@ subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, / ( du2TopOfEdge(k,iEdge) + 1e-20_RKIND ) end do end do + !$omp end do ! compute RiTopOfCell using ddensityTopOfCell and du2TopOfCell ! coef = -g/density_0/2 - RiTopOfCell = 0.0_RKIND + !$omp do schedule(runtime) private(k) do iCell = 1,nCells do k = 2,maxLevelCell(iCell) RiTopOfCell(k,iCell) = coef * ddensityTopOfCell(k,iCell) & @@ -526,9 +563,13 @@ subroutine ocn_vmix_get_rich_numbers(meshPool, indexTemperature, indexSalinity, / (du2TopOfCell(k,iCell) + 1e-20_RKIND) end do end do + !$omp end do - deallocate(ddensityTopOfCell, ddensityTopOfEdge, & - du2TopOfCell, du2TopOfEdge) + call mpas_threading_barrier() + call mpas_deallocate_scratch_field(ddensityTopOfCellField, .true.) + call mpas_deallocate_scratch_field(ddensityTopOfEdgeField, .true.) + call mpas_deallocate_scratch_field(du2TopOfCellField, .true.) + call mpas_deallocate_scratch_field(du2TopOfEdgeField, .true.) !-------------------------------------------------------------------- diff --git a/src/core_ocean/shared/mpas_ocn_vmix_coefs_tanh.F b/src/core_ocean/shared/mpas_ocn_vmix_coefs_tanh.F index a6f8c733ae..61b2ba9710 100644 --- a/src/core_ocean/shared/mpas_ocn_vmix_coefs_tanh.F +++ b/src/core_ocean/shared/mpas_ocn_vmix_coefs_tanh.F @@ -210,10 +210,12 @@ subroutine ocn_vel_vmix_coefs_tanh(meshPool, vertViscTopOfEdge, err)!{{{ ! vary in time, would give the exact location of the top, but it ! would only change the diffusion value very slightly. do k = 2, nVertLevels + !$omp workshare vertViscTopOfEdge(k,:) = vertViscTopOfEdge(k,:) - (config_max_visc_tanh - config_min_visc_tanh) / 2.0 & * tanh((refBottomDepth(k-1) + config_ZMid_tanh) & / config_zWidth_tanh) & + (config_max_visc_tanh + config_min_visc_tanh) / 2 + !$omp end workshare end do @@ -290,10 +292,12 @@ subroutine ocn_tracer_vmix_coefs_tanh(meshPool, vertDiffTopOfCell, err)!{{{ ! vary in time, would give the exact location of the top, but it ! would only change the diffusion value very slightly. do k=2,nVertLevels + !$omp workshare vertDiffTopOfCell(k,:) = vertDiffTopOfCell(k,:) - (config_max_diff_tanh - config_min_diff_tanh) / 2.0 & * tanh((refBottomDepth(k-1) + config_ZMid_tanh) & / config_zWidth_tanh) & + (config_max_diff_tanh + config_min_diff_tanh) / 2 + !$omp end workshare end do diff --git a/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F b/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F index 89a448cbad..d74d121627 100644 --- a/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F +++ b/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F @@ -58,7 +58,6 @@ module ocn_vmix_cvmix type(cvmix_bkgnd_params_type) :: cvmix_background_params type(cvmix_shear_params_type) :: cvmix_shear_params type(cvmix_tidal_params_type) :: cvmix_tidal_params - type(cvmix_data_type) :: cvmix_variables logical :: cvmixOn, cvmixBackgroundOn, cvmixConvectionOn, cvmixKPPOn real (kind=RKIND) :: backgroundVisc, backgroundDiff @@ -120,6 +119,8 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, ! !----------------------------------------------------------------- + type(cvmix_data_type) :: cvmix_variables + integer, dimension(:), pointer :: & maxLevelCell, nEdgesOnCell @@ -248,8 +249,10 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, call mpas_pool_get_array(diagnosticsPool, 'vertViscTopOfCell', vertViscTopOfCell) call mpas_pool_get_array(diagnosticsPool, 'vertDiffTopOfCell', vertDiffTopOfCell) + !$omp workshare vertViscTopOfCell = 0.0 vertDiffTopOfCell = 0.0 + !$omp end workshare ! ! set pointers for nonlocal flux and intialize to zero @@ -257,14 +260,18 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, call mpas_pool_get_array(diagnosticsPool, 'vertNonLocalFlux', vertNonLocalFlux) call mpas_pool_get_dimension(diagnosticsPool, 'index_vertNonLocalFluxTemp', index_vertNonLocalFluxTemp) + !$omp workshare vertNonLocalFlux = 0.0 + !$omp end workshare ! ! start by adding the mininum background values to the visocity/diffusivity arrays ! if (cvmixBackgroundOn) then + !$omp workshare vertViscTopOfCell(:,:) = vertViscTopOfCell(:,:) + config_cvmix_background_viscosity vertDiffTopOfCell(:,:) = vertDiffTopOfCell(:,:) + config_cvmix_background_diffusion + !$omp end workshare endif ! @@ -287,6 +294,7 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, allocate(RiSmoothed(nVertLevels+1)) allocate(BVFSmoothed(nVertLevels+1)) + !$omp do schedule(runtime) private(k, bulkRichardsonNumberStop, kIndexOBL, bulkRichardsonFlag) do iCell = 1, nCells ! specify geometry/location @@ -555,6 +563,7 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, vertDiffTopOfCell(maxLevelCell(iCell)+1:nVertLevels,iCell)=0.0 end do ! do iCell=1,mesh%nCells + !$omp end do ! dellocate cmvix variables deallocate(cvmix_variables % Mdiff_iface) From b2a1893796950f934fc5f515075df6df731a7fb7 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Fri, 30 Oct 2015 13:10:01 -0600 Subject: [PATCH 0396/1724] Adding a kind specifier in time series stats The time series stats analysis member was previously missing a kind specifier on a real. This breaks compilation using certain compiler options, and on certain machines. This commit adds the kind specifier. --- src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F index 6793f5f93d..4550af1414 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F +++ b/src/core_ocean/analysis_members/mpas_ocn_time_series_stats.F @@ -65,7 +65,7 @@ module ocn_time_series_stats duration_alarm_ID, reset_alarm_ID ! counter for accumulation - real, pointer :: counter + real (kind=RKIND), pointer :: counter end type time_series_buffer_type type time_series_type From 809fa9a0c843d94a4da92f2ecfa9de295d5aa554 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Wed, 4 Nov 2015 09:42:46 -0700 Subject: [PATCH 0397/1724] Add check for ice presence for cells used for FEM temperature In the FEM Interface, temperature gets averaged over FEM triangles. This commit adds a check to make sure ice is present before including the temperature at a cell center (triangle node) in this average. Without this fix, undefined (non-ice) temperature is used where nunataks (single non-ice cells inside the active ice extent) exist. --- src/core_landice/mode_forward/Interface_velocity_solver.cpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_landice/mode_forward/Interface_velocity_solver.cpp b/src/core_landice/mode_forward/Interface_velocity_solver.cpp index 482bcf0b8c..e778f157bf 100644 --- a/src/core_landice/mode_forward/Interface_velocity_solver.cpp +++ b/src/core_landice/mode_forward/Interface_velocity_solver.cpp @@ -1395,8 +1395,8 @@ void importP0Temperature(double const * temperature_F) { int nPoints = 0; for (int iVertex = 0; iVertex < 3; iVertex++) { int v = verticesOnTria[iVertex + 3 * index]; - if (!isVertexBoundary[v]) { - int iCell = vertexToFCell[v]; + int iCell = vertexToFCell[v]; + if (cellsMask_F[iCell] & ice_present_bit_value) { temperature += temperature_F[iCell * nLayers + ilReversed]; nPoints++; } From 7add4839217bb41303d6bd795411d1c25c52ac07 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Wed, 4 Nov 2015 11:31:25 -0700 Subject: [PATCH 0398/1724] Update timer calls Some important parts of the code were not timed and there was one mismatched timer. These issues are fixed in this commit. --- src/core_landice/mode_forward/mpas_li_core.F | 6 ++++++ src/core_landice/mode_forward/mpas_li_thermal.F | 7 +++++-- src/core_landice/mode_forward/mpas_li_velocity_external.F | 2 +- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/src/core_landice/mode_forward/mpas_li_core.F b/src/core_landice/mode_forward/mpas_li_core.F index 6379503ded..236bfcbafd 100644 --- a/src/core_landice/mode_forward/mpas_li_core.F +++ b/src/core_landice/mode_forward/mpas_li_core.F @@ -194,8 +194,10 @@ function li_core_init(domain, startTimeStamp) result(err) ! halo update for reconstruction coefficients ! Note: Results on multiple processors may be incorrect without this update + call mpas_timer_start("halo updates") call mpas_pool_get_field(meshPool, 'coeffs_reconstruct', coeffsReconstructField) call mpas_dmpar_exch_halo_field(coeffsReconstructField) + call mpas_timer_stop("halo updates") ! check for errors and exit @@ -448,6 +450,8 @@ function li_core_finalize(domain) result(err) !----------------------------------------------------------------- integer :: err, err_tmp, globalErr + call mpas_timer_start("land ice finalize") + err = 0 err_tmp = 0 globalErr = 0 @@ -472,6 +476,8 @@ function li_core_finalize(domain) result(err) call mpas_dmpar_global_abort("An error has occurred in li_core_finalize. Aborting...") endif + call mpas_timer_stop("land ice finalize") + end function li_core_finalize !-------------------------------------------------------------------- diff --git a/src/core_landice/mode_forward/mpas_li_thermal.F b/src/core_landice/mode_forward/mpas_li_thermal.F index 279622aebe..80eeb06568 100644 --- a/src/core_landice/mode_forward/mpas_li_thermal.F +++ b/src/core_landice/mode_forward/mpas_li_thermal.F @@ -26,6 +26,7 @@ module li_thermal use mpas_pool_routines use mpas_constants use mpas_dmpar + use mpas_timer use li_setup use li_mask use li_constants @@ -381,7 +382,7 @@ subroutine li_thermal_init(domain, err) ! E.g., make sure the temperature read from a file is in Kelvin and not Celsius ! halo updates - + call mpas_timer_start("halo updates") call mpas_pool_get_field(thermalPool, 'surfaceTemperature', surfaceTemperatureField) call mpas_dmpar_exch_halo_field(surfaceTemperatureField) @@ -396,6 +397,7 @@ subroutine li_thermal_init(domain, err) !! call mpas_pool_get_field(thermalPool, 'waterfrac', waterfracField) !! call mpas_dmpar_exch_halo_field(waterfracField) endif + call mpas_timer_stop("halo updates") ! === error check if (err > 0) then @@ -1025,7 +1027,7 @@ subroutine li_thermal_solver(domain, deltat, err) enddo ! associated(block) ! halo updates - + call mpas_timer_start("halo updates") call mpas_pool_get_field(thermalPool, 'surfaceTemperature', surfaceTemperatureField) call mpas_dmpar_exch_halo_field(surfaceTemperatureField) @@ -1040,6 +1042,7 @@ subroutine li_thermal_solver(domain, deltat, err) !! call mpas_pool_get_field(thermalPool, 'waterfrac', waterfracField) !! call mpas_dmpar_exch_halo_field(waterfracField) endif + call mpas_timer_stop("halo updates") ! === error check if (err > 0) then diff --git a/src/core_landice/mode_forward/mpas_li_velocity_external.F b/src/core_landice/mode_forward/mpas_li_velocity_external.F index 5ed9b7af71..6c7a332981 100644 --- a/src/core_landice/mode_forward/mpas_li_velocity_external.F +++ b/src/core_landice/mode_forward/mpas_li_velocity_external.F @@ -518,9 +518,9 @@ subroutine li_velocity_external_solve(meshPool, geometryPool, thermalPool, veloc uReconstructX, uReconstructY, & ! Dirichlet boundary values to apply where dirichletVelocityMask=1 normalVelocity, uReconstructX, uReconstructY, deltat) ! return values ! call velocity_solver_estimate_SS_SMB(normalVelocity, mesh % sfcMassBal % array) ! this was used only for some ice2sea experiments, and is not a general routine to use + call mpas_timer_stop("velocity_solver_solve_FO") if (config_output_external_velocity_solver_data) then - call mpas_timer_stop("velocity_solver_solve_FO") call mpas_timer_start("velocity_solver export") call velocity_solver_export_FO_velocity() call mpas_timer_stop("velocity_solver export") From 28a6e7540541fd345a5248650fdee0df23cd6655 Mon Sep 17 00:00:00 2001 From: Matthew Hoffman Date: Wed, 4 Nov 2015 16:11:35 -0700 Subject: [PATCH 0399/1724] Add gravity to velocity_solver_set_parameters F/C interface Without explicitly including it, compile fails in ACME because of type mismatch. --- src/core_landice/mode_forward/mpas_li_velocity_external.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_landice/mode_forward/mpas_li_velocity_external.F b/src/core_landice/mode_forward/mpas_li_velocity_external.F index 5ed9b7af71..1e30467444 100644 --- a/src/core_landice/mode_forward/mpas_li_velocity_external.F +++ b/src/core_landice/mode_forward/mpas_li_velocity_external.F @@ -54,7 +54,7 @@ subroutine velocity_solver_set_parameters(gravity, config_ice_density, config_oc INTEGER(C_INT) :: li_mask_ValueDynamicIce, li_mask_ValueIce REAL(C_DOUBLE) :: config_ice_density, config_ocean_density, config_sea_level, config_default_flowParamA, & - config_enhancementFactor, config_flowLawExponent, config_dynamic_thickness + config_enhancementFactor, config_flowLawExponent, config_dynamic_thickness, gravity end subroutine velocity_solver_set_parameters end interface From 254654b890c9083469cd5907628d1e06a2fc90c8 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Thu, 5 Nov 2015 08:38:16 -0700 Subject: [PATCH 0400/1724] Comment specifying that run is fixed to 16 procs Particle decomposition is fixed so run only works with 16 processors --- .../ocean/ocean/periodic_planar/20km/config_forward.xml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml b/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml index af470707ca..30706d0126 100644 --- a/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml +++ b/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml @@ -66,6 +66,10 @@ + 16 From fc72675cca3ddd226d80e5679f577f5e8060243e Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Wed, 4 Nov 2015 13:31:36 -0700 Subject: [PATCH 0401/1724] Fix areaB for Wachspress init for planar periodic Previously, planar periodic cases were not completely handled by the initialization of the areaB for Wachspress. This has been fixed via ensuring that locations are within the domain via mpas_fix_periodicity --- .../mpas_ocn_lagrangian_particle_tracking.F | 28 ++++++++++++++++--- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F index a4afce1fb8..d1557cb39b 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -1331,14 +1331,17 @@ subroutine intialize_wachspress_coefficients(domain, err) !{{{ type (block_type), pointer :: block type (mpas_pool_type), pointer :: lagrPartTrackCellsPool type (mpas_pool_type), pointer :: meshPool - integer :: nVertices, iCell, i, im1, i0, ip1 + integer :: nVertices, iCell, i, im1, i0, ip1, iVertex integer, pointer :: nCells real (kind=RKIND), dimension(:), allocatable :: xv,yv,zv real (kind=RKIND), pointer :: radiusLocal integer, dimension(:,:), pointer :: verticesOnCell integer, dimension(:), pointer :: nCellVerticesArray real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell real (kind=RKIND), dimension(:,:), pointer :: areaBArray + logical, pointer :: on_a_sphere, is_periodic + real(kind=RKIND), pointer :: x_period, y_period err = 0 @@ -1347,6 +1350,10 @@ subroutine intialize_wachspress_coefficients(domain, err) !{{{ ! setup pointers / get block call mpas_pool_get_subpool(block % structs, 'lagrPartTrackCells', lagrPartTrackCellsPool) call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(meshPool, 'is_periodic', is_periodic) + call mpas_pool_get_config(meshPool, 'x_period', x_period) + call mpas_pool_get_config(meshPool, 'y_period', y_period) call mpas_pool_get_dimension(meshPool, 'nCells', nCells) call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nCellVerticesArray) call mpas_pool_get_config(meshPool, 'sphere_radius', radiusLocal) @@ -1354,6 +1361,9 @@ subroutine intialize_wachspress_coefficients(domain, err) !{{{ call mpas_pool_get_array(meshPool, 'xVertex', xVertex) call mpas_pool_get_array(meshPool, 'yVertex', yVertex) call mpas_pool_get_array(meshPool, 'zVertex', zVertex) + call mpas_pool_get_array(meshPool, 'xCell', xCell) + call mpas_pool_get_array(meshPool, 'yCell', yCell) + call mpas_pool_get_array(meshPool, 'zCell', zCell) call mpas_pool_get_array(lagrPartTrackCellsPool, 'wachspressAreaB', areaBArray) ! compute B_i coefficients @@ -1361,9 +1371,19 @@ subroutine intialize_wachspress_coefficients(domain, err) !{{{ do iCell = 1, nCells nVertices = nCellVerticesArray(iCell) allocate(xv(nVertices), yv(nVertices), zv(nVertices)) - xv = xVertex(verticesOnCell(:,iCell)) - yv = yVertex(verticesOnCell(:,iCell)) - zv = zVertex(verticesOnCell(:,iCell)) + if (on_a_sphere .or. .not. is_periodic) then + xv = xVertex(verticesOnCell(:,iCell)) + yv = yVertex(verticesOnCell(:,iCell)) + zv = zVertex(verticesOnCell(:,iCell)) + else + do iVertex=1,nVertices + xv(iVertex) = mpas_fix_periodicity(xVertex(verticesOnCell(iVertex,iCell)), & + xCell(iCell), x_period) + yv(iVertex) = mpas_fix_periodicity(yVertex(verticesOnCell(iVertex,iCell)), & + yCell(iCell), y_period) + zv(iVertex) = zVertex(verticesOnCell(iVertex,iCell)) + end do + end if do i = 1, nVertices ! compute first area B_i ! get vertex indices From 3a215f1da8b2c7b89a0793ff0e0537b5733e75ec Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Thu, 5 Nov 2015 15:43:50 -0700 Subject: [PATCH 0402/1724] Bug fix to ensure particles are in cell on plane Previously the check to make sure a particle is in a cell for a plane had an error because the test of the cross-product direction was not correct. This commit fixes that error. Note, this only applies for DEBUG mode. --- .../mpas_ocn_lagrangian_particle_tracking.F | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F index d1557cb39b..25398564ed 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -1188,8 +1188,14 @@ logical function point_in_cell(nVertices, xv,yv,zv , xp,yp,zp, on_a_sphere) !{{{ ! compute the cross product and dot with normal, if negative we are outside cell ! we only need to fail on a single test! call mpas_cross_product_in_r3(vec1,vec2,crossProd) - if(sum(crossProd*pVertices(:,v0)) < 0) then - point_in_cell = .false. + if (on_a_sphere) then + if(sum(crossProd*pVertices(:,v0)) < 0) then + point_in_cell = .false. + end if + else + if(crossProd(3) < 0) then + point_in_cell = .false. + end if end if end do From e69b60b353fc1fb06559cc939f9a38baaed62653 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 6 Nov 2015 12:26:27 -0700 Subject: [PATCH 0403/1724] must also include graph file Graph file decomposition depends on metis version. Therefore, because particle decomposition is fixed, the graph file decomposition must also be fixed. --- .../ocean/periodic_planar/20km/config_forward.xml | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml b/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml index 30706d0126..3fbf077c3f 100644 --- a/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml +++ b/test_cases/ocean/ocean/periodic_planar/20km/config_forward.xml @@ -9,6 +9,12 @@ + + + + + + @@ -69,11 +75,11 @@ - - 16 - 16 ./ocean_model From c521423d184d8de9e8dc001679f3e296d4f399ea Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Tue, 27 Oct 2015 10:18:19 -0600 Subject: [PATCH 0404/1724] Adding files for the QU 240km global ocean configuration This commit adds some files to define the global ocean configuration. Currently it only adds the QU 240km version of this configuration, but later can add more resolutions. --- .../ocean/global_ocean/QU_240km/.gitignore | 3 + .../global_ocean/QU_240km/config_forward.xml | 66 ++++++++++ .../global_ocean/QU_240km/config_init1.xml | 119 ++++++++++++++++++ .../global_ocean/QU_240km/config_init2.xml | 102 +++++++++++++++ 4 files changed, 290 insertions(+) create mode 100644 test_cases/ocean/ocean/global_ocean/QU_240km/.gitignore create mode 100644 test_cases/ocean/ocean/global_ocean/QU_240km/config_forward.xml create mode 100644 test_cases/ocean/ocean/global_ocean/QU_240km/config_init1.xml create mode 100644 test_cases/ocean/ocean/global_ocean/QU_240km/config_init2.xml diff --git a/test_cases/ocean/ocean/global_ocean/QU_240km/.gitignore b/test_cases/ocean/ocean/global_ocean/QU_240km/.gitignore new file mode 100644 index 0000000000..4b2e84bcb7 --- /dev/null +++ b/test_cases/ocean/ocean/global_ocean/QU_240km/.gitignore @@ -0,0 +1,3 @@ +init_step1 +init_step2 +forward diff --git a/test_cases/ocean/ocean/global_ocean/QU_240km/config_forward.xml b/test_cases/ocean/ocean/global_ocean/QU_240km/config_forward.xml new file mode 100644 index 0000000000..b9c41c2a12 --- /dev/null +++ b/test_cases/ocean/ocean/global_ocean/QU_240km/config_forward.xml @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + init.nc + + + init.nc + + + output + output.nc + 0000_00:00:01 + truncate + + + + + + + + + + + + + 4 + + + 4 + ./ocean_model + namelist.ocean + streams.ocean + + + diff --git a/test_cases/ocean/ocean/global_ocean/QU_240km/config_init1.xml b/test_cases/ocean/ocean/global_ocean/QU_240km/config_init1.xml new file mode 100644 index 0000000000..741de5a9fe --- /dev/null +++ b/test_cases/ocean/ocean/global_ocean/QU_240km/config_init1.xml @@ -0,0 +1,119 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + base_mesh.nc + + + output + 0000_00:00:01 + truncate + ocean.nc + + + + + + + + + + + + + + + + + + + + + + + + 1 + ./ocean_model + namelist.ocean + streams.ocean + + + + ocean.nc + + + diff --git a/test_cases/ocean/ocean/global_ocean/QU_240km/config_init2.xml b/test_cases/ocean/ocean/global_ocean/QU_240km/config_init2.xml new file mode 100644 index 0000000000..f441c88ed5 --- /dev/null +++ b/test_cases/ocean/ocean/global_ocean/QU_240km/config_init2.xml @@ -0,0 +1,102 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + mesh.nc + + + output + 0000_00:00:01 + truncate + ocean.nc + + + + + + + + + + + + + + + + + + + + + + + + 1 + ./ocean_model + namelist.ocean + streams.ocean + + + From 6a69c1fb835aab80e7469cf6de818d69a81a2d7c Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Mon, 9 Nov 2015 08:14:22 -0700 Subject: [PATCH 0405/1724] Turn defaults in registry to off, and cleanup registry This commit disables all physics options within the ocean model by default. This means you need to turn on the specific features you want in a run now. Additionally, this commit performs some cleanup. Including removing unneeded attributes, and cleaning up white space within Registry files. Additionally, it removes the src/core_ocean/inc directory when a `make clean` is issued. --- src/core_ocean/Makefile | 16 ++------ src/core_ocean/Registry.xml | 38 +++++++------------ .../mode_init/Registry_baroclinic_channel.xml | 2 +- src/core_ocean/mode_init/Registry_iso.xml | 20 +++++----- src/core_ocean/mode_init/Registry_ziso.xml | 2 +- 5 files changed, 28 insertions(+), 50 deletions(-) diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index e86be060eb..56b9dc4f54 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -23,23 +23,10 @@ core_input_gen: (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.forward mode=forward ) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.analysis mode=analysis ) (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init mode=init ) - (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.baroclinic_channel mode=init configuration=baroclinic_channel) - (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.lock_exchange mode=init configuration=lock_exchange) - (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.internal_waves mode=init configuration=internal_waves) - (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.overflow mode=init configuration=overflow) - (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.cvmix_convection_unit_test mode=init configuration=cvmix_convection_unit_test) - (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.cvmix_shear_unit_test mode=init configuration=cvmix_shear_unit_test) - (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.soma mode=init configuration=soma) - (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.iso mode=init configuration=iso) - (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.ziso mode=init configuration=ziso) - (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.global_ocean mode=init configuration=global_ocean) - (cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.periodic_planar mode=init configuration=periodic_planar) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean stream_list.ocean. mutable ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.forward stream_list.ocean.forward. mutable mode=forward ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis ) (cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.init stream_list.ocean.init. mutable mode=init ) - #(cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.ocean.init.TEMPLATE mode=init configuration=TEMPLATE) - #(cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.ocean.init.TEMPLATE stream_list.ocean.init.TEMPLATE. mutable mode=init configuration=TEMPLATE ) gen_includes: $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml @@ -79,6 +66,9 @@ clean: if [ -d cvmix ]; then \ (cd cvmix; make clean) \ fi + if [ -d inc ]; then \ + ($(RM) -r inc) \ + fi (cd mode_forward; $(MAKE) clean) (cd mode_analysis; $(MAKE) clean) (cd mode_init; $(MAKE) clean) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 261a8faa88..6c08dd054b 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -141,34 +141,22 @@ - + - - @@ -280,7 +268,7 @@ /> - @@ -310,10 +298,10 @@ description="Coefficient for horizontal biharmonic operator on momentum." possible_values="any positive real" /> - + - @@ -482,7 +470,7 @@ description="Prandtl number to be used within the CVMix parameterization suite" possible_values="Any non-negative real value." /> - @@ -506,7 +494,7 @@ description="Convective vertical viscosity applied to horizontal velocity components" possible_values="Any positive real value." /> - diff --git a/src/core_ocean/mode_init/Registry_baroclinic_channel.xml b/src/core_ocean/mode_init/Registry_baroclinic_channel.xml index 1891bd2955..fbb982ae91 100644 --- a/src/core_ocean/mode_init/Registry_baroclinic_channel.xml +++ b/src/core_ocean/mode_init/Registry_baroclinic_channel.xml @@ -3,7 +3,7 @@ description="Number of vertical levels in baroclinic channel test case. Typical value is 20." possible_values="Any positive integer number greater than 0." /> - diff --git a/src/core_ocean/mode_init/Registry_iso.xml b/src/core_ocean/mode_init/Registry_iso.xml index 91d0d182c6..57820b17ab 100644 --- a/src/core_ocean/mode_init/Registry_iso.xml +++ b/src/core_ocean/mode_init/Registry_iso.xml @@ -15,7 +15,7 @@ description="Latitude of the top of the main channel south wall wall in the ISO domain." possible_values="Any real number." /> - @@ -31,7 +31,7 @@ description="Width of the ridge at the zonal middle of the ISO domain." possible_values="Any positive real number." /> - @@ -55,7 +55,7 @@ description="Width of the sloping region of the plateau in the ISO domain." possible_values="Any positive real number." /> - @@ -67,7 +67,7 @@ description="Width of the shelf in the ISO." possible_values="Any positive real number." /> - @@ -75,7 +75,7 @@ description="Maximum slope of the continental slope in the ISO." possible_values="Any positive real number." /> - @@ -95,7 +95,7 @@ description="Depth of the embayment in the ISO." possible_values="Any positive real number." /> - @@ -267,7 +267,7 @@ description="Sponge layer restoring time scale, used to calculate interior restoring rate." possible_values="Any real number." /> - @@ -283,7 +283,7 @@ description="Meridional length scale of the restoring region 1" possible_values="Any real number." /> - @@ -299,7 +299,7 @@ description="Meridional length scale of the restoring region 2" possible_values="Any real number." /> - @@ -315,7 +315,7 @@ description="Meridional length scale of the restoring region 3" possible_values="Any real number." /> - diff --git a/src/core_ocean/mode_init/Registry_ziso.xml b/src/core_ocean/mode_init/Registry_ziso.xml index f06e2d3aae..155ccd7210 100644 --- a/src/core_ocean/mode_init/Registry_ziso.xml +++ b/src/core_ocean/mode_init/Registry_ziso.xml @@ -1,4 +1,4 @@ - + Date: Mon, 9 Nov 2015 09:38:23 -0700 Subject: [PATCH 0406/1724] Remove set_restingThickness_to_IC flag. This should have been removed in #605. The flag is no longer used. In init mode, each init case should set the resting thickness. --- src/core_ocean/Registry.xml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 6c08dd054b..15f51c4fe0 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -204,10 +204,6 @@ description="Maximum thickness allowed. This is a factor times the resting thickness, i.e., maximum thickness = config_max_thickness_factor*$h^{rest}$." possible_values="any positive real value, but typically 2-4." /> - Date: Mon, 9 Nov 2015 09:42:29 -0700 Subject: [PATCH 0407/1724] Adding a summary of OpenMP threads for the ocean core This commit adds writing of the number of OpenMP threads available to an MPI task within the log.*.err file. Note: The thread number is the number available to an MPI task, but the MPI task may not use them. For example, if there is no parallel region, no additionaly OpenMP threads will be used. --- src/core_ocean/driver/mpas_ocn_core.F | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/core_ocean/driver/mpas_ocn_core.F b/src/core_ocean/driver/mpas_ocn_core.F index 3c94254986..766a0f0e9a 100644 --- a/src/core_ocean/driver/mpas_ocn_core.F +++ b/src/core_ocean/driver/mpas_ocn_core.F @@ -28,6 +28,7 @@ module ocn_core use mpas_dmpar use mpas_timer use mpas_io_units + use mpas_threading use ocn_forward_mode use ocn_analysis_mode @@ -60,11 +61,20 @@ function ocn_core_init(domain, startTimeStamp) result(ierr)!{{{ integer :: ierr character (len=StrKIND), pointer :: config_ocean_run_mode + integer :: numThreads ierr = 0 call mpas_pool_get_config(domain % configs, 'config_ocean_run_mode', config_ocean_run_mode) + numThreads = mpas_threading_get_max_threads() + + write(stderrUnit, *) '' + write(stderrUnit, *) ' **********************************************************************************' + write(stderrUnit, *) ' MPI Task ', domain % dminfo % my_proc_id, ' has access to ', numThreads, ' threads' + write(stderrUnit, *) ' **********************************************************************************' + write(stderrUnit, *) '' + if ( trim(config_ocean_run_mode) == 'forward' ) then ierr = ocn_forward_mode_init(domain, startTimeStamp) else if ( trim(config_ocean_run_mode) == 'analysis' ) then From 733ffbde3f0fb54778d4030b655b2efa674a5c71 Mon Sep 17 00:00:00 2001 From: Mathew Maltrud Date: Mon, 9 Nov 2015 13:45:39 -0700 Subject: [PATCH 0408/1724] defined all standard tracer Registry entries (eg, SurfaceRestoringFields, exp decay rate, etc) for BGC tracers. all tracers need to have definitions for all possible tracer types and forcings. added these for ecosys, DMS, and MacroMolecules even though they will almost certainly never be used by BGC since it is a self-contained module. --- src/core_ocean/tracer_groups/Registry_DMS.xml | 72 ++ .../tracer_groups/Registry_MacroMolecules.xml | 93 +++ .../tracer_groups/Registry_ecosys.xml | 652 ++++++++++++++++++ 3 files changed, 817 insertions(+) diff --git a/src/core_ocean/tracer_groups/Registry_DMS.xml b/src/core_ocean/tracer_groups/Registry_DMS.xml index 249c53ecfb..c470f2ecf0 100644 --- a/src/core_ocean/tracer_groups/Registry_DMS.xml +++ b/src/core_ocean/tracer_groups/Registry_DMS.xml @@ -35,6 +35,12 @@ + + + + + + @@ -91,4 +97,70 @@ description="Surface DMSP flux from sea ice" /> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/tracer_groups/Registry_MacroMolecules.xml b/src/core_ocean/tracer_groups/Registry_MacroMolecules.xml index cc1d3b469f..e19cc5b28f 100644 --- a/src/core_ocean/tracer_groups/Registry_MacroMolecules.xml +++ b/src/core_ocean/tracer_groups/Registry_MacroMolecules.xml @@ -35,6 +35,12 @@ + + + + + + @@ -100,4 +106,91 @@ description="Surface Organic Proteins flux from sea ice" /> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/tracer_groups/Registry_ecosys.xml b/src/core_ocean/tracer_groups/Registry_ecosys.xml index fc5d85502e..4c1965bc4a 100644 --- a/src/core_ocean/tracer_groups/Registry_ecosys.xml +++ b/src/core_ocean/tracer_groups/Registry_ecosys.xml @@ -35,6 +35,12 @@ + + + + + + @@ -597,4 +603,650 @@ description="diag_P_iron_REMIN" /> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + From 231f0ad5e16b7654e8b3997f01231a4fec907d6f Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Wed, 11 Nov 2015 11:57:45 -0700 Subject: [PATCH 0409/1724] add forcing to temperature due to rainFlux and snowFlux. surface water fluxes have an associated heat content. the modifications here assume that rain and snow fluxes have a temperature equal to the sea surface temperature. --- .../shared/mpas_ocn_surface_bulk_forcing.F | 28 ++++++++++++++++--- src/core_ocean/shared/mpas_ocn_tendency.F | 4 +-- 2 files changed, 26 insertions(+), 6 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F index b3667a1c51..8e55c5748e 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F @@ -73,7 +73,7 @@ module ocn_surface_bulk_forcing ! TRACER-CLEAN-UP ! Currently, penetrativeTemperatureFlux is built into bulk forcing.. what should we do about that? - subroutine ocn_surface_bulk_forcing_tracers(meshPool, groupName, forcingPool, tracersSurfaceFlux, err)!{{{ + subroutine ocn_surface_bulk_forcing_tracers(meshPool, groupName, forcingPool, tracerGroup, tracersSurfaceFlux, err)!{{{ !----------------------------------------------------------------- ! @@ -89,6 +89,7 @@ subroutine ocn_surface_bulk_forcing_tracers(meshPool, groupName, forcingPool, tr ! !----------------------------------------------------------------- type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information + real (kind=RKIND), dimension(:,:,:), intent(inout) :: tracerGroup real (kind=RKIND), dimension(:,:), intent(inout) :: tracersSurfaceFlux !< Input/Output: Surface flux for tracer group !----------------------------------------------------------------- @@ -108,7 +109,7 @@ subroutine ocn_surface_bulk_forcing_tracers(meshPool, groupName, forcingPool, tr err = 0 if ( trim(groupName) == 'activeTracers' ) then - call ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracersSurfaceFlux, err) + call ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracerGroup, tracersSurfaceFlux, err) end if end subroutine ocn_surface_bulk_forcing_tracers!}}} @@ -325,7 +326,7 @@ end subroutine ocn_surface_bulk_forcing_init!}}} ! !----------------------------------------------------------------------- - subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracersSurfaceFlux, err)!{{{ + subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracerGroup, tracersSurfaceFlux, err)!{{{ !----------------------------------------------------------------- ! @@ -333,6 +334,7 @@ subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracer ! !----------------------------------------------------------------- type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information + real (kind=RKIND), dimension(:,:,:), intent(in) :: tracerGroup !----------------------------------------------------------------- ! @@ -360,15 +362,20 @@ subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracer integer, pointer :: index_temperature_flux, index_salinity_flux integer, pointer :: nCells - real (kind=RKIND), dimension(:), pointer :: latentHeatFlux, sensibleHeatFlux, longWaveHeatFluxUp, longWaveHeatFluxDown, seaIceHeatFlux, snowFlux + real (kind=RKIND), dimension(:), pointer :: latentHeatFlux, sensibleHeatFlux, longWaveHeatFluxUp, longWaveHeatFluxDown, seaIceHeatFlux real (kind=RKIND), dimension(:), pointer :: seaIceFreshWaterFlux, seaIceSalinityFlux, iceRunoffFlux real (kind=RKIND), dimension(:), pointer :: shortWaveHeatFlux, penetrativeTemperatureFlux + real (kind=RKIND), dimension(:), pointer :: snowFlux, rainFlux + ! CLEANUP + ! real (kind=RKIND), dimension(:), pointer :: seaIceFreshWaterFlux, riverRunoffFlux, iceRunoffFlux ! Do we want to include these in the heat forcing? + err = 0 call mpas_pool_get_dimension(meshPool, 'nCells', nCells) ! CLEANUP + ! Doug: Should we keep these two lines? If so, we should uncomment them and used them for the indexing. ! call mpas_pool_get_dimension(forcingPool, 'index_temperatureSurfaceFlux', index_temperature_flux) ! call mpas_pool_get_dimension(forcingPool, 'index_salinitySurfaceFlux', index_salinity_flux) @@ -398,6 +405,19 @@ subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracer end do !$omp end do + ! Surface fluxes of water have an associated heat content, but the coupled system does not account for this + ! Assume surface fluxes of water have a temperature equal to the surface temperature. + ! Assume surface fluxes of water have zero salinity. So the RHS forcing is zero for salinity. + ! Only include this heat forcing when bulk thickness is turned on + ! indices on tracerGroup are (iTracer, iLevel, iCell) + ! DOUG: OpenMP directive here? + if (bulkThicknessFluxOn) then + do iCell = 1, nCells + tracersSurfaceFlux(1, iCell) = tracersSurfaceFlux(1, iCell) + (snowFlux(iCell) + rainFlux(iCell))*tracerGroup(1,1,iCell) + end do + endif ! bulkThicknessFluxOn + ! DOUG: OpenMP directive here? + ! TRACER-CLEAN-UP ! Do we want this here still? penetrativeTemperatureFlux = shortWaveHeatFlux * hflux_factor diff --git a/src/core_ocean/shared/mpas_ocn_tendency.F b/src/core_ocean/shared/mpas_ocn_tendency.F index c1ee171e61..7ce5b6d6d7 100644 --- a/src/core_ocean/shared/mpas_ocn_tendency.F +++ b/src/core_ocean/shared/mpas_ocn_tendency.F @@ -375,7 +375,7 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me type (mpas_pool_type), intent(in) :: statePool !< Input: State information type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information type (mpas_pool_type), intent(in) :: diagnosticsPool !< Input: Diagnostic information - type (mpas_pool_type), intent(inout) :: meshPool !< Input: Mesh information + type (mpas_pool_type), intent(inout) :: meshPool !< Input: Mesh information type (mpas_pool_type), intent(in) :: scratchPool !< Input: Scratch information real (kind=RKIND), intent(in) :: dt !< Input: Time step integer, intent(in), optional :: timeLevelIn !< Input/Optional: Time Level Indes @@ -564,7 +564,7 @@ subroutine ocn_tend_tracer(tendPool, statePool, forcingPool, diagnosticsPool, me ! if (config_use_tracerGroup_surface_bulk_forcing) then call mpas_timer_start("bulk_" // trim(groupItr % memberName), .false.) - call ocn_surface_bulk_forcing_tracers(meshPool, groupItr % memberName, forcingPool, tracerGroupSurfaceFlux, err) + call ocn_surface_bulk_forcing_tracers(meshPool, groupItr % memberName, forcingPool, tracerGroup, tracerGroupSurfaceFlux, err) call mpas_timer_stop("bulk_" // trim(groupItr % memberName)) end if From 2870ba758462575e849d5a8fe635cccb9e3e8405 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Wed, 11 Nov 2015 16:53:11 -0800 Subject: [PATCH 0410/1724] mpi communication bug fix with > 1000 processors This fixes an issue where there was corruption of array temporaries during MPI_ISend statements due to Fortran vs C-array ordering. Essentially, array temporaries were being formed for the send data. This did not present an issue on small processor counts and certain architectures but caused problems that appeared during usage on Edison with the 30-10km Idealized Southern Ocean. --- .../mpas_ocn_lagrangian_particle_tracking.F | 2 +- src/core_ocean/analysis_members/mpas_ocn_particle_list.F | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F index 25398564ed..f9e64299ed 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -309,7 +309,7 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_filter_number', filterNum) - allocate(ioProcRecvList(size(g_ioProcNeighs), domain % dminfo % nprocs)) + allocate(ioProcRecvList(domain % dminfo % nprocs, size(g_ioProcNeighs))) allocate(ioProcSendList(domain % dminfo % nprocs)) ioProcRecvList = .False. ioProcSendList = .False. diff --git a/src/core_ocean/analysis_members/mpas_ocn_particle_list.F b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F index 0f0f44709c..53a4646baa 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_particle_list.F +++ b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F @@ -617,12 +617,12 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS ! for each ioProc, send logical array information do i = 1, nioProcNeighs #ifdef _MPI - call MPI_ISend(ioProcRecvList(i,:), nProcs, MPI_LOGICAL, ioProcNeighs(i), domain % dminfo % my_proc_id, & + call MPI_ISend(ioProcRecvList(:,i), nProcs, MPI_LOGICAL, ioProcNeighs(i), domain % dminfo % my_proc_id, & domain % dminfo % comm, sendRequestID(i), mpi_ierr) #endif #ifdef MPAS_DEBUG write(stderrUnit,*) 'ioProcNeigh= ', ioProcNeighs(i) - write(stderrUnit,*) 'send data = ', ioProcRecvList(i,:) + write(stderrUnit,*) 'send data = ', ioProcRecvList(:,i) #endif end do @@ -3953,7 +3953,7 @@ subroutine mpas_particle_list_update_computational_halos(domain, block, particle ! which is dependent upon current, on-processor particles if (ioProc /= domain % dminfo % my_proc_id) then arrayIndex = find_index(gioProcNeighs, ioProc) - ioProcRecvList(arrayIndex, currentProc+1) = .True. + ioProcRecvList(currentProc+1, arrayIndex) = .True. else ! consider the case where a particle on A has an ioProc of A and is sent to B (need to have B in A's halo). ioProcSendList(currentProc+1) = .True. From a31a702156b8841320d9213f7eee9a8d8def3924 Mon Sep 17 00:00:00 2001 From: Todd Ringler Date: Wed, 11 Nov 2015 18:54:37 -0700 Subject: [PATCH 0411/1724] add rainFlux array and add missing factor of rho_sw. --- src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F index 8e55c5748e..3c0a3f8deb 100644 --- a/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F +++ b/src/core_ocean/shared/mpas_ocn_surface_bulk_forcing.F @@ -334,7 +334,6 @@ subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracer ! !----------------------------------------------------------------- type (mpas_pool_type), intent(in) :: meshPool !< Input: mesh information - real (kind=RKIND), dimension(:,:,:), intent(in) :: tracerGroup !----------------------------------------------------------------- ! @@ -343,6 +342,7 @@ subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracer !----------------------------------------------------------------- type (mpas_pool_type), intent(inout) :: forcingPool !< Input: Forcing information real (kind=RKIND), dimension(:,:), intent(inout) :: tracersSurfaceFlux + real (kind=RKIND), dimension(:,:,:), intent(inout) :: tracerGroup !----------------------------------------------------------------- ! @@ -384,6 +384,7 @@ subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracer call mpas_pool_get_array(forcingPool, 'longWaveHeatFluxUp', longWaveHeatFluxUp) call mpas_pool_get_array(forcingPool, 'longWaveHeatFluxDown', longWaveHeatFluxDown) call mpas_pool_get_array(forcingPool, 'seaIceHeatFlux', seaIceHeatFlux) + call mpas_pool_get_array(forcingPool, 'rainFlux', rainFlux) call mpas_pool_get_array(forcingPool, 'snowFlux', snowFlux) call mpas_pool_get_array(forcingPool, 'shortWaveHeatFlux', shortWaveHeatFlux) @@ -413,7 +414,7 @@ subroutine ocn_surface_bulk_forcing_active_tracers(meshPool, forcingPool, tracer ! DOUG: OpenMP directive here? if (bulkThicknessFluxOn) then do iCell = 1, nCells - tracersSurfaceFlux(1, iCell) = tracersSurfaceFlux(1, iCell) + (snowFlux(iCell) + rainFlux(iCell))*tracerGroup(1,1,iCell) + tracersSurfaceFlux(1, iCell) = tracersSurfaceFlux(1, iCell) + (snowFlux(iCell) + rainFlux(iCell))*tracerGroup(1,1,iCell) / rho_sw end do endif ! bulkThicknessFluxOn ! DOUG: OpenMP directive here? From e434bd9380e2d09415965f14e2f533b945cc0b6f Mon Sep 17 00:00:00 2001 From: Mathew Maltrud Date: Thu, 12 Nov 2015 14:12:47 -0700 Subject: [PATCH 0412/1724] fixed bugs related to PGI compiler, and cleaned up comments in code (specifically attribution/date stamp/references to cvmix). --- src/core_ocean/Makefile | 2 +- src/core_ocean/build_options.mk | 1 + src/core_ocean/get_BGC.sh | 4 +-- .../mode_init/mpas_ocn_init_ecosys_column.F | 25 +++++++++---------- src/core_ocean/shared/mpas_ocn_tracer_DMS.F | 14 +++++------ .../shared/mpas_ocn_tracer_MacroMolecules.F | 14 +++++------ .../shared/mpas_ocn_tracer_ecosys.F | 14 +++++------ 7 files changed, 37 insertions(+), 37 deletions(-) diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index 18f92382dd..31b760b853 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -2,7 +2,7 @@ OCEAN_SHARED_INCLUDES = -I$(PWD)/../framework -I$(PWD)/../external/esmf_time_f90 -I$(PWD)/../operators -OCEAN_SHARED_INCLUDES += -I$(PWD)/shared -I$(PWD)/analysis_members -I$(PWD)/cvmix -I$(PWD)/mode_forward -I$(PWD)/mode_analysis -I$(PWD)/mode_init -I$(PWD)/BGC +OCEAN_SHARED_INCLUDES += -I$(PWD)/BGC -I$(PWD)/shared -I$(PWD)/analysis_members -I$(PWD)/cvmix -I$(PWD)/mode_forward -I$(PWD)/mode_analysis -I$(PWD)/mode_init all: shared libcvmix analysis_members libBGC (cd mode_forward; $(MAKE) FCINCLUDES="$(FCINCLUDES) $(OCEAN_SHARED_INCLUDES)" all ) diff --git a/src/core_ocean/build_options.mk b/src/core_ocean/build_options.mk index 67d44adc11..fd70ba46d8 100644 --- a/src/core_ocean/build_options.mk +++ b/src/core_ocean/build_options.mk @@ -7,6 +7,7 @@ FCINCLUDES += -I$(ROOT_DIR)/core_ocean/driver FCINCLUDES += -I$(ROOT_DIR)/core_ocean/mode_forward -I$(ROOT_DIR)/core_ocean/mode_analysis -I$(ROOT_DIR)/core_ocean/mode_init FCINCLUDES += -I$(ROOT_DIR)/core_ocean/shared -I$(ROOT_DIR)/core_ocean/analysis_members FCINCLUDES += -I$(ROOT_DIR)/core_ocean/cvmix +FCINCLUDES += -I$(ROOT_DIR)/core_ocean/BGC override CPPFLAGS += -DCORE_OCEAN report_builds: diff --git a/src/core_ocean/get_BGC.sh b/src/core_ocean/get_BGC.sh index cf8973e622..5631c0490f 100755 --- a/src/core_ocean/get_BGC.sh +++ b/src/core_ocean/get_BGC.sh @@ -1,7 +1,7 @@ #!/bin/bash ## BGC Tag for build -BGC_TAG=50af425 +BGC_TAG=6c4240c ## Subdirectory in BGC repo to use BGC_SUBDIR=. @@ -32,7 +32,7 @@ if [ -d BGC ]; then fi fi -# CVmix Doesn't exist, need to acquire souce code +# BGC Doesn't exist, need to acquire souce code # If might have been flushed from the above if, in the case where it was svn or wget that acquired the source. if [ ! -d BGC ]; then if [ -d .BGC_all ]; then diff --git a/src/core_ocean/mode_init/mpas_ocn_init_ecosys_column.F b/src/core_ocean/mode_init/mpas_ocn_init_ecosys_column.F index 2458610f94..46c138b917 100644 --- a/src/core_ocean/mode_init/mpas_ocn_init_ecosys_column.F +++ b/src/core_ocean/mode_init/mpas_ocn_init_ecosys_column.F @@ -9,14 +9,13 @@ ! ! ocn_init_ecosys_column ! -!> \brief MPAS ocean initialize case -- CVMix Unit Test -!> WSwSBF means Wind Stress with Surface Buoyancy Forcing -!> \author Todd Ringler -!> \date 04/23/2015 +!> \brief MPAS ocean initialize case -- BGC (ecosys + DMS + MacroMolecules) +!> \author Mathew Maltrud +!> \date 11/01/2015 !> \details !> This module contains the routines for initializing the !> the ecosys column test configuration. This in a -!> single column configuration +!> single column configuration. ! !----------------------------------------------------------------------- @@ -69,8 +68,8 @@ module ocn_init_ecosys_column ! routine ocn_init_setup_ecosys_column ! !> \brief Setup for ecosys column test configuration -!> \author Todd Ringler -!> \date 04/23/2015 +!> \author Mathew Maltrud +!> \date 11/01/2015 !> \details !> This routine sets up the initial conditions for the ecosys column test configuration. ! @@ -443,11 +442,11 @@ end subroutine ocn_init_setup_ecosys_column!}}} ! ! routine ocn_init_validate_ecosys_column ! -!> \brief Validation for CVMix WSwSBF mixing unit test case -!> \author Doug Jacobsen -!> \date 04/01/2015 +!> \brief Validation for ecosys column test case +!> \author Mathew Maltrud +!> \date 11/01/2015 !> \details -!> This routine validates the configuration options for the CVMix WSwSBF mixing unit test configuration. +!> This routine validates the configuration options for the ecosys column test configuration. ! !----------------------------------------------------------------------- @@ -490,8 +489,8 @@ end subroutine ocn_init_validate_ecosys_column!}}} ! routine ocn_init_setup_ecosys_read_column ! !> \brief Read a column of a specified field from a given file -!> \author Doug Jacobsen -!> \date 03/04/2014 +!> \author Mathew Maltrud +!> \date 11/01/2014 !> \details !> This routine reads a column of a specified field from a given file ! diff --git a/src/core_ocean/shared/mpas_ocn_tracer_DMS.F b/src/core_ocean/shared/mpas_ocn_tracer_DMS.F index 23aa814cdd..eb40b75cd2 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_DMS.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_DMS.F @@ -11,7 +11,7 @@ ! !> \brief MPAS ocean DMS !> \author Mathew Maltrud -!> \date 08/24/2015 +!> \date 11/01/2015 !> \details !> This module contains routines for computing tracer forcing due to DMS ! @@ -83,8 +83,8 @@ module ocn_tracer_DMS ! routine ocn_tracer_DMS_compute ! !> \brief computes a tracer tendency due to DMS -!> \author Todd Ringler -!> \date 06/09/2015 +!> \author Mathew Maltrud +!> \date 11/01/2015 !> \details !> This routine computes a tracer tendency due to DMS ! @@ -205,8 +205,8 @@ end subroutine ocn_tracer_DMS_compute!}}} ! routine ocn_tracer_DMS_surface_flux_compute ! !> \brief computes a tracer tendency due to DMS -!> \author Todd Ringler -!> \date 06/09/2015 +!> \author Mathew Maltrud +!> \date 11/01/2015 !> \details !> This routine computes a tracer tendency due to DMS ! @@ -314,8 +314,8 @@ end subroutine ocn_tracer_DMS_surface_flux_compute!}}} ! routine ocn_tracer_DMS_init ! !> \brief Initializes ocean surface restoring -!> \author Todd Ringler -!> \date 06/09/2015 +!> \author Mathew Maltrud +!> \date 11/01/2015 !> \details !> This routine initializes fields required for tracer surface flux restoring ! diff --git a/src/core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F b/src/core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F index 6d976d3803..7e7e01c06e 100644 --- a/src/core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F @@ -11,7 +11,7 @@ ! !> \brief MPAS ocean MacroMolecules !> \author Mathew Maltrud -!> \date 08/24/2015 +!> \date 11/01/2015 !> \details !> This module contains routines for computing tracer forcing due to MacroMolecules ! @@ -81,8 +81,8 @@ module ocn_tracer_MacroMolecules ! routine ocn_tracer_MacroMolecules_compute ! !> \brief computes a tracer tendency due to MacroMolecules -!> \author Todd Ringler -!> \date 06/09/2015 +!> \author Mathew Maltrud +!> \date 11/01/2015 !> \details !> This routine computes a tracer tendency due to MacroMolecules ! @@ -207,8 +207,8 @@ end subroutine ocn_tracer_MacroMolecules_compute!}}} ! routine ocn_tracer_MacroMolecules_surface_flux_compute ! !> \brief computes a tracer tendency due to MacroMolecules -!> \author Todd Ringler -!> \date 06/09/2015 +!> \author Mathew Maltrud +!> \date 11/01/2015 !> \details !> This routine computes a tracer tendency due to MacroMolecules ! @@ -284,8 +284,8 @@ end subroutine ocn_tracer_MacroMolecules_surface_flux_compute!}}} ! routine ocn_tracer_MacroMolecules_init ! !> \brief Initializes ocean surface restoring -!> \author Todd Ringler -!> \date 06/09/2015 +!> \author Mathew Maltrud +!> \date 11/01/2015 !> \details !> This routine initializes fields required for tracer surface flux restoring ! diff --git a/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F b/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F index a5554ac669..ea95074a0e 100755 --- a/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F +++ b/src/core_ocean/shared/mpas_ocn_tracer_ecosys.F @@ -11,7 +11,7 @@ ! !> \brief MPAS ocean ecosys !> \author Mathew Maltrud -!> \date 08/24/2015 +!> \date 11/01/2015 !> \details !> This module contains routines for computing tracer forcing due to ecosys ! @@ -82,8 +82,8 @@ module ocn_tracer_ecosys ! routine ocn_tracer_ecosys_compute ! !> \brief computes a tracer tendency due to ecosys -!> \author Todd Ringler -!> \date 06/09/2015 +!> \author Mathew Maltrud +!> \date 11/01/2015 !> \details !> This routine computes a tracer tendency due to ecosys ! @@ -503,8 +503,8 @@ end subroutine ocn_tracer_ecosys_compute!}}} ! routine ocn_tracer_ecosys_surface_flux_compute ! !> \brief computes a tracer tendency due to ecosys -!> \author Todd Ringler -!> \date 06/09/2015 +!> \author Mathew Maltrud +!> \date 11/01/2015 !> \details !> This routine computes a tracer tendency due to ecosys ! @@ -722,8 +722,8 @@ end subroutine ocn_tracer_ecosys_surface_flux_compute!}}} ! routine ocn_tracer_ecosys_init ! !> \brief Initializes ocean surface restoring -!> \author Todd Ringler -!> \date 06/09/2015 +!> \author Mathew Maltrud +!> \date 11/01/2015 !> \details !> This routine initializes fields required for tracer surface flux restoring ! From b03ff368419222727f8296bff779808facb7aa50 Mon Sep 17 00:00:00 2001 From: Douglas Jacobsen Date: Fri, 13 Nov 2015 09:02:55 -0700 Subject: [PATCH 0413/1724] Fixing an issue with KPP that prevents bit-reproducibility This commit fixes three issues with KPP. To begin with, it changes two casts to floats to cast to RKIND reals to ensure the types are consistent. Additionally, normvalVelocityAv previously was computed using the incorrect iEdge (iEdge instead of iEdgeVal). This made KPP incorrect and non-bit reproducible in most configurations. --- src/core_ocean/shared/mpas_ocn_vmix_cvmix.F | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F b/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F index d74d121627..d14e7d6bd5 100644 --- a/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F +++ b/src/core_ocean/shared/mpas_ocn_vmix_cvmix.F @@ -404,9 +404,9 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, invAreaCell = 1.0 / areaCell(iCell) deltaVelocitySquared = 0.0_RKIND do iEdge=1,nEdgesOnCell(iCell) - normalVelocityAv = sum(normalVelocity(1:kav,iEdge))/float(kav) - iEdgeVal = edgesOnCell(iEdge,iCell) + + normalVelocityAv = sum(normalVelocity(1:kav,iEdgeVal))/real(kav, kind=RKIND) factor = 0.5 * dcEdge(iEdgeVal) * dvEdge(iEdgeVal) * invAreaCell delU2 = (normalVelocityAv - normalVelocity(kIndexOBL,iEdgeVal))**2 deltaVelocitySquared = deltaVelocitySquared + factor * delU2 @@ -415,7 +415,7 @@ subroutine ocn_vmix_coefs_cvmix_build(meshPool, statePool, diagnosticsPool, err, bulkRichardsonNumberShear(kIndexOBL,iCell) = max(deltaVelocitySquared, 1.0e-15_RKIND) bulkRichardsonNumberBuoy(kIndexOBL,iCell) = gravity * (density(kIndexOBL,iCell) - & - sum(density(1:kav,iCell))/float(kav)) / rho_sw + sum(density(1:kav,iCell))/real(kav, kind=RKIND)) / rho_sw enddo ! do kIndexOBL cvmix_variables % bulkRichardson_cntr(:) = cvmix_kpp_compute_bulk_Richardson( & From b4b89ec7970fc9d5d8afefa139ff8701281e35ba Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Fri, 13 Nov 2015 09:24:15 -0700 Subject: [PATCH 0414/1724] Corrections to forcing variables in Registry. --- .../tracer_groups/Registry_MacroMolecules.xml | 14 +++++++------- src/core_ocean/tracer_groups/Registry_ecosys.xml | 15 ++++++++++++--- 2 files changed, 19 insertions(+), 10 deletions(-) diff --git a/src/core_ocean/tracer_groups/Registry_MacroMolecules.xml b/src/core_ocean/tracer_groups/Registry_MacroMolecules.xml index e19cc5b28f..5ac29ac2d0 100644 --- a/src/core_ocean/tracer_groups/Registry_MacroMolecules.xml +++ b/src/core_ocean/tracer_groups/Registry_MacroMolecules.xml @@ -107,7 +107,7 @@ /> - + @@ -118,7 +118,7 @@ description="A non-negative field controlling the rate at which LIP is restored to LIPSurfaceRestoringValue" /> - + @@ -131,7 +131,7 @@ - + @@ -142,7 +142,7 @@ description="A non-negative field controlling the rate at which LIP is restored to LIPInteriorRestoringValue" /> - + @@ -155,7 +155,7 @@ - + @@ -168,7 +168,7 @@ - + @@ -181,7 +181,7 @@ - + diff --git a/src/core_ocean/tracer_groups/Registry_ecosys.xml b/src/core_ocean/tracer_groups/Registry_ecosys.xml index 4c1965bc4a..9d470fa68e 100644 --- a/src/core_ocean/tracer_groups/Registry_ecosys.xml +++ b/src/core_ocean/tracer_groups/Registry_ecosys.xml @@ -855,6 +855,9 @@ + @@ -1038,6 +1041,9 @@ + @@ -1062,9 +1068,6 @@ - @@ -1132,6 +1135,9 @@ + @@ -1223,6 +1229,9 @@ + From 1c66c666c365de6c77367565805c84f3683b0003 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 13 Nov 2015 11:39:23 -0700 Subject: [PATCH 0415/1724] pure refractoring, results should be bit identical Combination of multiple squashed commits: 1) Tested with LIGHT_planar_periodic_periodic_advection test case. Note that if there are problems it is likely this commit is to blame and it should be tested. Refractoring in anticipation of generalizing the computational halos to accomodate particle resets. 2) This commit allows for processors to send a particle to an arbitrary currentBlock via update of the computational halos. However, at present the computational halos should be static in time and this commit should consequently be identical in computation to the previous commit. 3) generalized computational halos to account for possibility of evolving halo, generalization uses infrastructure for IO halos 4) prepartation for particle resets commented out analagous communication patterns as for IO halos 5) This ensures that halos as currently written are not broken by considering 'currentBlockReset' as a component in building the halo. This current commit was tested with all 'currentBlockReset'=0 as well as 'currentBlockReset'='currentBlock' at initialization time. 6) Tested with 48 processes for planar periodic 20km case where particles are placed randomly. IO and computational halos grow and shrink dynamically to account for variable communication patterns to be able to communicate with ioHalo and currentBlockReset. These tests suggest that particles should be resetable within the current halo infrastructure. 7) implicit merge of code with bug fix commit (fixup) 2870ba758462575e849d5a8fe635cccb9e3e8405 mpi communication bug fix with > 1000 processors This fixes an issue where there was corruption of array temporaries during MPI_ISend statements due to Fortran vs C-array ordering. Essentially, array temporaries were being formed for the send data. This did not present an issue on small processor counts and certain architectures but caused problems that appeared during usage on Edison with the 30-10km Idealized Southern Ocean. --- .../Registry_lagrangian_particle_tracking.xml | 2 +- .../mpas_ocn_lagrangian_particle_tracking.F | 109 +++++++- .../analysis_members/mpas_ocn_particle_list.F | 255 ++++++++++++------ 3 files changed, 269 insertions(+), 97 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml index a5832ace19..982d107d5d 100644 --- a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml +++ b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml @@ -34,7 +34,7 @@ - null(), g_ioProcNeighs=>null() + integer, dimension(:), pointer :: g_compProcNeighsNearby => null(), g_compProcNeighs => null(), g_ioProcNeighs=>null() !*********************************************************************** @@ -143,13 +144,18 @@ subroutine ocn_init_lagrangian_particle_tracking(domain, err)!{{{ ! parallel code: ! get "MPI halos" for communication of particles in halo during computational step - call mpas_particle_list_build_computation_halos(domain, err, g_ProcNeighs) + call mpas_particle_list_build_computation_halos(domain, err, g_compProcNeighsNearby) + ! make sure Eulerian computational halo values are transfered to general computational halo + ! just copy this data + allocate(g_compProcNeighs(size(g_compProcNeighsNearby))) + g_compProcNeighs = g_compProcNeighsNearby #ifdef MPAS_DEBUG write(stderrUnit,*) 'finished building and computational halos' #endif ! get "MPI halos" for IO communication during write and restart steps (ioBlock to currentBlocks) - call mpas_particle_list_build_io_halos(domain, err, 'currentBlock', g_ioProcNeighs) + ! AllToAll Computation! + call mpas_particle_list_build_halos(domain, err, 'currentBlock', g_ioProcNeighs) #ifdef MPAS_DEBUG write(stderrUnit,*) 'g_ioProcNeighs=', g_ioProcNeighs write(stderrUnit,*) 'finished building io halos' @@ -159,8 +165,9 @@ subroutine ocn_init_lagrangian_particle_tracking(domain, err)!{{{ ! note, don't necessarily need to have g_ionSend and g_ionRecv comeout #ifdef MPAS_DEBUG call mpas_timer_start("trans_from_block_to_blockLPT", .false., timerTransferParticles_init) - call mpas_particle_list_test_numparticles_to_neighprocs(domain % dminfo % my_proc_id, g_ProcNeighs, g_ioProcNeighs) + call mpas_particle_list_test_numparticles_to_neighprocs(domain % dminfo % my_proc_id, g_compProcNeighsNearby, g_ioProcNeighs) #endif + ! move particles to the 'currentBlock' call mpas_particle_list_transfer_particles_from_block_to_named_block(domain, err, .True., .False., 'currentBlock', & g_ioProcNeighs) #ifdef MPAS_DEBUG @@ -168,11 +175,31 @@ subroutine ocn_init_lagrangian_particle_tracking(domain, err)!{{{ !call MPI_Barrier(domain % dminfo % comm, err) #endif + ! at initialization time we need to build the initial halo for the reset + ! (could be anywhere so we'll need to make a connection between the + ! 'currentBlock' and 'currentBlockReset' + ! if reset () then + ! + ! build halos to reset blocks + ! AllToAll Computation! + call mpas_particle_list_build_halos(domain, err, 'currentBlockReset', g_compProcNeighs) +#if MPAS_DEBUG + write(stderrUnit,*) 'Neighs: self begin = ', g_compProcNeighs + write(stderrUnit,*) 'Neighs: list = ', g_compProcNeighsNearby +#endif + ! take the union of this halo with the particle computation halos to build complete computational halo + call mpas_particle_list_self_union_halo_lists(g_compProcNeighs, g_compProcNeighsNearby, domain % dminfo % nprocs, domain % dminfo % my_proc_id) +#if MPAS_DEBUG + write(stderrUnit,*) 'Neighs: self end = ', g_compProcNeighs +#endif + ! end if + ! tests to make sure all the values are ok !{{{ #ifdef MPAS_DEBUG call mpas_particle_list_test_neighscalc(domain, err) - call mpas_particle_list_test_numparticles_to_neighprocs(domain % dminfo % my_proc_id, g_ProcNeighs, g_ioProcNeighs) + call mpas_particle_list_test_numparticles_to_neighprocs(domain % dminfo % my_proc_id, g_compProcNeighsNearby, g_ioProcNeighs) call mpas_particle_list_test_num_current_particlelist(domain) + write(stderrUnit,*) 'g_compProcNeighsNearby = ', g_compProcNeighsNearby #endif !}}} @@ -187,6 +214,9 @@ subroutine ocn_init_lagrangian_particle_tracking(domain, err)!{{{ call initialize_particle_properties(domain,2,err) call write_lagrangian_particle_tracking(domain, err) + !! set up particle reset condition + !call ocn_setup_particle_reset_condition(domain, err) + write(stderrunit,*) 'finished ocn_init_lagrangian_particle_tracking' call mpas_timer_stop("initLPT", timerInit) @@ -275,6 +305,8 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ integer, dimension(:,:), pointer :: cellsOnCell logical, dimension(:,:), pointer :: ioProcRecvList logical, dimension(:), pointer :: ioProcSendList + logical, dimension(:,:), pointer :: compProcRecvList + logical, dimension(:), pointer :: compProcSendList logical, pointer :: onSphere real (kind=RKIND), dimension(4) :: kWeightK, kWeightKVert @@ -312,7 +344,20 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ allocate(ioProcRecvList(domain % dminfo % nprocs, size(g_ioProcNeighs))) allocate(ioProcSendList(domain % dminfo % nprocs)) ioProcRecvList = .False. + allocate(ioProcSendList(domain % dminfo % nprocs)) ioProcSendList = .False. + allocate(compProcRecvList(domain % dminfo % nprocs, size(g_compProcNeighs))) + compProcRecvList = .False. + allocate(compProcSendList(domain % dminfo % nprocs)) + compProcSendList = .False. + ! initialize with neighboring blocks to current block + ! (make sure computational halo has Eulerian MPAS halos) + compProcSendList(g_compProcNeighsNearby+1) = .True. +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'compProcSendList before halo updates = ', compProcSendList + write(stderrUnit,*) 'g_compProcNeighs before halo updates = ', g_compProcNeighs +#endif + ! get the most recent velocities on the potential density surfaces #ifdef MPAS_DEBUG @@ -751,10 +796,26 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ #ifdef MPAS_DEBUG call mpas_timer_start("particleAssignments", .false., timerParticleAssignment) #endif - ! update halo fields - call mpas_particle_list_update_computational_halos(domain, block, particle, 'lagrPartTrackCells', iCell, arrayIndex, ioProcRecvList, ioProcSendList, g_ioProcNeighs) + + ! if (reset criteria is met) then + ! update currentBlock to be reset value, setting iCell = -1 + ! + ! else + ! update halo fields for particles moving from adjacent computational halos + call mpas_particle_list_update_particle_block(domain, block, particle, 'lagrPartTrackCells', iCell) + ! end if + + !! update IO halos based on particle movement + call mpas_particle_list_update_halos_start(domain, block, particle, 'lagrPartTrackCells', iCell, & + arrayIndex, 'ioBlock', ioProcRecvList, ioProcSendList, g_ioProcNeighs) + + ! if (particle reset) then ! need to link to currentBlockReset for communication + ! update computational halos (to account for non block halo communication caused by resets, etc) + call mpas_particle_list_update_halos_start(domain, block, particle, 'lagrPartTrackCells', iCell, & + arrayIndex, 'currentBlockReset', compProcRecvList, compProcSendList, g_compProcNeighs) + ! end if #ifdef MPAS_DEBUG - call mpas_timer_stop("particleAssignments", timerParticleAssignment) + call mpas_timer_stop("particleAssignments", timerParticleAssignment) #endif !}}} @@ -778,21 +839,41 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ ! updated. Then, a routine can be called to make sure particles are placed on their appropriate ! currentBlocks +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'compProcSendList after 1st halo updates = ', compProcSendList + write(stderrUnit,*) 'compProcRecvList after 1st halo updates = ', compProcRecvList + write(stderrUnit,*) 'write halo information before' + write(stderrUnit,*) 'g_compProcNeighs = ', g_compProcNeighs + write(stderrUnit,*) 'g_compProcNeighsNearby = ', g_compProcNeighsNearby +#endif + ! particle transfer can then occur from computational processor to computational processor #ifdef MPAS_DEBUG call mpas_timer_start("trans_from_block_to_blockLPT", .false., timerTransferParticles) #endif call mpas_particle_list_transfer_particles_from_block_to_named_block(domain, err, .True., .False., 'currentBlock', & - g_ProcNeighs) + g_compProcNeighs) #ifdef MPAS_DEBUG call mpas_timer_stop("trans_from_block_to_blockLPT", timerTransferParticles) call mpas_timer_start("update_io_haloLPT", .false., timerUpdateIOHalo) #endif - call mpas_particle_list_update_io_halos(domain, err, g_ioProcNeighs, ioProcSendList, ioProcRecvList) -#ifdef MPAS_DEBUG + ! update io halo + call mpas_particle_list_update_halos_end(domain, err, 'ioBlock', g_ioProcNeighs, ioProcSendList, ioProcRecvList) + ! if (doing a particle reset) then + ! update computational halo + call mpas_particle_list_update_halos_end(domain, err, 'currentBlockReset', g_compProcNeighs, compProcSendList, compProcRecvList) + ! end if +#ifdef MPAS_DEBUG + write(stderrUnit,*) 'g_compProcNeighs after halo updates = ', g_compProcNeighs + write(stderrUnit,*) 'compProcSendList after last halo updates = ', compProcSendList + write(stderrUnit,*) 'compProcRecvList after last halo updates = ', compProcRecvList + write(stderrUnit,*) 'write halo information after' + write(stderrUnit,*) 'g_compProcNeighsNearby = ', g_compProcNeighsNearby + write(stderrUnit,*) 'g_compProcNeighs = ', g_compProcNeighs + write(stderrUnit,*) 'g_ioProcNeighs = ', g_ioProcNeighs call mpas_timer_stop("update_io_haloLPT",timerUpdateIOHalo) #endif - deallocate(ioProcSendList, ioProcRecvList) + deallocate(compProcSendList, compProcRecvList, ioProcSendList, ioProcRecvList) ! do IO communications if this is an output time step if (mpas_stream_mgr_ringing_alarms(domain % streamManager, streamID='lagrPartTrackOutput', direction=MPAS_STREAM_OUTPUT, ierr=err)) then @@ -942,7 +1023,7 @@ subroutine write_lagrangian_particle_tracking(domain, err)!{{{ #endif ! depreciated (can just use update_halo_io to keep g_ioProcNeighs up to date) !! get "MPI halos" for IO communication during write and restart steps (currentBlock to ioBlock) - !call mpas_particle_list_build_io_halos(domain, err, 'ioBlock', g_ioProcNeighs) + !call mpas_particle_list_build_halos(domain, err, 'ioBlock', g_ioProcNeighs) ! transfer the data call mpas_particle_list_transfer_particles_from_block_to_named_block(domain, err, .False., .True., 'ioBlock', & g_ioProcNeighs) @@ -1030,7 +1111,7 @@ subroutine ocn_finalize_lagrangian_particle_tracking(domain, err)!{{{ block => block % next end do - deallocate(g_ProcNeighs, g_ioProcNeighs) + deallocate(g_compProcNeighsNearby, g_compProcNeighs, g_ioProcNeighs) ! these following ones should be deallocated once rest of the code is sketched in !deallocate(g_nPartSend, g_nPartRecv, g_ionSend, g_ionRecv) diff --git a/src/core_ocean/analysis_members/mpas_ocn_particle_list.F b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F index 53a4646baa..baa91b654a 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_particle_list.F +++ b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F @@ -33,7 +33,7 @@ module ocn_particle_list ! blanket statments to restrict implicit module's scope implicit none private - + ! mpi defines #ifdef _MPI integer, parameter :: MPI_INTEGERKIND = MPI_INTEGER @@ -105,11 +105,13 @@ module ocn_particle_list ! define publically accessible subroutines, functions, interfaces public :: mpas_particle_list_build_and_assign_particle_list public :: mpas_particle_list_destroy_particle_list, mpas_particle_list_remove_particles_not_on_current_block - public :: mpas_particle_list_build_computation_halos, mpas_particle_list_build_io_halos - public :: mpas_particle_list_update_computational_halos, mpas_particle_list_update_io_halos + public :: mpas_particle_list_build_computation_halos, mpas_particle_list_build_halos + public :: mpas_particle_list_update_particle_block + public :: mpas_particle_list_update_halos_start, mpas_particle_list_update_halos_end public :: mpas_particle_list_transfer_particles_from_block_to_named_block public :: mpas_particle_list_write_halo_data, mpas_particle_list_write_nonhalo_data public :: mpas_particle_list_test_neighscalc, mpas_particle_list_test_numparticles_to_neighprocs, mpas_particle_list_test_num_current_particlelist + public :: mpas_particle_list_self_union_halo_lists ! subroutine / function definition contains @@ -337,10 +339,10 @@ end subroutine mpas_particle_list_remove_particles_not_on_current_block !}}} !> \author Phillip Wolfram !> \date 07/02/2014 !> \details -!> This routine builds g_ProcNeighs which is the neighboring processor +!> This routine builds g_compProcNeighs which is the neighboring processor !> list needed to process MPI communication, assuming a list of !> particlelists is built up corresponding to the processors in this -!> array. The end result is that g_ProcNeighs is populated. +!> array. The end result is that g_compProcNeighs is populated. ! !----------------------------------------------------------------------- subroutine mpas_particle_list_build_computation_halos(domain, err, procNeighs) !{{{ @@ -397,7 +399,7 @@ end subroutine mpas_particle_list_build_computation_halos !}}} !*********************************************************************** ! -! routine mpas_particle_list_build_io_halos +! routine mpas_particle_list_build_halos ! !> \brief Build the IO halo information to transmit particles from their !> initial host IO processor to the appropriate currentBlock @@ -410,7 +412,7 @@ end subroutine mpas_particle_list_build_computation_halos !}}} !> processor. The end result is that g_ioProcNeighs is populated. ! !----------------------------------------------------------------------- - subroutine mpas_particle_list_build_io_halos(domain, err, namedBlock, ioProcNeighs) !{{{ + subroutine mpas_particle_list_build_halos(domain, err, namedBlock, ioProcNeighs) !{{{ !{{{ initialization implicit none @@ -531,24 +533,24 @@ subroutine mpas_particle_list_build_io_halos(domain, err, namedBlock, ioProcNeig #endif deallocate(tempInt) - end subroutine mpas_particle_list_build_io_halos !}}} + end subroutine mpas_particle_list_build_halos !}}} !*********************************************************************** ! -! routine mpas_particle_list_update_io_halos +! routine mpas_particle_list_update_halos_end ! -!> \brief Updates halo processor for io communication, noting that +!> \brief Updates halo processors for communication, noting that !> the receiving processors must be informed of changes !> \author Phillip Wolfram !> \date 07/08/2014 !> \details !> This routine transmits a logical list of processors that will -!> transmit data for each ioProc. On the ioProcs, these lists must -!> be aggregated to build out the full list of processors from -!> which data will be received. +!> transmit data for each compProc or ioProc. On the compProcs or +!> ioProcs, these lists must be aggregated to build out the full list +!> of processors from which data will be received. ! !----------------------------------------------------------------------- - subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcSendList, ioProcRecvList) !{{{ + subroutine mpas_particle_list_update_halos_end(domain, err, destinationName, sendProcNeighs, sendProcSendList, sendProcRecvList) !{{{ implicit none !----------------------------------------------------------------- ! @@ -556,8 +558,10 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS ! !----------------------------------------------------------------- - logical, dimension(:,:), intent(in) :: ioProcRecvList !< x: ioProcNeighs for send. y: each receiving processors on x denoted by true - logical, dimension(:), pointer, intent(inout) :: ioProcSendList !< location of true indicates processors to send data to + logical, dimension(:,:), intent(in) :: sendProcRecvList !< x: sendProcNeighs for send. y: each receiving processors on x denoted by true + ! 'ioBlock' and 'currentBlock' are options for destinationName + character(len=*), intent(in) :: destinationName + logical, dimension(:), pointer, intent(inout) :: sendProcSendList !< location of true indicates processors to send data to type (domain_type), intent(in) :: domain !----------------------------------------------------------------- @@ -566,7 +570,7 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS ! !----------------------------------------------------------------- - integer, dimension(:), pointer, intent(inout) :: ioProcNeighs !< list of io halo processors + integer, dimension(:), pointer, intent(inout) :: sendProcNeighs !< list of io halo processors !----------------------------------------------------------------- ! @@ -582,7 +586,7 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS ! !----------------------------------------------------------------- - integer :: i, nioProcNeighs, nProcs + integer :: i, nsendProcNeighs, nProcs logical, dimension(:), pointer :: completeList, recvList integer, dimension(:), pointer :: intArray integer, dimension(:), pointer :: sendRequestID, recvRequestID @@ -594,43 +598,44 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS ! compute send list now that all particles reside on correct block (processor) 'currentBlock' ! didn't show up with serial IO because all computational processors sent data to proc 0 ! note that this could be missing communication where before transfer particle on proc A - ! has ioProc of A and is sent to B (must have previously kept a record that B is in A's halo list - ! note, may be slightly redundant because we could update ioProcSendList once particles are transfered - call compute_additional_particle_send_list(domain, ioProcSendList) + ! has sendProc of A and is sent to B (must have previously kept a record that B is in A's halo list + ! note, may be slightly redundant because we could update sendProcSendList once particles are transfered + call compute_additional_particle_send_list(domain, destinationName, sendProcSendList) #ifdef MPAS_DEBUG ! need to update IO processors as to the change also so that they know where to get data from!!! - ! should uncomment for testing when multiple ioProcs are utilized (parallel IO) - write(stderrUnit,*) 'ioProcSendList before = ', ioProcSendList - write(stderrUnit,*) 'ioProcRecvList before = ', ioProcRecvList - write(stderrUnit,*) 'ioProcNeighs before = ', ioProcNeighs + ! should uncomment for testing when multiple sendProcs are utilized (parallel IO) + write(stderrUnit,*) 'destinationName= ', destinationName + write(stderrUnit,*) 'sendProcSendList before = ', sendProcSendList + write(stderrUnit,*) 'sendProcRecvList before = ', sendProcRecvList + write(stderrUnit,*) 'sendProcNeighs before = ', sendProcNeighs #endif ! proceed to update the halo nProcs = domain % dminfo % nprocs - nioProcNeighs = size(ioProcNeighs) + nsendProcNeighs = size(sendProcNeighs) allocate(completeList(nProcs), recvList(nProcs)) - allocate(sendRequestID(nioProcNeighs), recvRequestID(nioProcNeighs)) + allocate(sendRequestID(nsendProcNeighs), recvRequestID(nsendProcNeighs)) completeList = .False. recvList = .False. - ! for each ioProc, send logical array information - do i = 1, nioProcNeighs + ! for each sendProc, send logical array information + do i = 1, nsendProcNeighs #ifdef _MPI - call MPI_ISend(ioProcRecvList(:,i), nProcs, MPI_LOGICAL, ioProcNeighs(i), domain % dminfo % my_proc_id, & + call MPI_ISend(sendProcRecvList(:,i), nProcs, MPI_LOGICAL, sendProcNeighs(i), domain % dminfo % my_proc_id, & domain % dminfo % comm, sendRequestID(i), mpi_ierr) #endif #ifdef MPAS_DEBUG - write(stderrUnit,*) 'ioProcNeigh= ', ioProcNeighs(i) - write(stderrUnit,*) 'send data = ', ioProcRecvList(:,i) + write(stderrUnit,*) 'sendProcNeigh= ', sendProcNeighs(i) + write(stderrUnit,*) 'send data = ', sendProcRecvList(i,:) #endif end do - ! for each ioProc, listen for logical array - do i = 1, nioProcNeighs + ! for each sendProc, listen for logical array + do i = 1, nsendProcNeighs ! send the data #ifdef _MPI - call MPI_IRecv(recvList, nProcs, MPI_LOGICAL, ioProcNeighs(i), ioProcNeighs(i), & + call MPI_IRecv(recvList, nProcs, MPI_LOGICAL, sendProcNeighs(i), sendProcNeighs(i), & domain % dminfo % comm, recvRequestID(i), mpi_ierr) #endif @@ -640,9 +645,9 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS #endif ! aggregate results after wait, making sure that we have the most - ! comprehensive list of ioProcs for receiving + ! comprehensive list of sendProcs for receiving #ifdef MPAS_DEBUG - write(stderrUnit,*) 'ioProcNeigh= ', ioProcNeighs(i) + write(stderrUnit,*) 'sendProcNeigh= ', sendProcNeighs(i) write(stderrUnit,*) 'recvList before = ', recvList write(stderrUnit,*) 'completeList before = ', completeList #endif @@ -655,11 +660,11 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS ! wait to make sure (just in case) that all sends have completed #ifdef _MPI - call MPI_WaitAll(nioProcNeighs, sendRequestID, MPI_STATUSES_IGNORE, mpi_ierr) + call MPI_WaitAll(nsendProcNeighs, sendRequestID, MPI_STATUSES_IGNORE, mpi_ierr) #endif ! "add" receiving and sending lists into a complete list - completeList = completeList .or. ioProcSendList + completeList = completeList .or. sendProcSendList !write(stderrUnit,*) 'completeList = ', completeList ! convert complete list into a unique list of processor numbers @@ -677,20 +682,20 @@ subroutine mpas_particle_list_update_io_halos(domain, err, ioProcNeighs, ioProcS end do ! now get the desired integer halo list - deallocate(ioProcNeighs) - call uniqueIntegerList(intArray, ioProcNeighs) - call removeValueFromIntList(ioProcNeighs, domain % dminfo % my_proc_id) + deallocate(sendProcNeighs) + call uniqueIntegerList(intArray, sendProcNeighs) + call removeValueFromIntList(sendProcNeighs, domain % dminfo % my_proc_id) deallocate(intArray, completeList, sendRequestID, recvRequestID) #ifdef MPAS_DEBUG ! need to update IO processors as to the change also so that they know where to get data from!!! - ! should uncomment for testing when multiple ioProcs are utilized (parallel IO) - write(stderrUnit,*) 'ioProcSendList after = ', ioProcSendList - write(stderrUnit,*) 'ioProcRecvList after = ', ioProcRecvList - write(stderrUnit,*) 'ioProcNeighs after = ', ioProcNeighs + ! should uncomment for testing when multiple sendProcs are utilized (parallel IO) + write(stderrUnit,*) 'sendProcSendList after = ', sendProcSendList + write(stderrUnit,*) 'sendProcRecvList after = ', sendProcRecvList + write(stderrUnit,*) 'sendProcNeighs after = ', sendProcNeighs #endif - end subroutine mpas_particle_list_update_io_halos !}}} + end subroutine mpas_particle_list_update_halos_end !}}} !*********************************************************************** ! @@ -770,7 +775,7 @@ subroutine mpas_particle_list_transfer_particles_from_block_to_named_block(domai ! 1. Make temporary particle lists for transfers based on currentBock of cells in halo. ! These lists live on each block and correspond to other ! blocks that the list must be moved to. The particle must end up on its currentBlock specified. - ! convention on particles lists is that g_ProcNeighs specifies the processor neighbor numbers + ! convention on particles lists is that g_compProcNeighs specifies the processor neighbor numbers ! corresponding to each index in the particlelists pointer array. Should use linked-list ! because processor neighbors are typically going to be somewhere less than 10 ! (perfect partitioning of plane gives hexagons with 6 cell neighbors, for instance). @@ -2424,6 +2429,60 @@ subroutine removeValueFromIntList(list, removeval) !{{{ end subroutine removeValueFromIntList +!*********************************************************************** +! +! routine mpas_particle_list_self_union_halo_lists(self, list) +! +!> \brief Taken union of self and list and store in self +!> \author Phillip J. Wolfram +!> \date 10/29/2015 +!> \details +!> This routine computes the unique entries in an array using a +!> linked list for dynamic memory storage +! +!----------------------------------------------------------------------- + subroutine mpas_particle_list_self_union_halo_lists(self, list, nprocs, procid) !{{{ + implicit none + integer, dimension(:), pointer, intent(inout) :: self + integer, dimension(:), pointer, intent(in) :: list + integer, intent(in) :: nprocs + integer, intent(in) :: procid + + logical, dimension(:), pointer :: theunion + integer :: i, thesum + + allocate(theunion(nprocs)) + theunion = .False. + + ! use Fortran integer indexing + theunion(self+1) = .True. + theunion(list+1) = .True. + + ! compute number of processors in halo + thesum = 0 + do i=1,nprocs + if (theunion(i)) then + thesum = thesum + 1 + end if + end do + + ! rebuild up self + deallocate(self) + allocate(self(thesum)) + + ! store processor number in new list + thesum = 0 + do i=1,nprocs + if (theunion(i)) then + thesum = thesum + 1 + self(thesum) = i-1 + end if + end do + + deallocate(theunion) + call removeValueFromIntList(self, procid) + + end subroutine mpas_particle_list_self_union_halo_lists !}}} !*********************************************************************** ! @@ -2912,16 +2971,17 @@ end subroutine communicate_num_particles_send_recv !}}} !> \details !> Compute send list for all particles residing on correct block 'currentBlock' !----------------------------------------------------------------------- - subroutine compute_additional_particle_send_list(domain, ioProcSendList) !{{{ + subroutine compute_additional_particle_send_list(domain, destinationName, ioProcSendList) !{{{ implicit none type (domain_type), intent(in) :: domain + character(len=*), intent(in) :: destinationName logical, dimension(:), pointer, intent(inout) :: ioProcSendList ! local variables type (block_type), pointer :: block type (mpas_particle_list_type), pointer :: particlelist type (mpas_particle_type), pointer :: particle - integer, pointer :: ioBlock + integer, pointer :: sendBlock integer :: ioProc block => domain % blocklist @@ -2929,8 +2989,8 @@ subroutine compute_additional_particle_send_list(domain, ioProcSendList) !{{{ particlelist => block % particlelist do while(associated(particlelist)) !{{{ particle => particlelist % particle - call mpas_pool_get_array(particle % haloDataPool, 'ioBlock', ioBlock) - call mpas_get_owning_proc(domain % dminfo, ioBlock, ioProc) + call mpas_pool_get_array(particle % haloDataPool, destinationName, sendBlock) + call mpas_get_owning_proc(domain % dminfo, sendBlock, ioProc) ioProcSendList(ioProc+1) = .True. ! get next particle to process on the list particlelist => particlelist % next @@ -3785,6 +3845,10 @@ subroutine read_haloData(domain, err)!{{{ #endif field1DIntPointer % array = domain % dminfo % my_proc_id end if +#ifdef MPAS_DEBUG + write(stderrunit,*) dimItr % memberName, ' = ' + write(stderrunit,*) field1DIntPointer % array +#endif call add_halo_data_to_particle_list(particlelist, dimItr % memberName, field1DIntPointer) else #ifdef MPAS_DEBUG @@ -3796,7 +3860,7 @@ subroutine read_haloData(domain, err)!{{{ else #ifdef MPAS_DEBUG write(stderrunit,*) "Different type expected in registry for key ", trim(dimItr % memberName), " in halo data for read, don't know what to do!" - ! false warning for + ! false warning for !Different type expected in registry for key on_a_sphere in nonHalo data for read, don't know what to do! !Different type expected in registry for key sphere_radius in nonHalo data for read, don't know what to do! !Different type expected in registry for key is_periodic in nonHalo data for read, don't know what to do! @@ -3894,44 +3958,32 @@ end subroutine read_nonhaloData!}}} !*********************************************************************** ! -! routine mpas_particle_list_update_computational_halos +! routine mpas_particle_list_update_particle_block ! -!> \brief Update halo +!> \brief Update particle block !> \author Phillip Wolfram -!> \date 06/24/2015 +!> \date 10/28/2015 !> \details -!> This routine updates the halos for particles within the particlelist loop. -!> This constitutes a computational transfer of a particle from one domain -!> to another. Its main goals are to -!> 1. determine if iCell is on halo (just set each particle's -!> currentBlock to the correct currentBlock -!> 2. determine owning block in halo, update particle's currentBlock -!> 3. determine currentBlock ownership of iCell and set cellOwnerBlock -!> to be current block +!> This routine updates the currentBlock for particles within the +!> particlelist loop. ! !----------------------------------------------------------------------- - subroutine mpas_particle_list_update_computational_halos(domain, block, particle, poolname, iCell, & - arrayIndex, ioProcRecvList, ioProcSendList, gioProcNeighs ) !{{{ + subroutine mpas_particle_list_update_particle_block(domain, block, particle, poolname, iCell) !{{{ implicit none type (domain_type), intent(inout) :: domain type (block_type), intent(inout), pointer :: block type (mpas_particle_type), intent(inout), pointer :: particle character(len=*), intent(in) :: poolname - integer, intent(inout) :: iCell, arrayIndex - integer, dimension(:), pointer, intent(inout) :: gioProcNeighs - logical, dimension(:,:), pointer, intent(inout) :: ioProcRecvList - logical, dimension(:), pointer, intent(inout) :: ioProcSendList + integer, intent(inout) :: iCell ! local variables - integer :: currentProc, ioProc type (mpas_pool_type), pointer :: lagrPartTrackCellsPool - integer, pointer :: currentBlock, ioBlock, transfered integer, dimension(:), pointer :: cellOwnerBlock + integer, pointer :: currentBlock, transfered call mpas_pool_get_subpool(block % structs, trim(poolname), lagrPartTrackCellsPool) call mpas_pool_get_array(lagrPartTrackCellsPool, 'cellOwnerBlock', cellOwnerBlock) call mpas_pool_get_array(particle % haloDataPool, 'currentBlock', currentBlock) - call mpas_pool_get_array(particle % haloDataPool, 'ioBlock', ioBlock) if(cellOwnerBlock(iCell) /= currentBlock) then ! increment transfer counter call mpas_pool_get_array(particle % haloDataPool, 'transfered', transfered) @@ -3941,25 +3993,64 @@ subroutine mpas_particle_list_update_computational_halos(domain, block, particle ! reset cell_id to be brute force computed on new block after trasnfer iCell = -1 end if + + end subroutine mpas_particle_list_update_particle_block !}}} + +!*********************************************************************** +! +! routine mpas_particle_list_update_halos_start +! +!> \brief Update halo +!> \author Phillip Wolfram +!> \date 10/28/2015 +!> \details +!> This routine updates the halos for particles within the particlelist loop. +!> This facilitates a computational transfer of a particle from one domain +!> to another. +! +!----------------------------------------------------------------------- + subroutine mpas_particle_list_update_halos_start(domain, block, particle, poolname, iCell, & + arrayIndex, destinationName, sendProcRecvList, sendProcSendList, gsendProcNeighs ) !{{{ + implicit none + type (domain_type), intent(inout) :: domain + type (block_type), intent(inout), pointer :: block + type (mpas_particle_type), intent(inout), pointer :: particle + character(len=*), intent(in) :: poolname + ! 'ioBlock' and 'currentBlock' are options for destinationName + character(len=*), intent(in) :: destinationName + integer, intent(inout) :: iCell, arrayIndex + integer, dimension(:), pointer, intent(inout) :: gsendProcNeighs + logical, dimension(:,:), pointer, intent(inout) :: sendProcRecvList + logical, dimension(:), pointer, intent(inout) :: sendProcSendList + + ! local variables + integer :: currentProc, sendProc + type (mpas_pool_type), pointer :: lagrPartTrackCellsPool + integer, pointer :: currentBlock, sendBlock + + call mpas_pool_get_subpool(block % structs, trim(poolname), lagrPartTrackCellsPool) + call mpas_pool_get_array(particle % haloDataPool, 'currentBlock', currentBlock) + call mpas_pool_get_array(particle % haloDataPool, destinationName, sendBlock) call mpas_get_owning_proc(domain % dminfo, currentBlock, currentProc) - call mpas_get_owning_proc(domain % dminfo, ioBlock, ioProc) + call mpas_get_owning_proc(domain % dminfo, sendBlock, sendProc) ! increment data for receiving processors (sum should be total number of particles on processor) #ifdef MPAS_DEBUG - write(stderrUnit,*) 'g_ioProcNeighs=',gioProcNeighs - write(stderrUnit,*) 'ioProc=',ioProc + write(stderrUnit,*) 'destinationName=',destinationName + write(stderrUnit,*) 'gsendProcNeighs=',gsendProcNeighs + write(stderrUnit,*) 'sendProc=',sendProc #endif ! do not need to transfer information for particles on-processor, this is computed from the send list ! which is dependent upon current, on-processor particles - if (ioProc /= domain % dminfo % my_proc_id) then - arrayIndex = find_index(gioProcNeighs, ioProc) - ioProcRecvList(currentProc+1, arrayIndex) = .True. + if (sendProc /= domain % dminfo % my_proc_id) then + arrayIndex = find_index(gsendProcNeighs, sendProc) + sendProcRecvList(currentProc+1, arrayIndex) = .True. else - ! consider the case where a particle on A has an ioProc of A and is sent to B (need to have B in A's halo). - ioProcSendList(currentProc+1) = .True. + ! consider the case where a particle on A has an sendProc of A and is sent to B (need to have B in A's halo). + sendProcSendList(currentProc+1) = .True. end if ! must be computed after computational particles are transferred (this was a bug left-over from serial IO) - end subroutine mpas_particle_list_update_computational_halos !}}} + end subroutine mpas_particle_list_update_halos_start!}}} !}}} From e7e7859fa7736274879af32b34c2aa82a81205b0 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Wed, 28 Oct 2015 08:22:06 -0600 Subject: [PATCH 0416/1724] working time-based particle resets Tested in config_AM_lagrPartTrack_reset_criteria = 'particle' and 'global_value' modes with scripts at https://gist.github.com/84d008a138bc427d6ece Tested with planar periodic grid to make sure particles are reset at the right frequencies. A potential optimization would be to specify, based on a decomposition, the currentCellReset instead of currently hardcoding it to be -1 in src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_reset.F:270. This, however, requires more inteligent ways of initializing particles depending upon runtime condition. This is essentially an optimization for performance so the current naive approach is used. Note that spatial reset information is time invarient. It would be possible to allow time-based resets in the future by making the dimensions to be of size (nParticles, Time), for xParticleReset, etc. However, this would require an all-to-all communication to process the halos and this would be quite expensive and break scalability. Note, there was a need to have a distinction between Eulerian halos for particle computation and the full Lagrangian computational halo (the result of the prior refractoring commit). --- src/core_ocean/analysis_members/Makefile | 11 +- .../Registry_lagrangian_particle_tracking.xml | 96 ++++- .../mpas_ocn_lagrangian_particle_tracking.F | 55 ++- ...s_ocn_lagrangian_particle_tracking_reset.F | 340 ++++++++++++++++++ 4 files changed, 478 insertions(+), 24 deletions(-) create mode 100644 src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_reset.F diff --git a/src/core_ocean/analysis_members/Makefile b/src/core_ocean/analysis_members/Makefile index 7f8d0bd1fa..575d2e14f2 100644 --- a/src/core_ocean/analysis_members/Makefile +++ b/src/core_ocean/analysis_members/Makefile @@ -13,11 +13,12 @@ MEMBERS = mpas_ocn_global_stats.o \ mpas_ocn_zonal_mean.o \ mpas_ocn_lagrangian_particle_tracking_interpolations.o \ mpas_ocn_particle_list.o \ + mpas_ocn_lagrangian_particle_tracking_reset.o \ mpas_ocn_lagrangian_particle_tracking.o \ mpas_ocn_eliassen_palm.o \ mpas_ocn_time_filters.o \ mpas_ocn_mixed_layer_depths.o \ - mpas_ocn_time_series_stats.o + mpas_ocn_time_series_stats.o all: $(OBJS) @@ -27,7 +28,9 @@ mpas_ocn_okubo_weiss.o: mpas_ocn_okubo_weiss_eigenvalues.o mpas_ocn_particle_list.o: -mpas_ocn_lagrangian_particle_tracking.o: mpas_ocn_particle_list.o mpas_ocn_lagrangian_particle_tracking_interpolations.o +mpas_ocn_lagrangian_particle_tracking_reset.o: + +mpas_ocn_lagrangian_particle_tracking.o: mpas_ocn_particle_list.o mpas_ocn_lagrangian_particle_tracking_interpolations.o mpas_ocn_lagrangian_particle_tracking_reset.o clean: $(RM) *.o *.i *.mod *.f90 @@ -36,9 +39,9 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) endif .c.o: diff --git a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml index 982d107d5d..af5eb54ada 100644 --- a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml +++ b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml @@ -7,7 +7,7 @@ description="Timestamp determining how often analysis member computation should be performed." possible_values="'DDDD_HH:MM:SS', 'output', 'dt'" /> - @@ -31,6 +31,26 @@ description="Number of times to apply filtering operation." possible_values="0, 1, 2, ..." /> + + + + + @@ -64,6 +84,13 @@ + + + + + + + @@ -111,6 +138,15 @@ + + + + + + + + + @@ -141,6 +177,13 @@ + + + + + + + @@ -151,8 +194,32 @@ + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F index f40c676138..80adc4e2c2 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -29,7 +29,7 @@ module ocn_lagrangian_particle_tracking use ocn_particle_list use ocn_lagrangian_particle_tracking_interpolations - !use ocn_lagrangian_particle_tracking_reset + use ocn_lagrangian_particle_tracking_reset implicit none private @@ -118,7 +118,8 @@ subroutine ocn_init_lagrangian_particle_tracking(domain, err)!{{{ ! local variables ! !----------------------------------------------------------------- - logical, pointer :: config_do_restart + logical :: config_AM_lagrPartTrack_reset_particles + character (len=StrKIND), pointer :: config_AM_lagrPartTrack_reset_criteria err = 0 @@ -178,8 +179,13 @@ subroutine ocn_init_lagrangian_particle_tracking(domain, err)!{{{ ! at initialization time we need to build the initial halo for the reset ! (could be anywhere so we'll need to make a connection between the ! 'currentBlock' and 'currentBlockReset' - ! if reset () then - ! + call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_reset_criteria', config_AM_lagrPartTrack_reset_criteria) + if (trim(config_AM_lagrPartTrack_reset_criteria) == 'none') then + config_AM_lagrPartTrack_reset_particles = .False. + else + config_AM_lagrPartTrack_reset_particles = .True. + end if + if (config_AM_lagrPartTrack_reset_particles) then ! build halos to reset blocks ! AllToAll Computation! call mpas_particle_list_build_halos(domain, err, 'currentBlockReset', g_compProcNeighs) @@ -192,7 +198,7 @@ subroutine ocn_init_lagrangian_particle_tracking(domain, err)!{{{ #if MPAS_DEBUG write(stderrUnit,*) 'Neighs: self end = ', g_compProcNeighs #endif - ! end if + end if ! tests to make sure all the values are ok !{{{ #ifdef MPAS_DEBUG @@ -214,8 +220,8 @@ subroutine ocn_init_lagrangian_particle_tracking(domain, err)!{{{ call initialize_particle_properties(domain,2,err) call write_lagrangian_particle_tracking(domain, err) - !! set up particle reset condition - !call ocn_setup_particle_reset_condition(domain, err) + ! set up particle reset condition + call ocn_setup_particle_reset_condition(domain, err) write(stderrunit,*) 'finished ocn_init_lagrangian_particle_tracking' call mpas_timer_stop("initLPT", timerInit) @@ -308,6 +314,8 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ logical, dimension(:,:), pointer :: compProcRecvList logical, dimension(:), pointer :: compProcSendList logical, pointer :: onSphere + logical :: config_AM_lagrPartTrack_reset_particles + character (len=StrKIND), pointer :: config_AM_lagrPartTrack_reset_criteria real (kind=RKIND), dimension(4) :: kWeightK, kWeightKVert real (kind=RKIND), dimension(3,4) :: kWeightX @@ -325,6 +333,7 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ integer, pointer :: verticalTreatment, vertexReconstMethod, timeIntegration, indexLevel, filterNum character(len=StrKIND), pointer :: config_dt type (MPAS_timeInterval_type) :: timeStepESMF + logical :: resetParticle integer :: err_tmp err = 0 @@ -340,6 +349,13 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ call mpas_timer_start("computeLPT", .false., timerCompute) call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_filter_number', filterNum) + call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_reset_criteria', config_AM_lagrPartTrack_reset_criteria) + + if (trim(config_AM_lagrPartTrack_reset_criteria) == 'none') then + config_AM_lagrPartTrack_reset_particles = .False. + else + config_AM_lagrPartTrack_reset_particles = .True. + end if allocate(ioProcRecvList(domain % dminfo % nprocs, size(g_ioProcNeighs))) allocate(ioProcSendList(domain % dminfo % nprocs)) @@ -797,23 +813,24 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ call mpas_timer_start("particleAssignments", .false., timerParticleAssignment) #endif - ! if (reset criteria is met) then - ! update currentBlock to be reset value, setting iCell = -1 - ! - ! else - ! update halo fields for particles moving from adjacent computational halos - call mpas_particle_list_update_particle_block(domain, block, particle, 'lagrPartTrackCells', iCell) - ! end if + resetParticle = .False. + if (config_AM_lagrPartTrack_reset_particles) then ! need to link to currentBlockReset for communication + ! determine if particles should be reset based on different criteria. If so, reset them. + call ocn_evaluate_particle_reset_condition(domain, block, particle, dtSim, iCell, err) + else + ! update halo fields for particles moving from adjacent computational halos + call mpas_particle_list_update_particle_block(domain, block, particle, 'lagrPartTrackCells', iCell) + end if !! update IO halos based on particle movement call mpas_particle_list_update_halos_start(domain, block, particle, 'lagrPartTrackCells', iCell, & arrayIndex, 'ioBlock', ioProcRecvList, ioProcSendList, g_ioProcNeighs) - ! if (particle reset) then ! need to link to currentBlockReset for communication - ! update computational halos (to account for non block halo communication caused by resets, etc) + if (config_AM_lagrPartTrack_reset_particles) then ! need to link to currentBlockReset for communication + ! update computational halos (to account for non block halo communication caused by resets, etc) call mpas_particle_list_update_halos_start(domain, block, particle, 'lagrPartTrackCells', iCell, & arrayIndex, 'currentBlockReset', compProcRecvList, compProcSendList, g_compProcNeighs) - ! end if + end if #ifdef MPAS_DEBUG call mpas_timer_stop("particleAssignments", timerParticleAssignment) #endif @@ -859,10 +876,10 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ #endif ! update io halo call mpas_particle_list_update_halos_end(domain, err, 'ioBlock', g_ioProcNeighs, ioProcSendList, ioProcRecvList) - ! if (doing a particle reset) then + if (config_AM_lagrPartTrack_reset_particles) then ! need to link to currentBlockReset for communication ! update computational halo call mpas_particle_list_update_halos_end(domain, err, 'currentBlockReset', g_compProcNeighs, compProcSendList, compProcRecvList) - ! end if + end if #ifdef MPAS_DEBUG write(stderrUnit,*) 'g_compProcNeighs after halo updates = ', g_compProcNeighs write(stderrUnit,*) 'compProcSendList after last halo updates = ', compProcSendList diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_reset.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_reset.F new file mode 100644 index 0000000000..eba6c2b276 --- /dev/null +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_reset.F @@ -0,0 +1,340 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!*********************************************************************** +! +! ocn_lagrangian_particle_tracking_reset +! +!> \brief LIGHT reset functionality +!> \author Phillip J. Wolfram +!> \date 10/28/2015 +!> \details +!> This module provides routines for performing particle resets in LIGHT. +! +!----------------------------------------------------------------------- +module ocn_lagrangian_particle_tracking_reset + + use mpas_derived_types + use mpas_constants + use mpas_timekeeping + use mpas_stream_manager + use mpas_pool_routines + + use ocn_constants + + implicit none + private + + !----------------------------------------------------------------- + ! public routines and interfaces + !----------------------------------------------------------------- + ! define publically accessible subroutines, functions, interfaces + public :: ocn_setup_particle_reset_condition + public :: ocn_evaluate_particle_reset_condition + public :: ocn_finalize_particle_reset_condition + + contains + +!*********************************************************************** +! +! routine ocn_setup_particle_reset_condition +! +!> \brief Set up needed information for particle resets +!> \author Phillip Wolfram +!> \date 10/28/2015 +!> \details +!> Purpose: Perform set up for particle resets. +!> Input: domain +!----------------------------------------------------------------------- + subroutine ocn_setup_particle_reset_condition(domain, err) !{{{ + + implicit none + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: lagrPartTrackScalarPool + real (kind=RKIND), pointer :: globalResetTimeValue + type (mpas_timeInterval_type) :: timeInterval + character (len=StrKIND), pointer :: config_AM_lagrPartTrack_reset_global_timestamp + + err = 0 + + ! get the configuration options + call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_reset_global_timestamp', config_AM_lagrPartTrack_reset_global_timestamp) + + ! load in region masks and store in pool + + + ! convert input config_AM_lagrPartTrack_reset_global_timestamp into S for calculations + block => domain % blocklist + do while (associated(block)) + ! setup pointers / get block + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackScalars', lagrPartTrackScalarPool) + call mpas_pool_get_array(lagrPartTrackScalarPool, 'globalResetTimeValue', globalResetTimeValue) + + ! convert config_AM_lagrPartTrack_reset_global_timestamp into seconds and store in globalResetTimeValue + call mpas_set_timeInterval(timeInterval, timeString=trim(config_AM_lagrPartTrack_reset_global_timestamp)) + call mpas_get_timeInterval(timeInterval, dt=globalResetTimeValue) + + !write(stderrUnit,*) 'resetTimeValue = ', globalResetTimeValue + + block => block % next + end do + + end subroutine ocn_setup_particle_reset_condition!}}} + +!*********************************************************************** +! +! routine ocn_evaluate_particle_reset_condition +! +!> \brief Evaluate needed information for particle resets +!> \author Phillip Wolfram +!> \date 10/30/2015 +!> \details +!> Purpose: Evaluate if particle resets should occur for a particle +!> Input: domain, particle +!> Output: boolean specifying whether the particles should be reset. +!----------------------------------------------------------------------- + subroutine ocn_evaluate_particle_reset_condition(domain, block, particle, dt, iCell, err) !{{{ + + implicit none + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + real (kind=RKIND), intent(in) :: dt + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + type (block_type), intent(inout), pointer :: block + type (mpas_particle_type), pointer, intent(inout) :: particle + integer, intent(inout) :: iCell + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + type (mpas_pool_type), pointer :: lagrPartTrackScalarPool + integer, pointer :: transfered, numTimesReset + integer, pointer :: currentBlock, currentBlockReset, currentCell, currentCellReset + real (kind=RKIND), pointer :: xParticleReset, yParticleReset, zParticleReset, zLevelParticleReset + real (kind=RKIND), pointer :: xParticle, yParticle, zParticle, zLevelParticle + real (kind=RKIND), pointer :: timeSinceReset + real (kind=RKIND), pointer :: sumU, sumV, sumUU, sumUV, sumVV + integer, pointer :: resetTime + real (kind=RKIND), pointer :: globalResetTimeValue + + character (len=StrKIND), pointer :: config_AM_lagrPartTrack_reset_criteria + logical, pointer :: config_AM_lagrPartTrack_reset_if_outside_region + logical, pointer :: config_AM_lagrPartTrack_reset_if_inside_region + logical :: resetParticle + + ! initialize outputs + err = 0 + resetParticle = .False. + + ! get config options + call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_reset_criteria', config_AM_lagrPartTrack_reset_criteria) + + ! get variables + call mpas_pool_get_array(particle % haloDataPool, 'timeSinceReset', timeSinceReset) + call mpas_pool_get_array(particle % haloDataPool, 'resetTime', resetTime) + + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackScalars', lagrPartTrackScalarPool) + call mpas_pool_get_array(lagrPartTrackScalarPool, 'globalResetTimeValue', globalResetTimeValue) + + ! advance particle time + timeSinceReset = timeSinceReset + dt + + ! determine whether reset should occur depending upon type of reset condition + select case (trim(config_AM_lagrPartTrack_reset_criteria)) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! time based + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !{{{ + + case ('particle_time') + ! use particle's value for resetTime and timeSinceReset + if (timeSinceReset > resetTime) then + resetParticle = .True. + end if + + case ('global_time') + if (timeSinceReset > globalResetTimeValue) then + resetParticle = .True. + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !}}} + ! region based + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !{{{ + + case ('outside_region') + + case ('inside_region') + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !}}} + ! default + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + case default + write(stderrUnit,*) 'WARNING: reset criteria in config_AM_lagrPartTrack_reset_criteria=', & + trim(config_AM_lagrPartTrack_reset_criteria),' unknown! Cannot restart.' + + end select + + ! reset particle block, cell, and position to reset values + if (resetParticle) then + + !write(stderrUnit,*) 'reseting particle' + + ! get data + call mpas_pool_get_array(particle % haloDataPool, 'currentBlock', currentBlock) + call mpas_pool_get_array(particle % haloDataPool, 'currentBlockReset', currentBlockReset) + call mpas_pool_get_array(particle % haloDataPool, 'currentCellReset', currentCellReset) + call mpas_pool_get_array(particle % haloDataPool, 'xParticleReset', xParticleReset) + call mpas_pool_get_array(particle % haloDataPool, 'yParticleReset', yParticleReset) + call mpas_pool_get_array(particle % haloDataPool, 'zParticleReset', zParticleReset) + call mpas_pool_get_array(particle % haloDataPool, 'zLevelParticleReset', zLevelParticleReset) + call mpas_pool_get_array(particle % haloDataPool, 'xParticle', xParticle) + call mpas_pool_get_array(particle % haloDataPool, 'yParticle', yParticle) + call mpas_pool_get_array(particle % haloDataPool, 'zParticle', zParticle) + call mpas_pool_get_array(particle % haloDataPool, 'zLevelParticle', zLevelParticle) + call mpas_pool_get_array(particle % haloDataPool, 'numTimesReset', numTimesReset) + call mpas_pool_get_array(particle % haloDataPool, 'transfered', transfered) + call mpas_pool_get_array(particle % haloDataPool, 'sumU', sumU) + call mpas_pool_get_array(particle % haloDataPool, 'sumV', sumV) + call mpas_pool_get_array(particle % haloDataPool, 'sumUU', sumUU) + call mpas_pool_get_array(particle % haloDataPool, 'sumUV', sumUV) + call mpas_pool_get_array(particle % haloDataPool, 'sumVV', sumVV) + + ! reset the time + timeSinceReset = 0.0_RKIND + + ! increment counters + if (currentBlock /= currentBlockReset) then + transfered = transfered + 1 + end if + numTimesReset = numTimesReset + 1 + + ! reset the block and the current cell + currentBlock = currentBlockReset + ! this should be a -1 in general but could precache based on an initial decomposition for performance + iCell = -1 + !iCell = currentCellReset + + ! reset positions + xParticle = xParticleReset + yParticle = yParticleReset + zParticle = zParticleReset + zLevelParticle = zLevelParticleReset + + ! reset velocity sums + sumU = 0.0_RKIND + sumV = 0.0_RKIND + sumUU = 0.0_RKIND + sumUV = 0.0_RKIND + sumVV = 0.0_RKIND + + ! more variables may need to be reset in the future + + end if + + end subroutine ocn_evaluate_particle_reset_condition!}}} + +!*********************************************************************** +! +! routine ocn_finalize_particle_reset_condition +! +!> \brief Finalize information for particle resets +!> \author Phillip Wolfram +!> \date 10/30/2015 +!> \details +!> Purpose: Finalize setup of particle resets +!> Input: domain +!----------------------------------------------------------------------- + subroutine ocn_finalize_particle_reset_condition(domain, err) !{{{ + + implicit none + !----------------------------------------------------------------- + ! + ! input variables + ! + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! + ! input/output variables + ! + !----------------------------------------------------------------- + + type (domain_type), intent(inout) :: domain + + !----------------------------------------------------------------- + ! + ! output variables + ! + !----------------------------------------------------------------- + + integer, intent(out) :: err !< Output: error flag + + !----------------------------------------------------------------- + ! + ! local variables + ! + !----------------------------------------------------------------- + + err = 0 + + ! particle reset cleanup + + end subroutine ocn_finalize_particle_reset_condition!}}} + +end module ocn_lagrangian_particle_tracking_reset + From 73e1cbbdc4d9d2c5cb7642eaa902be4294016858 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 13 Nov 2015 11:16:40 -0700 Subject: [PATCH 0417/1724] working region-based particle resets Tested with planar periodic grid to make sure particles are reset at the right frequencies. Tested for config_AM_lagrPartTrack_reset_criteria ='region' with config_AM_lagrPartTrack_reset_if_inside_region = .true. and config_AM_lagrPartTrack_reset_if_outside_region = .true. modes with particle and region files generated via the scripts at https://gist.github.com/aaa546352ec6ee49d686 --- .../Registry_lagrangian_particle_tracking.xml | 8 +- .../mpas_ocn_lagrangian_particle_tracking.F | 8 +- ...s_ocn_lagrangian_particle_tracking_reset.F | 75 ++++++++++++++++--- 3 files changed, 73 insertions(+), 18 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml index af5eb54ada..2c0c0a76f1 100644 --- a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml +++ b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml @@ -208,11 +208,11 @@ - - diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F index 80adc4e2c2..cb4b9966e6 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -816,13 +816,15 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ resetParticle = .False. if (config_AM_lagrPartTrack_reset_particles) then ! need to link to currentBlockReset for communication ! determine if particles should be reset based on different criteria. If so, reset them. - call ocn_evaluate_particle_reset_condition(domain, block, particle, dtSim, iCell, err) - else + call ocn_evaluate_particle_reset_condition(domain, block, particle, dtSim, iCell, resetParticle, err) + end if + + if (.not. resetParticle) then ! update halo fields for particles moving from adjacent computational halos call mpas_particle_list_update_particle_block(domain, block, particle, 'lagrPartTrackCells', iCell) end if - !! update IO halos based on particle movement + !! update IO halos based on particle movement (if particle isn't reset) call mpas_particle_list_update_halos_start(domain, block, particle, 'lagrPartTrackCells', iCell, & arrayIndex, 'ioBlock', ioProcRecvList, ioProcSendList, g_ioProcNeighs) diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_reset.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_reset.F index eba6c2b276..3796536973 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_reset.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_reset.F @@ -82,18 +82,31 @@ subroutine ocn_setup_particle_reset_condition(domain, err) !{{{ !----------------------------------------------------------------- type (block_type), pointer :: block - type (mpas_pool_type), pointer :: lagrPartTrackScalarPool + type (mpas_pool_type), pointer :: lagrPartTrackScalarPool, lagrPartTrackRegionsPool real (kind=RKIND), pointer :: globalResetTimeValue type (mpas_timeInterval_type) :: timeInterval character (len=StrKIND), pointer :: config_AM_lagrPartTrack_reset_global_timestamp + character (len=StrKIND), pointer :: config_AM_lagrPartTrack_region_stream + character (len=StrKIND), pointer :: config_AM_lagrPartTrack_reset_criteria + type (field1DInteger), pointer :: resetInsideRegionMaskValue1Field, resetOutsideRegionMaskValue1Field + integer, dimension(:), pointer :: resetInsideRegionMaskValue1, resetOutsideRegionMaskValue1 err = 0 ! get the configuration options - call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_reset_global_timestamp', config_AM_lagrPartTrack_reset_global_timestamp) - - ! load in region masks and store in pool - + call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_reset_global_timestamp', & + config_AM_lagrPartTrack_reset_global_timestamp) + call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_region_stream', & + config_AM_lagrPartTrack_region_stream) + call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_reset_criteria', & + config_AM_lagrPartTrack_reset_criteria) + + ! load in region masks streams (masks stored in pool) + if (trim(config_AM_lagrPartTrack_reset_criteria) == 'region' .or. & + trim(config_AM_lagrPartTrack_reset_criteria) == 'all' & + ) then + call MPAS_stream_mgr_read(domain % streamManager, streamID=trim(config_AM_lagrPartTrack_region_stream), ierr=err) + end if ! convert input config_AM_lagrPartTrack_reset_global_timestamp into S for calculations block => domain % blocklist @@ -125,7 +138,7 @@ end subroutine ocn_setup_particle_reset_condition!}}} !> Input: domain, particle !> Output: boolean specifying whether the particles should be reset. !----------------------------------------------------------------------- - subroutine ocn_evaluate_particle_reset_condition(domain, block, particle, dt, iCell, err) !{{{ + subroutine ocn_evaluate_particle_reset_condition(domain, block, particle, dt, iCell, resetParticle, err) !{{{ implicit none !----------------------------------------------------------------- @@ -153,6 +166,7 @@ subroutine ocn_evaluate_particle_reset_condition(domain, block, particle, dt, iC ! !----------------------------------------------------------------- + logical, intent(out) :: resetParticle integer, intent(out) :: err !< Output: error flag !----------------------------------------------------------------- @@ -161,7 +175,7 @@ subroutine ocn_evaluate_particle_reset_condition(domain, block, particle, dt, iC ! !----------------------------------------------------------------- - type (mpas_pool_type), pointer :: lagrPartTrackScalarPool + type (mpas_pool_type), pointer :: lagrPartTrackScalarPool, lagrPartTrackRegionsPool integer, pointer :: transfered, numTimesReset integer, pointer :: currentBlock, currentBlockReset, currentCell, currentCellReset real (kind=RKIND), pointer :: xParticleReset, yParticleReset, zParticleReset, zLevelParticleReset @@ -174,14 +188,19 @@ subroutine ocn_evaluate_particle_reset_condition(domain, block, particle, dt, iC character (len=StrKIND), pointer :: config_AM_lagrPartTrack_reset_criteria logical, pointer :: config_AM_lagrPartTrack_reset_if_outside_region logical, pointer :: config_AM_lagrPartTrack_reset_if_inside_region - logical :: resetParticle + integer, dimension(:), pointer :: resetInsideRegionMaskValue1, resetOutsideRegionMaskValue1 ! initialize outputs err = 0 resetParticle = .False. ! get config options - call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_reset_criteria', config_AM_lagrPartTrack_reset_criteria) + call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_reset_criteria', & + config_AM_lagrPartTrack_reset_criteria) + call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_reset_if_outside_region', & + config_AM_lagrPartTrack_reset_if_outside_region) + call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_reset_if_inside_region', & + config_AM_lagrPartTrack_reset_if_inside_region) ! get variables call mpas_pool_get_array(particle % haloDataPool, 'timeSinceReset', timeSinceReset) @@ -190,6 +209,14 @@ subroutine ocn_evaluate_particle_reset_condition(domain, block, particle, dt, iC call mpas_pool_get_subpool(block % structs, 'lagrPartTrackScalars', lagrPartTrackScalarPool) call mpas_pool_get_array(lagrPartTrackScalarPool, 'globalResetTimeValue', globalResetTimeValue) + if (trim(config_AM_lagrPartTrack_reset_criteria) == 'region' .or. & + trim(config_AM_lagrPartTrack_reset_criteria) == 'all' & + ) then + call mpas_pool_get_subpool(block % structs, 'lagrPartTrackRegions', lagrPartTrackRegionsPool) + call mpas_pool_get_array(lagrPartTrackRegionsPool, 'resetInsideRegionMaskValue1', resetInsideRegionMaskValue1) + call mpas_pool_get_array(lagrPartTrackRegionsPool, 'resetOutsideRegionMaskValue1', resetOutsideRegionMaskValue1) + end if + ! advance particle time timeSinceReset = timeSinceReset + dt @@ -215,9 +242,35 @@ subroutine ocn_evaluate_particle_reset_condition(domain, block, particle, dt, iC ! region based !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !{{{ - case ('outside_region') + case ('region') + ! outside region + if (config_AM_lagrPartTrack_reset_if_outside_region .and. & + resetOutsideRegionMaskValue1(iCell) == 0) then + resetParticle = .True. + end if + ! inside region + if (config_AM_lagrPartTrack_reset_if_inside_region .and. & + resetInsideRegionMaskValue1(iCell) == 1) then + resetParticle = .True. + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !}}} + ! all conditions + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !{{{ - case ('inside_region') + case ('all') + ! particle time + if ((timeSinceReset > resetTime) .or. & + ! global time + (timeSinceReset > globalResetTimeValue) .or. & + ! outside region + (config_AM_lagrPartTrack_reset_if_outside_region .and. & + resetOutsideRegionMaskValue1(iCell) == 0) .or. & + ! inside region + (config_AM_lagrPartTrack_reset_if_inside_region .and. & + resetInsideRegionMaskValue1(iCell) == 1)) then + resetParticle = .True. + end if !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !}}} ! default From a9ba8715b14192b6f531d1ac735ad9390060fac4 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 13 Nov 2015 11:17:35 -0700 Subject: [PATCH 0418/1724] restructuring to speed up computation of particles This refractor removes capability to keep track of halos as they are modified because this was determined to be an expensive computation, particularly for a large number of processors because the number of computational steps are larger than the number of write or restart steps. Also rearranged send/recv for less latency: MPI_IRecv should be called before MPI_ISend so all sends have a "hook" to receive them. --- .../mpas_ocn_lagrangian_particle_tracking.F | 109 +++--------------- .../analysis_members/mpas_ocn_particle_list.F | 40 +++---- 2 files changed, 39 insertions(+), 110 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F index cb4b9966e6..f5dc93f470 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -146,10 +146,7 @@ subroutine ocn_init_lagrangian_particle_tracking(domain, err)!{{{ ! get "MPI halos" for communication of particles in halo during computational step call mpas_particle_list_build_computation_halos(domain, err, g_compProcNeighsNearby) - ! make sure Eulerian computational halo values are transfered to general computational halo - ! just copy this data - allocate(g_compProcNeighs(size(g_compProcNeighsNearby))) - g_compProcNeighs = g_compProcNeighsNearby + #ifdef MPAS_DEBUG write(stderrUnit,*) 'finished building and computational halos' #endif @@ -176,30 +173,6 @@ subroutine ocn_init_lagrangian_particle_tracking(domain, err)!{{{ !call MPI_Barrier(domain % dminfo % comm, err) #endif - ! at initialization time we need to build the initial halo for the reset - ! (could be anywhere so we'll need to make a connection between the - ! 'currentBlock' and 'currentBlockReset' - call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_reset_criteria', config_AM_lagrPartTrack_reset_criteria) - if (trim(config_AM_lagrPartTrack_reset_criteria) == 'none') then - config_AM_lagrPartTrack_reset_particles = .False. - else - config_AM_lagrPartTrack_reset_particles = .True. - end if - if (config_AM_lagrPartTrack_reset_particles) then - ! build halos to reset blocks - ! AllToAll Computation! - call mpas_particle_list_build_halos(domain, err, 'currentBlockReset', g_compProcNeighs) -#if MPAS_DEBUG - write(stderrUnit,*) 'Neighs: self begin = ', g_compProcNeighs - write(stderrUnit,*) 'Neighs: list = ', g_compProcNeighsNearby -#endif - ! take the union of this halo with the particle computation halos to build complete computational halo - call mpas_particle_list_self_union_halo_lists(g_compProcNeighs, g_compProcNeighsNearby, domain % dminfo % nprocs, domain % dminfo % my_proc_id) -#if MPAS_DEBUG - write(stderrUnit,*) 'Neighs: self end = ', g_compProcNeighs -#endif - end if - ! tests to make sure all the values are ok !{{{ #ifdef MPAS_DEBUG call mpas_particle_list_test_neighscalc(domain, err) @@ -309,10 +282,6 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ integer, pointer :: nCells, nVertLevels, iCell integer, dimension(:), pointer :: nCellVerticesArray integer, dimension(:,:), pointer :: cellsOnCell - logical, dimension(:,:), pointer :: ioProcRecvList - logical, dimension(:), pointer :: ioProcSendList - logical, dimension(:,:), pointer :: compProcRecvList - logical, dimension(:), pointer :: compProcSendList logical, pointer :: onSphere logical :: config_AM_lagrPartTrack_reset_particles character (len=StrKIND), pointer :: config_AM_lagrPartTrack_reset_criteria @@ -333,7 +302,7 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ integer, pointer :: verticalTreatment, vertexReconstMethod, timeIntegration, indexLevel, filterNum character(len=StrKIND), pointer :: config_dt type (MPAS_timeInterval_type) :: timeStepESMF - logical :: resetParticle + logical :: resetParticle, resetParticleAny integer :: err_tmp err = 0 @@ -357,24 +326,6 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ config_AM_lagrPartTrack_reset_particles = .True. end if - allocate(ioProcRecvList(domain % dminfo % nprocs, size(g_ioProcNeighs))) - allocate(ioProcSendList(domain % dminfo % nprocs)) - ioProcRecvList = .False. - allocate(ioProcSendList(domain % dminfo % nprocs)) - ioProcSendList = .False. - allocate(compProcRecvList(domain % dminfo % nprocs, size(g_compProcNeighs))) - compProcRecvList = .False. - allocate(compProcSendList(domain % dminfo % nprocs)) - compProcSendList = .False. - ! initialize with neighboring blocks to current block - ! (make sure computational halo has Eulerian MPAS halos) - compProcSendList(g_compProcNeighsNearby+1) = .True. -#ifdef MPAS_DEBUG - write(stderrUnit,*) 'compProcSendList before halo updates = ', compProcSendList - write(stderrUnit,*) 'g_compProcNeighs before halo updates = ', g_compProcNeighs -#endif - - ! get the most recent velocities on the potential density surfaces #ifdef MPAS_DEBUG call mpas_timer_start("velocity_pot_density_LPT", .false., timerVelocityPotDensity) @@ -384,6 +335,8 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ call mpas_timer_stop("velocity_pot_density_LPT",timerVelocityPotDensity) #endif + resetParticleAny = .False. + block => domain % blocklist do while (associated(block)) !{{{ #ifdef MPAS_DEBUG @@ -818,21 +771,13 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ ! determine if particles should be reset based on different criteria. If so, reset them. call ocn_evaluate_particle_reset_condition(domain, block, particle, dtSim, iCell, resetParticle, err) end if + resetParticleAny = resetParticleAny .or. resetParticle if (.not. resetParticle) then ! update halo fields for particles moving from adjacent computational halos call mpas_particle_list_update_particle_block(domain, block, particle, 'lagrPartTrackCells', iCell) end if - !! update IO halos based on particle movement (if particle isn't reset) - call mpas_particle_list_update_halos_start(domain, block, particle, 'lagrPartTrackCells', iCell, & - arrayIndex, 'ioBlock', ioProcRecvList, ioProcSendList, g_ioProcNeighs) - - if (config_AM_lagrPartTrack_reset_particles) then ! need to link to currentBlockReset for communication - ! update computational halos (to account for non block halo communication caused by resets, etc) - call mpas_particle_list_update_halos_start(domain, block, particle, 'lagrPartTrackCells', iCell, & - arrayIndex, 'currentBlockReset', compProcRecvList, compProcSendList, g_compProcNeighs) - end if #ifdef MPAS_DEBUG call mpas_timer_stop("particleAssignments", timerParticleAssignment) #endif @@ -858,41 +803,24 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ ! updated. Then, a routine can be called to make sure particles are placed on their appropriate ! currentBlocks -#ifdef MPAS_DEBUG - write(stderrUnit,*) 'compProcSendList after 1st halo updates = ', compProcSendList - write(stderrUnit,*) 'compProcRecvList after 1st halo updates = ', compProcRecvList - write(stderrUnit,*) 'write halo information before' - write(stderrUnit,*) 'g_compProcNeighs = ', g_compProcNeighs - write(stderrUnit,*) 'g_compProcNeighsNearby = ', g_compProcNeighsNearby -#endif - ! particle transfer can then occur from computational processor to computational processor #ifdef MPAS_DEBUG call mpas_timer_start("trans_from_block_to_blockLPT", .false., timerTransferParticles) #endif + if (config_AM_lagrPartTrack_reset_particles .and. resetParticleAny) then ! need to link to currentBlockReset for communication + call mpas_particle_list_build_halos(domain, err, 'currentBlockReset', g_compProcNeighs) + ! take the union of this halo with the particle computation halos to build complete computational halo + call mpas_particle_list_self_union_halo_lists(g_compProcNeighs, g_compProcNeighsNearby, domain % dminfo % nprocs, domain % dminfo % my_proc_id) + else + allocate(g_compProcNeighs(size(g_compProcNeighsNearby))) + g_compProcNeighs = g_compProcNeighsNearby + end if call mpas_particle_list_transfer_particles_from_block_to_named_block(domain, err, .True., .False., 'currentBlock', & g_compProcNeighs) + deallocate(g_compProcNeighs) #ifdef MPAS_DEBUG call mpas_timer_stop("trans_from_block_to_blockLPT", timerTransferParticles) - call mpas_timer_start("update_io_haloLPT", .false., timerUpdateIOHalo) -#endif - ! update io halo - call mpas_particle_list_update_halos_end(domain, err, 'ioBlock', g_ioProcNeighs, ioProcSendList, ioProcRecvList) - if (config_AM_lagrPartTrack_reset_particles) then ! need to link to currentBlockReset for communication - ! update computational halo - call mpas_particle_list_update_halos_end(domain, err, 'currentBlockReset', g_compProcNeighs, compProcSendList, compProcRecvList) - end if -#ifdef MPAS_DEBUG - write(stderrUnit,*) 'g_compProcNeighs after halo updates = ', g_compProcNeighs - write(stderrUnit,*) 'compProcSendList after last halo updates = ', compProcSendList - write(stderrUnit,*) 'compProcRecvList after last halo updates = ', compProcRecvList - write(stderrUnit,*) 'write halo information after' - write(stderrUnit,*) 'g_compProcNeighsNearby = ', g_compProcNeighsNearby - write(stderrUnit,*) 'g_compProcNeighs = ', g_compProcNeighs - write(stderrUnit,*) 'g_ioProcNeighs = ', g_ioProcNeighs - call mpas_timer_stop("update_io_haloLPT",timerUpdateIOHalo) #endif - deallocate(compProcSendList, compProcRecvList, ioProcSendList, ioProcRecvList) ! do IO communications if this is an output time step if (mpas_stream_mgr_ringing_alarms(domain % streamManager, streamID='lagrPartTrackOutput', direction=MPAS_STREAM_OUTPUT, ierr=err)) then @@ -961,8 +889,10 @@ subroutine ocn_restart_lagrangian_particle_tracking(domain, err)!{{{ write(stderrUnit,*) 'start ocn_restart_lagrangian_particle_tracking' ! transfer particles to their appropriate blocks (ioBlock) via MPI ! note, don't necessarily need to have g_ionSend and g_ionRecv comeout + call mpas_particle_list_build_halos(domain, err, 'ioBlock', g_ioProcNeighs) call mpas_particle_list_transfer_particles_from_block_to_named_block(domain, err, .True., .True., 'ioBlock', & g_ioProcNeighs) + deallocate(g_ioProcNeighs) ! write out all the data, sorting to make sure that shuffled particles ! are ouptut correctly (done separately in each function, could be @@ -1042,10 +972,11 @@ subroutine write_lagrangian_particle_tracking(domain, err)!{{{ #endif ! depreciated (can just use update_halo_io to keep g_ioProcNeighs up to date) !! get "MPI halos" for IO communication during write and restart steps (currentBlock to ioBlock) - !call mpas_particle_list_build_halos(domain, err, 'ioBlock', g_ioProcNeighs) + call mpas_particle_list_build_halos(domain, err, 'ioBlock', g_ioProcNeighs) ! transfer the data call mpas_particle_list_transfer_particles_from_block_to_named_block(domain, err, .False., .True., 'ioBlock', & g_ioProcNeighs) + deallocate(g_ioProcNeighs) #ifdef MPAS_DEBUG call mpas_timer_stop("trans_from_block_to_blockLPT", timerTransferParticles_write) #endif @@ -1130,9 +1061,7 @@ subroutine ocn_finalize_lagrangian_particle_tracking(domain, err)!{{{ block => block % next end do - deallocate(g_compProcNeighsNearby, g_compProcNeighs, g_ioProcNeighs) - ! these following ones should be deallocated once rest of the code is sketched in - !deallocate(g_nPartSend, g_nPartRecv, g_ionSend, g_ionRecv) + deallocate(g_compProcNeighsNearby) write(stderrUnit,*) 'end ocn_finalize_lagrangian_particle_tracking' call mpas_timer_stop("finalizeLPT", timerFinalize) diff --git a/src/core_ocean/analysis_members/mpas_ocn_particle_list.F b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F index baa91b654a..4cba42149b 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_particle_list.F +++ b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F @@ -587,7 +587,8 @@ subroutine mpas_particle_list_update_halos_end(domain, err, destinationName, sen !----------------------------------------------------------------- integer :: i, nsendProcNeighs, nProcs - logical, dimension(:), pointer :: completeList, recvList + logical, dimension(:), pointer :: completeList + logical, dimension(:,:), pointer :: recvList integer, dimension(:), pointer :: intArray integer, dimension(:), pointer :: sendRequestID, recvRequestID integer :: mpi_ierr @@ -614,7 +615,7 @@ subroutine mpas_particle_list_update_halos_end(domain, err, destinationName, sen ! proceed to update the halo nProcs = domain % dminfo % nprocs nsendProcNeighs = size(sendProcNeighs) - allocate(completeList(nProcs), recvList(nProcs)) + allocate(completeList(nProcs), recvList(nProcs,nsendProcNeighs)) allocate(sendRequestID(nsendProcNeighs), recvRequestID(nsendProcNeighs)) completeList = .False. @@ -629,31 +630,28 @@ subroutine mpas_particle_list_update_halos_end(domain, err, destinationName, sen write(stderrUnit,*) 'sendProcNeigh= ', sendProcNeighs(i) write(stderrUnit,*) 'send data = ', sendProcRecvList(i,:) #endif - end do - - ! for each sendProc, listen for logical array - do i = 1, nsendProcNeighs - ! send the data #ifdef _MPI - call MPI_IRecv(recvList, nProcs, MPI_LOGICAL, sendProcNeighs(i), sendProcNeighs(i), & + call MPI_IRecv(recvList(:,i), nProcs, MPI_LOGICAL, sendProcNeighs(i), sendProcNeighs(i), & domain % dminfo % comm, recvRequestID(i), mpi_ierr) #endif + end do - ! wait until the data is in the buffer #ifdef _MPI - call MPI_Wait(recvRequestID(i), MPI_STATUS_IGNORE, mpi_ierr) + ! wait until the data is in the buffer + call MPI_WaitAll(nsendProcNeighs,recvRequestID, MPI_STATUSES_IGNORE, mpi_ierr) #endif + do i = 1, nsendProcNeighs ! aggregate results after wait, making sure that we have the most ! comprehensive list of sendProcs for receiving #ifdef MPAS_DEBUG write(stderrUnit,*) 'sendProcNeigh= ', sendProcNeighs(i) - write(stderrUnit,*) 'recvList before = ', recvList + write(stderrUnit,*) 'recvList before = ', recvList(:,i) write(stderrUnit,*) 'completeList before = ', completeList #endif - completeList = completeList .or. recvList + completeList = completeList .or. recvList(:,i) #ifdef MPAS_DEBUG - write(stderrUnit,*) 'recvList after = ', recvList + write(stderrUnit,*) 'recvList after = ', recvList(:,i) write(stderrUnit,*) 'completeList after = ', completeList #endif end do @@ -2928,19 +2926,21 @@ subroutine communicate_num_particles_send_recv(domain, procNeighs, nPartSend, nP #endif do i=1,numProcs #ifdef MPAS_DEBUG - write(stderrUnit,*) 'procNeighs=', procNeighs - write(stderrUnit,*) 'sending data i=',i, ' procNeighs(i)=', procNeighs(i), ' nPartSend(i)=', nPartSend(i) + write(stderrUnit,*) 'receiving data i=',i, ' procNeighs(i)=', procNeighs(i) #endif #ifdef _MPI - call MPI_ISend(nPartSend(i), 1, MPI_INTEGERKIND, procNeighs(i), domain % dminfo % my_proc_id, & - domain % dminfo % comm, requestID(numProcs + i), mpi_ierr) + call MPI_IRecv(nPartRecv(i), 1, MPI_INTEGERKIND, procNeighs(i), procNeighs(i), & + domain % dminfo % comm, requestID(i), mpi_ierr) #endif + end do + do i=1,numProcs #ifdef MPAS_DEBUG - write(stderrUnit,*) 'receiving data i=',i, ' procNeighs(i)=', procNeighs(i) + write(stderrUnit,*) 'procNeighs=', procNeighs + write(stderrUnit,*) 'sending data i=',i, ' procNeighs(i)=', procNeighs(i), ' nPartSend(i)=', nPartSend(i) #endif #ifdef _MPI - call MPI_IRecv(nPartRecv(i), 1, MPI_INTEGERKIND, procNeighs(i), procNeighs(i), & - domain % dminfo % comm, requestID(i), mpi_ierr) + call MPI_ISend(nPartSend(i), 1, MPI_INTEGERKIND, procNeighs(i), domain % dminfo % my_proc_id, & + domain % dminfo % comm, requestID(numProcs + i), mpi_ierr) #endif end do #ifdef MPAS_DEBUG From f583c2012700763e12665e2439eebc5662dbd7d4 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 13 Nov 2015 10:55:59 -0700 Subject: [PATCH 0419/1724] updated particle template for test cases This follows adding time and region based reset into LIGHT. Also updated planar periodic test case so that it runs. --- .../ocean/lagrangian_particle_tracking.xml | 32 +++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/test_cases/ocean/templates/ocean/lagrangian_particle_tracking.xml b/test_cases/ocean/templates/ocean/lagrangian_particle_tracking.xml index e9268dc21e..5a3592e176 100644 --- a/test_cases/ocean/templates/ocean/lagrangian_particle_tracking.xml +++ b/test_cases/ocean/templates/ocean/lagrangian_particle_tracking.xml @@ -8,6 +8,11 @@ + + + + + @@ -29,6 +34,15 @@ + + + + + + + + + @@ -78,6 +92,15 @@ + + + + + + + + + @@ -111,6 +134,15 @@ + + + + + + + + + From 2775f10f4cc591b59fa1d514527e7447edb7b900 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 13 Nov 2015 12:55:02 -0700 Subject: [PATCH 0420/1724] time based particle reset example Test with script at https://www.dropbox.com/s/fh5kcs96hwn41vr/plot_particles.py?dl=0 --- .../20km/config_driver.xml | 11 +++ .../20km/config_forward.xml | 92 +++++++++++++++++++ .../20km/config_init1.xml | 69 ++++++++++++++ .../20km/config_init2.xml | 58 ++++++++++++ 4 files changed, 230 insertions(+) create mode 100644 test_cases/ocean/ocean/periodic_planar_time_reset/20km/config_driver.xml create mode 100644 test_cases/ocean/ocean/periodic_planar_time_reset/20km/config_forward.xml create mode 100644 test_cases/ocean/ocean/periodic_planar_time_reset/20km/config_init1.xml create mode 100644 test_cases/ocean/ocean/periodic_planar_time_reset/20km/config_init2.xml diff --git a/test_cases/ocean/ocean/periodic_planar_time_reset/20km/config_driver.xml b/test_cases/ocean/ocean/periodic_planar_time_reset/20km/config_driver.xml new file mode 100644 index 0000000000..f8d9249cef --- /dev/null +++ b/test_cases/ocean/ocean/periodic_planar_time_reset/20km/config_driver.xml @@ -0,0 +1,11 @@ + + + + + + + + + + + diff --git a/test_cases/ocean/ocean/periodic_planar_time_reset/20km/config_forward.xml b/test_cases/ocean/ocean/periodic_planar_time_reset/20km/config_forward.xml new file mode 100644 index 0000000000..aaf96f2141 --- /dev/null +++ b/test_cases/ocean/ocean/periodic_planar_time_reset/20km/config_forward.xml @@ -0,0 +1,92 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +