#include "w3macros.h"
!/
!/ ------------------------------------------------------------------- /
!/ Macros for ESMF logging
!/
#define FILENAME "wmesmfmd.ftn"
#define CONTEXT line=__LINE__,file=FILENAME,method=METHOD
#define PASSTHRU msg=ESMF_LOGERR_PASSTHRU,CONTEXT
!/
!/ ------------------------------------------------------------------- /
!/ Define real kind for data passed through ESMF interface
!/
#if defined(ESMF_R8)
#define ESMF_KIND_RX ESMF_KIND_R8
#define ESMF_TYPEKIND_RX ESMF_TYPEKIND_R8
#else
#define ESMF_KIND_RX ESMF_KIND_R4
#define ESMF_TYPEKIND_RX ESMF_TYPEKIND_R4
#endif
!/
!/ ------------------------------------------------------------------- /
!/ Macro for enabling using W3OUTG to calculate export fields
!/
#define USE_W3OUTG_FOR_EXPORT___disabled
!/
!/ ------------------------------------------------------------------- /
!/ Macros for enabling test output
!/
#define TEST_WMESMFMD___disabled
#define TEST_WMESMFMD_GETIMPORT___disabled
#define TEST_WMESMFMD_SETEXPORT___disabled
#define TEST_WMESMFMD_CREATEIMPGRID___disabled
#define TEST_WMESMFMD_CREATEEXPGRID___disabled
#define TEST_WMESMFMD_SETUPIMPBMSK___disabled
#define TEST_WMESMFMD_CHARNK___disabled
#define TEST_WMESMFMD_ROUGHL___disabled
#define TEST_WMESMFMD_BOTCUR___disabled
#define TEST_WMESMFMD_RADSTR2D___disabled
#define TEST_WMESMFMD_STOKES3D___disabled
!/
!/ ------------------------------------------------------------------- /
module WMESMFMD
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | J. Meixner, NCEP |
!/ | A. J. van der Westhuysen |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/ 09-Aug-2017 : Add ocean forcing export fields ( version 6.03 )
!/ 28-Feb-2018 : Modifications for unstruc meshes ( version 6.06 )
!/
!/ Copyright 2009-2014 National Weather Service (NWS),
!/ National Oceanic and Atmospheric Administration. All rights
!/ reserved. WAVEWATCH III is a trademark of the NWS.
!/ No unauthorized use without permission.
!/
! 1. Purpose :
!
! National Unified Prediction Capability (NUOPC) based
! Earth System Modeling Framework (ESMF) interface module for
! multi-grid wave model.
!
! 2. Variables and types :
!
! All module variables and types are scoped private by default.
! The private module variables and types are not listed in this section.
!
! Name Type Scope Description
! ----------------------------------------------------------------
! ----------------------------------------------------------------
!
! 3. Subroutines and functions :
!
! All module subroutines and functions are scoped private by default.
!
! Name Type Scope Description
! -----------------------------------------------------------------
! SetServices Subr. Public Wave model ESMF Set Services
! -----------------------------------------------------------------
! InitializeP0 Subr. Private NUOPC/ESMF Initialize phase 0
! InitializeP1 Subr. Private NUOPC/ESMF Initialize phase 1
! InitializeP3 Subr. Private NUOPC/ESMF Initialize phase 3
! Finalize Subr. Private NUOPC/ESMF Finalize
! DataInitialize Subr. Private NUOPC/ESMF Data Initialize
! ModelAdvance Subr. Private NUOPC/ESMF Model Advance
! GetImport Subr. Private Get fields from import state
! SetExport Subr. Private Set fields from export state
! CreateImpGrid Subr. Private Create ESMF grid for import
! CreateExpGrid Subr. Private Create ESMF grid for export
! CreateImpMesh Subr. Private Create ESMF mesh for import
! CreateExpMesh Subr. Private Create ESMF mesh for export
! SetupImpBmsk Subr. Private Setup background blending mask
! BlendImpField Subr. Private Blend import field with background
! FieldFill Subr. Private Fill ESMF field
! FieldGather Subr. Private Gather ESMF field
! FieldIndex Func. Private Return field index
! PrintTimers Subr. Private Print wallclock timers
! CalcDecomp Subr. Private Calculate a 2D processor layout
! GetEnvValue Subr. Private Get value of env. variable
! GetZlevels Subr. Private Get z-levels from file for SDC
! CalcCharnk Subr. Private Calculate Charnock for export
! CalcRoughl Subr. Private Calculate roughness length for export
! CalcBotcur Subr. Private Calculate wave-bottom currents for export
! CalcRadstr2D Subr. Private Calculate 2D radiation stresses for export
! CalcStokes3D Subr. Private Calculate 3D Stokes drift current for export
! ----------------------------------------------------------------
!
! 4. Subroutines and functions used :
!
! See subroutine documentation.
!
! 5. Remarks :
!
! 6. Switches :
!
! See subroutine documentation.
!
! !/MPI Switch for enabling Message Passing Interface API
! !/SHRD Switch for shared memory architecture
! !/DIST Switch for distributed memory architecture
! !/ST3 WAM 4+ input and dissipation.
! !/ST4 Ardhuin et al. (2009, 2010)
!
! 7. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ Use associated modules
!/
! --- ESMF Module
use ESMF
! --- NUOPC modules
use NUOPC
use NUOPC_Model, parent_SetServices => SetServices
! --- WW3 modules
use CONSTANTS
use WMINITMD, only: WMINIT, WMINITNML
use WMWAVEMD, only: WMWAVE
use WMFINLMD, only: WMFINL
use WMMDATMD
use W3GDATMD
use W3IDATMD
use W3ODATMD
use W3WDATMD
use W3ADATMD
use W3TIMEMD
use WMUPDTMD, only: WMUPD2
use W3UPDTMD, only: W3UINI
!/ST3 use W3SRC3MD, only: W3SPR3
!/ST4 use W3SRC4MD, only: W3SPR4
use W3IOGOMD, only: W3OUTG
!/
!/ Specify default data typing
!/
implicit none
!/
!/ Include MPI definitions
!/
!/MPI include "mpif.h"
!/
!/ Specify default accessibility
!/
private
save
!/
!/ Public module methods
!/
public SetServices
!/
!/ Private module parameters
!/
! --- Default Mask Convention for import/export fields
INTEGER, PARAMETER :: DEFAULT_MASK_WATER = 0
INTEGER, PARAMETER :: DEFAULT_MASK_LAND = 1
! --- Miscellaneous
integer, parameter :: stdo = 6
type(ESMF_VM) :: vm
integer :: lpet, npet
integer :: verbosity
logical :: realizeAllExport = .false.
integer :: maskValueWater = DEFAULT_MASK_WATER
integer :: maskValueLand = DEFAULT_MASK_LAND
integer :: nz ! Number of z-levels for SDC
real(4), allocatable :: zl(:) ! Array of z-levels for SDC
character(256) :: zlfile = 'none' ! File containing z-levels for SDC
character(ESMF_MAXSTR) :: msg
real(ESMF_KIND_RX) :: zeroValue
real(ESMF_KIND_RX) :: missingValue
!
! --- Timing
integer, parameter :: numwt=8
character(32) :: wtnam(numwt)
integer :: wtcnt(numwt)
real(8) :: wtime(numwt)
!
! --- Import fields
type(ESMF_ArraySpec) :: impArraySpec2D
type(ESMF_StaggerLoc) :: impStaggerLoc
type(ESMF_Index_Flag) :: impIndexFlag
type(ESMF_Grid) :: impGrid
integer :: impGridID
logical :: impGridIsLocal
integer, parameter :: impHaloWidth = 3
integer :: impHaloLWidth(2)
integer :: impHaloUWidth(2)
type(ESMF_RouteHandle) :: impHaloRH
type(ESMF_Field) :: impMask
logical :: noActiveImpFields
integer :: numImpFields
character(6), allocatable :: impFieldName(:)
character(128), allocatable :: impFieldStdName(:)
logical, allocatable :: impFieldInitRqrd(:)
logical, allocatable :: impFieldActive(:)
type(ESMF_Field), allocatable :: impField(:)
!
! --- Background import fields
character(10), allocatable :: mbgFieldName(:)
character(128), allocatable :: mbgFieldStdName(:)
logical, allocatable :: mbgFieldActive(:)
type(ESMF_Field), allocatable :: mbgField(:)
type(ESMF_Field), allocatable :: bmskField(:)
!
! --- Unstructured import meshes
type(ESMF_Mesh) :: impMesh
! integer :: impMeshID
! logical :: impMeshIsLocal
!
! --- Export fields
type(ESMF_ArraySpec) :: expArraySpec2D
type(ESMF_ArraySpec) :: expArraySpec3D
type(ESMF_StaggerLoc) :: expStaggerLoc
type(ESMF_Index_Flag) :: expIndexFlag
type(ESMF_Grid) :: expGrid
integer :: expGridID = 1
logical :: expGridIsLocal
integer, parameter :: expHaloWidth = 3
integer :: expHaloLWidth(2)
integer :: expHaloUWidth(2)
type(ESMF_RouteHandle) :: expHaloRH
type(ESMF_Field) :: expMask
logical :: noActiveExpFields
integer :: numExpFields
character(6), allocatable :: expFieldName(:)
character(128), allocatable :: expFieldStdName(:)
integer, allocatable :: expFieldDim(:)
logical, allocatable :: expFieldActive(:)
type(ESMF_Field), allocatable :: expField(:)
!
! --- Unstructured export meshes
type(ESMF_Mesh) :: expMesh
integer :: expMeshID
logical :: expMeshIsLocal
!
! --- Native field stuff
type(ESMF_ArraySpec) :: natArraySpec1D
type(ESMF_ArraySpec) :: natArraySpec2D
type(ESMF_ArraySpec) :: natArraySpec3D
type(ESMF_StaggerLoc) :: natStaggerLoc
type(ESMF_Index_Flag) :: natIndexFlag
type(ESMF_Grid) :: natGrid
integer :: natGridID
logical :: natGridIsLocal
type(ESMF_RouteHandle):: n2eRH
!/
!/ ------------------------------------------------------------------- /
contains
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "SetServices"
subroutine SetServices ( gcomp, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 20-Jan-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/
! 1. Purpose :
!
! Wave model ESMF set services.
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! gcomp Type I/O Gridded component
! rc Int. O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! InitializeP0 Subr. WMESMFMD Wave model NUOPC/ESMF Initialize phase 0
! InitializeP1 Subr. WMESMFMD Wave model NUOPC/ESMF Initialize phase 1
! InitializeP3 Subr. WMESMFMD Wave model NUOPC/ESMF Initialize phase 3
! Finalize Subr. WMESMFMD Wave model NUOPC/ESMF Finalize
! DataInitialize Subr. WMESMFMD Wave model NUOPC/ESMF Data Initialize
! ModelAdvance Subr. WMESMFMD Wave model NUOPC/ESMF Model Advance
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_GridComp) :: gcomp
integer,intent(out) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
!NONE
!
! -------------------------------------------------------------------- /
! Prep
!
rc = ESMF_SUCCESS
! --- Initialize wallclock timers
wtnam( 1) = 'InitializeP0'
wtnam( 2) = 'InitializeP1'
wtnam( 3) = 'InitializeP3'
wtnam( 4) = 'DataInitialize'
wtnam( 5) = 'ModelAdvance'
wtnam( 6) = 'Finalize'
wtnam( 7) = 'GetImport'
wtnam( 8) = 'SetExport'
wtcnt( :) = 0
wtime( :) = 0d0
!
! -------------------------------------------------------------------- /
! 1. NUOPC model component will register the generic methods
!
call NUOPC_CompDerive(gcomp, parent_SetServices, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! -------------------------------------------------------------------- /
! 2. Set model entry points
!
! --- Initialize - phase 0 (requires use of ESMF method)
call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, &
userRoutine=InitializeP0, phase=0, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
! --- Set entry points for initialize methods
! >= IPDv03 supports satisfying inter-model data dependencies and
! the transfer of ESMF Grid & Mesh objects between Model and/or
! Mediator components during initialization
! IPDv03p1: advertise import & export fields
call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, &
phaseLabelList=(/"IPDv03p1"/), userRoutine=InitializeP1, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
! IPDv03p2: unspecified by NUOPC -- not required
! IPDv03p3: realize import & export fields
call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, &
phaseLabelList=(/"IPDv03p3"/), userRoutine=InitializeP3, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
! IPDv03p4: relevant for TransferActionGeomObject=="accept"
! IPDv03p5: relevant for TransferActionGeomObject=="accept"
! IPDv03p6: check compatibility of fields connected status
! IPDv03p7: handle field data initialization
!
! -------------------------------------------------------------------- /
! 3. Register specializing methods
!
! --- Model initialize export data method
call NUOPC_CompSpecialize(gcomp, specLabel=label_DataInitialize, &
specRoutine=DataInitialize, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
! --- Model checkImport method (overriding default)
call ESMF_MethodRemove(gcomp, label_CheckImport, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call NUOPC_CompSpecialize(gcomp, specLabel=label_CheckImport, &
specRoutine=NUOPC_NoOp, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
! --- Model advance method
call NUOPC_CompSpecialize(gcomp, specLabel=label_Advance, &
specRoutine=ModelAdvance, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
! --- Model finalize method
call NUOPC_CompSpecialize(gcomp, specLabel=label_Finalize, &
specRoutine=Finalize, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! -------------------------------------------------------------------- /
! Post
!
rc = ESMF_SUCCESS
!/
!/ End of SetServices ------------------------------------------------ /
!/
end subroutine SetServices
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "InitializeP0"
subroutine InitializeP0 ( gcomp, impState, expState, extClock, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 20-Jan-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/
! 1. Purpose :
!
! Initialize wave model (phase 0)
! * Define the NUOPC Initialize Phase Mapping
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! gcomp Type I/O Gridded component
! impState Type I/O Import state
! expState Type I/O Export state
! extClock Type I External clock
! rc Int. O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_GridComp) :: gcomp
type(ESMF_State) :: impState
type(ESMF_State) :: expState
type(ESMF_Clock) :: extClock
integer,intent(out) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
character(ESMF_MAXSTR) :: valueString
integer, parameter :: iwt=1
real(8) :: wstime, wftime
!
! -------------------------------------------------------------------- /
! Prep
!
rc = ESMF_SUCCESS
call ESMF_VMWtime(wstime)
call ESMF_GridCompGet(gcomp, name=cname, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! -------------------------------------------------------------------- /
! Determine verbosity
!
call NUOPC_CompAttributeGet(gcomp, name='Verbosity', &
value=valueString, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
verbosity = ESMF_UtilString2Int( valueString, &
specialStringList=(/'high','max '/), &
specialValueList=(/ 255, 255/), rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': entered InitializeP0', ESMF_LOGMSG_INFO)
!
! -------------------------------------------------------------------- /
! Define initialization phases
! * switch to IPDv03 by filtering all other phaseMap entries
!
call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, &
acceptStringList=(/"IPDv03p"/), rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! -------------------------------------------------------------------- /
! Post
!
rc = ESMF_SUCCESS
call ESMF_VMWtime(wftime)
wtime(iwt) = wtime(iwt) + wftime - wstime
wtcnt(iwt) = wtcnt(iwt) + 1
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': leaving InitializeP0', ESMF_LOGMSG_INFO)
!/
!/ End of InitializeP0 ----------------------------------------------- /
!/
end subroutine InitializeP0
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "InitializeP1"
subroutine InitializeP1 ( gcomp, impState, expState, extClock, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/ 09-Aug-2017 : Add ocean forcing export fields ( version 6.03 )
!/
! 1. Purpose :
!
! Initialize wave model (phase 1)
! * Advertise fields in import and export states.
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! gcomp Type I/O Gridded component
! impState Type I/O Import state
! expState Type I/O Export state
! extClock Type I External clock
! rc Int. O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! WMINIT Subr. WMINITMD Wave model initialization
! WMINITNML Subr. WMINITMD Wave model initialization
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! ----------------------------------------------------------------
! 1. Initialization necessary for driver
! a General I/O: (implicit in WMMDATMD)
! b MPI environment
! c Identifying output to "screen" unit
! 2. Initialization of all wave models / grids
! 3. Advertise import fields
! 4. Advertise export fields
! ----------------------------------------------------------------
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_GridComp) :: gcomp
type(ESMF_State) :: impState
type(ESMF_State) :: expState
type(ESMF_Clock) :: extClock
integer,intent(out) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
integer, parameter :: iwt=2
real(8) :: wstime, wftime
integer :: idsi, idso, idss, idst, idse
integer :: mpiComm = -99
logical :: configIsPresent
type(ESMF_Config) :: config
character(ESMF_MAXSTR) :: wrkdir = '.'
character(ESMF_MAXSTR) :: preamb = '.'
character(ESMF_MAXSTR) :: ifname = 'ww3_multi.inp'
logical :: lsep_ss = .true.
logical :: lsep_st = .true.
logical :: lsep_se = .true.
character(ESMF_MAXSTR) :: attstr
integer(ESMF_KIND_I4) :: yy,mm,dd,h,m,s
type(ESMF_Time) :: ttmp, cttmp
type(ESMF_TimeInterval) :: tstep, etstep
integer :: i, j, n, istep, imod, jmod
integer, allocatable :: cplmap(:,:)
logical :: includeObg, includeAbg, includeIbg
!
! -------------------------------------------------------------------- /
! Prep
!
rc = ESMF_SUCCESS
call ESMF_VMWtime(wstime)
call ESMF_GridCompGet(gcomp, name=cname, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': entered InitializeP1', ESMF_LOGMSG_INFO)
!
! -------------------------------------------------------------------- /
! 1. Initialization necessary for driver
!
! 1.a Set global flag indicating that model is an ESMF Component
!
is_esmf_component = .true.
zeroValue = real(0,ESMF_KIND_RX)
missingValue = real(0,ESMF_KIND_RX)
!
!
! 1.b Get MPI environment from ESMF VM and set WW3 MPI related variables
!
call ESMF_GridCompGet(gcomp, vm=vm, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_VMGet(vm, petCount=npet, localPet=lpet, &
mpiCommunicator=mpiComm, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
nmproc = npet
improc = lpet + 1
nmpscr = 1
if ( improc .eq. nmpscr ) write (*,900)
!
! 1.c Get background model info
!
#if defined(COAMPS)
call ESMF_AttributeGet(gcomp, name="OcnBackground", &
value=attstr, defaultValue="none", &
convention="COAMPS", purpose="General", rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
includeObg = trim(attstr).eq."model"
call ESMF_AttributeGet(gcomp, name="AtmBackground", &
value=attstr, defaultValue="none", &
convention="COAMPS", purpose="General", rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
includeAbg = trim(attstr).eq."model"
call ESMF_AttributeGet(gcomp, name="IceBackground", &
value=attstr, defaultValue="none", &
convention="COAMPS", purpose="General", rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
includeIbg = trim(attstr).eq."model"
call ESMF_AttributeGet(gcomp, name="MissingValue", &
value=missingValue, defaultValue=real(0,ESMF_KIND_RX), &
convention="COAMPS", purpose="General", rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
#else
includeObg = .false.
includeAbg = .false.
includeIbg = .false.
#endif
!
! 1.d Config input
!
call ESMF_GridCompGet(gcomp, configIsPresent=configIsPresent, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (configIsPresent) then
call ESMF_GridCompGet(gcomp, config=config, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
! working directory
call ESMF_ConfigGetAttribute(config, wrkdir, &
label=trim(cname)//'_work_dir:', default='.', rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
! I/O options
call ESMF_ConfigGetAttribute(config, ifname, &
label=trim(cname)//'_input_file_name:', &
default='ww3_multi.inp', rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_ConfigGetAttribute(config, lsep_ss, &
label=trim(cname)//'_stdo_output_to_file:', default=.false., rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_ConfigGetAttribute(config, lsep_st, &
label=trim(cname)//'_test_output_to_file:', default=.false., rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_ConfigGetAttribute(config, lsep_se, &
label=trim(cname)//'_error_output_to_file:', default=.false., rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
! export grid id
call ESMF_ConfigGetAttribute(config, expGridID, &
label=trim(cname)//'_export_grid_id:', default=1, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
! realize all export flag
call ESMF_ConfigGetAttribute(config, realizeAllExport, &
label=trim(cname)//'_realize_all_export:', default=.false., rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
! grid mask convention
call ESMF_ConfigGetAttribute(config, maskValueWater, &
label='mask_value_water:', default=DEFAULT_MASK_WATER, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_ConfigGetAttribute(config, maskValueLand, &
label='mask_value_land:', default=DEFAULT_MASK_LAND, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
! z-level file
call ESMF_ConfigGetAttribute(config, zlfile, &
label=trim(cname)//'_zlevel_exp_file:', default='none', rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
! preamb = trim(wrkdir)//'/'
preamb = trim(preamb)//'/' !TODO: have separate paths for .inp, logs and data?
!
! 1.e Set internal start/stop time from external start/stop time
!
call ESMF_ClockGet(extClock, startTime=ttmp, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_ClockGet(extClock, currTime=cttmp, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! Adjust internal start time to currTime in case of delayed start
!
if ( cttmp.gt.ttmp ) ttmp=cttmp
call ESMF_TimeGet(ttmp, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
stime(1) = 10000*yy + 100*mm + dd
stime(2) = 10000*h + 100*m + s
call ESMF_ClockGet(extClock, stopTime=ttmp, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_TimeGet(ttmp, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
etime(1) = 10000*yy + 100*mm + dd
etime(2) = 10000*h + 100*m + s
!
! 1.f Identify available unit numbers
! Each ESMF_UtilIOUnitGet is followed by an OPEN statement for that
! unit so that subsequent ESMF_UtilIOUnitGet calls do not return the
! the same unit. After getting all the available unit numbers, close
! the units since they will be opened within WMINIT.
!
call ESMF_UtilIOUnitGet(idsi); open(unit=idsi, status='scratch');
call ESMF_UtilIOUnitGet(idso); open(unit=idso, status='scratch');
call ESMF_UtilIOUnitGet(idss); open(unit=idss, status='scratch');
call ESMF_UtilIOUnitGet(idst); open(unit=idst, status='scratch');
call ESMF_UtilIOUnitGet(idse); open(unit=idse, status='scratch');
close(idsi); close(idso); close(idss); close(idst); close(idse);
!
! -------------------------------------------------------------------- /
! 2. Initialization of all wave models / grids
!
! 2.a Call into WMINIT
!
if ( .not.lsep_ss ) idss = stdo
if ( .not.lsep_st ) idst = stdo
if ( .not.lsep_se ) idse = stdo
if ( trim(ifname).eq.'ww3_multi.nml' ) then
call wminitnml ( idsi, idso, idss, idst, idse, trim(ifname), &
mpicomm, preamb=preamb )
else
call wminit ( idsi, idso, idss, idst, idse, trim(ifname), &
mpicomm, preamb=preamb )
endif
!
! 2.b Check consistency between internal timestep and external
! timestep (coupling interval)
!
call ESMF_ClockGet(extClock, timeStep=etstep, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 2.c Trap unsupported CPL input forcing settings
!
if ( any(inpmap.lt.0) ) then
if ( nrgrd.gt.1 ) then
if ( any(inpmap.eq.-999) ) then
write (msg,'(a)') 'CPL input forcing defined on a '// &
'native grid is not supported with multiple model grids'
if ( improc .eq. nmpscr ) write (idse,'(a)') trim(msg)
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
return
endif
endif
allocate (cplmap(nrgrd,jfirst:8), stat=rc)
if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return
jmod = minval(inpmap)
cplmap = inpmap
where ( inpmap.lt.0 ) cplmap = jmod
if ( any(inpmap.ne.cplmap) ) then
write (msg,'(a)') 'All CPL input forcing must be '// &
'defined on the same grid'
if ( improc .eq. nmpscr ) write (idse,'(a)') trim(msg)
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
return
endif
deallocate (cplmap, stat=rc)
if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return
endif
!
! -------------------------------------------------------------------- /
! 3. Initialize import field list
!
istep_import: do istep = 1, 2
if ( istep.eq.2 ) then
allocate ( impFieldName(numImpFields), &
impFieldStdName(numImpFields), &
impFieldInitRqrd(numImpFields), &
impFieldActive(numImpFields), &
impField(numImpFields), &
stat=rc )
if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return
allocate ( mbgFieldName(numImpFields), &
mbgFieldStdName(numImpFields), &
mbgFieldActive(numImpFields), &
mbgField(numImpFields), &
bmskField(numImpFields), &
stat=rc )
if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return
impFieldActive(:) = .false.
endif
i = 0
!i = i + 1
!if ( istep.eq.2 ) then
! j = 1
! impFieldActive(i) = any(inpmap(:,j).lt.0)
! impFieldName(i) = 'seahgt'
! impFieldStdName(i) = 'sea_surface_height_above_sea_level'
! impFieldInitRqrd(i) = .true.
! mbgFieldActive(i) = impFieldActive(i).and.includeObg
!endif
!i = i + 1
!if ( istep.eq.2 ) then
! j = 2
! impFieldActive(i) = any(inpmap(:,j).lt.0)
! impFieldName(i) = 'uucurr'
! impFieldStdName(i) = 'surface_eastward_sea_water_velocity'
! impFieldInitRqrd(i) = .true.
! mbgFieldActive(i) = impFieldActive(i).and.includeObg
!endif
!i = i + 1
!if ( istep.eq.2 ) then
! j = 2
! impFieldActive(i) = any(inpmap(:,j).lt.0)
! impFieldName(i) = 'vvcurr'
! impFieldStdName(i) = 'surface_northward_sea_water_velocity'
! impFieldInitRqrd(i) = .true.
! mbgFieldActive(i) = impFieldActive(i).and.includeObg
!endif
i = i + 1
if ( istep.eq.2 ) then
j = 3
impFieldActive(i) = any(inpmap(:,j).lt.0)
impFieldName(i) = 'uutrue'
impFieldStdName(i) = 'eastward_wind_at_10m_height'
impFieldInitRqrd(i) = .true.
mbgFieldActive(i) = impFieldActive(i).and.includeAbg
endif
i = i + 1
if ( istep.eq.2 ) then
j = 3
impFieldActive(i) = any(inpmap(:,j).lt.0)
impFieldName(i) = 'vvtrue'
impFieldStdName(i) = 'northward_wind_at_10m_height'
impFieldInitRqrd(i) = .true.
mbgFieldActive(i) = impFieldActive(i).and.includeAbg
endif
!i = i + 1
!if ( istep.eq.2 ) then
! j = 4
! impFieldActive(i) = any(inpmap(:,j).lt.0)
! impFieldName(i) = 'seaice'
! impFieldStdName(i) = 'sea_ice_concentration'
! impFieldInitRqrd(i) = .true.
! mbgFieldActive(i) = impFieldActive(i).and.includeIbg
!endif
numImpFields = i
enddo istep_import
noActiveImpFields = all(.not.impFieldActive)
do i = 1,numImpFields
mbgFieldName(i) = 'mbg_'//trim(impFieldName(i))
mbgFieldStdName(i) = 'mbg_'//trim(impFieldStdName(i))
enddo
!
! -------------------------------------------------------------------- /
! 4. Initialize export field list
!
istep_export: do istep = 1, 2
if ( istep.eq.2 ) then
allocate ( expFieldName(numExpFields), &
expFieldStdName(numExpFields), &
expFieldDim(numExpFields), &
expFieldActive(numExpFields), &
expField(numExpFields), &
stat=rc )
if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return
expFieldActive(:) = .false.
endif
i = 0
!i = i + 1
!if ( istep.eq.2 ) then
! expFieldName(i) = 'charno'
! expFieldStdName(i) = 'wave_induced_charnock_parameter'
! expFieldDim(i) = 2
!endif
!i = i + 1
!if ( istep.eq.2 ) then
! expFieldName(i) = 'z0rlen'
! expFieldStdName(i) = 'wave_z0_roughness_length'
! expFieldDim(i) = 2
!endif
!i = i + 1
!if ( istep.eq.2 ) then
! expFieldName(i) = 'uscurr'
! expFieldStdName(i) = 'eastward_stokes_drift_current'
! expFieldDim(i) = 3
!endif
!i = i + 1
!if ( istep.eq.2 ) then
! expFieldName(i) = 'vscurr'
! expFieldStdName(i) = 'northward_stokes_drift_current'
! expFieldDim(i) = 3
!endif
!i = i + 1
!if ( istep.eq.2 ) then
! expFieldName(i) = 'wbcuru'
! expFieldStdName(i) = 'eastward_wave_bottom_current'
! expFieldDim(i) = 2
!endif
!i = i + 1
!if ( istep.eq.2 ) then
! expFieldName(i) = 'wbcurv'
! expFieldStdName(i) = 'northward_wave_bottom_current'
! expFieldDim(i) = 2
!endif
!i = i + 1
!if ( istep.eq.2 ) then
! expFieldName(i) = 'wbcurp'
! expFieldStdName(i) = 'wave_bottom_current_period'
! expFieldDim(i) = 2
!endif
!i = i + 1
!if ( istep.eq.2 ) then
! expFieldName(i) = 'wavsuu'
! expFieldStdName(i) = 'eastward_wave_radiation_stress'
! expFieldDim(i) = 2
!endif
!i = i + 1
!if ( istep.eq.2 ) then
! expFieldName(i) = 'wavsuv'
! expFieldStdName(i) = 'eastward_northward_wave_radiation_stress'
! expFieldDim(i) = 2
!endif
!i = i + 1
!if ( istep.eq.2 ) then
! expFieldName(i) = 'wavsvv'
! expFieldStdName(i) = 'northward_wave_radiation_stress'
! expFieldDim(i) = 2
!endif
numExpFields = i
enddo istep_export
noActiveExpFields = all(.not.expFieldActive)
!
! -------------------------------------------------------------------- /
! 5. Advertise import fields
!
! 5.a Advertise active import fields
!
n = 0
do i = 1,numImpFields
if (.not.impFieldActive(i)) cycle
n = n + 1
call NUOPC_Advertise(impState, &
trim(impFieldStdName(i)), name=trim(impFieldName(i)), rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (.not.mbgFieldActive(i)) cycle
n = n + 1
call NUOPC_Advertise(impState, &
trim(mbgFieldStdName(i)), name=trim(mbgFieldName(i)), rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
enddo
!
! 5.b Report advertised import fields
!
write(msg,'(a,i0,a)') trim(cname)// &
': List of advertised import fields(',n,'):'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,a5,a,a10,a3,a)') trim(cname)// &
': ','index',' ','name',' ','standardName'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
n = 0
do i = 1,numImpFields
if (.not.impFieldActive(i)) cycle
n = n + 1
write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, &
' ',trim(impFieldName(i)),' ',trim(impFieldStdName(i))
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
if (.not.mbgFieldActive(i)) cycle
n = n + 1
write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, &
' ',trim(mbgFieldName(i)),' ',trim(mbgFieldStdName(i))
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
enddo
!
! -------------------------------------------------------------------- /
! 6. Advertise export fields
!
! 6.a Advertise all export fields
!
do i = 1,numExpFields
call NUOPC_Advertise(expState, &
trim(expFieldStdName(i)), name=trim(expFieldName(i)), rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
enddo
!
! 6.b Report advertised export fields
!
write(msg,'(a,i0,a)') trim(cname)// &
': List of advertised export fields(',numExpFields,'):'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,a5,a,a10,a3,a)') trim(cname)// &
': ','index',' ','name',' ','standardName'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
do i = 1,numExpFields
write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',i, &
' ',trim(expFieldName(i)),' ',trim(expFieldStdName(i))
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
enddo
!
! -------------------------------------------------------------------- /
! Post
!
rc = ESMF_SUCCESS
call ESMF_VMWtime(wftime)
wtime(iwt) = wtime(iwt) + wftime - wstime
wtcnt(iwt) = wtcnt(iwt) + 1
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': leaving InitializeP1', ESMF_LOGMSG_INFO)
!
! -------------------------------------------------------------------- /
! Formats
!
900 format (/15x,' *** WAVEWATCH III Multi-grid shell *** '/ &
15x,'================================================='/)
!/
!/ End of InitializeP1 ----------------------------------------------- /
!/
end subroutine InitializeP1
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "InitializeP3"
subroutine InitializeP3 ( gcomp, impState, expState, extClock, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | A. J. van der Westhuysen |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/ 09-Aug-2017 : Update 3D export field setup ( version 6.03 )
!/ 28-Feb-2018 : Modifications for unstruc meshes ( version 6.06 )
!/
! 1. Purpose :
!
! Initialize wave model (phase 3)
! * Realize fields in import and export states.
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! gcomp Type I/O Gridded component
! impState Type I/O Import state
! expState Type I/O Export state
! extClock Type I External clock
! rc Int. O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! WMINIT Subr. WMINITMD Wave model initialization
! WMINITNML Subr. WMINITMD Wave model initialization
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_GridComp) :: gcomp
type(ESMF_State) :: impState
type(ESMF_State) :: expState
type(ESMF_Clock) :: extClock
integer,intent(out) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
integer, parameter :: iwt=3
real(8) :: wstime, wftime
integer :: i1, i2, i3, i, n
logical :: isConnected
!
! -------------------------------------------------------------------- /
! Prep
!
rc = ESMF_SUCCESS
call ESMF_VMWtime(wstime)
call ESMF_GridCompGet(gcomp, name=cname, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': entered InitializeP3', ESMF_LOGMSG_INFO)
!
! -------------------------------------------------------------------- /
! 1. Realize active import fields
!
! 1.a Create ESMF grid for import fields
!
if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then
write(msg,'(a)') trim(cname)// &
': Creating import grid for Reg/Curvilinear Mode'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
call CreateImpGrid( gcomp, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
elseif (GTYPE.eq.UNGTYPE) then
write(msg,'(a)') trim(cname)// &
': Creating import mesh for Unstructured Mode'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
call CreateImpMesh( gcomp, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
!
! 1.b Create import fields and realize
!
n = 0
do i = 1,numImpFields
if (.not.impFieldActive(i)) cycle
n = n + 1
if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then
impField(i) = ESMF_FieldCreate( impGrid, impArraySpec2D, &
totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, &
staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, &
name=trim(impFieldName(i)), rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call FieldFill( impField(i), zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
elseif (GTYPE.eq.UNGTYPE) then
impField(i) = ESMF_FieldCreate( impMesh, &
typekind=ESMF_TYPEKIND_RX, name=trim(impFieldName(i)), rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call FieldFill( impField(i), zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
call NUOPC_Realize( impState, impField(i), rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then
if (.not.mbgFieldActive(i)) cycle
n = n + 1
mbgField(i) = ESMF_FieldCreate( impGrid, impArraySpec2D, &
totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, &
staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, &
name=trim(mbgFieldName(i)), rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call FieldFill( mbgField(i), zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call NUOPC_Realize( impState, mbgField(i), rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
bmskField(i) = ESMF_FieldCreate( impGrid, impArraySpec2D, &
totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, &
staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, &
name='bmsk_'//trim(impFieldName(i)), rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
enddo
!
! 1.c Report realized import fields
!
write(msg,'(a,i0,a)') trim(cname)// &
': List of realized import fields(',n,'):'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,a5,a,a10,a3,a)') trim(cname)// &
': ','index',' ','name',' ','standardName'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
n = 0
do i = 1,numImpFields
if (.not.impFieldActive(i)) cycle
n = n + 1
write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, &
' ',trim(impFieldName(i)),' ',trim(impFieldStdName(i))
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
if (.not.mbgFieldActive(i)) cycle
n = n + 1
write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, &
' ',trim(mbgFieldName(i)),' ',trim(mbgFieldStdName(i))
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
enddo
!
! -------------------------------------------------------------------- /
! 2. Realize active export fields
!
! 2.a Set connected export fields as active and remove unconnected
! If realizeAllExport, then set all fields as active and realize.
!
do i = 1,numExpFields
isConnected = NUOPC_IsConnected(expState, &
expFieldName(i), rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
expFieldActive(i) = isConnected .or. realizeAllExport
if (expFieldActive(i)) noActiveExpFields = .false.
if (.not.expFieldActive(i)) then
call ESMF_StateRemove(expState, (/expFieldName(i)/), rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
enddo
!
! 2.b Create ESMF grid for export fields
!
if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then
write(msg,'(a)') trim(cname)// &
': Creating export grid for Reg/Curvilinear Mode'
call CreateExpGrid( gcomp, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
elseif (GTYPE.eq.UNGTYPE) then
write(msg,'(a)') trim(cname)// &
': Creating export mesh for Unstructured Mode'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
call CreateExpMesh( gcomp, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
!
! 2.c Create active export fields and realize
!
n = 0
do i = 1,numExpFields
if (.not.expFieldActive(i)) cycle
n = n + 1
if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then
if ( expFieldDim(i).eq.3 ) then
expField(i) = ESMF_FieldCreate( expGrid, expArraySpec3D, &
totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, &
gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), &
staggerLoc=expStaggerLoc, name=trim(expFieldName(i)), rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
else
expField(i) = ESMF_FieldCreate( expGrid, expArraySpec2D, &
totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, &
staggerLoc=expStaggerLoc, name=trim(expFieldName(i)), rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
call FieldFill( expField(i), zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
elseif (GTYPE.eq.UNGTYPE) then
expField(i) = ESMF_FieldCreate( expMesh, &
typekind=ESMF_TYPEKIND_RX, name=trim(expFieldName(i)), rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call FieldFill( expField(i), zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
call NUOPC_Realize( expState, expField(i), rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
enddo
!
! 2.d Report realized export fields
!
write(msg,'(a,i0,a)') trim(cname)// &
': List of realized export fields(',n,'):'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,a5,a,a10,a3,a)') trim(cname)// &
': ','index',' ','name',' ','standardName'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
n = 0
do i = 1,numExpFields
if (.not.expFieldActive(i)) cycle
n = n + 1
write(msg,'(a,i5,a,a10,a3,a)') trim(cname)//': ',n, &
' ',trim(expFieldName(i)),' ',trim(expFieldStdName(i))
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
enddo
!
! 2.e Set W3OUTG flags needed for calculating export fields
!
#ifdef USE_W3OUTG_FOR_EXPORT
call w3seto ( expGridID, mdse, mdst )
i1 = FieldIndex( expFieldName, 'uscurr', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
i2 = FieldIndex( expFieldName, 'vscurr', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( expFieldActive(i1) .and. &
expFieldActive(i2) ) then
flogr2(6,8) = .true. !Spectrum of surface Stokes drift
if ( us3df(1) .le. 0 ) then
msg = trim(cname)//': Stokes drift export using W3OUTG'// &
' requires setting US3D=1 (ww3_grid.inp: OUTS namelist)'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
return
endif
endif
i1 = FieldIndex( expFieldName, 'wbcuru', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
i2 = FieldIndex( expFieldName, 'wbcurv', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
i3 = FieldIndex( expFieldName, 'wbcurp', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( expFieldActive(i1) .and. &
expFieldActive(i2) .and. &
expFieldActive(i3) ) then
flogr2(7,1) = .true. !Near bottom rms amplitudes
flogr2(7,2) = .true. !Near bottom rms velocities
endif
i1 = FieldIndex( expFieldName, 'wavsuu', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
i2 = FieldIndex( expFieldName, 'wavsuv', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
i3 = FieldIndex( expFieldName, 'wavsvv', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( expFieldActive(i1) .and. &
expFieldActive(i2) .and. &
expFieldActive(i3) ) then
flogr2(6,1) = .true. !Radiation stresses
endif
#endif
!
! -------------------------------------------------------------------- /
! Post
!
rc = ESMF_SUCCESS
call ESMF_VMWtime(wftime)
wtime(iwt) = wtime(iwt) + wftime - wstime
wtcnt(iwt) = wtcnt(iwt) + 1
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': leaving InitializeP3', ESMF_LOGMSG_INFO)
!/
!/ End of InitializeP3 ----------------------------------------------- /
!/
end subroutine InitializeP3
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "Finalize"
subroutine Finalize ( gcomp, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/ 09-Aug-2017 : Add clean up of local allocations ( version 6.03 )
!/
! 1. Purpose :
!
! Finalize wave model
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! gcomp Type I/O Gridded component
! rc Int. O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! WMFINL Subr. WMFINLMD Wave model finalization
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_GridComp) :: gcomp
integer,intent(out) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
integer, parameter :: iwt=6
real(8) :: wstime, wftime
integer :: i
!
! -------------------------------------------------------------------- /
! Prep
!
rc = ESMF_SUCCESS
call ESMF_VMWtime(wstime)
call ESMF_GridCompGet(gcomp, name=cname, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': entered Finalize', ESMF_LOGMSG_INFO)
!
! -------------------------------------------------------------------- /
! 1. Finalize the wave model
!
call wmfinl
!
! -------------------------------------------------------------------- /
! 2. Clean up ESMF data structures
!
! 2.a Import field and grid stuff
!
if ( .not.noActiveImpFields ) then
do i = 1,numImpFields
if (.not.impFieldActive(i)) cycle
call ESMF_FieldDestroy(impField(i), rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (.not.mbgFieldActive(i)) cycle
call ESMF_FieldDestroy(mbgField(i), rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy(bmskField(i), rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
enddo
if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then
call ESMF_FieldHaloRelease(impHaloRH, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_GridDestroy(impGrid, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
elseif (GTYPE.eq.UNGTYPE) then
!AW call ESMF_GridDestroy(impMesh, rc=rc)
!AW if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
endif
deallocate (impFieldName, &
impFieldStdName, &
impFieldInitRqrd, &
impFieldActive, &
impField, &
stat=rc)
if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return
deallocate (mbgFieldName, &
mbgFieldStdName, &
mbgFieldActive, &
mbgField, &
bmskField, &
stat=rc)
if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return
!
! 2.b Export field and grid stuff
!
if ( .not.noActiveExpFields ) then
do i = 1,numExpFields
if (.not.expFieldActive(i)) cycle
call ESMF_FieldDestroy(expField(i), rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
enddo
if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then
call ESMF_FieldHaloRelease(expHaloRH, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_GridDestroy(expGrid, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
elseif (GTYPE.eq.UNGTYPE) then
!AW call ESMF_GridDestroy(expMesh, rc=rc)
!AW if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
endif
deallocate (expFieldName, &
expFieldStdName, &
expFieldDim, &
expFieldActive, &
expField, &
stat=rc)
if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return
!
! 2.c Native field and grid stuff
!
if ( .not.noActiveExpFields ) then
call ESMF_FieldRedistRelease(n2eRH, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_GridDestroy(natGrid, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
!
! -------------------------------------------------------------------- /
! 3. Clean up locally allocated data structures
!
if (allocated(zl)) then
deallocate (zl, stat=rc)
if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return
endif
!
! -------------------------------------------------------------------- /
! Post
!
call ESMF_VMWtime(wftime)
wtime(iwt) = wtime(iwt) + wftime - wstime
wtcnt(iwt) = wtcnt(iwt) + 1
call PrintTimers(trim(cname), wtnam, wtcnt, wtime)
rc = ESMF_SUCCESS
if ( improc .eq. nmpscr ) write (*,999)
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': leaving Finalize', ESMF_LOGMSG_INFO)
!
! -------------------------------------------------------------------- /
! Formats
!
999 format(//' End of program '/ &
' ========================================'/ &
' WAVEWATCH III Multi-grid shell '/)
!/
!/ End of Finalize --------------------------------------------------- /
!/
end subroutine Finalize
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "DataInitialize"
subroutine DataInitialize ( gcomp, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 20-Jan-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/
! 1. Purpose :
!
! Initialize wave model export data
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! gcomp Type I/O Gridded component
! rc Int. O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! GetImport Subr. WMESMFMD Wave model get import fields
! SetExport Subr. WMESMFMD Wave model set export fields
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_GridComp) :: gcomp
integer,intent(out) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
integer, parameter :: iwt=4
real(8) :: wstime, wftime
type(ESMF_Clock) :: clock
type(ESMF_Time) :: currTime
logical :: fldUpdated, allUpdated
integer :: i, imod
logical :: local
!
! -------------------------------------------------------------------- /
! Prep
!
rc = ESMF_SUCCESS
call ESMF_VMWtime(wstime)
call ESMF_GridCompGet(gcomp, name=cname, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': entered DataInitialize', ESMF_LOGMSG_INFO)
!
! -------------------------------------------------------------------- /
! 1. Check that required import fields show correct time stamp
!
call ESMF_GridCompGet(gcomp, clock=clock, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_ClockGet(clock, currTime=currTime, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
allUpdated = .true.
do i = 1,numImpFields
if (.not.impFieldActive(i)) cycle
if (impFieldInitRqrd(i)) then
fldUpdated = NUOPC_IsAtTime(impField(i), currTime, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (fldUpdated) then
write(msg,'(a,a10,a,a13)') trim(cname)//': ', &
trim(impFieldName(i)),': inter-model data dependency: ', &
'SATISFIED'
else
allUpdated = .false.
write(msg,'(a,a10,a,a13)') trim(cname)//': ', &
trim(impFieldName(i)),': inter-model data dependency: ', &
'NOT SATISFIED'
endif
else
write(msg,'(a,a10,a,a13)') trim(cname)//': ', &
trim(impFieldName(i)),': inter-model data dependency: ', &
'NOT REQUIRED'
endif
if (verbosity.gt.0) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
if (improc.eq.nmpscr) write(*,'(a)') trim(msg)
! background
if (.not.mbgFieldActive(i)) cycle
if (impFieldInitRqrd(i)) then
fldUpdated = NUOPC_IsAtTime(mbgField(i), currTime, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (fldUpdated) then
write(msg,'(a,a10,a,a13)') trim(cname)//': ', &
trim(mbgFieldName(i)),': inter-model data dependency: ', &
'SATISFIED'
else
allUpdated = .false.
write(msg,'(a,a10,a,a13)') trim(cname)//': ', &
trim(mbgFieldName(i)),': inter-model data dependency: ', &
'NOT SATISFIED'
endif
else
write(msg,'(a,a10,a,a13)') trim(cname)//': ', &
trim(mbgFieldName(i)),': inter-model data dependency: ', &
'NOT REQUIRED'
endif
if (verbosity.gt.0) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
if (improc.eq.nmpscr) write(*,'(a)') trim(msg)
enddo
!
! If not all import dependencies are satisfied, then return
!
if (.not.allUpdated) goto 1
!
! -------------------------------------------------------------------- /
! 2. All import dependencies are satisfied, so finish initialization
!
! 2.a Report all import dependencies are satisfied
!
write(msg,'(a)') trim(cname)// &
': all inter-model data dependencies SATISFIED'
if (verbosity.gt.0) call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
if (improc.eq.nmpscr) write(*,'(a)') trim(msg)
!
! 2.b Setup background blending mask for each import field
!
do i = 1,numImpFields
if (.not.impFieldActive(i)) cycle
if (.not.mbgFieldActive(i)) cycle
call SetupImpBmsk(bmskField(i), impField(i), missingValue, rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
enddo
!
! 2.c Get import fields
!
call GetImport(gcomp, rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 2.d Finish initialization (compute initial state), if not restart
!
do imod = 1,nrgrd
call w3setg ( imod, mdse, mdst )
call w3setw ( imod, mdse, mdst )
call w3seta ( imod, mdse, mdst )
call w3seti ( imod, mdse, mdst )
call w3seto ( imod, mdse, mdst )
call wmsetm ( imod, mdse, mdst )
local = iaproc .gt. 0 .and. iaproc .le. naproc
if ( local .and. flcold .and. fliwnd ) call w3uini( va )
enddo
!
! 2.e Set export fields
!
!call SetExport(gcomp, rc)
!if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 2.f Set Updated Field Attribute to "true", indicating to the
! generic code to set the timestamp for these fields
!
!do i = 1,numExpFields
! if (.not.expFieldActive(i)) cycle
! call NUOPC_SetAttribute(expField(i), name="Updated", &
! value="true", rc=rc)
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
!enddo
!
! 2.g Set InitializeDataComplete Attribute to "true", indicating to the
! generic code that all inter-model data dependencies are satisfied
!
call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", &
value="true", rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! -------------------------------------------------------------------- /
! Post
!
1 rc = ESMF_SUCCESS
call ESMF_VMWtime(wftime)
wtime(iwt) = wtime(iwt) + wftime - wstime
wtcnt(iwt) = wtcnt(iwt) + 1
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': leaving DataInitialize', ESMF_LOGMSG_INFO)
!/
!/ End of DataInitialize --------------------------------------------- /
!/
end subroutine DataInitialize
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "ModelAdvance"
subroutine ModelAdvance ( gcomp, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 20-Jan-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/
! 1. Purpose :
!
! Advance wave model in time
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! gcomp Type I/O Gridded component
! rc Int. O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! GetImport Subr. WMESMFMD Wave model get import fields
! SetExport Subr. WMESMFMD Wave model set export fields
! WMWAVE Subr. WMWAVEMD Wave model run
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_GridComp) :: gcomp
integer,intent(out) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
integer, parameter :: iwt=5
real(8) :: wstime, wftime
integer :: stat, imod, tcur(2)
integer, allocatable :: tend(:,:)
integer(ESMF_KIND_I4) :: yy,mm,dd,h,m,s
type(ESMF_Clock) :: clock
type(ESMF_Time) :: currTime, stopTime
real :: delt
logical :: lerr
!
! -------------------------------------------------------------------- /
! Prep
!
rc = ESMF_SUCCESS
call ESMF_VMWtime(wstime)
call ESMF_GridCompGet(gcomp, name=cname, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': entered ModelAdvance', ESMF_LOGMSG_INFO)
allocate (tend(2,nrgrd), stat=rc)
if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return
!
! -------------------------------------------------------------------- /
! 1. Advance model to requested end time
!
! 1.a Get component clock
!
call ESMF_GridCompGet(gcomp, clock=clock, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 1.b Report
!
if ( improc .eq. nmpscr ) then
write(*,'(///)')
call ESMF_ClockPrint(clock, options="currTime", &
preString="-->Advancing "//TRIM(cname)//" from: ")
call ESMF_ClockPrint(clock, options="stopTime", &
preString="-----------------> to: ")
endif
!
! 1.c Check internal current time with component current time
!
call ESMF_ClockGet(clock, currTime=currTime, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_TimeGet(currTime, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
lerr=.false.
do imod = 1,nrgrd
tcur(1) = 10000*yy + 100*mm + dd
tcur(2) = 10000*h + 100*m + s
call w3setw ( imod, mdse, mdst )
delt = dsec21 ( time, tcur )
if ( abs(delt).gt.0 ) then
lerr=.true.
write(msg,'(a,i2,a,2(a,i8,a,i8,a))') &
'Wave model grid ',imod,': ', &
'Internal time (',time(1),'.',time(2),') /= ', &
'Component time (',tcur(1),'.',tcur(2),')'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR)
endif
enddo
if (lerr) then
rc = ESMF_FAILURE
return
endif
!
! 1.d Set end time of this advance
!
call ESMF_ClockGet(clock, stopTime=stopTime, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_TimeGet(stopTime, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
do imod = 1,nrgrd
tend(1,imod) = 10000*yy + 100*mm + dd
tend(2,imod) = 10000*h + 100*m + s
enddo
!
! 1.e Get import fields
!
call GetImport(gcomp, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 1.f Advance model
!
call wmwave ( tend )
!
! 1.g Set export fields
!
!call SetExport(gcomp, rc=rc)
!if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! -------------------------------------------------------------------- /
! Post
!
deallocate (tend, stat=rc)
if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return
rc = ESMF_SUCCESS
call ESMF_VMWtime(wftime)
wtime(iwt) = wtime(iwt) + wftime - wstime
wtcnt(iwt) = wtcnt(iwt) + 1
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': leaving ModelAdvance', ESMF_LOGMSG_INFO)
!/
!/ End of ModelAdvance ----------------------------------------------- /
!/
end subroutine ModelAdvance
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "GetImport"
subroutine GetImport ( gcomp, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 20-Jan-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/
! 1. Purpose :
!
! Get import fields and put in internal data structures
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! gcomp Type I/O Gridded component
! rc Int. O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
!/MPI USE WMMDATMD, ONLY: IMPROC
implicit none
type(ESMF_GridComp) :: gcomp
integer,intent(out) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
!AW ---TEST-TEST-TEST---------------------------
character(500) :: msg
integer :: k
!AW ---TEST-TEST-TEST---------------------------
integer, parameter :: iwt=7
real(8) :: wstime, wftime
integer :: i1, i2, i3, j, imod, jmod
logical, save :: firstCall = .true.
integer :: tcur(2), tend(2)
integer(ESMF_KIND_I4) :: yy,mm,dd,h,m,s
type(ESMF_Clock) :: clock
type(ESMF_Time) :: currTime, stopTime
#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_GETIMPORT)
type(ESMF_State) :: dumpState
integer, save :: timeSlice = 1
#endif
!
! -------------------------------------------------------------------- /
! Prep
!
rc = ESMF_SUCCESS
if ( noActiveImpFields ) return
call ESMF_VMWtime(wstime)
call ESMF_GridCompGet(gcomp, name=cname, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': entered GetImport', ESMF_LOGMSG_INFO)
#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_GETIMPORT)
call NUOPC_ModelGet(gcomp, importState=dumpState, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call NUOPC_Write(dumpState, overwrite=.true., &
fileNamePrefix="field_"//trim(cname)//"_import1_", &
timeslice=timeSlice, relaxedFlag=.true., rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
#endif
!
! -------------------------------------------------------------------- /
! Set time stamps using currTime and stopTime
!
call ESMF_GridCompGet(gcomp, clock=clock, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_ClockGet(clock, currTime=currTime, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_TimeGet(currTime, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
tcur(1) = 10000*yy + 100*mm + dd
tcur(2) = 10000*h + 100*m + s
call ESMF_ClockGet(clock, stopTime=stopTime, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_TimeGet(stopTime, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
tend(1) = 10000*yy + 100*mm + dd
tend(2) = 10000*h + 100*m + s
!!
!! -------------------------------------------------------------------- /
!! Water levels
!!
! j = 1
! i1 = FieldIndex( impFieldName, 'seahgt', rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! i2 = i1
! if ( impFieldActive(i1) ) then
! call w3setg ( impGridID, mdse, mdst )
! call w3seti ( impGridID, mdse, mdst )
! if (firstCall) then
! tln = tcur
! else
! tln = tend
! endif
! tfn(:,j) = tln
! if ( mbgFieldActive(i1) ) then
! call BlendImpField( impField(i1), mbgField(i1), bmskField(i1), rc=rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! endif
! call FieldGather( impField(i1), nx, ny, wlev, rc=rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! do imod = 1,nrgrd
! call w3setg ( imod, mdse, mdst )
! call w3setw ( imod, mdse, mdst )
! call w3seti ( imod, mdse, mdst )
! call w3seto ( imod, mdse, mdst )
! call wmsetm ( imod, mdse, mdst )
!!/MPI if ( mpi_comm_grd .eq. mpi_comm_null ) cycle
! jmod = inpmap(imod,j)
! if ( jmod.lt.0 .and. jmod.ne.-999 ) then
! call wmupd2( imod, j, jmod, rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! endif
! enddo
! endif
!!
!! -------------------------------------------------------------------- /
!! Currents
!!
! j = 2
! i1 = FieldIndex( impFieldName, 'uucurr', rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! i2 = FieldIndex( impFieldName, 'vvcurr', rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! if ( impFieldActive(i1) ) then
! call w3setg ( impGridID, mdse, mdst )
! call w3seti ( impGridID, mdse, mdst )
! if (firstCall) then
! tcn = tcur
! else
! tc0 = tcn
! cx0 = cxn
! cy0 = cyn
! tcn = tend
! endif
! tfn(:,j) = tcn
! if ( mbgFieldActive(i1) ) then
! call BlendImpField( impField(i1), mbgField(i1), bmskField(i1), rc=rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! call BlendImpField( impField(i2), mbgField(i2), bmskField(i2), rc=rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! endif
! call FieldGather( impField(i1), nx, ny, cxn, rc=rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! call FieldGather( impField(i2), nx, ny, cyn, rc=rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! if (firstCall) then
! tc0 = tcn
! cx0 = cxn
! cy0 = cyn
! endif
! do imod = 1,nrgrd
! call w3setg ( imod, mdse, mdst )
! call w3setw ( imod, mdse, mdst )
! call w3seti ( imod, mdse, mdst )
! call wmsetm ( imod, mdse, mdst )
!!/MPI if ( mpi_comm_grd .eq. mpi_comm_null ) cycle
! jmod = inpmap(imod,j)
! if ( jmod.lt.0 .and. jmod.ne.-999 ) then
! call wmupd2( imod, j, jmod, rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! endif
! enddo
! endif
!
! -------------------------------------------------------------------- /
! Winds
!
j = 3
i1 = FieldIndex( impFieldName, 'uutrue', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
i2 = FieldIndex( impFieldName, 'vvtrue', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( impFieldActive(i1) ) then
call w3setg ( impGridID, mdse, mdst )
call w3seti ( impGridID, mdse, mdst )
if (firstCall) then
twn = tcur
else
tw0 = twn
wx0 = wxn
wy0 = wyn
twn = tend
endif
tfn(:,j) = twn
if ( mbgFieldActive(i1) ) then
call BlendImpField( impField(i1), mbgField(i1), bmskField(i1), rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call BlendImpField( impField(i2), mbgField(i2), bmskField(i2), rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
call FieldGather( impField(i1), nx, ny, wxn, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call FieldGather( impField(i2), nx, ny, wyn, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (firstCall) then
tw0 = twn
wx0 = wxn
wy0 = wyn
!/WRST wxn = WXNwrst !replace with values from restart
!/WRST wyn = WYNwrst
!/WRST wx0 = WXNwrst
!/WRST wy0 = WYNwrst
!/WRST do imod = 1,nrgrd
!/WRST call w3setg ( imod, mdse, mdst )
!/WRST call w3setw ( imod, mdse, mdst )
!/WRST call w3seti ( imod, mdse, mdst )
!/WRST call wmsetm ( imod, mdse, mdst )
!/WRST if ( mpi_comm_grd .eq. mpi_comm_null ) cycle
!/WRST INPUTS(IMOD)%TW0(:) = INPUTS(impGridID)%TW0(:)
!/WRST INPUTS(IMOD)%TFN(:,3) = INPUTS(impGridID)%TFN(:,3)
!/WRST wxn = WXNwrst !replace with values from restart
!/WRST wyn = WYNwrst
!/WRST wx0 = WXNwrst
!/WRST wy0 = WYNwrst
!/WRST if (ESMF_LogFoundError(rc, PASSTHRU)) return
!/WRST enddo
!/WRST endif
!/WRST if ( ((twn(1)-tw0(1))*1000000+((twn(2)-tw0(2)))) .le. 0 ) then
!/WRST !If the time of the field is still initial time, replace
!/WRST !with restart field
!/WRST wxn = WXNwrst !replace with values from restart
!/WRST wyn = WYNwrst
!/WRST else !twn>tw0
do imod = 1,nrgrd
call w3setg ( imod, mdse, mdst )
call w3setw ( imod, mdse, mdst )
call w3seti ( imod, mdse, mdst )
call wmsetm ( imod, mdse, mdst )
!/MPI if ( mpi_comm_grd .eq. mpi_comm_null ) cycle
jmod = inpmap(imod,j)
if ( jmod.lt.0 .and. jmod.ne.-999 ) then
call wmupd2( imod, j, jmod, rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
enddo
!/WRST endif !if ( twn-tw0 .le. 0 )
endif
!!
!! -------------------------------------------------------------------- /
!! Sea ice concentration
!!
! j = 4
! i1 = FieldIndex( impFieldName, 'seaice', rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! i2 = i1
! if ( impFieldActive(i1) ) then
! call w3setg ( impGridID, mdse, mdst )
! call w3seti ( impGridID, mdse, mdst )
! if (firstCall) then
! tin = tcur
! else
! tin = tend
! endif
! tfn(:,j) = tin
! if ( mbgFieldActive(i1) ) then
! call BlendImpField( impField(i1), mbgField(i1), bmskField(i1), rc=rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! endif
! call FieldGather( impField(i1), nx, ny, icei, rc=rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! do imod = 1,nrgrd
! call w3setg ( imod, mdse, mdst )
! call w3setw ( imod, mdse, mdst )
! call w3seti ( imod, mdse, mdst )
! call wmsetm ( imod, mdse, mdst )
!!/MPI if ( mpi_comm_grd .eq. mpi_comm_null ) cycle
! jmod = inpmap(imod,j)
! if ( jmod.lt.0 .and. jmod.ne.-999 ) then
! call wmupd2( imod, j, jmod, rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! endif
! enddo
! endif
!
! -------------------------------------------------------------------- /
! Post
!
#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_GETIMPORT)
call NUOPC_Write(dumpState, overwrite=.true., &
fileNamePrefix="field_"//trim(cname)//"_import2_", &
timeslice=timeSlice, relaxedFlag=.true., rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
timeSlice = timeSlice + 1
#endif
firstCall = .false.
rc = ESMF_SUCCESS
call ESMF_VMWtime(wftime)
wtime(iwt) = wtime(iwt) + wftime - wstime
wtcnt(iwt) = wtcnt(iwt) + 1
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': leaving GetImport', ESMF_LOGMSG_INFO)
!/
!/ End of GetImport -------------------------------------------------- /
!/
end subroutine GetImport
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "SetExport"
subroutine SetExport ( gcomp, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/ 09-Aug-2017 : Add ocean forcing export fields ( version 6.03 )
!/
! 1. Purpose :
!
! Set export fields from internal data structures
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! gcomp Type I/O Gridded component
! rc Int. O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_GridComp) :: gcomp
integer,intent(out) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
integer, parameter :: iwt=8
real(8) :: wstime, wftime
integer :: i1, i2, i3
logical :: flpart = .false., floutg = .false., floutg2 = .true.
#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETEXPORT)
type(ESMF_State) :: dumpState
integer, save :: timeSlice = 1
#endif
!
! -------------------------------------------------------------------- /
! Prep
!
rc = ESMF_SUCCESS
if ( noActiveExpFields ) return
call ESMF_VMWtime(wstime)
call ESMF_GridCompGet(gcomp, name=cname, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': entered SetExport', ESMF_LOGMSG_INFO)
!
! -------------------------------------------------------------------- /
! Setup
!
call w3setg ( expGridID, mdse, mdst )
call w3setw ( expGridID, mdse, mdst )
call w3seta ( expGridID, mdse, mdst )
call w3seti ( expGridID, mdse, mdst )
call w3seto ( expGridID, mdse, mdst )
call wmsetm ( expGridID, mdse, mdst )
#ifdef USE_W3OUTG_FOR_EXPORT
if ( natGridIsLocal ) call w3outg( va, flpart, floutg, floutg2 )
#endif
!
! -------------------------------------------------------------------- /
! Charnock
!
i1 = FieldIndex( expFieldName, 'charno', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( expFieldActive(i1) ) then
call CalcCharnk( expField(i1), rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
!
! -------------------------------------------------------------------- /
! Surface Roughness
!
i1 = FieldIndex( expFieldName, 'z0rlen', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( expFieldActive(i1) ) then
call CalcRoughl( expField(i1), rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
!
! -------------------------------------------------------------------- /
! Stokes Drift 3D
!
i1 = FieldIndex( expFieldName, 'uscurr', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
i2 = FieldIndex( expFieldName, 'vscurr', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( expFieldActive(i1) .and. &
expFieldActive(i2) ) then
call CalcStokes3D( va, expField(i1), expField(i2), rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
!
! -------------------------------------------------------------------- /
! Bottom Currents
!
i1 = FieldIndex( expFieldName, 'wbcuru', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
i2 = FieldIndex( expFieldName, 'wbcurv', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
i3 = FieldIndex( expFieldName, 'wbcurp', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( expFieldActive(i1) .and. &
expFieldActive(i2) .and. &
expFieldActive(i3) ) then
call CalcBotcur( va, expField(i1), expField(i2), expField(i3), rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
!
! -------------------------------------------------------------------- /
! Radiation stresses 2D
!
i1 = FieldIndex( expFieldName, 'wavsuu', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
i2 = FieldIndex( expFieldName, 'wavsuv', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
i3 = FieldIndex( expFieldName, 'wavsvv', rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( expFieldActive(i1) .and. &
expFieldActive(i2) .and. &
expFieldActive(i3) ) then
call CalcRadstr2D( va, expField(i1), expField(i2), expField(i3), rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
!
! -------------------------------------------------------------------- /
! Post
!
#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETEXPORT)
call NUOPC_ModelGet(gcomp, exportState=dumpState, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call NUOPC_Write(dumpState, overwrite=.true., &
fileNamePrefix="field_"//trim(cname)//"_export_", &
timeslice=timeSlice, relaxedFlag=.true., rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
timeSlice = timeSlice + 1
#endif
rc = ESMF_SUCCESS
call ESMF_VMWtime(wftime)
wtime(iwt) = wtime(iwt) + wftime - wstime
wtcnt(iwt) = wtcnt(iwt) + 1
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': leaving SetExport', ESMF_LOGMSG_INFO)
!/
!/ End of SetExport -------------------------------------------------- /
!/
end subroutine SetExport
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "CreateImpGrid"
subroutine CreateImpGrid ( gcomp, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 20-Jan-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/
! 1. Purpose :
!
! Create ESMF grid for import fields
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! gcomp Type I/O Gridded component
! rc Int. O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_GridComp) :: gcomp
integer,intent(out) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
integer :: nproc, nxproc, nyproc
integer, parameter :: lde = 0
integer :: ldecnt
integer :: ix, iy, isea, jsea
integer :: elb(2), eub(2)
integer :: tlb(2), tub(2)
integer(ESMF_KIND_I4), pointer :: iptr(:,:)
real(ESMF_KIND_RX), pointer :: rptrx(:,:), rptry(:,:)
real(ESMF_KIND_RX), pointer :: rptr(:,:)
type(ESMF_Field) :: tmpField
!
! -------------------------------------------------------------------- /
! Prep
!
rc = ESMF_SUCCESS
if ( noActiveImpFields ) return
call ESMF_GridCompGet(gcomp, name=cname, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': entered CreateImpGrid', ESMF_LOGMSG_INFO)
!
! -------------------------------------------------------------------- /
! 1. Setup
!
! 1.a Set grid pointers
!
impGridID = minval(inpmap)
if ( impGridID.eq.-999 ) impGridID = 1
call w3setg ( impGridID, mdse, mdst )
call w3seti ( impGridID, mdse, mdst )
call w3seto ( impGridID, mdse, mdst )
if ( impGridID.gt.0 ) then
call wmsetm ( impGridID, mdse, mdst )
nproc = naproc
else
nproc = nmproc
endif
!
! 1.b Compute a 2D subdomain layout based on nproc
!
call CalcDecomp( nx, ny, nproc, impHaloWidth, .true., nxproc, nyproc, rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 1.c Set arraySpec, staggerLoc, and indexFlag for import fields
!
call ESMF_ArraySpecSet( impArraySpec2D, rank=2, &
typekind=ESMF_TYPEKIND_RX, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
impStaggerLoc = ESMF_STAGGERLOC_CENTER
impIndexFlag = ESMF_INDEX_GLOBAL
!
! -------------------------------------------------------------------- /
! 2. Create ESMF grid for import with 2D subdomain layout
! Note that the ESMF grid layout is dim1=X, dim2=Y
!
! 2.a Create ESMF import grid
!
select case (iclose)
case (iclose_none)
impGrid = ESMF_GridCreateNoPeriDim( &
minIndex=(/ 1, 1/), &
maxIndex=(/nx,ny/), &
coordDep1=(/1,2/), &
coordDep2=(/1,2/), &
regDecomp=(/nxproc,nyproc/), &
decompFlag=(/ESMF_DECOMP_BALANCED,ESMF_DECOMP_BALANCED/), &
coordTypeKind=ESMF_TYPEKIND_RX, &
coordSys=ESMF_COORDSYS_SPH_DEG, &
indexFlag=impIndexFlag, &
name=trim(cname)//"_import_grid", rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
case (iclose_smpl)
impGrid = ESMF_GridCreate1PeriDim( &
periodicDim=1, &
poleDim=2, &
poleKindFlag=(/ESMF_POLEKIND_NONE,ESMF_POLEKIND_NONE/), &
minIndex=(/ 1, 1/), &
maxIndex=(/nx,ny/), &
coordDep1=(/1,2/), &
coordDep2=(/1,2/), &
regDecomp=(/nxproc,nyproc/), &
decompFlag=(/ESMF_DECOMP_BALANCED,ESMF_DECOMP_BALANCED/), &
coordTypeKind=ESMF_TYPEKIND_RX, &
coordSys=ESMF_COORDSYS_SPH_DEG, &
indexFlag=impIndexFlag, &
name=trim(cname)//"_import_grid", rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
case default
write(msg,'(a,i1,a)') 'Index closure ',iclose, &
' not supported for import grid'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
return
endselect
!
! 2.b Add coordinate arrays and land/sea mask to import grid
!
call ESMF_GridAddCoord( impGrid, staggerLoc=impStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_GridAddItem( impGrid, ESMF_GRIDITEM_MASK, &
staggerLoc=impStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 2.c Set flag to indicate that this processor has local import grid storage
!
call ESMF_GridGet( impGrid, localDECount=ldecnt, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
impGridIsLocal = ldecnt.gt.0
!
! 2.d Get exclusive bounds (global index) for import grid
!
if ( impGridIsLocal ) then
call ESMF_GridGet( impGrid, impStaggerLoc, lde, &
exclusiveLBound=elb, exclusiveUBound=eub, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
!
! 2.e Set halo widths for import fields
!
if ( impGridIsLocal ) then
impHaloLWidth = (/impHaloWidth,impHaloWidth/)
impHaloUWidth = (/impHaloWidth,impHaloWidth/)
select case (iclose)
case (iclose_none)
if ( elb(1).eq.1 ) impHaloLWidth(1) = 0
if ( elb(2).eq.1 ) impHaloLWidth(2) = 0
if ( eub(1).eq.nx ) impHaloUWidth(1) = 0
if ( eub(2).eq.ny ) impHaloUWidth(2) = 0
case (iclose_smpl)
if ( elb(2).eq.1 ) impHaloLWidth(2) = 0
if ( eub(2).eq.ny ) impHaloUWidth(2) = 0
endselect
else
impHaloLWidth = (/0,0/)
impHaloUWidth = (/0,0/)
endif
!
! 2.f Set ESMF import grid coordinates
!
if ( impGridIsLocal ) then
call ESMF_GridGetCoord( impGrid, 1, localDE=lde, &
staggerLoc=impStaggerLoc, farrayPtr=rptrx, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_GridGetCoord( impGrid, 2, localDE=lde, &
staggerLoc=impStaggerLoc, farrayPtr=rptry, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptrx(ix,iy) = xgrd(iy,ix)
rptry(ix,iy) = ygrd(iy,ix)
enddo
enddo
endif
!
! 2.g Set ESMF import grid land/sea mask values.
! Land/sea mask is fixed in time and based on excluded points only.
!
if ( impGridIsLocal ) then
call ESMF_GridGetItem( impGrid, ESMF_GRIDITEM_MASK, localDE=lde, &
staggerLoc=impStaggerLoc, farrayPtr=iptr, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
if ( mapsta(iy,ix).ne.0 ) then
iptr(ix,iy) = maskValueWater
else
iptr(ix,iy) = maskValueLand
endif
enddo
enddo
endif
!
! -------------------------------------------------------------------- /
! 3. Create import field mask and routeHandle halo update
!
! 3.a Create field for import grid land/sea mask.
!
impMask = ESMF_FieldCreate( impGrid, impArraySpec2D, &
totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, &
staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, &
name='mask', rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 3.b Store import field halo routeHandle
!
call ESMF_FieldHaloStore( impMask, routeHandle=impHaloRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 3.c Set import field land/sea mask values and update halos
!
if ( impGridIsLocal ) then
call ESMF_FieldGet( impMask, localDE=lde, farrayPtr=rptr, &
totalLBound=tlb, totalUBound=tub, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptr(ix,iy) = iptr(ix,iy)
enddo
enddo
endif
call ESMF_FieldHalo( impMask, impHaloRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! -------------------------------------------------------------------- /
! Post
!
#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_CREATEIMPGRID)
write(msg,'(a,i6)') ' impGridID: ',impGridID
call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,l6)') 'impGridIsLocal: ',impGridIsLocal
call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' nx, ny: ',nx,ny
call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') 'naproc, nmproc: ',naproc,nmproc
call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,i6)') ' nproc: ',nproc
call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') 'nxproc, nyproc: ',nxproc,nyproc
call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' elb: ',elb(:)
call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' eub: ',eub(:)
call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' tlb: ',tlb(:)
call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' tub: ',tub(:)
call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' impHaloLWidth: ',impHaloLWidth(:)
call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' impHaloUWidth: ',impHaloUWidth(:)
call ESMF_LogWrite(trim(cname)//': CreateImpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
call ESMF_FieldWrite( impMask, &
"wmesmfmd_createimpgrid_import_mask.nc", overwrite=.true., rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
tmpField = ESMF_FieldCreate( impGrid, impArraySpec2D, &
totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, &
staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, &
name='temp', rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( impGridIsLocal ) then
call ESMF_FieldGet( tmpField, localDE=lde, farrayPtr=rptr, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
if ( impGridIsLocal ) then
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptr(ix,iy) = xgrd(iy,ix)
enddo
enddo
endif
call ESMF_FieldWrite( tmpField, &
"wmesmfmd_createimpgrid_import_xgrd.nc", overwrite=.true., rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( impGridIsLocal ) then
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptr(ix,iy) = ygrd(iy,ix)
enddo
enddo
endif
call ESMF_FieldWrite( tmpField, &
"wmesmfmd_createimpgrid_import_ygrd.nc", overwrite=.true., rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( impGridIsLocal ) then
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptr(ix,iy) = hpfac(iy,ix)
enddo
enddo
endif
call ESMF_FieldWrite( tmpField, &
"wmesmfmd_createimpgrid_import_hpfac.nc", overwrite=.true., rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( impGridIsLocal ) then
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptr(ix,iy) = hqfac(iy,ix)
enddo
enddo
endif
call ESMF_FieldWrite( tmpField, &
"wmesmfmd_createimpgrid_import_hqfac.nc", overwrite=.true., rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( impGridIsLocal ) then
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptr(ix,iy) = lpet
enddo
enddo
endif
call ESMF_FieldWrite( tmpField, &
"wmesmfmd_createimpgrid_import_dcomp.nc", overwrite=.true., rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy( tmpField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
#endif
!
rc = ESMF_SUCCESS
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': leaving CreateImpGrid', ESMF_LOGMSG_INFO)
!/
!/ End of CreateImpGrid ---------------------------------------------- /
!/
end subroutine CreateImpGrid
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "CreateExpGrid"
subroutine CreateExpGrid ( gcomp, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 20-Jan-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/
! 1. Purpose :
!
! Create ESMF grid for export fields
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! gcomp Type I/O Gridded component
! rc Int. O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! !/SHRD Switch for shared / distributed memory architecture.
! !/DIST Id.
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_GridComp) :: gcomp
integer,intent(out) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
integer :: nproc, nxproc, nyproc
integer, parameter :: lde = 0
integer :: ldecnt
integer :: ix, iy, isea, jsea, k
integer :: elb(2), eub(2)
integer :: tlb(2), tub(2)
integer(ESMF_KIND_I4), pointer :: iptr(:,:)
real(ESMF_KIND_RX), pointer :: rptrx(:,:), rptry(:,:)
real(ESMF_KIND_RX), pointer :: rptr(:,:)
integer :: arbIndexCount
integer, allocatable :: arbIndexList(:,:)
type(ESMF_Field) :: nField, eField
type(ESMF_Field) :: tmpField
!
! -------------------------------------------------------------------- /
! Prep
!
rc = ESMF_SUCCESS
if ( noActiveExpFields ) return
call ESMF_GridCompGet(gcomp, name=cname, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': entered CreateExpGrid', ESMF_LOGMSG_INFO)
!
! -------------------------------------------------------------------- /
! 1. Setup
!
! 1.a Set grid pointers
!
!TODO: only export from one grid
!expGridID set from config input (default = 1)
call w3setg ( expGridID, mdse, mdst )
call w3setw ( expGridID, mdse, mdst )
call w3seta ( expGridID, mdse, mdst )
call w3seti ( expGridID, mdse, mdst )
call w3seto ( expGridID, mdse, mdst )
call wmsetm ( expGridID, mdse, mdst )
natGridID = expGridID
nproc = naproc
!
! 1.b Compute a 2D subdomain layout based on nproc
!
call CalcDecomp( nx, ny, nproc, expHaloWidth, .true., nxproc, nyproc, rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 1.c Set arraySpec, staggerLoc, and indexFlag for export fields
!
call ESMF_ArraySpecSet( expArraySpec2D, rank=2, &
typekind=ESMF_TYPEKIND_RX, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_ArraySpecSet( expArraySpec3D, rank=3, &
typekind=ESMF_TYPEKIND_RX, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
expStaggerLoc = ESMF_STAGGERLOC_CENTER
expIndexFlag = ESMF_INDEX_GLOBAL
!
! 1.d Set arraySpec, staggerLoc, and indexFlag for native fields
!
call ESMF_ArraySpecSet( natArraySpec2D, rank=1, &
typekind=ESMF_TYPEKIND_RX, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_ArraySpecSet( natArraySpec3D, rank=2, &
typekind=ESMF_TYPEKIND_RX, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
natStaggerLoc = ESMF_STAGGERLOC_CENTER
natIndexFlag = ESMF_INDEX_DELOCAL
!
! 1.e Get z-levels for 3D export fields
!
call GetZlevels( rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
write(msg,'(a)') 'input z-level file: '//trim(zlfile)
call ESMF_LogWrite(trim(cname)//': '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a)') 'table of z-levels'
call ESMF_LogWrite(trim(cname)//': '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a)') ' index z'
call ESMF_LogWrite(trim(cname)//': '//trim(msg), ESMF_LOGMSG_INFO)
do k=1,nz
write(msg,'(i8,1f10.2)') k, zl(k)
call ESMF_LogWrite(trim(cname)//': '//trim(msg), ESMF_LOGMSG_INFO)
enddo
!
! -------------------------------------------------------------------- /
! 2. Create ESMF grid for export with 2D subdomain layout
! Note that the ESMF grid layout is dim1=X, dim2=Y
!
! 2.a Create ESMF export grid
!
select case (iclose)
case (iclose_none)
expGrid = ESMF_GridCreateNoPeriDim( &
minIndex=(/ 1, 1/), &
maxIndex=(/nx,ny/), &
coordDep1=(/1,2/), &
coordDep2=(/1,2/), &
regDecomp=(/nxproc,nyproc/), &
decompFlag=(/ESMF_DECOMP_BALANCED,ESMF_DECOMP_BALANCED/), &
coordTypeKind=ESMF_TYPEKIND_RX, &
coordSys=ESMF_COORDSYS_SPH_DEG, &
indexFlag=expIndexFlag, &
name=trim(cname)//"_export_grid", rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
case (iclose_smpl)
expGrid = ESMF_GridCreate1PeriDim( &
periodicDim=1, &
poleDim=2, &
poleKindFlag=(/ESMF_POLEKIND_NONE,ESMF_POLEKIND_NONE/), &
minIndex=(/ 1, 1/), &
maxIndex=(/nx,ny/), &
coordDep1=(/1,2/), &
coordDep2=(/1,2/), &
regDecomp=(/nxproc,nyproc/), &
decompFlag=(/ESMF_DECOMP_BALANCED,ESMF_DECOMP_BALANCED/), &
coordTypeKind=ESMF_TYPEKIND_RX, &
coordSys=ESMF_COORDSYS_SPH_DEG, &
indexFlag=expIndexFlag, &
name=trim(cname)//"_export_grid", rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
case default
write(msg,'(a,i1,a)') 'Index closure ',iclose, &
' not supported for export grid'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
return
endselect
!
! 2.b Add coordinate arrays and land/sea mask to export grid
!
call ESMF_GridAddCoord( expGrid, staggerLoc=expStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_GridAddItem( expGrid, ESMF_GRIDITEM_MASK, &
staggerLoc=expStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 2.c Set flag to indicate that this processor has local export grid storage
!
call ESMF_GridGet( expGrid, localDECount=ldecnt, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
expGridIsLocal = ldecnt.gt.0
!
! 2.d Get exclusive bounds (global index) for export grid
!
if ( expGridIsLocal ) then
call ESMF_GridGet( expGrid, expStaggerLoc, lde, &
exclusiveLBound=elb, exclusiveUBound=eub, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
!
! 2.e Set halo widths for export fields
!
if ( expGridIsLocal ) then
expHaloLWidth = (/expHaloWidth,expHaloWidth/)
expHaloUWidth = (/expHaloWidth,expHaloWidth/)
select case (iclose)
case (iclose_none)
if ( elb(1).eq.1 ) expHaloLWidth(1) = 0
if ( elb(2).eq.1 ) expHaloLWidth(2) = 0
if ( eub(1).eq.nx ) expHaloUWidth(1) = 0
if ( eub(2).eq.ny ) expHaloUWidth(2) = 0
case (iclose_smpl)
if ( elb(2).eq.1 ) expHaloLWidth(2) = 0
if ( eub(2).eq.ny ) expHaloUWidth(2) = 0
endselect
else
expHaloLWidth = (/0,0/)
expHaloUWidth = (/0,0/)
endif
!
! 2.f Set ESMF export grid coordinate
!
if ( expGridIsLocal ) then
call ESMF_GridGetCoord( expGrid, 1, localDE=lde, &
staggerLoc=expStaggerLoc, farrayPtr=rptrx, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_GridGetCoord( expGrid, 2, localDE=lde, &
staggerLoc=expStaggerLoc, farrayPtr=rptry, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptrx(ix,iy) = xgrd(iy,ix)
rptry(ix,iy) = ygrd(iy,ix)
enddo
enddo
endif
!
! 2.g Set ESMF export grid land/sea mask values.
! Land/sea mask is fixed in time and based on excluded points only.
!
if ( expGridIsLocal ) then
call ESMF_GridGetItem( expGrid, ESMF_GRIDITEM_MASK, localDE=lde, &
staggerLoc=expStaggerLoc, farrayPtr=iptr, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
if ( mapsta(iy,ix).ne.0 ) then
iptr(ix,iy) = maskValueWater
else
iptr(ix,iy) = maskValueLand
endif
enddo
enddo
endif
!
! -------------------------------------------------------------------- /
! 3. Create export field mask and routeHandle halo update
!
! 3.a Create field for export grid land/sea mask.
!
expMask = ESMF_FieldCreate( expGrid, expArraySpec2D, &
totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, &
staggerLoc=expStaggerLoc, indexFlag=expIndexFlag, &
name='mask', rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 3.b Store export field halo routeHandle
!
call ESMF_FieldHaloStore( expMask, routeHandle=expHaloRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 3.c Set export field land/sea mask values and update halos
!
if ( expGridIsLocal ) then
call ESMF_FieldGet( expMask, localDE=lde, farrayPtr=rptr, &
totalLBound=tlb, totalUBound=tub, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptr(ix,iy) = iptr(ix,iy)
enddo
enddo
endif
call ESMF_FieldHalo( expMask, expHaloRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! -------------------------------------------------------------------- /
! 4. Create ESMF grid with arbitrary domain decomposition to match
! the native domain decomposition of the non-excluded points
! Note that the native grid layout is dim1=X, dim2=Y
! Note that coordinates and mask are not needed since this
! grid is only used to define fields for a redist operation
!
! 4.a Set flag to indicate that this processor has local native grid storage
!
natGridIsLocal = iaproc .gt. 0 .and. iaproc .le. naproc
!
! 4.b Setup arbitrary sequence index list
!
do ipass = 1,2
if (ipass.eq.2) then
allocate (arbIndexList(arbIndexCount,2), stat=rc)
if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return
endif
arbIndexCount = 0
! list local native grid non-excluded points
if ( natGridIsLocal ) then
do jsea = 1,nseal
!/DIST isea = iaproc + (jsea-1)*naproc
!/SHRD isea = jsea
arbIndexCount = arbIndexCount+1
if (ipass.eq.2) then
ix = mapsf(isea,1)
iy = mapsf(isea,2)
! native grid layout: dim1=X, dim2=Y
arbIndexList(arbIndexCount,1) = ix
arbIndexList(arbIndexCount,2) = iy
endif
enddo
endif
! list local export grid excluded points
if ( expGridIsLocal ) then
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
if ( mapsta(iy,ix).ne.0 ) cycle ! skip non-excluded point
arbIndexCount = arbIndexCount+1
if (ipass.eq.2) then
! native grid layout: dim1=X, dim2=Y
arbIndexList(arbIndexCount,1) = ix
arbIndexList(arbIndexCount,2) = iy
endif
enddo
enddo
endif
enddo !ipass
!
! 4.c Create ESMF native grid
!
select case (iclose)
case (iclose_none)
natGrid = ESMF_GridCreateNoPeriDim( &
minIndex=(/ 1, 1/), &
maxIndex=(/nx,ny/), &
coordDep1=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), &
coordDep2=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), &
arbIndexCount=arbIndexCount, &
arbIndexList=arbIndexList, &
coordTypeKind=ESMF_TYPEKIND_RX, &
coordSys=ESMF_COORDSYS_SPH_DEG, &
name=trim(cname)//"_native_grid", rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
case (iclose_smpl)
natGrid = ESMF_GridCreate1PeriDim( &
periodicDim=1, &
poleDim=2, &
poleKindFlag=(/ESMF_POLEKIND_NONE,ESMF_POLEKIND_NONE/), &
minIndex=(/ 1, 1/), &
maxIndex=(/nx,ny/), &
coordDep1=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), &
coordDep2=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), &
arbIndexCount=arbIndexCount, &
arbIndexList=arbIndexList, &
coordTypeKind=ESMF_TYPEKIND_RX, &
coordSys=ESMF_COORDSYS_SPH_DEG, &
name=trim(cname)//"_native_grid", rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
case default
write(msg,'(a,i1,a)') 'Index closure ',iclose, &
' not supported for native grid'
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
return
endselect
!
! 4.d Deallocate arbitrary sequence index list
!
deallocate (arbIndexList, stat=rc)
if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return
!
! -------------------------------------------------------------------- /
! 5. Create route handle for redist between native grid domain
! decomposition and the export grid domain decomposition
!
! 5.a Create temporary fields
!
nField = ESMF_FieldCreate( natGrid, natArraySpec2D, &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
eField = ESMF_FieldCreate( expGrid, expArraySpec2D, &
totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, &
staggerLoc=expStaggerLoc, indexFlag=expIndexFlag, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 5.b Store route handle
!
call ESMF_FieldRedistStore( nField, eField, n2eRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 5.c Clean up
!
call ESMF_FieldDestroy( nField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy( eField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! -------------------------------------------------------------------- /
! Post
!
#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_CREATEEXPGRID)
write(msg,'(a,i6)') ' expGridID: ',expGridID
call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,l6)') 'expGridIsLocal: ',expGridIsLocal
call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' nx, ny: ',nx,ny
call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') 'naproc, nmproc: ',naproc,nmproc
call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,i6)') ' nproc: ',nproc
call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') 'nxproc, nyproc: ',nxproc,nyproc
call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' elb: ',elb(:)
call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' eub: ',eub(:)
call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' tlb: ',tlb(:)
call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' tub: ',tub(:)
call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' expHaloLWidth: ',expHaloLWidth(:)
call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
write(msg,'(a,2i6)') ' expHaloUWidth: ',expHaloUWidth(:)
call ESMF_LogWrite(trim(cname)//': CreateExpGrid: '//trim(msg), ESMF_LOGMSG_INFO)
call ESMF_FieldWrite( expMask, &
"wmesmfmd_createexpgrid_export_mask.nc", overwrite=.true., rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
tmpField = ESMF_FieldCreate( expGrid, expArraySpec2D, &
totalLWidth=expHaloLWidth, totalUWidth=expHaloUWidth, &
staggerLoc=expStaggerLoc, indexFlag=expIndexFlag, &
name='temp', rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( expGridIsLocal ) then
call ESMF_FieldGet( tmpField, localDE=lde, farrayPtr=rptr, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
if ( expGridIsLocal ) then
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptr(ix,iy) = xgrd(iy,ix)
enddo
enddo
endif
call ESMF_FieldWrite( tmpField, &
"wmesmfmd_createexpgrid_export_xgrd.nc", overwrite=.true., rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( expGridIsLocal ) then
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptr(ix,iy) = ygrd(iy,ix)
enddo
enddo
endif
call ESMF_FieldWrite( tmpField, &
"wmesmfmd_createexpgrid_export_ygrd.nc", overwrite=.true., rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( expGridIsLocal ) then
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptr(ix,iy) = hpfac(iy,ix)
enddo
enddo
endif
call ESMF_FieldWrite( tmpField, &
"wmesmfmd_createexpgrid_export_hpfac.nc", overwrite=.true., rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( expGridIsLocal ) then
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptr(ix,iy) = hqfac(iy,ix)
enddo
enddo
endif
call ESMF_FieldWrite( tmpField, &
"wmesmfmd_createexpgrid_export_hqfac.nc", overwrite=.true., rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( expGridIsLocal ) then
do iy = elb(2),eub(2)
do ix = elb(1),eub(1)
rptr(ix,iy) = lpet
enddo
enddo
endif
call ESMF_FieldWrite( tmpField, &
"wmesmfmd_createexpgrid_export_dcomp.nc", overwrite=.true., rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy( tmpField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
#endif
!
rc = ESMF_SUCCESS
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': leaving CreateExpGrid', ESMF_LOGMSG_INFO)
!/
!/ End of CreateExpGrid ---------------------------------------------- /
!/
end subroutine CreateExpGrid
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "CreateImpMesh"
subroutine CreateImpMesh ( gcomp, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | A. J. van der Westhuysen |
!/ | FORTRAN 90 |
!/ | Last update : 28-FEB_2018 |
!/ +-----------------------------------+
!/
!/ 28-Feb-2018 : Origination. ( version 6.06 )
!/
! 1. Purpose :
!
! Create ESMF mesh (unstructured) for import fields
!
! 2. Method :
!
! Create an ESMF Mesh for import using the unstructured mesh description
! in W3GDATMD. At present, this import mesh is not domain decomposed,
! but instead is defined on PET 0 only. (In future, when the unstructured
! mesh will run on domain decomposition, we will use that decomposition.)
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! gcomp Type I/O Gridded component
! rc Int. O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/PDLIB use yowNodepool, only: npa, iplg, nodes_global
!/PDLIB use yowElementpool, only: ne, ielg, INE
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_GridComp) :: gcomp
integer,intent(out) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
character(128) :: msg
integer :: nproc, nxproc, nyproc, n, nfac, irp
real :: gr, rp, pr, diff
integer, parameter :: lde = 0
integer :: ldecnt
integer :: i, j, pos, ix, iy
integer(ESMF_KIND_I4), pointer :: iptr(:,:)
real(ESMF_KIND_RX), pointer :: rptrx(:,:), rptry(:,:)
real(ESMF_KIND_RX), pointer :: rptr(:,:)
type(ESMF_Field) :: tmpField
integer(ESMF_KIND_I4), allocatable :: nodeIds(:)
real(ESMF_KIND_R8), allocatable :: nodeCoords(:)
integer(ESMF_KIND_I4), allocatable :: nodeOwners(:)
integer(ESMF_KIND_I4), allocatable :: elemIds(:)
integer(ESMF_KIND_I4), allocatable :: elemTypes(:)
integer(ESMF_KIND_I4), allocatable :: elemConn(:)
!
! -------------------------------------------------------------------- /
! Prep
!
rc = ESMF_SUCCESS
if ( noActiveImpFields ) return
call ESMF_GridCompGet(gcomp, name=cname, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': entered CreateImpMesh', ESMF_LOGMSG_INFO)
!
! -------------------------------------------------------------------- /
! 1. Setup
!
! 1.a Set grid pointers
!
impGridID = minval(inpmap)
if ( impGridID.eq.-999 ) impGridID = 1
call w3setg ( impGridID, mdse, mdst )
call w3seti ( impGridID, mdse, mdst )
call w3seto ( impGridID, mdse, mdst )
if ( impGridID.gt.0 ) then
call wmsetm ( impGridID, mdse, mdst )
nproc = naproc
else
nproc = nmproc
endif
!
! 1.b Set arraySpec, staggerLoc, and indexFlag for import fields
!
! call ESMF_ArraySpecSet( impArraySpec2D, rank=2, &
! typekind=ESMF_TYPEKIND_RX, rc=rc )
! if (ESMF_LogFoundError(rc, PASSTHRU)) return
! impStaggerLoc = ESMF_STAGGERLOC_CENTER
! impIndexFlag = ESMF_INDEX_GLOBAL
!
! -------------------------------------------------------------------- /
! 2. Create ESMF mesh for import, currently without domain decomposition
! Note that the ESMF grid layout is dim1=X, dim2=Y
!
! 2.a Create ESMF import mesh
!
! Allocate and fill the node id array.
!/PDLIB if ( LPDLIB == .FALSE. ) then
allocate(nodeIds(NX))
do i = 1,NX
nodeIds(i)=i
enddo
!/PDLIB else
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! ESMF Definition: The global id's of the nodes resident on this processor
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! Allocate global node ids, including ghost nodes (npa=np+ng)
!/PDLIB allocate(nodeIds(npa))
!/PDLIB do i = 1,npa
!/PDLIB nodeIds(i)=iplg(i)
!/PDLIB enddo
!/PDLIB endif
!/PDLIB!
!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeIds=', &
!/PDLIB! ESMF_LOGMSG_INFO)
!/PDLIB! do i = 1,npa
!/PDLIB! write(msg,*) trim(cname)//': nodeIds(i)',i, &
!/PDLIB! ' ',nodeIds(i)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB! enddo
! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeIds=', &
! ESMF_LOGMSG_INFO)
! do i = 1,NX
! write(msg,*) trim(cname)//': ',i, &
! ' ',nodeIds(i)
! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
! enddo
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
!/PDLIB if ( LPDLIB == .FALSE. ) then
allocate(nodeCoords(2*NX))
do i = 1,NX
do j = 1,2
pos=2*(i-1)+j
nodeCoords(pos)=XYB(i,j)
enddo
enddo
!/PDLIB else
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! ESMF Definition: Physical coordinates of the nodes
!/PDLIB! -------------------------------------------------------------------
!/PDLIB allocate(nodeCoords(2*npa))
!/PDLIB do i = 1,npa
!/PDLIB do j = 1,2
!/PDLIB pos=2*(i-1)+j
!/PDLIB nodeCoords(pos)=XYB(iplg(i),j)
!/PDLIB enddo
!/PDLIB enddo
!/PDLIB endif
!/PDLIB!
!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeCoords=', &
!/PDLIB! ESMF_LOGMSG_INFO)
!/PDLIB! do i = 1,(2*npa)
!/PDLIB! write(msg,*) trim(cname)//': nodeCoords(i)',i, &
!/PDLIB! ' ',nodeCoords(i)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB! enddo
! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeCoords=', &
! ESMF_LOGMSG_INFO)
! do i = 1,(2*NX)
! write(msg,*) trim(cname)//': ',i, &
! ' ',nodeCoords(i)
! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
! enddo
! Allocate and fill the node owner array.
! Since this mesh is all on PET 0, it’s just set to all 0.
!/PDLIB if ( LPDLIB == .FALSE. ) then
allocate(nodeOwners(NX))
nodeOwners=0 ! everything on PET 0
!/PDLIB else
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! ESMF Definition: Processor that owns the node
!/PDLIB! -------------------------------------------------------------------
!/PDLIB allocate(nodeOwners(npa))
!/PDLIB nodeOwners=nodes_global(iplg(1:npa))%domainID-1
!/PDLIB endif
!/PDLIB!
!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeOwners=', &
!/PDLIB! ESMF_LOGMSG_INFO)
!/PDLIB! do i = 1,npa
!/PDLIB! write(msg,*) trim(cname)//': nodeOwners(i)',i, &
!/PDLIB! ' ',nodeOwners(i)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB! enddo
! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeOwners=', &
! ESMF_LOGMSG_INFO)
! do i = 1,NX
! write(msg,*) trim(cname)//': ',i, &
! ' ',nodeOwners(i)
! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
! enddo
! Allocate and fill the element id array.
!/PDLIB if ( LPDLIB == .FALSE. ) then
allocate(elemIds(NTRI))
do i = 1,NTRI
elemIds(i)=i
enddo
!/PDLIB else
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! ESMF Definition: The global id's of the elements resident on this processor
!/PDLIB! -------------------------------------------------------------------
!/PDLIB allocate(elemIds(ne))
!/PDLIB do i = 1,ne
!/PDLIB elemIds(i)=ielg(i)
!/PDLIB enddo
!/PDLIB endif
!/PDLIB!
!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemIds=', &
!/PDLIB! ESMF_LOGMSG_INFO)
!/PDLIB! do i = 1,ne
!/PDLIB! write(msg,*) trim(cname)//': elemIds(i)',i, &
!/PDLIB! ' ',elemIds(i)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB! enddo
! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemIds=', &
! ESMF_LOGMSG_INFO)
! do i = 1,NTRI
! write(msg,*) trim(cname)//': ',i, &
! ' ',elemIds(i)
! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
! enddo
! Allocate and fill the element topology type array.
!/PDLIB if ( LPDLIB == .FALSE. ) then
allocate(elemTypes(NTRI))
do i = 1,NTRI
elemTypes(i)=ESMF_MESHELEMTYPE_TRI
enddo
!/PDLIB else
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! ESMF Definition: Topology of the given element (one of ESMF_MeshElement)
!/PDLIB! -------------------------------------------------------------------
!/PDLIB allocate(elemTypes(ne))
!/PDLIB do i = 1,ne
!/PDLIB elemTypes(i)=ESMF_MESHELEMTYPE_TRI
!/PDLIB enddo
!/PDLIB endif
!/PDLIB!
!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateImpM, elemTypes=', &
!/PDLIB! ESMF_LOGMSG_INFO)
!/PDLIB! do i = 1,ne
!/PDLIB! write(msg,*) trim(cname)//': elemTypes(i)',i, &
!/PDLIB! ' ',elemTypes(i)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB! enddo
! call ESMF_LogWrite(trim(cname)//': In CreateImpM, elemTypes=', &
! ESMF_LOGMSG_INFO)
! do i = 1,NTRI
! write(msg,*) trim(cname)//': ',i, &
! ' ',elemTypes(i)
! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
! enddo
! Allocate and fill the element connection type array.
!/PDLIB if ( LPDLIB == .FALSE. ) then
allocate(elemConn(3*NTRI))
do i = 1,NTRI
do j = 1,3
pos=3*(i-1)+j
elemConn(pos)=TRIGP(i,j)
enddo
enddo
!/PDLIB else
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! ESMF Definition: Connectivity table. The number of entries should
!/PDLIB! be equal to the number of nodes in the given topology. The indices
!/PDLIB! should be the local index (1 based) into the array of nodes that
!/PDLIB! was declared with MeshAddNodes.
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! > INE is local element array. it stores the local node IDs
!/PDLIB! > first index from 1 to 3.
!/PDLIB! > second index from 1 to ne.
!/PDLIB allocate(elemConn(3*ne))
!/PDLIB do i = 1,ne
!/PDLIB do j = 1,3
!/PDLIB pos=3*(i-1)+j
!/PDLIB elemConn(pos)=INE(j,i)
!/PDLIB enddo
!/PDLIB enddo
!/PDLIB endif
!/PDLIB!
!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemConn=', &
!/PDLIB! ESMF_LOGMSG_INFO)
!/PDLIB! do i = 1,(3*ne)
!/PDLIB! write(msg,*) trim(cname)//': elemConn(i)',i, &
!/PDLIB! ' ',elemConn(i)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB! enddo
! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemConn=', &
! ESMF_LOGMSG_INFO)
! do i = 1,(3*NTRI)
! write(msg,*) trim(cname)//': ',i, &
! ' ',elemConn(i)
! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
! enddo
impMesh = ESMF_MeshCreate( parametricDim=2,spatialDim=2, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, &
rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, created impMesh', &
ESMF_LOGMSG_INFO)
!
rc = ESMF_SUCCESS
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': leaving CreateImpMesh', ESMF_LOGMSG_INFO)
!/
!/ End of CreateImpMesh ---------------------------------------------- /
!/
end subroutine CreateImpMesh
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "CreateExpMesh"
subroutine CreateExpMesh ( gcomp, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | A. J. van der Westhuysen |
!/ | FORTRAN 90 |
!/ | Last update : 28-FEB-2018 |
!/ +-----------------------------------+
!/
!/ 28-Feb-2018 : Origination. ( version 6.06 )
!/
! 1. Purpose :
!
! Create ESMF mesh (unstructured) for export fields
!
! 2. Method :
!
! Create an ESMF Mesh for export using the unstructured mesh description
! in W3GDATMD. At present, this export mesh is not domain decomposed,
! but instead is defined on PET 0 only. (In future, when the unstructured
! mesh will run on domain decomposition, we will use that decomposition.)
!
! Since the internal parallel data is currently stored accross grid points
! in a "card deck" fashion, we will define an intermediate native grid, as
! is done for regular/curvilinear grids, and perform an ESMF regrid to the
! export mesh. This code segment is taken from T. J. Campbell, and
! modified to 1D, because the internal data structure for unstructred
! meshes is an array with dimensions [NX,NY=1].
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! gcomp Type I/O Gridded component
! rc Int. O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! !/SHRD Switch for shared / distributed memory architecture.
! !/DIST Id.
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/PDLIB use yowNodepool, only: npa, iplg, nodes_global
!/PDLIB use yowElementpool, only: ne, ielg, INE
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_GridComp) :: gcomp
integer,intent(out) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
character(128) :: msg
integer :: nproc, nxproc, nyproc, n, nfac, irp
real :: gr, rp, pr, diff
integer, parameter :: lde = 0
integer :: ldecnt
integer :: i, j, pos, ix, iy, isea, jsea, iproc
integer :: elb(2), eub(2)
integer(ESMF_KIND_I4), pointer :: iptr(:,:)
real(ESMF_KIND_RX), pointer :: rptrx(:,:), rptry(:,:)
real(ESMF_KIND_RX), pointer :: rptr(:,:)
integer :: arbIndexCount
integer, allocatable :: arbIndexList(:,:)
type(ESMF_Field) :: nField, eField
type(ESMF_Field) :: tmpField
integer(ESMF_KIND_I4), allocatable :: nodeIds(:)
real(ESMF_KIND_R8), allocatable :: nodeCoords(:)
integer(ESMF_KIND_I4), allocatable :: nodeOwners(:)
integer(ESMF_KIND_I4), allocatable :: elemIds(:)
integer(ESMF_KIND_I4), allocatable :: elemTypes(:)
integer(ESMF_KIND_I4), allocatable :: elemConn(:)
!
! -------------------------------------------------------------------- /
! Prep
!
rc = ESMF_SUCCESS
if ( noActiveExpFields ) return
call ESMF_GridCompGet(gcomp, name=cname, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': entered CreateExpMesh', ESMF_LOGMSG_INFO)
!
! -------------------------------------------------------------------- /
! Set flag to indicate that this processor has local native grid storage
!
natGridIsLocal = iaproc .gt. 0 .and. iaproc .le. naproc
! 1. Setup
!
! 1.a Set grid pointers
!
expGridID = 1 !TODO: only export from grid 1
call w3setg ( expGridID, mdse, mdst )
call w3setw ( expGridID, mdse, mdst )
call w3seta ( expGridID, mdse, mdst )
call w3seti ( expGridID, mdse, mdst )
call w3seto ( expGridID, mdse, mdst )
call wmsetm ( expGridID, mdse, mdst )
natGridID = expGridID
nproc = naproc
!
! 1.b Set arraySpec, staggerLoc, and indexFlag for native fields.
! NOTE: For unstructured meshes the native grid is a 1D array (NY=1)
!
call ESMF_ArraySpecSet( natArraySpec1D, rank=1, &
typekind=ESMF_TYPEKIND_RX, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
natStaggerLoc = ESMF_STAGGERLOC_CENTER
natIndexFlag = ESMF_INDEX_DELOCAL
!
! -------------------------------------------------------------------- /
! 2. Create ESMF mesh for export
!
! 2.a Create ESMF export mesh
!
! Allocate and fill the node id array.
!/PDLIB if ( LPDLIB == .FALSE. ) then
allocate(nodeIds(NX))
do i = 1,NX
nodeIds(i)=i
enddo
!/PDLIB else
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! ESMF Definition: The global id's of the nodes resident on this processor
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! Allocate global node ids, including ghost nodes (npa=np+ng)
!/PDLIB allocate(nodeIds(npa))
!/PDLIB do i = 1,npa
!/PDLIB nodeIds(i)=iplg(i)
!/PDLIB enddo
!/PDLIB endif
!/PDLIB!
!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeIds=', &
!/PDLIB! ESMF_LOGMSG_INFO)
!/PDLIB! do i = 1,npa
!/PDLIB! write(msg,*) trim(cname)//': nodeIds(i)',i, &
!/PDLIB! ' ',nodeIds(i)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB! enddo
! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeIds=', &
! ESMF_LOGMSG_INFO)
! do i = 1,NX
! write(msg,*) trim(cname)//': ',i, &
! ' ',nodeIds(i)
! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
! enddo
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
!/PDLIB if ( LPDLIB == .FALSE. ) then
allocate(nodeCoords(2*NX))
do i = 1,NX
do j = 1,2
pos=2*(i-1)+j
nodeCoords(pos)=XYB(i,j)
enddo
enddo
!/PDLIB else
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! ESMF Definition: Physical coordinates of the nodes
!/PDLIB! -------------------------------------------------------------------
!/PDLIB allocate(nodeCoords(2*npa))
!/PDLIB do i = 1,npa
!/PDLIB do j = 1,2
!/PDLIB pos=2*(i-1)+j
!/PDLIB nodeCoords(pos)=XYB(iplg(i),j)
!/PDLIB enddo
!/PDLIB enddo
!/PDLIB endif
!/PDLIB!
!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeCoords=', &
!/PDLIB! ESMF_LOGMSG_INFO)
!/PDLIB! do i = 1,(2*npa)
!/PDLIB! write(msg,*) trim(cname)//': nodeCoords(i)',i, &
!/PDLIB! ' ',nodeCoords(i)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB! enddo
! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeCoords=', &
! ESMF_LOGMSG_INFO)
! do i = 1,(2*NX)
! write(msg,*) trim(cname)//': ',i, &
! ' ',nodeCoords(i)
! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
! enddo
! Allocate and fill the node owner array.
!/PDLIB if ( LPDLIB == .FALSE. ) then
allocate(nodeOwners(NX))
nodeOwners=0 ! TODO: For now, export everything via PET 0
!/PDLIB else
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! ESMF Definition: Processor that owns the node
!/PDLIB! -------------------------------------------------------------------
!/PDLIB allocate(nodeOwners(npa))
!/PDLIB nodeOwners=nodes_global(iplg(1:npa))%domainID-1
!/PDLIB endif
!/PDLIB!
!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeOwners=', &
!/PDLIB! ESMF_LOGMSG_INFO)
!/PDLIB! do i = 1,npa
!/PDLIB! write(msg,*) trim(cname)//': nodeOwners(i)',i, &
!/PDLIB! ' ',nodeOwners(i)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB! enddo
! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeOwners=', &
! ESMF_LOGMSG_INFO)
! do i = 1,NX
! write(msg,*) trim(cname)//': ',i, &
! ' ',nodeOwners(i)
! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
! enddo
! Allocate and fill the element id array.
!/PDLIB if ( LPDLIB == .FALSE. ) then
allocate(elemIds(NTRI))
do i = 1,NTRI
elemIds(i)=i
enddo
!/PDLIB else
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! ESMF Definition: The global id's of the elements resident on this processor
!/PDLIB! -------------------------------------------------------------------
!/PDLIB allocate(elemIds(ne))
!/PDLIB do i = 1,ne
!/PDLIB elemIds(i)=ielg(i)
!/PDLIB enddo
!/PDLIB endif
!/PDLIB!
!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemIds=', &
!/PDLIB! ESMF_LOGMSG_INFO)
!/PDLIB! do i = 1,ne
!/PDLIB! write(msg,*) trim(cname)//': elemIds(i)',i, &
!/PDLIB! ' ',elemIds(i)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB! enddo
! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemIds=', &
! ESMF_LOGMSG_INFO)
! do i = 1,NTRI
! write(msg,*) trim(cname)//': ',i, &
! ' ',elemIds(i)
! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
! enddo
! Allocate and fill the element topology type array.
!/PDLIB if ( LPDLIB == .FALSE. ) then
allocate(elemTypes(NTRI))
do i = 1,NTRI
elemTypes(i)=ESMF_MESHELEMTYPE_TRI
enddo
!/PDLIB else
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! ESMF Definition: Topology of the given element (one of ESMF_MeshElement)
!/PDLIB! -------------------------------------------------------------------
!/PDLIB allocate(elemTypes(ne))
!/PDLIB do i = 1,ne
!/PDLIB elemTypes(i)=ESMF_MESHELEMTYPE_TRI
!/PDLIB enddo
!/PDLIB endif
!/PDLIB!
!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemTypes=', &
!/PDLIB! ESMF_LOGMSG_INFO)
!/PDLIB! do i = 1,ne
!/PDLIB! write(msg,*) trim(cname)//': elemTypes(i)',i, &
!/PDLIB! ' ',elemTypes(i)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB! enddo
! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemTypes=', &
! ESMF_LOGMSG_INFO)
! do i = 1,NTRI
! write(msg,*) trim(cname)//': ',i, &
! ' ',elemTypes(i)
! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
! enddo
! Allocate and fill the element connection type array.
!/PDLIB if ( LPDLIB == .FALSE. ) then
allocate(elemConn(3*NTRI))
do i = 1,NTRI
do j = 1,3
pos=3*(i-1)+j
elemConn(pos)=TRIGP(i,j)
enddo
enddo
!/PDLIB else
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! ESMF Definition: Connectivity table. The number of entries should
!/PDLIB! be equal to the number of nodes in the given topology. The indices
!/PDLIB! should be the local index (1 based) into the array of nodes that
!/PDLIB! was declared with MeshAddNodes.
!/PDLIB! -------------------------------------------------------------------
!/PDLIB! > INE is local element array. it stores the local node IDs
!/PDLIB! > first index from 1 to 3.
!/PDLIB! > second index from 1 to ne.
!/PDLIB allocate(elemConn(3*ne))
!/PDLIB do i = 1,ne
!/PDLIB do j = 1,3
!/PDLIB pos=3*(i-1)+j
!/PDLIB elemConn(pos)=INE(j,i)
!/PDLIB enddo
!/PDLIB enddo
!/PDLIB endif
!/PDLIB!
!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemConn=', &
!/PDLIB! ESMF_LOGMSG_INFO)
!/PDLIB! do i = 1,(3*ne)
!/PDLIB! write(msg,*) trim(cname)//': elemConn(i)',i, &
!/PDLIB! ' ',elemConn(i)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB! enddo
! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemConn=', &
! ESMF_LOGMSG_INFO)
! do i = 1,(3*NTRI)
! write(msg,*) trim(cname)//': ',i, &
! ' ',elemConn(i)
! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
! enddo
expMesh = ESMF_MeshCreate( parametricDim=2,spatialDim=2, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, &
rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
!
! Set flag to indicate that this processor has local export grid storage
!
!AW if (lpet == 0) then
!AW call ESMF_GridGet( expMesh, localDECount=ldecnt, rc=rc )
!AW if (ESMF_LogFoundError(rc, PASSTHRU)) return
!AW expGridIsLocal = ldecnt.gt.0
!AW endif
!
! -------------------------------------------------------------------- /
! 3. Create ESMF grid with arbitrary domain decomposition to match
! the native domain decomposition of the non-excluded points
! Note that the native grid layout is dim1=Y, dim2=X
! Note that coordinates and mask are not needed since this
! grid is only used to define fields for a redist operation
!
! 3.a Set flag to indicate that this processor has local native grid storage
!
natGridIsLocal = iaproc .gt. 0 .and. iaproc .le. naproc
!/PDLIB if ( LPDLIB == .FALSE. ) then
!
! 3.b Setup arbitrary sequence index list
!
do ipass = 1,2
if (ipass.eq.2) then
allocate (arbIndexList(arbIndexCount,2), stat=rc)
if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return
endif
arbIndexCount = 0
! list local native grid non-excluded points
if ( natGridIsLocal ) then
do jsea = 1,nseal
!/DIST isea = iaproc + (jsea-1)*naproc
!/SHRD isea = jsea
arbIndexCount = arbIndexCount+1
if (ipass.eq.2) then
ix = mapsf(isea,1)
iy = mapsf(isea,2)
! native grid layout: dim1=Y, dim2=X
arbIndexList(arbIndexCount,1) = iy
arbIndexList(arbIndexCount,2) = ix
endif
enddo
endif
enddo !ipass
!
! 3.c Create ESMF native grid
!
natGrid = ESMF_GridCreateNoPeriDim( &
minIndex=(/ 1, 1/), &
maxIndex=(/ny,nx/), &
coordDep1=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), &
coordDep2=(/ESMF_DIM_ARB,ESMF_DIM_ARB/), &
arbIndexCount=arbIndexCount, &
arbIndexList=arbIndexList, &
coordTypeKind=ESMF_TYPEKIND_RX, &
coordSys=ESMF_COORDSYS_SPH_DEG, &
name=trim(cname)//"_native_grid", rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 3.d Deallocate arbitrary sequence index list
!
deallocate (arbIndexList, stat=rc)
if (ESMF_LogFoundDeallocError(rc, PASSTHRU)) return
!
! -------------------------------------------------------------------- /
! 4. Create route handle for redist between native grid domain
! decomposition and the export grid domain decomposition
!
! 4.a Create temporary fields
!
nField = ESMF_FieldCreate( natGrid, natArraySpec1D, &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
eField = ESMF_FieldCreate(expMesh, typekind=ESMF_TYPEKIND_RX, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 4.b Store route handle
!
call ESMF_FieldRedistStore( nField, eField, n2eRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!
! 4.c Clean up
!
call ESMF_FieldDestroy( nField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy( eField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!/PDLIB endif
call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, created expMesh', &
ESMF_LOGMSG_INFO)
rc = ESMF_SUCCESS
if (verbosity.gt.0) call ESMF_LogWrite(trim(cname)// &
': leaving CreateExpMesh', ESMF_LOGMSG_INFO)
!/
!/ End of CreateExpMesh ---------------------------------------------- /
!/
end subroutine CreateExpMesh
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "SetupImpBmsk"
subroutine SetupImpBmsk( bmskField, impField, missingVal, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 09-Aug-2017 : Origination. ( version 6.03 )
!/
! 1. Purpose :
!
! Setup background blending mask field for an import field
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! bmskField Type I/O blending mask field
! impField Type I import field
! missingVal Real I missing value
! rc Int O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_Field) :: bmskField
type(ESMF_Field) :: impField
real(ESMF_KIND_RX) :: missingVal
integer, optional :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
real(ESMF_KIND_RX), parameter :: zero = 0.0
real(ESMF_KIND_RX), parameter :: half = 0.5
real(ESMF_KIND_RX), parameter :: one = 1.0
integer, parameter :: nsig = impHaloWidth-1
integer, parameter :: niter = 10
integer, parameter :: iter0 = 1-niter
integer, parameter :: lde = 0
integer :: iter, i, j, ii, jj, k, l
integer :: elb(2), eub(2)
integer :: tlb(2), tub(2)
real(ESMF_KIND_RX), pointer :: mptr(:,:), dptr(:,:)
type(ESMF_Field) :: cmskField
real(ESMF_KIND_RX), pointer :: bmsk(:,:), cmsk(:,:)
real(ESMF_KIND_RX) :: bsum, wsum
real(ESMF_KIND_RX) :: wflt(-nsig:nsig,-nsig:nsig)
character(ESMF_MAXSTR) :: fnm
#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETUPIMPBMSK)
integer :: timeSlice
#endif
!
! -------------------------------------------------------------------- /
! Initialize filter
!
if (present(rc)) rc = ESMF_SUCCESS
do l = -nsig,nsig
do k = -nsig,nsig
wflt(k,l) = exp( -half*( real(k,ESMF_KIND_RX)**2 &
+ real(l,ESMF_KIND_RX)**2 ) )
enddo
enddo
!
! -------------------------------------------------------------------- /
! Set up fields and pointers
!
call ESMF_FieldGet( impField, name=fnm, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
cmskField = ESMF_FieldCreate( impGrid, impArraySpec2D, &
totalLWidth=impHaloLWidth, totalUWidth=impHaloUWidth, &
staggerLoc=impStaggerLoc, indexFlag=impIndexFlag, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( impGridIsLocal ) then
call ESMF_FieldGet( impMask, localDE=lde, farrayPtr=mptr, &
exclusiveLBound=elb, exclusiveUBound=eub, &
totalLBound=tlb, totalUBound=tub, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldGet( impField, localDE=lde, farrayPtr=dptr, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldGet( bmskField, localDE=lde, farrayPtr=bmsk, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldGet( cmskField, localDE=lde, farrayPtr=cmsk, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
!
! -------------------------------------------------------------------- /
! Create blending mask
!
if ( impGridIsLocal ) then
do j = elb(2),eub(2)
do i = elb(1),eub(1)
if ( nint(dptr(i,j)).eq.nint(missingVal) ) then
bmsk(i,j) = zero
else
bmsk(i,j) = one
endif
cmsk(i,j) = bmsk(i,j)
enddo
enddo
endif
#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETUPIMPBMSK)
timeSlice = 1
call ESMF_FieldWrite( bmskField, &
"wmesmfmd_setupimpbmsk_"//trim(fnm)//".nc", &
overwrite=.true., timeSlice=timeSlice, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
#endif
iter_loop: do iter = iter0,niter
call ESMF_FieldHalo( bmskField, impHaloRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( impGridIsLocal ) then
j_loop: do j = elb(2),eub(2)
i_loop: do i = elb(1),eub(1)
if ( nint(mptr(i,j)).eq.maskValueLand ) cycle i_loop
if ( nint(dptr(i,j)).eq.nint(missingVal) ) cycle i_loop
if (iter.le.0) then
! initialize blending zone to zero
l_loop0: do l = -1,1
jj = j + l
if ( jj.lt.tlb(2).or.jj.gt.tub(2) ) cycle l_loop0
k_loop0: do k = -1,1
ii = i + k
if ( ii.lt.tlb(1).or.ii.gt.tub(1) ) cycle k_loop0
if ( nint(mptr(ii,jj)).eq.maskValueLand ) cycle k_loop0
if ( bmsk(ii,jj).eq.zero ) cmsk(i,j) = zero
enddo k_loop0
enddo l_loop0
else
! iterate filter over blending zone
bsum = zero
wsum = zero
l_loop: do l = -nsig,nsig
jj = j + l
if ( jj.lt.tlb(2).or.jj.gt.tub(2) ) cycle l_loop
k_loop: do k = -nsig,nsig
ii = i + k
if ( ii.lt.tlb(1).or.ii.gt.tub(1) ) cycle k_loop
if ( nint(mptr(ii,jj)).eq.maskValueLand ) cycle k_loop
bsum = bsum + wflt(k,l)*bmsk(ii,jj)
wsum = wsum + wflt(k,l)
enddo k_loop
enddo l_loop
if ( wsum.gt.zero ) cmsk(i,j) = bsum/wsum
endif
enddo i_loop
enddo j_loop
do j = elb(2),eub(2)
do i = elb(1),eub(1)
if ( nint(mptr(i,j)).eq.maskValueLand ) cycle
bmsk(i,j) = cmsk(i,j)
enddo
enddo
endif
#if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETUPIMPBMSK)
timeSlice = timeSlice + 1
call ESMF_FieldWrite( bmskField, &
"wmesmfmd_setupimpbmsk_"//trim(fnm)//".nc", &
overwrite=.true., timeSlice=timeSlice, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
#endif
enddo iter_loop
!
! -------------------------------------------------------------------- /
! Clean up
!
call ESMF_FieldDestroy( cmskField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!/
!/ End of SetupImpBmsk ----------------------------------------------- /
!/
end subroutine SetupImpBmsk
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "BlendImpField"
subroutine BlendImpField( impField, mbgField, bmskField, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 09-Aug-2017 : Origination. ( version 6.03 )
!/
! 1. Purpose :
!
! Blend import field with background field
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! impField Type I/O import field
! mbgField Type I/O import background field
! bmskField Type I blending mask field
! rc Int O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_Field) :: impField
type(ESMF_Field) :: mbgField
type(ESMF_Field) :: bmskField
integer, optional :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
real(ESMF_KIND_RX), parameter :: one = 1.0
integer, parameter :: lde = 0
integer :: i, j
integer :: elb(2), eub(2)
real(ESMF_KIND_RX), pointer :: mptr(:,:), dptr(:,:), sptr(:,:)
real(ESMF_KIND_RX), pointer :: bmsk(:,:)
!
! -------------------------------------------------------------------- /
! Get array pointers and bounds
!
if (present(rc)) rc = ESMF_SUCCESS
if ( impGridIsLocal ) then
call ESMF_FieldGet( impMask, localDE=lde, farrayPtr=mptr, &
exclusiveLBound=elb, exclusiveUBound=eub, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldGet( impField, localDE=lde, farrayPtr=dptr, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldGet( mbgField, localDE=lde, farrayPtr=sptr, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldGet( bmskField, localDE=lde, farrayPtr=bmsk, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
endif
!
! -------------------------------------------------------------------- /
! Blend Fields
!
if ( impGridIsLocal ) then
do j = elb(2),eub(2)
do i = elb(1),eub(1)
if ( nint(mptr(i,j)).eq.maskValueLand ) cycle
dptr(i,j) = bmsk(i,j)*dptr(i,j) + (one-bmsk(i,j))*sptr(i,j)
enddo
enddo
endif
!/
!/ End of BlendImpField ---------------------------------------------- /
!/
end subroutine BlendImpField
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "FieldFill"
subroutine FieldFill(field, fillVal, rc)
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/ 09-Aug-2017 : Remove mask parameter. ( version 6.03 )
!/
! 1. Purpose :
!
! Fill ESMF Field
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! field Type I/O ESMF field
! fillVal Real I fill value
! rc Int O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_Field) :: field
real(ESMF_KIND_RX) :: fillVal
integer, optional :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
integer :: ldecnt, lde, i, j, k
integer :: rank
integer :: lb1(1), ub1(1)
integer :: lb2(2), ub2(2)
integer :: lb3(3), ub3(3)
real(ESMF_KIND_RX), pointer :: dptr1(:)
real(ESMF_KIND_RX), pointer :: dptr2(:,:)
real(ESMF_KIND_RX), pointer :: dptr3(:,:,:)
!
! -------------------------------------------------------------------- /
! Fill Field
!
if (present(rc)) rc = ESMF_SUCCESS
call ESMF_FieldGet(field, localDECount=ldecnt, rank=rank, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return ! bail out
if (rank.ne.1.and.rank.ne.2.and.rank.ne.3) then
call ESMF_LogSetError(ESMF_FAILURE, rcToReturn=rc, &
msg='FieldFill: rank must be 1, 2 or 3')
return ! bail out
endif
do lde=0,ldecnt-1
if (rank.eq.1) then
call ESMF_FieldGet(field, localDE=lde, farrayPtr=dptr1, &
exclusiveLBound=lb1, exclusiveUBound=ub1, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return ! bail out
elseif (rank.eq.2) then
call ESMF_FieldGet(field, localDE=lde, farrayPtr=dptr2, &
exclusiveLBound=lb2, exclusiveUBound=ub2, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return ! bail out
else
call ESMF_FieldGet(field, localDE=lde, farrayPtr=dptr3, &
exclusiveLBound=lb3, exclusiveUBound=ub3, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return ! bail out
endif
if (rank.eq.1) then
dptr1(lb1(1):ub1(1)) = fillVal
elseif (rank.eq.2) then
dptr2(lb2(1):ub2(1),lb2(2):ub2(2)) = fillVal
else
dptr3(lb3(1):ub3(1),lb3(2):ub3(2),lb3(3):ub3(3)) = fillVal
endif
enddo
!/
!/ End of FieldFill ------------------------------------------------- /
!/
end subroutine FieldFill
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "FieldGather"
subroutine FieldGather(field, n1, n2, fout, rc)
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | A. J. van der Westhuysen |
!/ | FORTRAN 90 |
!/ | Last update : 20-Jan-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/ 27-Feb-2018 : Modification for use with UNGTYPE ( version 6.06 )
!/
! 1. Purpose :
!
! All gather of ESMF field
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! field Type I/O ESMF field
! n1,n2 Int I Dimensions of output array
! fout R.A. O global output array
! rc Int O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/PDLIB use yowNodepool, only: np, iplg
!/PDLIB use yowrankModule, only: rank
!/
implicit none
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
type(ESMF_Field) :: field
integer :: n1, n2
real :: fout(n1,n2)
integer, optional :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
character(500) :: msg
integer :: i, j, k, ir, ip, count
real(ESMF_KIND_RX) :: floc(n1,n2)
real(ESMF_KIND_RX) :: floc1d(n1), floc1dary(n1*n2)
!/PDLIB real(ESMF_KIND_R8), pointer :: fldptr(:)
!
! -------------------------------------------------------------------- /
! Gather Field
!
if (present(rc)) rc = ESMF_SUCCESS
! call ESMF_FieldWrite(field,fileName="ww3_import_dump.nc",overwrite=.true.,rc=rc)
if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then
count = n1 * n2
floc = 0.
floc1dary = 0.
call ESMF_FieldGather( field, floc, rootPet=0, vm=vm, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
do j=1,n2
do i=1,n1
floc1dary(i+(j-1)*n1) = floc(i,j)
enddo
enddo
call ESMF_VMbroadcast( vm, bcstData=floc1dary, count=count, rootPet=0, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
do j=1,n2
do i=1,n1
fout(i,j) = floc1dary(i+(j-1)*n1)
enddo
enddo
elseif (GTYPE.eq.UNGTYPE) then
count = n1
floc1d = 0.
call ESMF_FieldGather( field, floc1d, rootPet=0, vm=vm, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_VMbroadcast( vm, bcstData=floc1d, count=count, rootPet=0, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!/PDLIB if ( LPDLIB == .FALSE. ) then
do k = 1, n1
fout(k,1) = floc1d(k)
enddo
!/PDLIB else
!/PDLIB count = 0
!/PDLIB do ir = 1, npet
!/PDLIB do ip = 1, rank(ir)%np
!/PDLIB count = count+1
!/PDLIB fout(rank(ir)%iplg(ip),1) = floc1d(count)
!/PDLIB! write(msg,*) trim(cname)//': count,ir,ip =',count, &
!/PDLIB! ir,ip
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB enddo
!/PDLIB enddo
!/PDLIB endif
!/PDLIB! call ESMF_LogWrite(trim(cname)//': In FieldGather, fout(k,1)=', &
!/PDLIB! ESMF_LOGMSG_INFO)
!/PDLIB! do k = 1, n1
!/PDLIB! write(msg,*) trim(cname)//': fout(k,1) =',k, &
!/PDLIB! ' ',fout(k,1)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB! enddo
endif
!/
!/ End of FieldGather ------------------------------------------------ /
!/
end subroutine FieldGather
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "FieldIndex"
function FieldIndex ( fnameList, fname, rc ) result (indx)
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 20-Jan-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/
! 1. Purpose :
!
! Return index associated with field name
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! fnameList StrA I Array of field names
! fname Str I Field name
! rc Int. O Return code
! indx Int I Returned index of fname
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
character (6) :: fnameList(:)
character (6) :: fname
integer :: rc
integer :: indx
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
integer :: i, check
!
! -------------------------------------------------------------------- /
! Find name in fnameList that matches fname
!
check = lbound(fnameList,1) - 1
indx = check
do i = lbound(fnameList,1),ubound(fnameList,1)
if ( fnameList(i).eq.fname ) then
indx = i
exit
endif
enddo
if ( indx.eq.check ) then
call ESMF_LogSetError(ESMF_FAILURE, rcToReturn=rc, &
msg='FieldIndex: input name ('//fname//') not in list')
endif
!/
!/ End of FieldIndex ------------------------------------------------- /
!/
end function FieldIndex
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "PrintTimers"
subroutine PrintTimers ( cname, wtnam, wtcnt, wtime )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 20-Jan-2017 |
!/ +-----------------------------------+
!/
!/ 20-Jan-2017 : Origination. ( version 6.02 )
!/
! 1. Purpose :
!
! Print wallclock timers to ESMF log file
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! cname Str I Name of component
! wtnam Str I Timer names
! wtcnt Int I Timer counts
! wtime R8 I Timers
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
character(*) :: cname
character(*) :: wtnam(:)
integer :: wtcnt(:)
real(8) :: wtime(:)
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(128) :: msg
integer :: k
!
! -------------------------------------------------------------------- /
! Print timers to ESMF log file
!
write(msg,1) trim(cname),"timer","count","time"
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
do k=lbound(wtcnt,1),ubound(wtcnt,1)
write(msg,2) trim(cname),trim(wtnam(k)),wtcnt(k),wtime(k)
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
enddo
!
! -------------------------------------------------------------------- /
! Formats
!
1 format(a,': wtime: ',a20,a10,a14)
2 format(a,': wtime: ',a20,i10,e14.6)
!/
!/ End of PrintTimers ------------------------------------------------ /
!/
end subroutine PrintTimers
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "CalcDecomp"
subroutine CalcDecomp ( nx, ny, nproc, npmin, adjust, nxproc, nyproc, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 09-Aug-2017 : Origination. ( version 6.03 )
!/
! 1. Purpose :
!
! Calculate a 2D processor layout
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! nx,ny Int I Grid dimensions
! nproc Int I Total processor count
! npmin Int I Min number of grid points per tile per direction
! adjust Log I Enable/disable adjusting proc count downward
! nxproc Int O Processor count in x-direction
! nyproc Int O Processor count in y-direction
! rc Int O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
integer, intent(in) :: nx, ny
integer, intent(in) :: nproc
integer, intent(in) :: npmin
logical, intent(in) :: adjust
integer, intent(out) :: nxproc
integer, intent(out) :: nyproc
integer, intent(inout) :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
integer, parameter :: k = 4
integer :: mproc, n, nfac, irp
real(k) :: gr, rp, pr, diff, npx, npy
character(256) :: msg
!
! -------------------------------------------------------------------- /
!
rc = ESMF_SUCCESS
if ( nx.gt.ny ) then
gr = real(nx,k)/real(ny,k)
else
gr = real(ny,k)/real(nx,k)
endif
mproc = nproc
mproc_loop: do
irp = int(sqrt(real(mproc,k)))
diff = huge(gr)
nfac = mproc
do n = irp,mproc
if ( mod(mproc,n).ne.0 ) cycle
pr = real(n**2,k)/real(mproc,k)
if ( abs(gr-pr) < diff ) then
diff = abs(gr-pr)
nfac = n
endif
enddo
if ( nx.gt.ny ) then
nxproc = nfac
nyproc = mproc/nfac
else
nxproc = mproc/nfac
nyproc = nfac
endif
npx = nx/real(nxproc,k)
npy = ny/real(nyproc,k)
if (.not.adjust) exit mproc_loop
if ( npx.ge.npmin .and. npy.ge.npmin ) then
exit mproc_loop
else
if ( mproc.gt.1 ) then
mproc = mproc - 1
else
exit mproc_loop
endif
endif
enddo mproc_loop
if ( npx.lt.npmin .or. npy.lt.npmin ) then
write(msg,'(a,7i6)') 'proc count is too large for grid size:', &
nx,ny,npmin,nproc,mproc,nxproc,nyproc
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
endif
!/
!/ End of CalcDecomp ------------------------------------------------- /
!/
end subroutine CalcDecomp
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "GetEnvValue"
subroutine GetEnvValue ( cenv, cval, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 09-Aug-2017 : Origination. ( version 6.03 )
!/
! 1. Purpose :
!
! Get value of environment variable
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! cenv Str I Name of environment variable
! cval Str O Value of environment variable
! rc Int O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
character(*) :: cenv
character(*) :: cval
integer :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(256) :: msg
integer :: length, istat
!
! -------------------------------------------------------------------- /
!
rc = ESMF_SUCCESS
call get_environment_variable( name=trim(cenv), value=cval, &
length=length, trim_name=.false., status=istat )
if (istat.lt.0) then
! The VALUE argument is present and has a length less than
! the significant length of the environment variable value.
write(msg,'(a,i3,a)') "Length of input variable", &
" is less than length of environment variable " &
//trim(cenv)//" value (",length,")."
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR)
rc = istat
elseif (istat.gt.0) then
! 1: The specified environment variable NAME does not exist.
! 2: The processor does not support environment variables.
!>2: Some other error condition occured.
cval=" "
endif
if (length.eq.0) cval=" "
!/
!/ End of GetEnvValue ------------------------------------------------ /
!/
end subroutine GetEnvValue
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "GetZlevels"
subroutine GetZlevels ( rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 09-Aug-2017 : Origination. ( version 6.03 )
!/
! 1. Purpose :
!
! Get array of z-levels from zlfile for SDC
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! rc Int O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
integer :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(256) :: msg
integer :: k, iunit, ierr
!
! -------------------------------------------------------------------- /
!
rc = ESMF_SUCCESS
if (len_trim(zlfile).eq.0 .or. trim(zlfile) .eq. 'none') then
nz = 1
allocate(zl(nz), stat=rc)
if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return
zl(1) = 0
else
call ESMF_UtilIOUnitGet(iunit, rc=rc)
if (ESMF_LogFoundError(rc, PASSTHRU)) return
open(unit=iunit, file=trim(zlfile), form='formatted', &
status='old', access='sequential', iostat=ierr)
if (ierr.ne.0) then
msg = "failed opening "//trim(zlfile)
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
return
endif
read(iunit, fmt=*, iostat=ierr) nz
if (ierr.ne.0) then
msg = "read nz failed: "//trim(zlfile)
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
return
endif
allocate(zl(nz), stat=rc)
if (ESMF_LogFoundAllocError(rc, PASSTHRU)) return
do k=1,nz
read(iunit, fmt=*, iostat=ierr) zl(k)
if (ierr.ne.0) then
msg = "read zl failed: "//trim(zlfile)
call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
return
endif
enddo
close(iunit)
endif
!/
!/ End of GetZlevels ------------------------------------------------- /
!/
end subroutine GetZlevels
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "CalcCharnk"
subroutine CalcCharnk ( chkField, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 09-Aug-2017 : Origination. ( version 6.03 )
!/
! 1. Purpose :
!
! Calculate Charnock for export
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! chkField Type I/O 2D Charnock export field
! rc Int O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_Field) :: chkField
integer :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
real , parameter :: zero = 0.0
logical, save :: firstCall = .true.
integer :: isea, jsea
real :: emean, fmean, fmean1, wnmean, amax, ustar, ustdr, &
tauwx, tauwy, cd, z0, fmeanws
logical :: llws(nspec)
type(ESMF_Field) :: chknField
real(ESMF_KIND_RX), pointer :: chkn(:)
integer, save :: timeSlice = 1
!
! -------------------------------------------------------------------- /
!
rc = ESMF_SUCCESS
chknField = ESMF_FieldCreate( natGrid, natArraySpec2D, &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call FieldFill( chknField, zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( natGridIsLocal ) then
call ESMF_FieldGet( chknField, farrayPtr=chkn, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
jsea_loop: do jsea = 1,nseal
!/DIST isea = iaproc + (jsea-1)*naproc
!/SHRD isea = jsea
if ( firstCall ) then
charn(jsea) = zero
!/ST3 llws(:) = .true.
!/ST3 ustar = zero
!/ST3 ustdr = zero
!/ST3 call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), &
!/ST3 emean, fmean, fmean1, wnmean, amax, &
!/ST3 u10(isea), u10d(isea), ustar, ustdr, tauwx, &
!/ST3 tauwy, cd, z0, charn(jsea), llws, fmeanws )
!/ST4 llws(:) = .true.
!/ST4 ustar = zero
!/ST4 ustdr = zero
!/ST4 call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), &
!/ST4 emean, fmean, fmean1, wnmean, amax, &
!/ST4 u10(isea), u10d(isea), ustar, ustdr, tauwx, &
!/ST4 tauwy, cd, z0, charn(jsea), llws, fmeanws )
endif !firstCall
chkn(jsea) = charn(jsea)
enddo jsea_loop
endif !natGridIsLocal
call ESMF_FieldRedist( chknField, chkField, n2eRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy( chknField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
firstCall = .false.
#ifdef TEST_WMESMFMD_CHARNK
call ESMF_FieldWrite( chkField, "wmesmfmd_charnk_chk.nc", &
overwrite=.true., timeSlice=timeSlice, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
timeSlice = timeSlice + 1
#endif
!/
!/ End of CalcCharnk ------------------------------------------------- /
!/
end subroutine CalcCharnk
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "CalcRoughl"
subroutine CalcRoughl ( wrlField, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 09-Aug-2017 : Origination. ( version 6.03 )
!/
! 1. Purpose :
!
! Calculate 2D wave roughness length for export
!
! 2. Method :
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! wrlField Type I/O 2D roughness length export field
! rc Int O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
type(ESMF_Field) :: wrlField
integer :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
real , parameter :: zero = 0.0
logical, save :: firstCall = .true.
integer :: isea, jsea
real :: emean, fmean, fmean1, wnmean, amax, ustar, ustdr, &
tauwx, tauwy, cd, z0, fmeanws
logical :: llws(nspec)
type(ESMF_Field) :: wrlnField
real(ESMF_KIND_RX), pointer :: wrln(:)
integer, save :: timeSlice = 1
!
! -------------------------------------------------------------------- /
!
rc = ESMF_SUCCESS
wrlnField = ESMF_FieldCreate( natGrid, natArraySpec2D, &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call FieldFill( wrlnField, zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( natGridIsLocal ) then
call ESMF_FieldGet( wrlnField, farrayPtr=wrln, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
jsea_loop: do jsea = 1,nseal
!/DIST isea = iaproc + (jsea-1)*naproc
!/SHRD isea = jsea
if ( firstCall ) then
charn(jsea) = zero
!/ST3 llws(:) = .true.
!/ST3 ustar = zero
!/ST3 ustdr = zero
!/ST3 call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), &
!/ST3 emean, fmean, fmean1, wnmean, amax, &
!/ST3 u10(isea), u10d(isea), ustar, ustdr, tauwx, &
!/ST3 tauwy, cd, z0, charn(jsea), llws, fmeanws )
!/ST4 llws(:) = .true.
!/ST4 ustar = zero
!/ST4 ustdr = zero
!/ST4 call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), &
!/ST4 emean, fmean, fmean1, wnmean, amax, &
!/ST4 u10(isea), u10d(isea), ustar, ustdr, tauwx, &
!/ST4 tauwy, cd, z0, charn(jsea), llws, fmeanws )
endif !firstCall
wrln(jsea) = charn(jsea)*ust(isea)**2/grav
enddo jsea_loop
endif !natGridIsLocal
call ESMF_FieldRedist( wrlnField, wrlField, n2eRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy( wrlnField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
firstCall = .false.
#ifdef TEST_WMESMFMD_ROUGHL
call ESMF_FieldWrite( wrlField, "wmesmfmd_roughl_wrl.nc", &
overwrite=.true., timeSlice=timeSlice, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
timeSlice = timeSlice + 1
#endif
!/
!/ End of CalcRoughl ------------------------------------------------- /
!/
end subroutine CalcRoughl
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "CalcBotcur"
subroutine CalcBotcur ( a, wbxField, wbyField, wbpField, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 09-Aug-2017 : Origination. ( version 6.03 )
!/
! 1. Purpose :
!
! Calculate wave-bottom currents for export
!
! 2. Method :
!
! > Madsen, O. S. (1994), ICCE
!
! //
! U_bot = sqrt( 2*|| S_ub dsig dtheta )
! (magnitude) //
!
! //
! || S_ub*sin(theta) dsig dtheta
! //
! phi_b = arctan( ---------------------------------- )
! (direction) //
! || S_ub*cos(theta) dsig dtheta
! //
!
! //
! || S_ub dsig dtheta
! //
! U_bp = 2*pi * ----------------------------
! (period) //
! || sig*S_ub dsig dtheta
! //
!
! Where:
! S_ub(theta,k) = near-bottom orbital velocity spectrum
! = ( sig^2 / sinh^2(kD) ) * E(theta,k) / Cg
! = ( sig^3 / sinh^2(kD) ) * Ac(theta,k) / Cg
! Ac(theta,k) = wave action density
! D = depth
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! a Real I Input spectra (in par list to change shape)
! wbxField Type I/O WBC 2D eastward-component export field
! wbyField Type I/O WBC 2D northward-component export field
! wbpField Type I/O WBC 2D period export field
! rc Int O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
real :: a(nth,nk,0:nseal)
type(ESMF_Field) :: wbxField
type(ESMF_Field) :: wbyField
type(ESMF_Field) :: wbpField
integer :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
real(8), parameter :: zero = 0.0
real(8), parameter :: half = 0.5
real(8), parameter :: one = 1.0
real(8), parameter :: two = 2.0
! kdmin = 1e-7: sinh(kdmin)**2 ~ 1e-14
real(8), parameter :: kdmin = 1e-7
! kdmax = 18.0: 1/sinh(kdmax)**2 ~ 1e-14
real(8), parameter :: kdmax = 18.0
integer :: isea, jsea, ik, ith
real(8) :: depth
real(8) :: kd, fack, fkd, aka, akx, aky, abr, ubr, ubx, uby, dir
real(8), allocatable :: sig2(:)
type(ESMF_Field) :: wbxnField, wbynField, wbpnField
real(ESMF_KIND_RX), pointer :: wbxn(:), wbyn(:), wbpn(:)
integer, save :: timeSlice = 1
!
! -------------------------------------------------------------------- /
!
rc = ESMF_SUCCESS
wbxnField = ESMF_FieldCreate( natGrid, natArraySpec2D, &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
wbynField = ESMF_FieldCreate( natGrid, natArraySpec2D, &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
wbpnField = ESMF_FieldCreate( natGrid, natArraySpec2D, &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call FieldFill( wbxnField, zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call FieldFill( wbynField, zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call FieldFill( wbpnField, zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( natGridIsLocal ) then
call ESMF_FieldGet( wbxnField, farrayPtr=wbxn, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldGet( wbynField, farrayPtr=wbyn, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldGet( wbpnField, farrayPtr=wbpn, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
allocate( sig2(1:nk) )
sig2(1:nk) = sig(1:nk)**2
jsea_loop: do jsea = 1,nseal
!/DIST isea = iaproc + (jsea-1)*naproc
!/SHRD isea = jsea
if ( dw(isea).le.zero ) cycle jsea_loop
depth = max(dmin,dw(isea))
#ifdef USE_W3OUTG_FOR_EXPORT
if ( aba(jsea).le.zero ) cycle jsea_loop
if ( uba(jsea).le.zero ) cycle jsea_loop
wbxn(jsea) = uba(jsea)*cos(ubd(jsea))
wbyn(jsea) = uba(jsea)*sin(ubd(jsea))
wbpn(jsea) = tpi*aba(jsea)/uba(jsea)
#else
abr = zero
ubr = zero
ubx = zero
uby = zero
ik_loop: do ik = 1,nk
aka = zero
akx = zero
aky = zero
ith_loop: do ith = 1,nth
aka = aka + a(ith,ik,jsea)
akx = akx + a(ith,ik,jsea)*ecos(ith)
aky = aky + a(ith,ik,jsea)*esin(ith)
enddo ith_loop
fack = dden(ik)/cg(ik,isea)
kd = max(kdmin,min(kdmax,wn(ik,isea)*depth))
fkd = fack/sinh(kd)**2
abr = abr + aka*fkd
ubr = ubr + aka*sig2(ik)*fkd
ubx = ubx + akx*sig2(ik)*fkd
uby = uby + aky*sig2(ik)*fkd
enddo ik_loop
if ( abr.le.zero .or. ubr.le.zero ) cycle jsea_loop
abr = sqrt(two*abr)
ubr = sqrt(two*ubr)
dir = atan2(uby,ubx)
wbxn(jsea) = ubr*cos(dir)
wbyn(jsea) = ubr*sin(dir)
wbpn(jsea) = tpi*abr/ubr
#endif
enddo jsea_loop
deallocate( sig2 )
endif !natGridIsLocal
call ESMF_FieldRedist( wbxnField, wbxField, n2eRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldRedist( wbynField, wbyField, n2eRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldRedist( wbpnField, wbpField, n2eRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy( wbxnField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy( wbynField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy( wbpnField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
#ifdef TEST_WMESMFMD_BOTCUR
call ESMF_FieldWrite( wbxField, "wmesmfmd_botcur_wbx.nc", &
overwrite=.true., timeSlice=timeSlice, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldWrite( wbyField, "wmesmfmd_botcur_wby.nc", &
overwrite=.true., timeSlice=timeSlice, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldWrite( wbpField, "wmesmfmd_botcur_wbp.nc", &
overwrite=.true., timeSlice=timeSlice, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
timeSlice = timeSlice + 1
#endif
!/
!/ End of CalcBotcur ------------------------------------------------- /
!/
end subroutine CalcBotcur
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "CalcRadstr2D"
subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | A. J. van der Westhuysen |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 09-Aug-2017 : Origination. ( version 6.03 )
!/ 27-Feb-2018 : Modification for use with UNGTYPE ( version 6.06 )
!/
! 1. Purpose :
!
! Calculate 2D radiation stresses for export
!
! 2. Method :
!
! Radiation stresses are defined as:
!
! //
! Sxx = rho grav || (N*cos^2(theta) + N - 1/2) * sig*Ac(theta,k)/Cg dsig dtheta
! //
! //
! Sxy = rho grav || N*sin(theta)*cos(theta) * sig*Ac(theta,k)/Cg dsig dtheta
! //
! //
! Syy = rho grav || (N*sin^2(theta) + N - 1/2) * sig*Ac(theta,k)/Cg dsig dtheta
! //
!
! Where:
! rho = density of sea water
! grav = acceleration due to gravity
! Ac(theta,k) = wave action density
! N = Cg/C = ratio of group velocity and phase velocity
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! a Real I Input spectra (in par list to change shape)
! sxxField Type I/O RS 2D eastward-component export field
! sxyField Type I/O RS 2D eastward-northward-component export field
! syyField Type I/O RS 2D northward-component export field
! rc Int O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/PDLIB use yowNodepool, only: np, iplg
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
real :: a(nth,nk,0:nseal)
type(ESMF_Field) :: sxxField
type(ESMF_Field) :: sxyField
type(ESMF_Field) :: syyField
integer :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
character(ESMF_MAXSTR) :: cname
character(128) :: msg
real(8), parameter :: zero = 0.0
real(8), parameter :: half = 0.5
real(8), parameter :: one = 1.0
real(8), parameter :: two = 2.0
integer :: isea, jsea, ik, ith
real(8) :: sxxs, sxys, syys
real(8) :: akxx, akxy, akyy, cgoc, facd, fack, facs
type(ESMF_Field) :: sxxnField, sxynField, syynField
real(ESMF_KIND_RX), pointer :: sxxn(:), sxyn(:), syyn(:)
integer, save :: timeSlice = 1
!
! -------------------------------------------------------------------- /
!
rc = ESMF_SUCCESS
! For regular and curvilinear grids the native grid has a 2D
! layout, whereas for unstructured meshes it is a 1D array
if ( (GTYPE.eq.RLGTYPE).or.(GTYPE.eq.CLGTYPE) ) then
sxxnField = ESMF_FieldCreate( natGrid, natArraySpec2D, &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
sxynField = ESMF_FieldCreate( natGrid, natArraySpec2D, &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
syynField = ESMF_FieldCreate( natGrid, natArraySpec2D, &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
elseif (GTYPE.eq.UNGTYPE) then
!/PDLIB if ( LPDLIB == .FALSE. ) then
sxxnField = ESMF_FieldCreate( natGrid, natArraySpec1D, &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
sxynField = ESMF_FieldCreate( natGrid, natArraySpec1D, &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
syynField = ESMF_FieldCreate( natGrid, natArraySpec1D, &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!/PDLIB endif
endif
!/PDLIB if ( LPDLIB == .FALSE. ) then
call FieldFill( sxxnField, zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call FieldFill( sxynField, zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call FieldFill( syynField, zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!/PDLIB endif
if ( natGridIsLocal ) then
!/PDLIB if ( LPDLIB == .FALSE. ) then
!/PDLIB! Use auxiliary native grid/mesh to populate and redistribute data
call ESMF_FieldGet( sxxnField, farrayPtr=sxxn, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldGet( sxynField, farrayPtr=sxyn, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldGet( syynField, farrayPtr=syyn, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!/PDLIB else
!/PDLIB! Use single domain-decomposed native mesh to populate and communicate data
!/PDLIB call ESMF_FieldGet( sxxField, farrayPtr=sxxn, rc=rc )
!/PDLIB if (ESMF_LogFoundError(rc, PASSTHRU)) return
!/PDLIB call ESMF_FieldGet( sxyField, farrayPtr=sxyn, rc=rc )
!/PDLIB if (ESMF_LogFoundError(rc, PASSTHRU)) return
!/PDLIB call ESMF_FieldGet( syyField, farrayPtr=syyn, rc=rc )
!/PDLIB if (ESMF_LogFoundError(rc, PASSTHRU)) return
!/PDLIB endif
facd = dwat*grav
!/PDLIB if ( LPDLIB == .FALSE. ) then
jsea_loop: do jsea = 1,nseal
!/DIST isea = iaproc + (jsea-1)*naproc
!/SHRD isea = jsea
if ( dw(isea).le.zero ) cycle jsea_loop
#ifdef USE_W3OUTG_FOR_EXPORT
sxxn(jsea) = sxx(jsea)
sxyn(jsea) = sxy(jsea)
syyn(jsea) = syy(jsea)
#else
sxxs = zero
sxys = zero
syys = zero
ik_loop: do ik = 1,nk
akxx = zero
akxy = zero
akyy = zero
cgoc = cg(ik,isea)*wn(ik,isea)/sig(ik)
cgoc = min(one,max(half,cgoc))
ith_loop: do ith = 1,nth
akxx = akxx + (cgoc*(ec2(ith)+one)-half)*a(ith,ik,jsea)
akxy = akxy + cgoc*esc(ith)*a(ith,ik,jsea)
akyy = akyy + (cgoc*(es2(ith)+one)-half)*a(ith,ik,jsea)
enddo ith_loop
fack = dden(ik)/cg(ik,isea)
sxxs = sxxs + akxx*fack
sxys = sxys + akxy*fack
syys = syys + akyy*fack
enddo ik_loop
facs = (one+fte/cg(nk,isea))*facd
sxxn(jsea) = sxxs*facs
sxyn(jsea) = sxys*facs
syyn(jsea) = syys*facs
#endif
enddo jsea_loop
!/PDLIB else
!/PDLIB jsea_loop2: do jsea = 1,np
!/PDLIB isea = iplg(jsea)
!/PDLIB! if ( dw(isea).le.zero ) cycle jsea_loop
!/PDLIB sxxn(jsea) = sxx(jsea)
!/PDLIB sxyn(jsea) = sxy(jsea)
!/PDLIB syyn(jsea) = syy(jsea)
!/PDLIB! write(msg,*) trim(cname)//' sxxn', sxxn(jsea)
!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
!/PDLIB enddo jsea_loop2
!/PDLIB endif
endif !natGridIsLocal
!/PDLIB if ( LPDLIB == .FALSE. ) then
call ESMF_FieldRedist( sxxnField, sxxField, n2eRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldRedist( sxynField, sxyField, n2eRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldRedist( syynField, syyField, n2eRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy( sxxnField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy( sxynField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy( syynField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
!/PDLIB endif
#ifdef TEST_WMESMFMD_RADSTR2D
call ESMF_FieldWrite( sxxField, "wmesmfmd_radstr2d_sxx.nc", &
overwrite=.true., timeSlice=timeSlice, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldWrite( sxyField, "wmesmfmd_radstr2d_sxy.nc", &
overwrite=.true., timeSlice=timeSlice, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldWrite( syyField, "wmesmfmd_radstr2d_syy.nc", &
overwrite=.true., timeSlice=timeSlice, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
timeSlice = timeSlice + 1
#endif
!/
!/ End of CalcRadstr2D ----------------------------------------------- /
!/
end subroutine CalcRadstr2D
!/ ------------------------------------------------------------------- /
#undef METHOD
#define METHOD "CalcStokes3D"
subroutine CalcStokes3D ( a, usxField, usyField, rc )
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | T. J. Campbell, NRL |
!/ | FORTRAN 90 |
!/ | Last update : 09-Aug-2017 |
!/ +-----------------------------------+
!/
!/ 09-Aug-2017 : Origination. ( version 6.03 )
!/
! 1. Purpose :
!
! Calculate 3D Stokes drift current for export
!
! 2. Method :
!
! Kenyon, K. E. (1969), J. Geophys. R., Vol 74, No 28, p 6991
!
! U_vec(z)
! //
! = 2 g || ( F(f,theta) k_vec/C cosh(2k(D+z))/sinh(2kD) ) dsig dtheta
! //
!
! //
! = || (Ac(k,theta) sig^2 k_vec/Cg cosh(2k(D+z))/sinh^2(kD) ) dsig dtheta
! //
!
! Where:
! Ac(k,theta) = wave action density
! k_vec = k*[cos(theta),sin(theta)]
! D = depth
! z = height (0 = mean sea level)
!
! In deep water (kD large): cosh(2k(D+z))/sinh^2(kD) --> 2*exp(2kz)
!
! 3. Parameters :
!
! Parameter list
! ----------------------------------------------------------------
! a Real I Input spectra (in par list to change shape)
! usxField Type I/O 3D SDC eastward-component export field
! usyField Type I/O 3D SDC northward-component export field
! rc Int O Return code
! ----------------------------------------------------------------
!
! 4. Subroutines used :
!
! Name Type Module Description
! ----------------------------------------------------------------
! NONE
! ----------------------------------------------------------------
!
! 5. Called by :
!
! 6. Error messages :
!
! 7. Remarks :
!
! 8. Structure :
!
! 9. Switches :
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
implicit none
real :: a(nth,nk,0:nseal)
type(ESMF_Field) :: usxField
type(ESMF_Field) :: usyField
integer :: rc
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
real(8), parameter :: zero = 0.0
real(8), parameter :: half = 0.5
real(8), parameter :: one = 1.0
real(8), parameter :: two = 2.0
! kdmin = 1e-7: sinh(kdmin)**2 ~ 1e-14
real(8), parameter :: kdmin = 1e-7
! kdmax = 18.0: cosh(2*(kdmax+kz))/sinh(kdmax)**2 - 2*exp(2*kz) < 1e-14
real(8), parameter :: kdmax = 18.0
! kdmin & kdmax settings used in w3iogomd
real(8), parameter :: kdmin_us3d = 1e-3
real(8), parameter :: kdmax_us3d = 6.0
integer :: isea, jsea, ik, ith, iz
real(8) :: depth
real(8) :: akx, aky, kd, kz, fac1, fac2, fac3
real(8) :: uzx(nz), uzy(nz)
real(8), allocatable :: fack(:)
type(ESMF_Field) :: usxnField, usynField
real(ESMF_KIND_RX), pointer :: usxn(:,:), usyn(:,:)
integer, save :: timeSlice = 1
! Need this workaround to deal with ESMF_FieldCreate not setting up the
! Fortran arrays with the ungridded dimension as the first array dimension
#define ESMF_ARBSEQ_WORKAROUND
#ifdef ESMF_ARBSEQ_WORKAROUND
type(ESMF_DistGrid) :: natDistGrid
type(ESMF_Array) :: usxnArray, usynArray
#endif
!
! -------------------------------------------------------------------- /
!
rc = ESMF_SUCCESS
#ifdef ESMF_ARBSEQ_WORKAROUND
call ESMF_GridGet( natGrid, distGrid=natDistGrid, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
usxnArray = ESMF_ArrayCreate( natDistGrid, ESMF_TYPEKIND_RX, &
distGridToArrayMap=(/2/), undistLBound=(/1/), undistUBound=(/nz/), rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
usxnField = ESMF_FieldCreate( natGrid, usxnArray, &
gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
usynArray = ESMF_ArrayCreate( natDistGrid, ESMF_TYPEKIND_RX, &
distGridToArrayMap=(/2/), undistLBound=(/1/), undistUBound=(/nz/), rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
usynField = ESMF_FieldCreate( natGrid, usynArray, &
gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
#else
usxnField = ESMF_FieldCreate( natGrid, natArraySpec3D, &
gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
usynField = ESMF_FieldCreate( natGrid, natArraySpec3D, &
gridToFieldMap=(/2,3/), ungriddedLBound=(/1/), ungriddedUBound=(/nz/), &
staggerLoc=natStaggerLoc, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
#endif
call FieldFill( usxnField, zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call FieldFill( usynField, zeroValue, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
if ( natGridIsLocal ) then
call ESMF_FieldGet( usxnField, farrayPtr=usxn, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldGet( usynField, farrayPtr=usyn, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
allocate( fack(1:nk) )
fack(1:nk) = dden(1:nk) * sig(1:nk)
jsea_loop: do jsea = 1,nseal
!/DIST isea = iaproc + (jsea-1)*naproc
!/SHRD isea = jsea
if ( dw(isea).le.zero ) cycle jsea_loop
depth = max(dmin,dw(isea))
uzx(:) = zero
uzy(:) = zero
#ifdef USE_W3OUTG_FOR_EXPORT
ik_loop: do ik = us3df(2),us3df(3)
fac1 = tpiinv*dsii(ik)
kd = max(kdmin_us3d,wn(ik,isea)*dw(isea))
iz_loop: do iz = 1,nz
if ( dw(isea)+zl(iz).le.zero ) cycle iz_loop
kz = wn(ik,isea)*zl(iz)
if ( kd .lt. kdmax_us3d ) then
fac2 = fac1*cosh(two*max(zero,kd+kz))/cosh(two*kd)
else
fac2 = fac1*exp(two*kz)
endif
uzx(iz) = uzx(iz) + us3d(jsea,ik )*fac2
uzy(iz) = uzy(iz) + us3d(jsea,nk+ik)*fac2
enddo iz_loop
enddo ik_loop
#else
ik_loop: do ik = 1,nk
akx = zero
aky = zero
ith_loop: do ith = 1,nth
akx = akx + a(ith,ik,jsea)*ecos(ith)
aky = aky + a(ith,ik,jsea)*esin(ith)
enddo ith_loop
fac1 = fack(ik)*wn(ik,isea)/cg(ik,isea)
kd = max(kdmin,wn(ik,isea)*depth)
if ( kd .lt. kdmax ) then
fac2 = fac1/sinh(kd)**2
else
fac2 = fac1*two
endif
akx = akx*fac2
aky = aky*fac2
iz_loop: do iz = 1,nz
if ( depth+zl(iz).le.zero ) cycle iz_loop
kz = wn(ik,isea)*zl(iz)
if ( kd .lt. kdmax ) then
fac3 = cosh(two*max(zero,kd+kz))
else
fac3 = exp(two*kz)
endif
uzx(iz) = uzx(iz) + akx*fac3
uzy(iz) = uzy(iz) + aky*fac3
enddo iz_loop
enddo ik_loop
#endif
usxn(:,jsea) = uzx(:)
usyn(:,jsea) = uzy(:)
enddo jsea_loop
deallocate( fack )
endif !natGridIsLocal
call ESMF_FieldRedist( usxnField, usxField, n2eRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldRedist( usynField, usyField, n2eRH, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
#ifdef ESMF_ARBSEQ_WORKAROUND
call ESMF_ArrayDestroy( usxnArray, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_ArrayDestroy( usynArray, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
#endif
call ESMF_FieldDestroy( usxnField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldDestroy( usynField, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
#ifdef TEST_WMESMFMD_STOKES3D
call ESMF_FieldWrite( usxField, "wmesmfmd_stokes3d_usx.nc", &
overwrite=.true., timeSlice=timeSlice, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
call ESMF_FieldWrite( usyField, "wmesmfmd_stokes3d_usy.nc", &
overwrite=.true., timeSlice=timeSlice, rc=rc )
if (ESMF_LogFoundError(rc, PASSTHRU)) return
timeSlice = timeSlice + 1
#endif
!/
!/ End of CalcStokes3D ----------------------------------------------- /
!/
end subroutine CalcStokes3D
!/ ------------------------------------------------------------------- /
!/
!/ End of module WMESMFMD -------------------------------------------- /
!/
end module WMESMFMD